diff --git a/befpc/Read me 1st b/befpc/Read me 1st new file mode 100644 index 0000000..fa721f0 --- /dev/null +++ b/befpc/Read me 1st @@ -0,0 +1,26 @@ +BeFPC alpha 1 release. + +This archive contains the alpha 1 release source (not official FP rating, my own) of BeFPC, the Free Pascal port to BeOS. + +The compiler is 'complete', in so much as it can correctly create executable files from pascal source - it's by no means finished to production levels. + +Things are at an experimental stage. No one claims that any of the code included is an example of 'good coding practice'. Please, no flames ;-) + +I expect to have a basic, non OO, pascal GUI sollution by the begining/mid of August 2001. This will consist of an expanded 'simpleapp' style affair, but will not be a 'replacement' for the Be API. The bottom line is that until FPC links to C++, we'll never fully get the full benefits of the Be API in apps. + +NB. the OO section of FPC is not yet working correctly in this version of the compiler - stay tuned. Work is underway for a version of the compiler that fully supports BeOS. The work is being undertaken by the FP team, take a look periodically at http://www.freepascal.org for more info. + +Source: I have no idea if this source compiles at this point. It does in its original form, but I deleted a lot of 'stuff' to make the archive smaller. The archive is meant only to comply with the GPL that governs the FPC distribution. + +Lastly, have fun!! + +Matt Emson (BeCL co ordinator) +memson@sourceforge.com / memsom@interalpha.co.uk + +Disclaimer: + +The software is presented 'as is'. No guarentee or assurance is given that the software wont nuke your system, wipe your harddisk and fry your computer. USE THIS SOFTWARE AT YOUR OWN RISK. The author/distributer holds no responsibility for any damage(s) caused through the use or mis-use of this software product to perform its intended purpose, or through any other conduct by the end user/downloader/recipient. NB. the author of this document can't spell for toffee. + +Original rights given to the FP team, http://www.freepascal.org + +This software is governed by the GPL and parts by the LGPL diff --git a/befpc/compiler/0.sh b/befpc/compiler/0.sh new file mode 100644 index 0000000..3bf549a --- /dev/null +++ b/befpc/compiler/0.sh @@ -0,0 +1 @@ +fpc -dGDB -dBROWSERLOG -dSUPPORT_MMX -dNOAG386INT -dNOAG386BIN -Sg -FE. -di386 -vi pp.pas diff --git a/befpc/compiler/0beos.sh b/befpc/compiler/0beos.sh new file mode 100644 index 0000000..f62fa64 --- /dev/null +++ b/befpc/compiler/0beos.sh @@ -0,0 +1 @@ +fpc -dGDB -dBROWSERLOG -dSUPPORT_MMX -dNOAG386INT -dNOAG386BIN -Sg -Fu../rtl/beos -TBEOS -FE. -di386 -vi pp.pas diff --git a/befpc/compiler/0linux.sh b/befpc/compiler/0linux.sh new file mode 100644 index 0000000..fc7e514 --- /dev/null +++ b/befpc/compiler/0linux.sh @@ -0,0 +1 @@ +fpc -dGDB -dBROWSERLOG -dSUPPORT_MMX -dNOAG386INT -dNOAG386BIN -Sg -FE. -di386 pp.pas -vi diff --git a/befpc/compiler/Makefile b/befpc/compiler/Makefile new file mode 100644 index 0000000..2800708 --- /dev/null +++ b/befpc/compiler/Makefile @@ -0,0 +1,1529 @@ +# +# Makefile generated by fpcmake v0.99.15 [2000/07/02] +# + +defaultrule: all + +##################################################################### +# Autodetect OS (Linux or Dos or Windows NT) +# define inlinux when running under linux +# 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 +inlinux=1 +endif +else +PWD:=$(firstword $(PWD)) +endif + +# Detect NT - NT sets OS to Windows_NT +ifndef inlinux +ifeq ($(OS),Windows_NT) +inWinNT=1 +endif +endif + +# Detect OS/2 - OS/2 has OS2_SHELL defined +ifndef inlinux +ifndef inWinNT +ifdef OS2_SHELL +inOS2=1 +endif +endif +endif + +# The extension of executables +ifdef inlinux +EXEEXT= +else +EXEEXT=.exe +endif + +# The path which is searched separated by spaces +ifdef inlinux +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 +ifdef inOS2 +FPC=ppos2 +else +FPC=ppc386 +endif +endif +endif +override FPC:=$(subst $(EXEEXT),,$(FPC)) +override FPC:=$(subst \,/,$(FPC))$(EXEEXT) + +# 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 + +##################################################################### +# Pre Settings +##################################################################### + +# Don't export OS_SOURCE because it can change after the first compile +unexport OS_SOURCE FPC_VERSION + +# Allow ALPHA, POWERPC, M68K, I386 defines for target cpu +ifdef ALPHA +CPU_TARGET=alpha +endif +ifdef POWERPC +CPU_TARGET=powerpc +endif +ifdef M68K +CPU_TARGET=m68k +endif +ifdef I386 +CPU_TARGET=i386 +endif + +# RTL +UTILSDIR=../utils + +# Utils used by compiler development/installation +COMPILERUTILSDIR=utils + +# Default language for the compiler +ifndef FPCLANG +FPCLANG=e +endif + +# Local defines for the compiler only +ifndef LOCALDEF +LOCALDEF= +endif + +# Local options for the compiler only +ifndef LOCALOPT +LOCALOPT=$(OPT) +endif + +# Options for the RTL only when cycling +ifndef RTLOPTS +RTLOPTS=$(OPT) +endif + +# Message files +MSGFILES=$(wildcard error*.msg) +##################################################################### +# 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 + +# Default FPCDIR +ifeq ($(FPCDIR),wrong) +override FPCDIR=.. +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=wrong +endif +endif +endif + +# Detect FPCDIR +ifeq ($(FPCDIR),wrong) +ifdef inlinux +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 + + +# Clean + + +# Install + +PACKAGENAME=compiler +ZIPTARGET=install + +# Defaults + +override NEEDOPT=-Sg + +# Directories + +ifndef TARGETDIR +TARGETDIR=. +endif + +# Packages + +override PACKAGES+=rtl + +# Libraries + + +# Info + +INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall + +##################################################################### +# Post Settings +##################################################################### + +# Default message file +MSGFILE=error$(FPCLANG).msg + +# set correct defines (-d$(CPU_TARGET) is automaticly added in makefile.fpc) +override LOCALDEF+=-dGDB -dBROWSERLOG + +# i386 specific +ifeq ($(CPU_TARGET),i386) +# also insert MMX support +override LOCALDEF+=-dSUPPORT_MMX +# We don't need the intel and binary writer on linux... +ifdef inlinux +override LOCALDEF+=-dNOAG386INT -dNOAG386BIN +endif +endif + +override LOCALOPT+=$(LOCALDEF) + +override FPCOPT+=$(LOCALOPT) + +##################################################################### +# Shell tools +##################################################################### + +# echo +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(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 inlinux +INSTALL:=install -m 644 +else +INSTALL:=$(COPY) +endif +endif + +# To install programs +ifndef INSTALLEXE +ifdef inlinux +INSTALLEXE:=install -m 755 +else +INSTALLEXE:=$(COPY) +endif +endif + +# To make a directory. +ifndef MKDIR +ifdef inlinux +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 inlinux +PPAS=ppas.sh +else +ifdef inOS2 +PPAS=ppas.cmd +else +PPAS=ppas.bat +endif +endif + +# ldconfig to rebuild .so cache +ifdef inlinux +LDCONFIG=ldconfig +else +LDCONFIG= +endif + +# ppumove +ifndef PPUMOVE +PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUMOVE),) +PPUMOVE= +else +PPUMOVE:=$(firstword $(PPUMOVE)) +endif +endif +export PPUMOVE + +# ppufiles +ifndef PPUFILES +PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(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$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(UPXPROG),) +UPXPROG= +else +UPXPROG:=$(firstword $(UPXPROG)) +endif +else +UPXPROG= +endif +endif +export UPXPROG + +# cmp +ifndef CMP +CMP:=$(strip $(wildcard $(addsuffix /cmp$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(CMP),) +CMP= +else +CMP:=$(firstword $(CMP)) +endif +endif +export CMP + +# diff +ifndef DIFF +DIFF:=$(strip $(wildcard $(addsuffix /diff$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(DIFF),) +DIFF= +else +DIFF:=$(firstword $(DIFF)) +endif +endif +export DIFF + +# gdate/date +ifndef DATE +DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(DATE),) +DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH)))) +ifeq ($(DATE),) +DATE= +else +DATE:=$(firstword $(DATE)) +endif +else +DATE:=$(firstword $(DATE)) +endif +endif +export DATE + +ifdef DATE +DATESTR:=$(shell $(DATE) +%Y%m%d) +else +DATESTR= +endif + +# ZipProg, you can't use Zip as the var name (PFV) +ifndef ZIPPROG +ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(ZIPPROG),) +ZIPPROG= +else +ZIPPROG:=$(firstword $(ZIPPROG)) +endif +endif +export ZIPPROG + +ZIPOPT=-9 +ZIPEXT=.zip + +# Tar +ifndef TARPROG +TARPROG:=$(strip $(wildcard $(addsuffix /tar$(EXEEXT),$(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 +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) +FPCMADE=fpcmade.lnx +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 +##################################################################### + +# set the prefix directory where to install everything +ifndef PREFIXINSTALLDIR +ifdef inlinux +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 inlinux +BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION) +else +BASEINSTALLDIR=$(PREFIXINSTALLDIR) +endif +endif + +# set the directory where to install the binaries +ifndef BININSTALLDIR +ifdef inlinux +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 inlinux +LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib +else +LIBINSTALLDIR=$(UNITINSTALLDIR) +endif +endif + +# Where the source files will be stored +ifndef SOURCEINSTALLDIR +ifdef inlinux +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 inlinux +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 inlinux +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 inlinux +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+=-g -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 NEEDOPT +override FPCOPT+=$(NEEDOPT) +endif + +ifdef NEEDUNITDIR +override FPCOPT+=$(addprefix -Fu,$(NEEDUNITDIR)) +endif + +ifdef UNITSDIR +override FPCOPT+=-Fu$(UNITSDIR) +endif + +# Target dirs +ifdef TARGETDIR +override FPCOPT+=-FE$(TARGETDIR) +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 +ifeq (,$(findstring -s ,$(COMPILER))) +EXECPPAS= +else +EXECPPAS:=@$(PPAS) +endif + +##################################################################### +# Standard rules +##################################################################### + +debug: fpc_debug + +smart: fpc_smart + +shared: fpc_shared + +showinstall: fpc_showinstall + +sourceinstall: fpc_sourceinstall + +exampleinstall: fpc_exampleinstall + +zipinstall: fpc_zipinstall + +zipsourceinstall: fpc_zipsourceinstall + +zipexampleinstall: fpc_zipexampleinstall + +cleanall: fpc_cleanall + +info: fpc_info + +.PHONY: debug smart shared showinstall sourceinstall exampleinstall zipinstall zipsourceinstall zipexampleinstall cleanall info + +##################################################################### +# 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 + +# 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 inlinux +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 +ifdef PPUFILES +INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES)) +else +INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES))) +endif +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 inlinux + @$(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 inlinux + 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 inlinux +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 inlinux +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) c$(TAROPT) --file $(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 EXTRACLEANUNITS +override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS)) +endif + +ifdef CLEANPPUFILES +ifdef PPUFILES +CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES)) +else +CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES))) +endif +endif + +fpc_clean: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(CLEANRSTFILES) +endif +ifdef EXTRACLEANFILES + -$(DEL) $(EXTRACLEANFILES) +endif +ifdef LIBNAME + -$(DEL) $(LIBNAME) $(LIBFULLNAME) +endif + -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) + +fpc_distclean: fpc_clean + +fpc_cleanall: $(CLEANTARGET) +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 +##################################################################### + +##################################################################### +# Setup Targets +##################################################################### + +ifeq ($(OS_TARGET),win32) +ifdef CMP +override DIFF:=$(CMP) -i138 +endif +# force try to smartlink for windows unit +override COMPILER+=-XX +endif + +# Used to avoid unnecessary steps in remake3 +ifdef DIFF +ifdef OLDFPC +DIFFRESULT:=$(shell $(DIFF) $(OLDFPC) $(FPC)) +else +DIFFRESULT=Not equal +endif +else +DIFFRESULT=No diff program +endif + + +##################################################################### +# Setup os-independent filenames +##################################################################### + +FPCEXENAME=pp$(EXEEXT) +EXENAME=ppc386$(EXEEXT) +M68KEXENAME=ppc68k$(EXEEXT) +TEMPNAME=ppc$(EXEEXT) +TEMPNAME1=ppc1$(EXEEXT) +TEMPNAME2=ppc2$(EXEEXT) +TEMPNAME3=ppc3$(EXEEXT) +MAKEDEP=ppdep$(EXEEXT) +MSG2INC=msg2inc$(EXEEXT) + + +##################################################################### +# Default makefile +##################################################################### + +all: $(EXENAME) + $(MAKE) echotime + +ifeq ($(MAKELEVEL),0) +ifndef STARTTIME +ifdef DATE +STARTTIME:=$(shell $(DATE) +%T) +else +STARTTIME:=unknown +endif +endif +endif + +export STARTTIME + +ifdef DATE +ENDTIME=$(shell $(DATE) +%T) +else +ENDTIME:=unknown +endif + +echotime: + @echo Start $(STARTTIME) now $(ENDTIME) + +ifndef DIFFRESULT +next : + @echo $(OLDFPC) and $(FPC) are equal + $(COPY) $(FPC) $(EXENAME) +else +next : + $(MAKE) execlean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) -C $(UNITDIR_RTL) 'FPC=$(FPC)' 'OPT=$(RTLOPTS)' all + $(MAKE) clean + $(MAKE) all +endif + +clean : execlean fpc_cleanall + +ppuclean: fpc_cleanall + +execlean : + -$(DEL) $(EXENAME) + +distclean: clean + -$(DEL) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) + + +##################################################################### +# Include depencies +##################################################################### + +$(MAKEDEP): $(UTILSDIR)/ppdep.pp + $(COMPILER) $(UTILSDIR)/ppdep.pp + $(COPY) $(UTILSDIR)/$(MAKEDEP) $(MAKEDEP) + +dependencies : $(MAKEDEP) + $(MAKEDEP) pp.pas $(FPCOPTDEF) $(LOCALDEF) '-F$$(COMPILER) $$(LOCALOPT)' > depend + +ifdef USEDEPEND + +include depend + +endif + + +##################################################################### +# Make targets +##################################################################### + +$(MSG2INC): $(COMPILERUTILSDIR)/msg2inc.pp + $(COMPILER) -FE. $(COMPILERUTILSDIR)/msg2inc.pp + +# The msgtxt.inc only depends on the error?.msg file, not on msg2inc, +# because that one will be new almost everytime +msgtxt.inc: $(MSGFILE) + $(MAKE) $(MSG2INC) + $(MSG2INC) $(MSGFILE) msg msg + +msg: msgtxt.inc + +# Make only the compiler +ifndef COMPLETE +$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg + $(COMPILER) pp.pas + $(EXECPPAS) + $(MOVE) $(FPCEXENAME) $(EXENAME) +else +$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg + $(COMPILER) pp.pas + $(EXECPPAS) + $(COMPILER) pp.pas + $(EXECPPAS) + $(COMPILER) pp.pas + $(EXECPPAS) + $(MOVE) $(FPCEXENAME) $(EXENAME) +endif + +tokens.dat : $(wildcard *.pas) $(wildcard *.inc) + $(COMPILER) tokendat.pas + ./tokendat + +# This target remakes the units with the currently made version +remake: $(EXENAME) + $(MOVE) $(EXENAME) $(TEMPNAME) + $(MAKE) execlean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) clean + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' all + +remake3: $(TEMPNAME3) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next + $(DIFF) $(TEMPNAME3) $(EXENAME) + +$(TEMPNAME1) : $(EXENAME) + -$(DEL) $(TEMPNAME1) + $(MOVE) $(EXENAME) $(TEMPNAME1) + +$(TEMPNAME2) : $(TEMPNAME1) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next + -$(DEL) $(TEMPNAME2) + $(MOVE) $(EXENAME) $(TEMPNAME2) + +$(TEMPNAME3) : $(TEMPNAME2) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next + -$(DEL) $(TEMPNAME3) + $(MOVE) $(EXENAME) $(TEMPNAME3) + +cycle: + $(MAKE) clean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) -C $(UNITDIR_RTL) 'OPT=$(RTLOPTS)' all + $(MAKE) remake3 + $(MAKE) echotime + +cycledep: + $(MAKE) cycle USEDEPEND=1 + +cvstest: + $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPTS=-n -Se' + + +##################################################################### +# Installation +##################################################################### + +.PHONY: quickinstall install installsym + +MSGINSTALLDIR=$(BASEINSTALLDIR)/msg + +# This will only install the ppc386.exe, not the message files etc. +quickinstall: +ifdef inlinux + $(MKDIR) $(BASEINSTALLDIR) + $(INSTALLEXE) $(EXENAME) $(BASEINSTALLDIR) +else + $(MKDIR) $(BININSTALLDIR) +ifdef UPXPROG + -$(UPXPROG) $(EXENAME) +endif + $(INSTALLEXE) $(EXENAME) $(BININSTALLDIR) +endif + +install: quickinstall +ifdef inlinux + $(INSTALLEXE) $(COMPILERUTILSDIR)/samplecfg $(BASEINSTALLDIR)/samplecfg +endif + $(MKDIR) $(MSGINSTALLDIR) + $(INSTALL) $(MSGFILES) $(MSGINSTALLDIR) + +# this also installs the link /usr/bin/ppc386. The .deb does that later +installsymlink: install +ifdef inlinux + $(MKDIR) $(BININSTALLDIR) + ln -sf $(BASEINSTALLDIR)/ppc386 $(BININSTALLDIR)/ppc386 +endif + + +##################################################################### +# Misc +##################################################################### + +.PHONY: rtl rtlclean rtlinstall + +rtl: + $(MAKE) -C $(UNITDIR_RTL) all + +rtlclean: + $(MAKE) -C $(UNITDIR_RTL) clean + +rtlinstall: + $(MAKE) -C $(UNITDIR_RTL) install + +##################################################################### +# local user configurable file +# in makefile.loc you can add any desired target +##################################################################### + +localmake:=$(strip $(wildcard makefile.loc)) + +ifdef localmake +include ./$(localmake) +endif + + +##################################################################### +# M68k test targets +##################################################################### + +# just a quick way to get ppc68k +# needs to be after makefile.def for PASFILES INCFILES + +$(M68KEXENAME): $(PASFILES) $(INCFILES) + $(MAKE) clean + $(FPC) -uI386 -uSUPPORT_MMX -dm68k -o$(M68KEXENAME) pp + $(MAKE) clean diff --git a/befpc/compiler/Makefile.fpc b/befpc/compiler/Makefile.fpc new file mode 100644 index 0000000..41c9122 --- /dev/null +++ b/befpc/compiler/Makefile.fpc @@ -0,0 +1,355 @@ +# +# Makefile.fpc for Free Pascal Compiler +# + +[dirs] +fpcdir=.. +targetdir=. + +[install] +packagename=compiler +sourcesubdirs=0 + +[require] +rtl=1 +options=-Sg + +[tools] +tooldiff=1 +toolcmp=1 +tooldate=1 +toolupx=1 + + +[presettings] +# Don't export OS_SOURCE because it can change after the first compile +unexport OS_SOURCE FPC_VERSION + +# Allow ALPHA, POWERPC, M68K, I386 defines for target cpu +ifdef ALPHA +CPU_TARGET=alpha +endif +ifdef POWERPC +CPU_TARGET=powerpc +endif +ifdef M68K +CPU_TARGET=m68k +endif +ifdef I386 +CPU_TARGET=i386 +endif + +# RTL +UTILSDIR=../utils + +# Utils used by compiler development/installation +COMPILERUTILSDIR=utils + +# Default language for the compiler +ifndef FPCLANG +FPCLANG=e +endif + +# Local defines for the compiler only +ifndef LOCALDEF +LOCALDEF= +endif + +# Local options for the compiler only +ifndef LOCALOPT +LOCALOPT=$(OPT) +endif + +# Options for the RTL only when cycling +ifndef RTLOPTS +RTLOPTS=$(OPT) +endif + +# Message files +MSGFILES=$(wildcard error*.msg) + + +[postsettings] +# Default message file +MSGFILE=error$(FPCLANG).msg + +# set correct defines (-d$(CPU_TARGET) is automaticly added in makefile.fpc) +override LOCALDEF+=-dGDB -dBROWSERLOG + +# i386 specific +ifeq ($(CPU_TARGET),i386) +# also insert MMX support +override LOCALDEF+=-dSUPPORT_MMX +# We don't need the intel and binary writer on linux... +ifdef inlinux +override LOCALDEF+=-dNOAG386INT -dNOAG386BIN +endif +endif + +override LOCALOPT+=$(LOCALDEF) + +override FPCOPT+=$(LOCALOPT) + + +[rules] +##################################################################### +# Setup Targets +##################################################################### + +ifeq ($(OS_TARGET),win32) +ifdef CMP +override DIFF:=$(CMP) -i138 +endif +# force try to smartlink for windows unit +override COMPILER+=-XX +endif + +# Used to avoid unnecessary steps in remake3 +ifdef DIFF +ifdef OLDFPC +DIFFRESULT:=$(shell $(DIFF) $(OLDFPC) $(FPC)) +else +DIFFRESULT=Not equal +endif +else +DIFFRESULT=No diff program +endif + + +##################################################################### +# Setup os-independent filenames +##################################################################### + +FPCEXENAME=pp$(EXEEXT) +EXENAME=ppc386$(EXEEXT) +M68KEXENAME=ppc68k$(EXEEXT) +TEMPNAME=ppc$(EXEEXT) +TEMPNAME1=ppc1$(EXEEXT) +TEMPNAME2=ppc2$(EXEEXT) +TEMPNAME3=ppc3$(EXEEXT) +MAKEDEP=ppdep$(EXEEXT) +MSG2INC=msg2inc$(EXEEXT) + + +##################################################################### +# Default makefile +##################################################################### + +all: $(EXENAME) + $(MAKE) echotime + +ifeq ($(MAKELEVEL),0) +ifndef STARTTIME +ifdef DATE +STARTTIME:=$(shell $(DATE) +%T) +else +STARTTIME:=unknown +endif +endif +endif + +export STARTTIME + +ifdef DATE +ENDTIME=$(shell $(DATE) +%T) +else +ENDTIME:=unknown +endif + +echotime: + @echo Start $(STARTTIME) now $(ENDTIME) + +ifndef DIFFRESULT +next : + @echo $(OLDFPC) and $(FPC) are equal + $(COPY) $(FPC) $(EXENAME) +else +next : + $(MAKE) execlean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) -C $(UNITDIR_RTL) 'FPC=$(FPC)' 'OPT=$(RTLOPTS)' all + $(MAKE) clean + $(MAKE) all +endif + +clean : execlean fpc_cleanall + +ppuclean: fpc_cleanall + +execlean : + -$(DEL) $(EXENAME) + +distclean: clean + -$(DEL) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) + + +##################################################################### +# Include depencies +##################################################################### + +$(MAKEDEP): $(UTILSDIR)/ppdep.pp + $(COMPILER) $(UTILSDIR)/ppdep.pp + $(COPY) $(UTILSDIR)/$(MAKEDEP) $(MAKEDEP) + +dependencies : $(MAKEDEP) + $(MAKEDEP) pp.pas $(FPCOPTDEF) $(LOCALDEF) '-F$$(COMPILER) $$(LOCALOPT)' > depend + +ifdef USEDEPEND + +include depend + +endif + + +##################################################################### +# Make targets +##################################################################### + +$(MSG2INC): $(COMPILERUTILSDIR)/msg2inc.pp + $(COMPILER) -FE. $(COMPILERUTILSDIR)/msg2inc.pp + +# The msgtxt.inc only depends on the error?.msg file, not on msg2inc, +# because that one will be new almost everytime +msgtxt.inc: $(MSGFILE) + $(MAKE) $(MSG2INC) + $(MSG2INC) $(MSGFILE) msg msg + +msg: msgtxt.inc + +# Make only the compiler +ifndef COMPLETE +$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg + $(COMPILER) pp.pas + $(EXECPPAS) + $(MOVE) $(FPCEXENAME) $(EXENAME) +else +$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg + $(COMPILER) pp.pas + $(EXECPPAS) + $(COMPILER) pp.pas + $(EXECPPAS) + $(COMPILER) pp.pas + $(EXECPPAS) + $(MOVE) $(FPCEXENAME) $(EXENAME) +endif + +tokens.dat : $(wildcard *.pas) $(wildcard *.inc) + $(COMPILER) tokendat.pas + ./tokendat + +# This target remakes the units with the currently made version +remake: $(EXENAME) + $(MOVE) $(EXENAME) $(TEMPNAME) + $(MAKE) execlean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) clean + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' all + +remake3: $(TEMPNAME3) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next + $(DIFF) $(TEMPNAME3) $(EXENAME) + +$(TEMPNAME1) : $(EXENAME) + -$(DEL) $(TEMPNAME1) + $(MOVE) $(EXENAME) $(TEMPNAME1) + +$(TEMPNAME2) : $(TEMPNAME1) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next + -$(DEL) $(TEMPNAME2) + $(MOVE) $(EXENAME) $(TEMPNAME2) + +$(TEMPNAME3) : $(TEMPNAME2) + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next + -$(DEL) $(TEMPNAME3) + $(MOVE) $(EXENAME) $(TEMPNAME3) + +cycle: + $(MAKE) clean + $(MAKE) -C $(UNITDIR_RTL) clean + $(MAKE) -C $(UNITDIR_RTL) 'OPT=$(RTLOPTS)' all + $(MAKE) remake3 + $(MAKE) echotime + +cycledep: + $(MAKE) cycle USEDEPEND=1 + +cvstest: + $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPTS=-n -Se' + + +##################################################################### +# Installation +##################################################################### + +.PHONY: quickinstall install installsym + +MSGINSTALLDIR=$(BASEINSTALLDIR)/msg + +# This will only install the ppc386.exe, not the message files etc. +quickinstall: +ifdef inlinux + $(MKDIR) $(BASEINSTALLDIR) + $(INSTALLEXE) $(EXENAME) $(BASEINSTALLDIR) +else + $(MKDIR) $(BININSTALLDIR) +ifdef UPXPROG + -$(UPXPROG) $(EXENAME) +endif + $(INSTALLEXE) $(EXENAME) $(BININSTALLDIR) +endif + +install: quickinstall +ifdef inlinux + $(INSTALLEXE) $(COMPILERUTILSDIR)/samplecfg $(BASEINSTALLDIR)/samplecfg +endif + $(MKDIR) $(MSGINSTALLDIR) + $(INSTALL) $(MSGFILES) $(MSGINSTALLDIR) + +# this also installs the link /usr/bin/ppc386. The .deb does that later +installsymlink: install +ifdef inlinux + $(MKDIR) $(BININSTALLDIR) + ln -sf $(BASEINSTALLDIR)/ppc386 $(BININSTALLDIR)/ppc386 +endif + + +##################################################################### +# Misc +##################################################################### + +.PHONY: rtl rtlclean rtlinstall + +rtl: + $(MAKE) -C $(UNITDIR_RTL) all + +rtlclean: + $(MAKE) -C $(UNITDIR_RTL) clean + +rtlinstall: + $(MAKE) -C $(UNITDIR_RTL) install + +##################################################################### +# local user configurable file +# in makefile.loc you can add any desired target +##################################################################### + +localmake:=$(strip $(wildcard makefile.loc)) + +ifdef localmake +include ./$(localmake) +endif + + +##################################################################### +# M68k test targets +##################################################################### + +# just a quick way to get ppc68k +# needs to be after makefile.def for PASFILES INCFILES + +$(M68KEXENAME): $(PASFILES) $(INCFILES) + $(MAKE) clean + $(FPC) -uI386 -uSUPPORT_MMX -dm68k -o$(M68KEXENAME) pp + $(MAKE) clean + + diff --git a/befpc/compiler/README b/befpc/compiler/README new file mode 100644 index 0000000..0dac990 --- /dev/null +++ b/befpc/compiler/README @@ -0,0 +1,89 @@ +This directory contains the sources of the Free Pascal Compiler + +To recompile the compiler, use the batch file +mppc386.bat + +If you want to build a m68k version to cross compile from i386 to m68k +use the batch file +mppc68k.bat + +If you want to compile/modify the compiler, please read first the +programmers manual. + + +Changes in the syntax or semantic of FPC: +----------------------------------------- + 28/01/99 implicit conversion from boolean to integer is not possible + anymore (solved several bugs) but this could lead to errors + on previously accepted code (PM) + 01/02/99 c styled comments are supported (/* ... */), mainly + for the Sibyl sources of Medigo (FK) + 02/02/99 class destructors take now two parameters: flag + if the helper routine should free the instance and + self pointer (FK) + 22/02/99 PROTECTED and PRIVATE have now the same behavior + as in TP + 09/03/99 small records and arrays passed by value to a function are now directly copied + into a 4 bytes parameter (needed for C and DLL calls) (PM) + 11/03/99 the makefile.fpc is now also needed for the compiler and RTL, you can + find it in the base.zip package (PFV) + 24/03/99 new directives UNITPATH,INCLUDEPATH,OBJECTPATH,LIBRARYPATH to + set the searchpaths where to find the files for that module (PFV) + 25/03/99 new directive STATIC +/- or on/off , works like -St commandline + switch + 02/04/99 rtl/cfg/ directory has been removed, it's not used anymore + 15/04/99 FINALIZATION is supported + 21/04/99 Default assembler for i386 changed to AT&T instead of direct + 25/04/99 initialized vars supported in Delphi mode (only $J+ mode) + getting the address of an untyped const is now + forbidden as in BP + 27/04/99 New unit format PPU016, you need to recompile all older units + 01/05/99 Internal assembler. Assembler readers now support MMX,KNI + instructions. + 12/05/99 rtl/utils/ directory moved to utils/. Moved the utils only needed + for compiler development to compiler/utils/ + 13/05/99 Classes are now only allowed in the ObjFpc or Delphi mode. Use + {$mode objfpc} or {$mode delphi}. Or from commandline -S2 or -Sd + 16/05/99 Remove options -Up (use now -Fu) and -Fg (use now -Fl) + 17/05/99 Redesign of ansistring temporary handling, please report + any problems + 17/05/99 Most stuff of the objpas unit is now in the system unit + because the new temporary ansistring handling support + exceptions and exceptions need the class OOP model + 18/05/99 The compiler will stop directly if there are errors in the + commandline parameters + 16/08/99 DLL are relocatable by default (need to strip symbols) + -WN make non relocatable DLL (which can retain debug info) + for both type of DLL the prefered image base can be specified + with -WB1100000 for instance to get image base at $11000000. + 08/09/99 pointer addition/substraction (only available in fpc,objfpc mode) + now uses the size of the type the pointer points to, just like + inc(),dec() already did. Now inc(p) is the same as p:=p+1. + But old code can be broken by this when there is a p:=p+4 then + it's now parsed like: p:=p+4*sizeof(type). To get the old situation + you can use typecasting: p:=ptype(pointer(p)+4). + 08/09/99 class/object field return their offsets in the object/class. You + must access them self with loading the object/class pointer and + then create a reference where you add the field + 07/11/99 Small change to property writing in PPU => all units + exporting classes with properties must be recompiled + (no new unit format, so be careful) (FK) + 08/11/99 PP variable in Makefiles changed to FPC + 14/11/99 makefile.fpc is not available anymore. You must now use fpcmake + which is available from the utils/. There is also an example + Makefile.fpc + 15/02/00 The support of the fixed data type has been removed from the + compiler because + 1. it is buggy + 2. it is very seldom used + 3. the single data type is faster on modern cpus (Pentium+) + + If still want to use it, you have to recompile the compiler + with -dSUPPORT_FIXED and recompile the rtl with that compiler. + To find out if the used compiler supports the fixed data + type, check the directive HASFIXED (FK) + 29/02/00 ORDERSOURCES released => PPU version change + this allows for a more correct include file hunting order. + 01/04/00 fix the handling of value parameters in cdecl function + 11/05/00 changed vmt handling to fix problems some problems + with overloading in objects diff --git a/befpc/compiler/aasm.pas b/befpc/compiler/aasm.pas new file mode 100644 index 0000000..7ce26c4 --- /dev/null +++ b/befpc/compiler/aasm.pas @@ -0,0 +1,1177 @@ +{ + $Id: aasm.pas,v 1.1.1.1 2001-07-23 17:15:20 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an abstract asmoutput class for all processor types + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit aasm; + + interface + + uses + globtype,systems,cobjects,globals; + + type + + tait = ( + ait_none, + ait_direct, + ait_string, + ait_label, + ait_comment, + ait_instruction, + ait_datablock, + ait_symbol, + ait_symbol_end, { needed to calc the size of a symbol } + ait_const_32bit, + ait_const_16bit, + ait_const_8bit, + ait_const_symbol, + ait_real_80bit, + ait_real_64bit, + ait_real_32bit, + ait_comp_64bit, + ait_align, + ait_section, + { the following is only used by the win32 version of the compiler } + { and only the GNU AS Win32 is able to write it } + ait_const_rva, + ait_stabn, + ait_stabs, + ait_force_line, + ait_stab_function_name, + ait_cut, { used to split into tiny assembler files } + ait_regalloc, { for register,temp allocation debugging } + ait_tempalloc, + ait_marker, + + { the follow is for the DEC Alpha } + ait_frame, + ait_ent, +{$ifdef m68k} + ait_labeled_instruction, +{$endif m68k} + { never used, makes insertation of new ait_ easier to type } + { lazy guy !!!! ;-) (FK) } + ait_dummy); + + tcpuflags = (cf_64bitaddr); + tcpuflagset = set of tcpuflags; + +{ ait_* types which don't result in executable code or which don't influence } +{ the way the program runs/behaves, but which may be encountered by the } +{ optimizer (= if it's sometimes added to the exprasm list). Update if you add } +{ a new ait type! } + const + SkipInstr = [ait_comment, ait_symbol,ait_force_line,ait_section +{$ifdef GDB} + ,ait_stabs, ait_stabn, ait_stab_function_name +{$endif GDB} + ,ait_regalloc, ait_tempalloc, ait_symbol_end + ]; + + + { asm symbol functions } + type + TAsmsymtype=(AS_NONE,AS_EXTERNAL,AS_LOCAL,AS_GLOBAL); + + pasmsymbol = ^tasmsymbol; + tasmsymbol = object(tnamedindexobject) + orgtyp, + typ : TAsmsymtype; + proclocal : boolean; + { this need to be incremented with every symbol loading into the + paasmoutput, thus in loadsym/loadref/const_symbol (PFV) } + refs : longint; + { the next fields are filled in the binary writer } + idx : longint; + section : tsection; + address, + size : longint; + { alternate symbol which can be used for 'renaming' needed for + inlining } + altsymbol : pasmsymbol; + constructor init(const s:string;_typ:TAsmsymtype); + procedure reset; + function is_used:boolean; + procedure settyp(t:tasmsymtype); + procedure setaddress(sec:tsection;offset,len:longint); + procedure GenerateAltSymbol; + end; + + pasmlabel = ^tasmlabel; + tasmlabel = object(tasmsymbol) + labelnr : longint; + { this is set by the pai_label.init } + is_set : boolean; + constructor init; + constructor initdata; + function name:string;virtual; + end; + + + pasmsymbollist = ^tasmsymbollist; + tasmsymbollist = object(tdictionary) + end; + + { the short name makes typing easier } + pai = ^tai; + tai = object(tlinkedlist_item) + typ : tait; + { pointer to record with optimizer info about this tai object } + optinfo : pointer; + fileinfo : tfileposinfo; + constructor init; + end; + + pai_string = ^tai_string; + tai_string = object(tai) + str : pchar; + { extra len so the string can contain an \0 } + len : longint; + constructor init(const _str : string); + constructor init_pchar(_str : pchar); + constructor init_length_pchar(_str : pchar;length : longint); + destructor done;virtual; + end; + + { generates a common label } + pai_symbol = ^tai_symbol; + tai_symbol = object(tai) + sym : pasmsymbol; + is_global : boolean; + size : longint; + constructor init(_sym:PAsmSymbol;siz:longint); + constructor initname(const _name : string;siz:longint); + constructor initname_global(const _name : string;siz:longint); + end; + + pai_symbol_end = ^tai_symbol_end; + tai_symbol_end = object(tai) + sym : pasmsymbol; + constructor init(_sym:PAsmSymbol); + constructor initname(const _name : string); + end; + + pai_label = ^tai_label; + tai_label = object(tai) + l : pasmlabel; + is_global : boolean; + constructor init(_l : pasmlabel); + end; + + pai_direct = ^tai_direct; + tai_direct = object(tai) + str : pchar; + constructor init(_str : pchar); + destructor done; virtual; + end; + + + { to insert a comment into the generated assembler file } + pai_asm_comment = ^tai_asm_comment; + tai_asm_comment = object(tai) + str : pchar; + constructor init(_str : pchar); + destructor done; virtual; + end; + + + { alignment for operator } + +{$ifdef i386} + pai_align_abstract = ^tai_align_abstract; + tai_align_abstract = object(tai) +{$else i386} + pai_align = ^tai_align; + tai_align = object(tai) +{$endif i386} + buf : array[0..63] of char; { buf used for fill } + aligntype : byte; { 1 = no align, 2 = word align, 4 = dword align } + fillsize : byte; { real size to fill } + fillop : byte; { value to fill with - optional } + use_op : boolean; + constructor init(b:byte); + constructor init_op(b: byte; _op: byte); + function getfillbuf:pchar; + end; + + { Insert a section/segment directive } + pai_section = ^tai_section; + tai_section = object(tai) + sec : tsection; + constructor init(s : tsection); + end; + + + { generates an uninitializised data block } + pai_datablock = ^tai_datablock; + tai_datablock = object(tai) + sym : pasmsymbol; + size : longint; + is_global : boolean; + constructor init(const _name : string;_size : longint); + constructor init_global(const _name : string;_size : longint); + end; + + + { generates a long integer (32 bit) } + pai_const = ^tai_const; + tai_const = object(tai) + value : longint; + constructor init_32bit(_value : longint); + constructor init_16bit(_value : word); + constructor init_8bit(_value : byte); + end; + + pai_const_symbol = ^tai_const_symbol; + tai_const_symbol = object(tai) + sym : pasmsymbol; + offset : longint; + constructor init(_sym:PAsmSymbol); + constructor init_offset(_sym:PAsmSymbol;ofs:longint); + constructor init_rva(_sym:PAsmSymbol); + constructor initname(const name:string); + constructor initname_offset(const name:string;ofs:longint); + constructor initname_rva(const name:string); + end; + + { generates a single (32 bit real) } + pai_real_32bit = ^tai_real_32bit; + tai_real_32bit = object(tai) + value : ts32real; + constructor init(_value : ts32real); + end; + + { generates a double (64 bit real) } + pai_real_64bit = ^tai_real_64bit; + tai_real_64bit = object(tai) + value : ts64real; + constructor init(_value : ts64real); + end; + + { generates an extended (80 bit real) } + pai_real_80bit = ^tai_real_80bit; + tai_real_80bit = object(tai) + value : ts80real; + constructor init(_value : ts80real); + end; + + { generates an comp (integer over 64 bits) } + pai_comp_64bit = ^tai_comp_64bit; + tai_comp_64bit = object(tai) + value : ts64comp; + constructor init(_value : ts64comp); + end; + + { insert a cut to split into several smaller files } + + tcutplace=(cut_normal,cut_begin,cut_end); + + pai_cut = ^tai_cut; + tai_cut = object(tai) + place : tcutplace; + constructor init; + constructor init_begin; + constructor init_end; + end; + + TMarker = (NoPropInfoStart, NoPropInfoEnd, + AsmBlockStart, AsmBlockEnd, + InlineStart,InlineEnd); + pai_marker = ^tai_marker; + tai_marker = object(tai) + Kind: TMarker; + Constructor init(_Kind: TMarker); + end; + + paitempalloc = ^taitempalloc; + taitempalloc = object(tai) + allocation : boolean; + temppos, + tempsize : longint; + constructor alloc(pos,size:longint); + constructor dealloc(pos,size:longint); + end; + +{ for each processor define the best precision } +{ bestreal is defined in globals } +{$ifdef i386} +const + ait_bestreal = ait_real_80bit; +type + pai_bestreal = pai_real_80bit; + tai_bestreal = tai_real_80bit; +{$endif i386} +{$ifdef m68k} +const + ait_bestreal = ait_real_32bit; +type + pai_bestreal = pai_real_32bit; + tai_bestreal = tai_real_32bit; +{$endif m68k} + + + paasmoutput = ^taasmoutput; + taasmoutput = object(tlinkedlist) + function getlasttaifilepos : pfileposinfo; + end; + + const + { maximum of aasmoutput lists there will be } + maxoutputlists = 10; + + var + { temporary lists } + exprasmlist, + { default lists } + datasegment,codesegment,bsssegment, + debuglist,withdebuglist,consts, + importssection,exportssection, + resourcesection,rttilist, + resourcestringlist : paasmoutput; + { asm symbol list } + asmsymbollist : pasmsymbollist; + + const + nextaltnr : longint = 1; + nextlabelnr : longint = 1; + countlabelref : boolean = true; + + { make l as a new label } + procedure getlabel(var l : pasmlabel); + { make l as a new label and flag is_data } + procedure getdatalabel(var l : pasmlabel); + {just get a label number } + procedure getlabelnr(var l : longint); + + function newasmsymbol(const s : string) : pasmsymbol; + function newasmsymboltyp(const s : string;_typ:TAsmSymType) : pasmsymbol; + function getasmsymbol(const s : string) : pasmsymbol; + function renameasmsymbol(const sold, snew : string):pasmsymbol; + + procedure ResetAsmsymbolList; + procedure ResetAsmSymbolListAltSymbol; + procedure CheckAsmSymbolListUndefined; + +implementation + +uses + strings,files,verbose; + +{**************************************************************************** + TAI + ****************************************************************************} + + constructor tai.init; + begin + optinfo := nil; + fileinfo:=aktfilepos; + end; + +{**************************************************************************** + TAI_SECTION + ****************************************************************************} + + constructor tai_section.init(s : tsection); + begin + inherited init; + typ:=ait_section; + sec:=s; + end; + + +{**************************************************************************** + TAI_DATABLOCK + ****************************************************************************} + + constructor tai_datablock.init(const _name : string;_size : longint); + + begin + inherited init; + typ:=ait_datablock; + sym:=newasmsymboltyp(_name,AS_LOCAL); + { keep things aligned } + if _size<=0 then + _size:=4; + size:=_size; + is_global:=false; + end; + + + constructor tai_datablock.init_global(const _name : string;_size : longint); + begin + inherited init; + typ:=ait_datablock; + sym:=newasmsymboltyp(_name,AS_GLOBAL); + { keep things aligned } + if _size<=0 then + _size:=4; + size:=_size; + is_global:=true; + end; + + +{**************************************************************************** + TAI_SYMBOL + ****************************************************************************} + + constructor tai_symbol.init(_sym:PAsmSymbol;siz:longint); + begin + inherited init; + typ:=ait_symbol; + sym:=_sym; + size:=siz; + is_global:=(sym^.typ=AS_GLOBAL); + end; + + constructor tai_symbol.initname(const _name : string;siz:longint); + begin + inherited init; + typ:=ait_symbol; + sym:=newasmsymboltyp(_name,AS_LOCAL); + size:=siz; + is_global:=false; + end; + + constructor tai_symbol.initname_global(const _name : string;siz:longint); + begin + inherited init; + typ:=ait_symbol; + sym:=newasmsymboltyp(_name,AS_GLOBAL); + size:=siz; + is_global:=true; + end; + + +{**************************************************************************** + TAI_SYMBOL + ****************************************************************************} + + constructor tai_symbol_end.init(_sym:PAsmSymbol); + begin + inherited init; + typ:=ait_symbol_end; + sym:=_sym; + end; + + constructor tai_symbol_end.initname(const _name : string); + begin + inherited init; + typ:=ait_symbol_end; + sym:=newasmsymboltyp(_name,AS_GLOBAL); + end; + + +{**************************************************************************** + TAI_CONST + ****************************************************************************} + + constructor tai_const.init_32bit(_value : longint); + + begin + inherited init; + typ:=ait_const_32bit; + value:=_value; + end; + + constructor tai_const.init_16bit(_value : word); + + begin + inherited init; + typ:=ait_const_16bit; + value:=_value; + end; + + constructor tai_const.init_8bit(_value : byte); + + begin + inherited init; + typ:=ait_const_8bit; + value:=_value; + end; + + +{**************************************************************************** + TAI_CONST_SYMBOL_OFFSET + ****************************************************************************} + + constructor tai_const_symbol.init(_sym:PAsmSymbol); + begin + inherited init; + typ:=ait_const_symbol; + sym:=_sym; + offset:=0; + { update sym info } + inc(sym^.refs); + end; + + constructor tai_const_symbol.init_offset(_sym:PAsmSymbol;ofs:longint); + begin + inherited init; + typ:=ait_const_symbol; + sym:=_sym; + offset:=ofs; + { update sym info } + inc(sym^.refs); + end; + + constructor tai_const_symbol.init_rva(_sym:PAsmSymbol); + begin + inherited init; + typ:=ait_const_rva; + sym:=_sym; + offset:=0; + { update sym info } + inc(sym^.refs); + end; + + constructor tai_const_symbol.initname(const name:string); + begin + inherited init; + typ:=ait_const_symbol; + sym:=newasmsymbol(name); + offset:=0; + { update sym info } + inc(sym^.refs); + end; + + constructor tai_const_symbol.initname_offset(const name:string;ofs:longint); + begin + inherited init; + typ:=ait_const_symbol; + sym:=newasmsymbol(name); + offset:=ofs; + { update sym info } + inc(sym^.refs); + end; + + constructor tai_const_symbol.initname_rva(const name:string); + begin + inherited init; + typ:=ait_const_rva; + sym:=newasmsymbol(name); + offset:=0; + { update sym info } + inc(sym^.refs); + end; + + +{**************************************************************************** + TAI_real_32bit + ****************************************************************************} + + constructor tai_real_32bit.init(_value : ts32real); + + begin + inherited init; + typ:=ait_real_32bit; + value:=_value; + end; + +{**************************************************************************** + TAI_real_64bit + ****************************************************************************} + + constructor tai_real_64bit.init(_value : ts64real); + + begin + inherited init; + typ:=ait_real_64bit; + value:=_value; + end; + +{**************************************************************************** + TAI_real_80bit + ****************************************************************************} + + constructor tai_real_80bit.init(_value : ts80real); + + begin + inherited init; + typ:=ait_real_80bit; + value:=_value; + end; + +{**************************************************************************** + Tai_comp_64bit + ****************************************************************************} + + constructor tai_comp_64bit.init(_value : ts64comp); + + begin + inherited init; + typ:=ait_comp_64bit; + value:=_value; + end; + + +{**************************************************************************** + TAI_STRING + ****************************************************************************} + + constructor tai_string.init(const _str : string); + + begin + inherited init; + typ:=ait_string; + getmem(str,length(_str)+1); + strpcopy(str,_str); + len:=length(_str); + end; + + constructor tai_string.init_pchar(_str : pchar); + + begin + inherited init; + typ:=ait_string; + str:=_str; + len:=strlen(_str); + end; + + constructor tai_string.init_length_pchar(_str : pchar;length : longint); + + begin + inherited init; + typ:=ait_string; + str:=_str; + len:=length; + end; + + destructor tai_string.done; + + begin + { you can have #0 inside the strings so } + if str<>nil then + freemem(str,len+1); + inherited done; + end; + + +{**************************************************************************** + TAI_LABEL + ****************************************************************************} + + constructor tai_label.init(_l : pasmlabel); + begin + inherited init; + typ:=ait_label; + l:=_l; + l^.is_set:=true; + is_global:=(l^.typ=AS_GLOBAL); + end; + + +{**************************************************************************** + TAI_DIRECT + ****************************************************************************} + + constructor tai_direct.init(_str : pchar); + + begin + inherited init; + typ:=ait_direct; + str:=_str; + end; + + destructor tai_direct.done; + + begin + strdispose(str); + inherited done; + end; + +{**************************************************************************** + TAI_ASM_COMMENT comment to be inserted in the assembler file + ****************************************************************************} + + constructor tai_asm_comment.init(_str : pchar); + + begin + inherited init; + typ:=ait_comment; + str:=_str; + end; + + destructor tai_asm_comment.done; + + begin + strdispose(str); + inherited done; + end; + +{**************************************************************************** + TAI_ALIGN + ****************************************************************************} + +{$ifdef i386} + constructor tai_align_abstract.init(b: byte); +{$else i386} + constructor tai_align.init(b: byte); +{$endif i386} + begin + inherited init; + typ:=ait_align; + if b in [1,2,4,8,16,32] then + aligntype := b + else + aligntype := 1; + fillsize:=0; + fillop:=0; + use_op:=false; + end; + + +{$ifdef i386} + constructor tai_align_abstract.init_op(b: byte; _op: byte); +{$else i386} + constructor tai_align.init_op(b: byte; _op: byte); +{$endif i386} + begin + inherited init; + typ:=ait_align; + if b in [1,2,4,8,16,32] then + aligntype := b + else + aligntype := 1; + fillsize:=0; + fillop:=_op; + use_op:=true; + fillchar(buf,sizeof(buf),_op) + end; + + +{$ifdef i386} + function tai_align_abstract.getfillbuf:pchar; +{$else i386} + function tai_align.getfillbuf:pchar; +{$endif i386} + begin + getfillbuf:=@buf; + end; + +{**************************************************************************** + TAI_CUT + ****************************************************************************} + + constructor tai_cut.init; + begin + inherited init; + typ:=ait_cut; + place:=cut_normal; + end; + + + constructor tai_cut.init_begin; + begin + inherited init; + typ:=ait_cut; + place:=cut_begin; + end; + + + constructor tai_cut.init_end; + begin + inherited init; + typ:=ait_cut; + place:=cut_end; + end; + + +{**************************************************************************** + Tai_Marker + ****************************************************************************} + + Constructor Tai_Marker.Init(_Kind: TMarker); + Begin + Inherited Init; + typ := ait_marker; + Kind := _Kind; + End; + +{***************************************************************************** + TaiTempAlloc +*****************************************************************************} + + constructor taitempalloc.alloc(pos,size:longint); + begin + inherited init; + typ:=ait_tempalloc; + allocation:=true; + temppos:=pos; + tempsize:=size; + end; + + + constructor taitempalloc.dealloc(pos,size:longint); + begin + inherited init; + typ:=ait_tempalloc; + allocation:=false; + temppos:=pos; + tempsize:=size; + end; + + + +{***************************************************************************** + AsmSymbol +*****************************************************************************} + + constructor tasmsymbol.init(const s:string;_typ:TAsmsymtype); + begin; + {$IFDEF NEWST} + inherited init(s); + {$ELSE} + inherited initname(s); + {$ENDIF NEWST} + reset; + orgtyp:=_typ; + typ:=_typ; + end; + + procedure tasmsymbol.GenerateAltSymbol; + begin + if not assigned(altsymbol) then + begin + new(altsymbol,init(name+'_'+tostr(nextaltnr),typ)); + { also copy the amount of references } + altsymbol^.refs:=refs; + inc(nextaltnr); + end; + end; + + procedure tasmsymbol.reset; + begin + { reset section info } + section:=sec_none; + address:=0; + size:=0; + idx:=-1; + typ:=AS_EXTERNAL; + proclocal:=false; + { mainly used to remove unused labels from the codesegment } + refs:=0; + end; + + function tasmsymbol.is_used:boolean; + begin + is_used:=(refs>0); + end; + + procedure tasmsymbol.settyp(t:tasmsymtype); + begin + typ:=t; + orgtyp:=t; + end; + + procedure tasmsymbol.setaddress(sec:tsection;offset,len:longint); + begin + section:=sec; + address:=offset; + size:=len; + { when the typ was reset to External, set it back to the original + type it got when defined } + if (typ=AS_EXTERNAL) and (orgtyp<>AS_NONE) then + typ:=orgtyp; + end; + + +{***************************************************************************** + AsmLabel +*****************************************************************************} + + constructor tasmlabel.init; + begin; + labelnr:=nextlabelnr; + inc(nextlabelnr); + inherited init(target_asm.labelprefix+tostr(labelnr),AS_LOCAL); + proclocal:=true; + is_set:=false; + end; + + + constructor tasmlabel.initdata; + begin; + labelnr:=nextlabelnr; + inc(nextlabelnr); + if (cs_create_smart in aktmoduleswitches) then + inherited init('_$'+current_module^.modulename^+'$_L'+tostr(labelnr),AS_GLOBAL) + else + inherited init(target_asm.labelprefix+tostr(labelnr),AS_LOCAL); + is_set:=false; + { write it always } + refs:=1; + end; + + + function tasmlabel.name:string; + begin + name:=inherited name; + inc(refs); + end; + + +{***************************************************************************** + AsmSymbolList helpers +*****************************************************************************} + + function newasmsymbol(const s : string) : pasmsymbol; + var + hp : pasmsymbol; + begin + hp:=pasmsymbol(asmsymbollist^.search(s)); + if assigned(hp) then + begin + newasmsymbol:=hp; + exit; + end; + { Not found, insert it as an External } + hp:=new(pasmsymbol,init(s,AS_EXTERNAL)); + asmsymbollist^.insert(hp); + newasmsymbol:=hp; + end; + + + function newasmsymboltyp(const s : string;_typ:TAsmSymType) : pasmsymbol; + var + hp : pasmsymbol; + begin + hp:=pasmsymbol(asmsymbollist^.search(s)); + if assigned(hp) then + begin + hp^.settyp(_typ); + newasmsymboltyp:=hp; + exit; + end; + { Not found, insert it as an External } + hp:=new(pasmsymbol,init(s,_typ)); + asmsymbollist^.insert(hp); + newasmsymboltyp:=hp; + end; + + + function getasmsymbol(const s : string) : pasmsymbol; + begin + getasmsymbol:=pasmsymbol(asmsymbollist^.search(s)); + end; + + + { renames an asmsymbol } + function renameasmsymbol(const sold, snew : string):pasmsymbol; + begin + renameasmsymbol:=pasmsymbol(asmsymbollist^.rename(sold,snew)); + end; + + + procedure ResetAsmSym(p:Pnamedindexobject);{$ifndef FPC}far;{$endif} + begin + pasmsymbol(p)^.reset; + end; + + + procedure ResetAsmsymbolList; + begin + asmsymbollist^.foreach({$ifndef TP}@{$endif}resetasmsym); + end; + + + procedure ResetAltSym(p:Pnamedindexobject);{$ifndef FPC}far;{$endif} + begin + pasmsymbol(p)^.altsymbol:=nil; + end; + + + procedure ResetAsmSymbolListAltSymbol; + begin + asmsymbollist^.foreach({$ifndef TP}@{$endif}resetaltsym); + end; + + + procedure checkundefinedasmsym(p:Pnamedindexobject);{$ifndef FPC}far;{$endif} + begin + if (pasmsymbol(p)^.refs>0) and + (pasmsymbol(p)^.section=Sec_none) and + (pasmsymbol(p)^.typ<>AS_EXTERNAL) then + Message1(asmw_e_undefined_label,pasmsymbol(p)^.name); + end; + + procedure CheckAsmSymbolListUndefined; + begin + asmsymbollist^.foreach({$ifndef TP}@{$endif}checkundefinedasmsym); + end; + + +{***************************************************************************** + Label Helpers +*****************************************************************************} + + procedure getlabel(var l : pasmlabel); + begin + l:=new(pasmlabel,init); + asmsymbollist^.insert(l); + end; + + + procedure getdatalabel(var l : pasmlabel); + begin + l:=new(pasmlabel,initdata); + asmsymbollist^.insert(l); + end; + + + procedure RegenerateLabel(var l : pasmlabel); + begin + if l^.proclocal then + getlabel(pasmlabel(l^.altsymbol)) + else + getdatalabel(pasmlabel(l^.altsymbol)); + end; + + + procedure getlabelnr(var l : longint); + begin + l:=nextlabelnr; + inc(nextlabelnr); + end; + + +{***************************************************************************** + TAAsmOutput +*****************************************************************************} + + function taasmoutput.getlasttaifilepos : pfileposinfo; + begin + if assigned(last) then + getlasttaifilepos:=@pai(last)^.fileinfo + else + getlasttaifilepos:=nil; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.82 2000/04/22 14:25:03 jonas + * aasm.pas: pai_align instead of pai_align_abstract if cpu <> i386 + + systems.pas: info for macos/ppc + * new/cgobj.pas: compiles again without newst define + * new/powerpc/cgcpu: generate different entry/exit code depending on + whether target_os is MacOs or Linux + + Revision 1.81 2000/04/10 12:21:33 jonas + * added ait_symbol_end to SkipInstr + + Revision 1.80 2000/02/29 23:55:53 pierre + + InlineStat and InlineEnd amrker added + + Revision 1.79 2000/02/28 17:23:56 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.78 2000/02/18 20:53:14 pierre + * fixes a stabs problem for functions + + includes a stabs local var for with statements + the name is with in lowercase followed by an index + for nested with. + + Withdebuglist added because the stabs declarations of local + var are postponed to end of function. + + Revision 1.77 2000/02/09 13:22:42 peter + * log truncated + + Revision 1.76 2000/02/03 23:01:45 peter + * fixed smartlinking + + Revision 1.75 2000/01/28 15:15:31 jonas + * moved skipinstr from daopt386 to aasm + * fixed crashing bug with -dreplacereg in csopt386.pas + + Revision 1.74 2000/01/23 16:31:38 peter + * fixed uninited asmsymbol.typ var + + Revision 1.73 2000/01/19 22:53:57 florian + * empty records/objects would generate static data of size 0 which is optimized away, tai_datablock + checks now the size and sets it to a value > 0 + + Revision 1.72 2000/01/13 13:07:05 jonas + * released -dalignreg + * some small fixes to -dnewOptimizations helper procedures + + Revision 1.71 2000/01/12 10:38:16 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.70 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.69 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.68 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.67 1999/11/05 16:01:45 jonas + + first implementation of choosing least used register for alignment code + (not yet working, between ifdef alignreg) + + Revision 1.66 1999/11/02 15:06:56 peter + * import library fixes for win32 + * alignment works again + + Revision 1.65 1999/10/27 16:11:27 peter + * insns.dat is used to generate all i386*.inc files + + Revision 1.64 1999/09/20 16:38:51 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.63 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.62 1999/09/15 20:35:37 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.61 1999/09/08 15:01:29 jonas + * some small changes so the noew optimizer is again compilable + + Revision 1.60 1999/08/06 15:30:17 florian + + cpu flags added, mainly for the new cg + + Revision 1.59 1999/08/05 15:51:01 michael + * Added ait_frame, ait_ent + + Revision 1.58 1999/08/04 00:39:56 michael + + Added ait_frame + + Revision 1.57 1999/08/02 21:01:41 michael + * Moved toperand type back =( + +} \ No newline at end of file diff --git a/befpc/compiler/ag386att.pas b/befpc/compiler/ag386att.pas new file mode 100644 index 0000000..e1a6e79 --- /dev/null +++ b/befpc/compiler/ag386att.pas @@ -0,0 +1,1001 @@ +{ + $Id: ag386att.pas,v 1.1.1.1 2001-07-23 17:15:23 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for i386 AT&T syntax + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit ag386att; + + interface + + uses cobjects,aasm,assemble; + + type + pi386attasmlist=^ti386attasmlist; + ti386attasmlist=object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; +{$ifdef GDB} + procedure WriteFileLineInfo(var fileinfo : tfileposinfo); + procedure WriteFileEndInfo; +{$endif} + end; + + implementation + + uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + strings, + globtype,globals,systems, + files,verbose,cpubase,cpuasm +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + + var +{$ifdef GDB} + n_line : byte; { different types of source lines } + linecount, + includecount : longint; + funcname : pchar; + stabslastfileinfo : tfileposinfo; +{$endif} + lastsec : tsection; { last section type written } + lastfileinfo : tfileposinfo; + infile, + lastinfile : pinputfile; + symendcount : longint; + + function fixline(s:string):string; + { + return s with all leading and ending spaces and tabs removed + } + var + i,j,k : longint; + begin + i:=length(s); + while (i>0) and (s[i] in [#9,' ']) do + dec(i); + j:=1; + while (jR_NO then + s:=att_reg2str[segment]+':' + else + s:=''; + if assigned(symbol) then + s:=s+symbol^.name; + if offset<0 then + s:=s+tostr(offset) + else + if (offset>0) then + begin + if assigned(symbol) then + s:=s+'+'+tostr(offset) + else + s:=s+tostr(offset); + end; + if (index<>R_NO) and (base=R_NO) then + Begin + s:=s+'(,'+att_reg2str[index]; + if scalefactor<>0 then + s:=s+','+tostr(scalefactor)+')' + else + s:=s+')'; + end + else + if (index=R_NO) and (base<>R_NO) then + s:=s+'('+att_reg2str[base]+')' + else + if (index<>R_NO) and (base<>R_NO) then + Begin + s:=s+'('+att_reg2str[base]+','+att_reg2str[index]; + if scalefactor<>0 then + s:=s+','+tostr(scalefactor)+')' + else + s := s+')'; + end; + end; + end; + getreferencestring:=s; + end; + + function getopstr(const o:toper) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr:=att_reg2str[o.reg]; + top_ref : + getopstr:=getreferencestring(o.ref^); + top_const : + getopstr:='$'+tostr(o.val); + top_symbol : + begin + if assigned(o.sym) then + hs:='$'+o.sym^.name + else + hs:='$'; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs) + else + if not(assigned(o.sym)) then + hs:=hs+'0'; + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(const o:toper) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr_jmp:='*'+att_reg2str[o.reg]; + top_ref : + getopstr_jmp:='*'+getreferencestring(o.ref^); + top_const : + getopstr_jmp:=tostr(o.val); + top_symbol : + begin + hs:=o.sym^.name; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs); + getopstr_jmp:=hs; + end; + else + internalerror(10001); + end; + end; + + +{**************************************************************************** + TI386ATTASMOUTPUT + ****************************************************************************} + + const + ait_const2str : array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'.long'#9,#9'.short'#9,#9'.byte'#9); + + + function ait_section2str(s:tsection):string; + begin + ait_section2str:=target_asm.secnames[s]; +{$ifdef GDB} + { this is needed for line info in data } + funcname:=nil; + case s of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + else n_line:=n_dataline; + end; +{$endif GDB} + LastSec:=s; + end; + + +{$ifdef GDB} + procedure ti386attasmlist.WriteFileLineInfo(var fileinfo : tfileposinfo); + var + curr_n : byte; + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + { file changed ? (must be before line info) } + if (fileinfo.fileindex<>0) and + (stabslastfileinfo.fileindex<>fileinfo.fileindex) then + begin + infile:=current_module^.sourcefiles^.get_file(fileinfo.fileindex); + if assigned(infile) then + begin + if includecount=0 then + curr_n:=n_sourcefile + else + curr_n:=n_includefile; + if (infile^.path^<>'') then + begin + AsmWriteLn(#9'.stabs "'+lower(BsToSlash(FixPath(infile^.path^,false)))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + end; + AsmWriteLn(#9'.stabs "'+lower(FixFileName(infile^.name^))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + AsmWriteLn('Ltext'+ToStr(IncludeCount)+':'); + inc(includecount); + end; + end; + { line changed ? } + if (stabslastfileinfo.line<>fileinfo.line) and (fileinfo.line<>0) then + begin + if (n_line=n_textline) and assigned(funcname) and + (target_os.use_function_relative_addresses) then + begin + AsmWriteLn(target_asm.labelprefix+'l'+tostr(linecount)+':'); + AsmWrite(#9'.stabn '+tostr(n_line)+',0,'+tostr(fileinfo.line)+','+ + target_asm.labelprefix+'l'+tostr(linecount)+' - '); + AsmWritePChar(FuncName); + AsmLn; + inc(linecount); + end + else + AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(fileinfo.line)); + end; + stabslastfileinfo:=fileinfo; + end; + + procedure ti386attasmlist.WriteFileEndInfo; + + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + AsmLn; + AsmWriteLn(ait_section2str(sec_code)); + AsmWriteLn(#9'.stabs "",'+tostr(n_sourcefile)+',0,0,Letext'); + AsmWriteLn('Letext:'); + end; + +{$endif GDB} + + + procedure ti386attasmlist.WriteTree(p:paasmoutput); + const + allocstr : array[boolean] of string[10]=(' released',' allocated'); + nolinetai =[ait_label, + ait_regalloc,ait_tempalloc, + ait_stabn,ait_stabs,ait_section, + ait_cut,ait_marker,ait_align,ait_stab_function_name]; + type + t80bitarray = array[0..9] of byte; + t64bitarray = array[0..7] of byte; + t32bitarray = array[0..3] of byte; + var + ch : char; + hp : pai; + consttyp : tait; + s : string; + found : boolean; + i,pos,l : longint; + InlineLevel : longint; + co : comp; + sin : single; + d : double; + e : extended; + op : tasmop; + calljmp, + do_line : boolean; + sep : char; + begin + if not assigned(p) then + exit; + InlineLevel:=0; + { lineinfo is only needed for codesegment (PFV) } + do_line:=(cs_asm_source in aktglobalswitches) or + ((cs_lineinfo in aktmoduleswitches) + and (p=codesegment)); + hp:=pai(p^.first); + while assigned(hp) do + begin + aktfilepos:=hp^.fileinfo; + + if not(hp^.typ in nolinetai) then + begin +{$ifdef GDB} + { write stabs } + if (cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches) then + WriteFileLineInfo(hp^.fileinfo); +{$endif GDB} + + if do_line then + begin + { load infile } + if lastfileinfo.fileindex<>hp^.fileinfo.fileindex then + begin + infile:=current_module^.sourcefiles^.get_file(hp^.fileinfo.fileindex); + if assigned(infile) then + begin + { open only if needed !! } + if (cs_asm_source in aktglobalswitches) then + infile^.open; + end; + { avoid unnecessary reopens of the same file !! } + lastfileinfo.fileindex:=hp^.fileinfo.fileindex; + { be sure to change line !! } + lastfileinfo.line:=-1; + end; + { write source } + if (cs_asm_source in aktglobalswitches) and + assigned(infile) then + begin + if (infile<>lastinfile) then + begin + AsmWriteLn(target_asm.comment+'['+infile^.name^+']'); + if assigned(lastinfile) then + lastinfile^.close; + end; + if (hp^.fileinfo.line<>lastfileinfo.line) and + ((hp^.fileinfo.line0)) then + begin + if (hp^.fileinfo.line<>0) and + ((infile^.linebuf^[hp^.fileinfo.line]>=0) or (InlineLevel>0)) then + AsmWriteLn(target_asm.comment+'['+tostr(hp^.fileinfo.line)+'] '+ + fixline(infile^.GetLineStr(hp^.fileinfo.line))); + { set it to a negative value ! + to make that is has been read already !! PM } + if (infile^.linebuf^[hp^.fileinfo.line]>=0) then + infile^.linebuf^[hp^.fileinfo.line]:=-infile^.linebuf^[hp^.fileinfo.line]-1; + end; + end; +{$ifdef LINEINFO} + { lineinfo } + if (cs_lineinfo in aktmoduleswitches) then + begin + if (infile<>lastinfile) then + begin + lineinfolist^.concat(new(pai_const(init_8bit + end + else + begin + end; + end; +{$endif LINEINFO} + lastfileinfo:=hp^.fileinfo; + lastinfile:=infile; + end; + end; + + case hp^.typ of + + ait_comment : + Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + + ait_regalloc : + begin + if (cs_asm_regalloc in aktglobalswitches) then + AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+ + allocstr[pairegalloc(hp)^.allocation]); + end; + + ait_tempalloc : + begin + if (cs_asm_tempalloc in aktglobalswitches) then + AsmWriteLn(target_asm.comment+'Temp '+tostr(paitempalloc(hp)^.temppos)+','+ + tostr(paitempalloc(hp)^.tempsize)+allocstr[paitempalloc(hp)^.allocation]); + end; + + ait_align : + begin + AsmWrite(#9'.balign '+tostr(pai_align(hp)^.aligntype)); + if pai_align(hp)^.use_op then + AsmWrite(','+tostr(pai_align(hp)^.fillop)); + AsmLn; + end; + + ait_section : + begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWriteLn(ait_section2str(pai_section(hp)^.sec)); +{$ifdef GDB} + lastfileinfo.line:=-1; +{$endif GDB} + end; + end; + + ait_datablock : + begin + if pai_datablock(hp)^.is_global then + AsmWrite(#9'.comm'#9) + else + AsmWrite(#9'.lcomm'#9); + AsmWrite(pai_datablock(hp)^.sym^.name); + AsmWriteLn(','+tostr(pai_datablock(hp)^.size)); + end; + + ait_const_32bit, + ait_const_16bit, + ait_const_8bit : + begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + + ait_const_symbol : + begin + AsmWrite(#9'.long'#9+pai_const_symbol(hp)^.sym^.name); + if pai_const_symbol(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) + else if pai_const_symbol(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol(hp)^.offset)); + AsmLn; + end; + + ait_const_rva : + AsmWriteLn(#9'.rva'#9+pai_const_symbol(hp)^.sym^.name); + + ait_real_80bit : + begin + if do_line then + AsmWriteLn(target_asm.comment+extended2str(pai_real_80bit(hp)^.value)); + { Make sure e is a extended type, bestreal could be + a different type (bestreal) !! (PFV) } + e:=pai_real_80bit(hp)^.value; + AsmWrite(#9'.byte'#9); + for i:=0 to 9 do + begin + if i<>0 then + AsmWrite(','); + AsmWrite(tostr(t80bitarray(e)[i])); + end; + AsmLn; + end; + + ait_real_64bit : + begin + if do_line then + AsmWriteLn(target_asm.comment+double2str(pai_real_64bit(hp)^.value)); + d:=pai_real_64bit(hp)^.value; + AsmWrite(#9'.byte'#9); + for i:=0 to 7 do + begin + if i<>0 then + AsmWrite(','); + AsmWrite(tostr(t64bitarray(d)[i])); + end; + AsmLn; + end; + + ait_real_32bit : + begin + if do_line then + AsmWriteLn(target_asm.comment+single2str(pai_real_32bit(hp)^.value)); + sin:=pai_real_32bit(hp)^.value; + AsmWrite(#9'.byte'#9); + for i:=0 to 3 do + begin + if i<>0 then + AsmWrite(','); + AsmWrite(tostr(t32bitarray(sin)[i])); + end; + AsmLn; + end; + + ait_comp_64bit : + begin + if do_line then + AsmWriteLn(target_asm.comment+comp2str(pai_comp_64bit(hp)^.value)); + AsmWrite(#9'.byte'#9); +{$ifdef FPC} + co:=comp(pai_comp_64bit(hp)^.value); +{$else} + co:=pai_comp_64bit(hp)^.value; +{$endif} + for i:=0 to 7 do + begin + if i<>0 then + AsmWrite(','); + AsmWrite(tostr(t64bitarray(co)[i])); + end; + AsmLn; + end; + + ait_direct : + begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; +{$IfDef GDB} + if strpos(pai_direct(hp)^.str,'.data')<>nil then + n_line:=n_dataline + else if strpos(pai_direct(hp)^.str,'.text')<>nil then + n_line:=n_textline + else if strpos(pai_direct(hp)^.str,'.bss')<>nil then + n_line:=n_bssline; +{$endif GDB} + end; + + ait_string : + begin + pos:=0; + for i:=1 to pai_string(hp)^.len do + begin + if pos=0 then + begin + AsmWrite(#9'.ascii'#9'"'); + pos:=20; + end; + ch:=pai_string(hp)^.str[i-1]; + case ch of + #0, {This can't be done by range, because a bug in FPC} + #1..#31, + #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7); + '"' : s:='\"'; + '\' : s:='\\'; + else + s:=ch; + end; + AsmWrite(s); + inc(pos,length(s)); + if (pos>line_length) or (i=pai_string(hp)^.len) then + begin + AsmWriteLn('"'); + pos:=0; + end; + end; + end; + + ait_label : + begin + if (pai_label(hp)^.l^.is_used) then + begin + if pai_label(hp)^.l^.typ=AS_GLOBAL then + begin + AsmWrite('.globl'#9); + AsmWriteLn(pai_label(hp)^.l^.name); + end; + AsmWrite(pai_label(hp)^.l^.name); + AsmWriteLn(':'); + end; + end; + + ait_symbol : + begin + if pai_symbol(hp)^.is_global then + begin + AsmWrite('.globl'#9); + AsmWriteLn(pai_symbol(hp)^.sym^.name); + end; + if target_info.target=target_i386_linux then + begin + AsmWrite(#9'.type'#9); + AsmWrite(pai_symbol(hp)^.sym^.name); + if assigned(pai(hp^.next)) and + (pai(hp^.next)^.typ in [ait_const_symbol,ait_const_rva, + ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_datablock, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit]) then + AsmWriteLn(',@object') + else + AsmWriteLn(',@function'); + if pai_symbol(hp)^.sym^.size>0 then + begin + AsmWrite(#9'.size'#9); + AsmWrite(pai_symbol(hp)^.sym^.name); + AsmWrite(', '); + AsmWriteLn(tostr(pai_symbol(hp)^.sym^.size)); + end; + end; + AsmWrite(pai_symbol(hp)^.sym^.name); + AsmWriteLn(':'); + end; + + ait_symbol_end : + begin + if target_info.target=target_i386_linux then + begin + s:=target_asm.labelprefix+'e'+tostr(symendcount); + inc(symendcount); + AsmWriteLn(s+':'); + AsmWrite(#9'.size'#9); + AsmWrite(pai_symbol(hp)^.sym^.name); + AsmWrite(', '+s+' - '); + AsmWriteLn(pai_symbol(hp)^.sym^.name); + end; + end; + + ait_instruction : + begin + op:=paicpu(hp)^.opcode; + calljmp:=is_calljmp(op); + { call maybe not translated to call } + s:=#9+att_op2str[op]+cond2str[paicpu(hp)^.condition]; + { suffix needed ? fnstsw,fldcw don't support suffixes + with binutils 2.9.5 under linux } + if (not calljmp) and + (att_needsuffix[op]<>AttSufNONE) and + (op<>A_FNSTSW) and (op<>A_FSTSW) and + (op<>A_FNSTCW) and (op<>A_FSTCW) and + (op<>A_FLDCW) and + not( + (paicpu(hp)^.oper[0].typ=top_reg) and + (paicpu(hp)^.oper[0].reg in [R_ST..R_ST7]) + ) then + s:=s+att_opsize2str[paicpu(hp)^.opsize]; + { process operands } + if paicpu(hp)^.ops<>0 then + begin + { call and jmp need an extra handling } + { this code is only called if jmp isn't a labeled instruction } + { quick hack to overcome a problem with manglednames=255 chars } + if calljmp then + begin + AsmWrite(s+#9); + s:=getopstr_jmp(paicpu(hp)^.oper[0]); + end + else + begin + for i:=0 to paicpu(hp)^.ops-1 do + begin + if i=0 then + sep:=#9 + else + sep:=','; + s:=s+sep+getopstr(paicpu(hp)^.oper[i]) + end; + end; + end; + AsmWriteLn(s); + end; + +{$ifdef GDB} + ait_stabs : + begin + AsmWrite(#9'.stabs '); + AsmWritePChar(pai_stabs(hp)^.str); + AsmLn; + end; + + ait_stabn : + begin + AsmWrite(#9'.stabn '); + AsmWritePChar(pai_stabn(hp)^.str); + AsmLn; + end; + + ait_force_line : + stabslastfileinfo.line:=0; + + ait_stab_function_name: + funcname:=pai_stab_function_name(hp)^.str; +{$endif GDB} + + ait_cut : + begin + if SmartAsm then + begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + AsmClose; + DoAssemble; + AsmCreate(pai_cut(hp)^.place); + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + lastsec:=pai_section(hp^.next)^.sec; + hp:=pai(hp^.next); + end; +{$ifdef GDB} + { force write of filename } + FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0); + includecount:=0; + funcname:=nil; + WriteFileLineInfo(hp^.fileinfo); +{$endif GDB} + if lastsec<>sec_none then + AsmWriteLn(ait_section2str(lastsec)); + AsmStartSize:=AsmSize; + end; + end; + + ait_marker : + if pai_marker(hp)^.kind=InlineStart then + inc(InlineLevel) + else if pai_marker(hp)^.kind=InlineEnd then + dec(InlineLevel); + + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + + procedure ti386attasmlist.WriteAsmList; + var + p:dirstr; + n:namestr; + e:extstr; +{$ifdef GDB} + fileinfo : tfileposinfo; +{$endif GDB} + + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + Comment(v_info,'Start writing att-styled assembler output for '+current_module^.mainsource^); +{$endif} + + LastSec:=sec_none; +{$ifdef GDB} + FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0); +{$endif GDB} + FillChar(lastfileinfo,sizeof(lastfileinfo),0); + LastInfile:=nil; + + if assigned(current_module^.mainsource) then + fsplit(current_module^.mainsource^,p,n,e) + else + begin + p:=inputdir; + n:=inputfile; + e:=inputextension; + end; + { to get symify to work } + AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"'); + +{$ifdef GDB} + n_line:=n_bssline; + funcname:=nil; + linecount:=1; + includecount:=0; + fileinfo.fileindex:=1; + fileinfo.line:=1; + { Write main file } + WriteFileLineInfo(fileinfo); +{$endif GDB} + AsmStartSize:=AsmSize; + symendcount:=0; + + countlabelref:=false; + If (cs_debuginfo in aktmoduleswitches) then + WriteTree(debuglist); + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + Writetree(resourcestringlist); + WriteTree(bsssegment); + Writetree(importssection); + { exports are written by DLLTOOL + if we use it so don't insert it twice (PM) } + if not UseDeffileForExport and assigned(exportssection) then + Writetree(exportssection); + Writetree(resourcesection); + {$ifdef GDB} + WriteFileEndInfo; + {$ENDIF} + countlabelref:=true; + + AsmLn; +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing att-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.34 2000/05/11 09:59:40 pierre + * changed to compile with Delphi, reported by Kovacs Attila Zoltan + + Revision 1.33 2000/04/12 12:42:28 pierre + * fix the -g-l option + + Revision 1.32 2000/04/06 07:04:50 pierre + + generate line stabs if cs_gdb_lineinfo is aktglobalswitches + + Revision 1.31 2000/04/01 14:18:03 peter + * don't write suffix for fldcw + + Revision 1.30 2000/02/29 23:56:49 pierre + * write source line again for inline procs + + Revision 1.29 2000/02/20 21:20:28 marco + * Put some call under Ifdef GDB, so that compiling without -dGDB works + + Revision 1.28 2000/02/18 21:54:07 pierre + * avoid LeText if no stabs info + + Revision 1.27 2000/02/18 12:31:07 pierre + * Reset file name to empty at end of code section + + Revision 1.26 2000/02/09 13:22:42 peter + * log truncated + + Revision 1.25 2000/02/07 17:51:20 peter + * quick hack for fnstsww which is not supported under linux as + + Revision 1.24 2000/01/28 09:41:39 peter + * fixed fpu suffix parsing for att reader + + Revision 1.23 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.22 1999/12/18 20:00:33 florian + * Bug reported by Marco fixed: Intel assembler reader: fld qword ptr x + was read as fldq x but it must be fldl x + + Revision 1.21 1999/12/08 10:39:59 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.20 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.19 1999/11/02 15:06:56 peter + * import library fixes for win32 + * alignment works again + + Revision 1.18 1999/10/27 16:11:28 peter + * insns.dat is used to generate all i386*.inc files + + Revision 1.17 1999/09/27 23:36:33 peter + * fixed -al with macro's + + Revision 1.16 1999/09/21 20:53:21 florian + * fixed 1/s problem from mailing list + + Revision 1.15 1999/09/19 20:55:11 florian + * fixed calls to procedures with manglednames=255 chars + (taking the address of such a procedure would still cause a problem!) + + Revision 1.14 1999/09/10 18:48:00 florian + * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.13 1999/09/02 17:07:38 florian + * problems with -Or fixed: tdef.isfpuregable was wrong! + + Revision 1.12 1999/08/25 16:03:46 peter + * symbol name is now written using separate asmwrite() calls to overcome + > 255 char strings + + Revision 1.11 1999/08/25 11:59:32 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.10 1999/08/13 15:44:57 peter + * first things to include lineinfo in the executable + + Revision 1.9 1999/08/10 12:26:20 pierre + * avoid double .edata section if using DLLTOOL + + Revision 1.8 1999/08/04 00:22:34 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.7 1999/07/30 12:26:07 peter + * write .size only for linux + + Revision 1.6 1999/07/29 20:53:56 peter + * write .size also + +} \ No newline at end of file diff --git a/befpc/compiler/ag386bin.pas b/befpc/compiler/ag386bin.pas new file mode 100644 index 0000000..c94d7fa --- /dev/null +++ b/befpc/compiler/ag386bin.pas @@ -0,0 +1,1070 @@ +{ + $Id: ag386bin.pas,v 1.1.1.1 2001-07-23 17:15:23 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements an binary assembler output class + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit ag386bin; + +{$define MULTIPASS} +{$define EXTERNALBSS} + + interface + + uses + cpubase,cobjects,aasm,files,assemble; + + type + togtype=(og_none,og_dbg,og_coff,og_pecoff); + + pi386binasmlist=^ti386binasmlist; + ti386binasmlist=object + SmartAsm : boolean; + constructor init(t:togtype;smart:boolean); + destructor done; + procedure WriteBin; + private + { the aasmoutput lists that need to be processed } + lists : byte; + list : array[1..maxoutputlists] of paasmoutput; + { current processing } + currlistidx : byte; + currlist : paasmoutput; + currpass : byte; +{$ifdef GDB} + n_line : byte; { different types of source lines } + linecount, + includecount : longint; + funcname : pasmsymbol; + stabslastfileinfo : tfileposinfo; + procedure convertstabs(p:pchar); +{$ifdef unused} + procedure emitsymbolstabs(s : string;nidx,nother,line : longint;firstasm,secondasm : pasmsymbol); +{$endif} + procedure emitlineinfostabs(nidx,line : longint); + procedure emitstabs(s:string); + procedure WriteFileLineInfo(var fileinfo : tfileposinfo); + procedure StartFileLineInfo; + procedure EndFileLineInfo; +{$endif} + function MaybeNextList(var hp:pai):boolean; + function TreePass0(hp:pai):pai; + function TreePass1(hp:pai):pai; + function TreePass2(hp:pai):pai; + procedure writetree; + procedure writetreesmart; + end; + + implementation + + uses + strings, + globtype,globals,systems,verbose, + cpuasm, +{$ifdef GDB} + gdb, +{$endif} + og386,og386dbg,og386cff; + +{$ifdef GDB} + + procedure ti386binasmlist.convertstabs(p:pchar); + var + ofs, + nidx,nother,ii,i,line,j : longint; + code : integer; + hp : pchar; + reloc : boolean; + sec : tsection; + ps : pasmsymbol; + s : string; + begin + ofs:=0; + reloc:=true; + ps:=nil; + sec:=sec_none; + if p[0]='"' then + begin + i:=1; + { we can have \" inside the string !! PM } + while not ((p[i]='"') and (p[i-1]<>'\')) do + inc(i); + p[i]:=#0; + ii:=i; + hp:=@p[1]; + s:=StrPas(@P[i+2]); + end + else + begin + hp:=nil; + s:=StrPas(P); + i:=-2; {needed below (PM) } + end; + { When in pass 1 then only alloc and leave } + if currpass=1 then + begin + objectalloc^.staballoc(hp); + if assigned(hp) then + p[i]:='"'; + exit; + end; + { Parse the rest of the stabs } + if s='' then + internalerror(33000); + j:=pos(',',s); + if j=0 then + internalerror(33001); + Val(Copy(s,1,j-1),nidx,code); + if code<>0 then + internalerror(33002); + i:=i+2+j; + Delete(s,1,j); + j:=pos(',',s); + if (j=0) then + internalerror(33003); + Val(Copy(s,1,j-1),nother,code); + if code<>0 then + internalerror(33004); + i:=i+j; + Delete(s,1,j); + j:=pos(',',s); + if j=0 then + begin + j:=256; + ofs:=-1; + end; + Val(Copy(s,1,j-1),line,code); + if code<>0 then + internalerror(33005); + if ofs=0 then + begin + Delete(s,1,j); + i:=i+j; + Val(s,ofs,code); + if code=0 then + reloc:=false + else + begin + ofs:=0; + s:=strpas(@p[i]); + { handle asmsymbol or + asmsymbol - asmsymbol } + j:=pos(' ',s); + if j=0 then + j:=pos('-',s); + { single asmsymbol } + if j=0 then + j:=256; + { the symbol can be external + so we must use newasmsymbol and + not getasmsymbol !! PM } + ps:=newasmsymbol(copy(s,1,j-1)); + if not assigned(ps) then + internalerror(33006) + else + begin + sec:=ps^.section; + ofs:=ps^.address; + reloc:=true; + end; + if j<256 then + begin + i:=i+j; + s:=strpas(@p[i]); + if (s<>'') and (s[1]=' ') then + begin + j:=0; + while (s[j+1]=' ') do + inc(j); + i:=i+j; + s:=strpas(@p[i]); + end; + ps:=getasmsymbol(s); + if not assigned(ps) then + internalerror(33007) + else + begin + if ps^.section<>sec then + internalerror(33008); + ofs:=ofs-ps^.address; + reloc:=false; + end; + end; + end; + end; + { external bss need speical handling (PM) } + if assigned(ps) and (ps^.section=sec_none) then + begin + if currpass<>1 then + objectoutput^.writesymbol(ps); + objectoutput^.WriteSymStabs(sec,ofs,hp,ps,nidx,nother,line,reloc) + end + else + objectoutput^.WriteStabs(sec,ofs,hp,nidx,nother,line,reloc); + if assigned(hp) then + p[ii]:='"'; + end; + + +{$ifdef unused} + procedure ti386binasmlist.emitsymbolstabs(s : string;nidx,nother,line : longint; + firstasm,secondasm : pasmsymbol); + var + hp : pchar; + begin + if s='' then + hp:=nil + else + begin + s:=s+#0; + hp:=@s[1]; + end; + if not assigned(secondasm) then + begin + if not assigned(firstasm) then + internalerror(33009); + objectoutput^.WriteStabs(firstasm^.section,firstasm^.address,hp,nidx,nother,line,true); + end + else + begin + if firstasm^.section<>secondasm^.section then + internalerror(33010); + objectoutput^.WriteStabs(firstasm^.section,firstasm^.address-secondasm^.address, + hp,nidx,nother,line,false); + end; + end; +{$endif} + + + procedure ti386binasmlist.emitlineinfostabs(nidx,line : longint); + var + sec : tsection; + begin + if currpass=1 then + begin + objectalloc^.staballoc(nil); + exit; + end; + + if (nidx=n_textline) and assigned(funcname) and + (target_os.use_function_relative_addresses) then + objectoutput^.WriteStabs(sec_code,pgenericcoffoutput(objectoutput)^.sects[sec_code]^.len-funcname^.address, + nil,nidx,0,line,false) + else + begin + if nidx=n_textline then + sec:=sec_code + else if nidx=n_dataline then + sec:=sec_data + else + sec:=sec_bss; + objectoutput^.WriteStabs(sec,pgenericcoffoutput(objectoutput)^.sects[sec]^.len, + nil,nidx,0,line,true); + end; + end; + + procedure ti386binasmlist.emitstabs(s:string); + begin + s:=s+#0; + ConvertStabs(@s[1]); + end; + + + procedure ti386binasmlist.WriteFileLineInfo(var fileinfo : tfileposinfo); + var + curr_n : byte; + hp : pasmsymbol; + infile : pinputfile; + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + { file changed ? (must be before line info) } + if (fileinfo.fileindex<>0) and + (stabslastfileinfo.fileindex<>fileinfo.fileindex) then + begin + infile:=current_module^.sourcefiles^.get_file(fileinfo.fileindex); + if includecount=0 then + curr_n:=n_sourcefile + else + curr_n:=n_includefile; + { get symbol for this includefile } + hp:=newasmsymbol('Ltext'+ToStr(IncludeCount)); + if currpass=1 then + begin + hp^.settyp(AS_LOCAL); + hp^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + end + else + objectoutput^.writesymbol(hp); + { emit stabs } + if (infile^.path^<>'') then + EmitStabs('"'+lower(BsToSlash(FixPath(infile^.path^,false)))+'",'+tostr(curr_n)+ + ',0,0,Ltext'+ToStr(IncludeCount)); + EmitStabs('"'+lower(FixFileName(infile^.name^))+'",'+tostr(curr_n)+ + ',0,0,Ltext'+ToStr(IncludeCount)); + inc(includecount); + end; + { line changed ? } + if (stabslastfileinfo.line<>fileinfo.line) and (fileinfo.line<>0) then + emitlineinfostabs(n_line,fileinfo.line); + stabslastfileinfo:=fileinfo; + end; + + + procedure ti386binasmlist.StartFileLineInfo; + var + fileinfo : tfileposinfo; + begin + FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0); + n_line:=n_textline; + funcname:=nil; + linecount:=1; + includecount:=0; + fileinfo.fileindex:=1; + fileinfo.line:=1; + WriteFileLineInfo(fileinfo); + end; + + procedure ti386binasmlist.EndFileLineInfo; + var + hp : pasmsymbol; + store_sec : tsection; + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + store_sec:=objectalloc^.currsec; + objectalloc^.setsection(sec_code); + hp:=newasmsymbol('Letext'); + if currpass=1 then + begin + hp^.settyp(AS_LOCAL); + hp^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + end + else + objectoutput^.writesymbol(hp); + EmitStabs('"",'+tostr(n_sourcefile)+ + ',0,0,Letext'); + objectalloc^.setsection(store_sec); + end; +{$endif GDB} + + + function ti386binasmlist.MaybeNextList(var hp:pai):boolean; + begin + { maybe end of list } + while not assigned(hp) do + begin + if currlistidx2 then + objectalloc^.sectionalign(4) + else if l>1 then + objectalloc^.sectionalign(2); + objectalloc^.sectionalloc(pai_datablock(hp)^.size); + end; + end + else + begin +{$endif} + l:=pai_datablock(hp)^.size; + if l>2 then + objectalloc^.sectionalign(4) + else if l>1 then + objectalloc^.sectionalign(2); + objectalloc^.sectionalloc(pai_datablock(hp)^.size); + end; + end; + ait_const_32bit : + objectalloc^.sectionalloc(4); + ait_const_16bit : + objectalloc^.sectionalloc(2); + ait_const_8bit : + objectalloc^.sectionalloc(1); + ait_real_80bit : + objectalloc^.sectionalloc(10); + ait_real_64bit : + objectalloc^.sectionalloc(8); + ait_real_32bit : + objectalloc^.sectionalloc(4); + ait_comp_64bit : + objectalloc^.sectionalloc(8); + ait_const_rva, + ait_const_symbol : + objectalloc^.sectionalloc(4); + ait_section: + objectalloc^.setsection(pai_section(hp)^.sec); + ait_symbol : + pai_symbol(hp)^.sym^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + ait_label : + pai_label(hp)^.l^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + ait_string : + objectalloc^.sectionalloc(pai_string(hp)^.len); + ait_instruction : + begin + { reset instructions which could change in pass 2 } + paicpu(hp)^.resetpass2; + objectalloc^.sectionalloc(paicpu(hp)^.Pass1(objectalloc^.sectionsize)); + end; + ait_cut : + if SmartAsm then + break; + end; + hp:=pai(hp^.next); + end; + TreePass0:=hp; + end; + + + function ti386binasmlist.TreePass1(hp:pai):pai; + var + l : longint; + begin + while assigned(hp) do + begin +{$ifdef GDB} + { write stabs } + if ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + begin + if (objectalloc^.currsec<>sec_none) and + not(hp^.typ in [ + ait_label, + ait_regalloc,ait_tempalloc, + ait_stabn,ait_stabs,ait_section, + ait_cut,ait_marker,ait_align,ait_stab_function_name]) then + WriteFileLineInfo(hp^.fileinfo); + end; +{$endif GDB} + case hp^.typ of + ait_align : + begin + { here we must determine the fillsize which is used in pass2 } + pai_align(hp)^.fillsize:=align(objectalloc^.sectionsize,pai_align(hp)^.aligntype)- + objectalloc^.sectionsize; + objectalloc^.sectionalloc(pai_align(hp)^.fillsize); + end; + ait_datablock : + begin + if objectalloc^.currsec<>sec_bss then + Message(asmw_e_alloc_data_only_in_bss); +{$ifdef EXTERNALBSS} + if not SmartAsm then + begin + if pai_datablock(hp)^.is_global then + begin + pai_datablock(hp)^.sym^.settyp(AS_EXTERNAL); + pai_datablock(hp)^.sym^.setaddress(sec_none,pai_datablock(hp)^.size,pai_datablock(hp)^.size); + end + else + begin + l:=pai_datablock(hp)^.size; + if l>2 then + objectalloc^.sectionalign(4) + else if l>1 then + objectalloc^.sectionalign(2); + pai_datablock(hp)^.sym^.settyp(AS_LOCAL); + pai_datablock(hp)^.sym^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize, + pai_datablock(hp)^.size); + objectalloc^.sectionalloc(pai_datablock(hp)^.size); + end; + end + else +{$endif} + begin + if pai_datablock(hp)^.is_global then + pai_datablock(hp)^.sym^.settyp(AS_GLOBAL) + else + pai_datablock(hp)^.sym^.settyp(AS_LOCAL); + l:=pai_datablock(hp)^.size; + if l>2 then + objectalloc^.sectionalign(4) + else if l>1 then + objectalloc^.sectionalign(2); + pai_datablock(hp)^.sym^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,pai_datablock(hp)^.size); + objectalloc^.sectionalloc(pai_datablock(hp)^.size); + end; + end; + ait_const_32bit : + objectalloc^.sectionalloc(4); + ait_const_16bit : + objectalloc^.sectionalloc(2); + ait_const_8bit : + objectalloc^.sectionalloc(1); + ait_real_80bit : + objectalloc^.sectionalloc(10); + ait_real_64bit : + objectalloc^.sectionalloc(8); + ait_real_32bit : + objectalloc^.sectionalloc(4); + ait_comp_64bit : + objectalloc^.sectionalloc(8); + ait_const_rva, + ait_const_symbol : + objectalloc^.sectionalloc(4); + ait_section: + begin + objectalloc^.setsection(pai_section(hp)^.sec); +{$ifdef GDB} + case pai_section(hp)^.sec of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + else + n_line:=n_dataline; + end; + stabslastfileinfo.line:=-1; +{$endif GDB} + end; +{$ifdef GDB} + ait_stabn : + convertstabs(pai_stabn(hp)^.str); + ait_stabs : + convertstabs(pai_stabs(hp)^.str); + ait_stab_function_name : + if assigned(pai_stab_function_name(hp)^.str) then + funcname:=getasmsymbol(strpas(pai_stab_function_name(hp)^.str)) + else + funcname:=nil; + ait_force_line : + stabslastfileinfo.line:=0; +{$endif} + ait_symbol : + begin + if pai_symbol(hp)^.is_global then + pai_symbol(hp)^.sym^.settyp(AS_GLOBAL) + else + pai_symbol(hp)^.sym^.settyp(AS_LOCAL); + pai_symbol(hp)^.sym^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + end; + ait_label : + begin + if pai_label(hp)^.is_global then + pai_label(hp)^.l^.settyp(AS_GLOBAL) + else + pai_label(hp)^.l^.settyp(AS_LOCAL); + pai_label(hp)^.l^.setaddress(objectalloc^.currsec,objectalloc^.sectionsize,0); + end; + ait_string : + objectalloc^.sectionalloc(pai_string(hp)^.len); + ait_instruction : + objectalloc^.sectionalloc(paicpu(hp)^.Pass1(objectalloc^.sectionsize)); + ait_direct : + Message(asmw_f_direct_not_supported); + ait_cut : + if SmartAsm then + break; + end; + hp:=pai(hp^.next); + end; + TreePass1:=hp; + end; + + + function ti386binasmlist.TreePass2(hp:pai):pai; + var + l : longint; +{$ifdef I386} + co : comp; +{$endif I386} + begin + { main loop } + while assigned(hp) do + begin +{$ifdef GDB} + { write stabs } + if ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + begin + if (objectoutput^.currsec<>sec_none) and + not(hp^.typ in [ + ait_label, + ait_regalloc,ait_tempalloc, + ait_stabn,ait_stabs,ait_section, + ait_cut,ait_marker,ait_align,ait_stab_function_name]) then + WriteFileLineInfo(hp^.fileinfo); + end; +{$endif GDB} + case hp^.typ of + ait_align : + objectoutput^.writebytes(pai_align(hp)^.getfillbuf^,pai_align(hp)^.fillsize); + ait_section : + begin + objectoutput^.defaultsection(pai_section(hp)^.sec); +{$ifdef GDB} + case pai_section(hp)^.sec of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + else + n_line:=n_dataline; + end; + stabslastfileinfo.line:=-1; +{$endif GDB} + end; + ait_symbol : + objectoutput^.writesymbol(pai_symbol(hp)^.sym); + ait_datablock : + begin + objectoutput^.writesymbol(pai_datablock(hp)^.sym); + if SmartAsm +{$ifdef EXTERNALBSS} + or (not pai_datablock(hp)^.is_global) +{$endif} + then + begin + l:=pai_datablock(hp)^.size; + if l>2 then + objectoutput^.writealign(4) + else if l>1 then + objectoutput^.writealign(2); + objectoutput^.writealloc(pai_datablock(hp)^.size); + end; + end; + ait_const_32bit : + objectoutput^.writebytes(pai_const(hp)^.value,4); + ait_const_16bit : + objectoutput^.writebytes(pai_const(hp)^.value,2); + ait_const_8bit : + objectoutput^.writebytes(pai_const(hp)^.value,1); + ait_real_80bit : + objectoutput^.writebytes(pai_real_80bit(hp)^.value,10); + ait_real_64bit : + objectoutput^.writebytes(pai_real_64bit(hp)^.value,8); + ait_real_32bit : + objectoutput^.writebytes(pai_real_32bit(hp)^.value,4); + ait_comp_64bit : + begin +{$ifdef FPC} + co:=comp(pai_comp_64bit(hp)^.value); +{$else} + co:=pai_comp_64bit(hp)^.value; +{$endif} + objectoutput^.writebytes(co,8); + end; + ait_string : + objectoutput^.writebytes(pai_string(hp)^.str^,pai_string(hp)^.len); + ait_const_rva : + objectoutput^.writereloc(pai_const_symbol(hp)^.offset,4, + pai_const_symbol(hp)^.sym,relative_rva); + ait_const_symbol : + objectoutput^.writereloc(pai_const_symbol(hp)^.offset,4, + pai_const_symbol(hp)^.sym,relative_false); + ait_label : + objectoutput^.writesymbol(pai_label(hp)^.l); + ait_instruction : + paicpu(hp)^.Pass2; +{$ifdef GDB} + ait_stabn : + convertstabs(pai_stabn(hp)^.str); + ait_stabs : + convertstabs(pai_stabs(hp)^.str); + ait_stab_function_name : + if assigned(pai_stab_function_name(hp)^.str) then + funcname:=getasmsymbol(strpas(pai_stab_function_name(hp)^.str)) + else + funcname:=nil; + ait_force_line : + stabslastfileinfo.line:=0; +{$endif} + ait_cut : + if SmartAsm then + break; + end; + hp:=pai(hp^.next); + end; + TreePass2:=hp; + end; + + + procedure ti386binasmlist.writetree; + var + hp : pai; + begin + objectalloc^.resetsections; + objectalloc^.setsection(sec_code); + + objectoutput^.initwriting(cut_normal); + objectoutput^.defaultsection(sec_code); + { reset the asmsymbol list } + ResetAsmsymbolList; + objectoutput^.defaultsection(sec_code); + +{$ifdef MULTIPASS} + { Pass 0 } + currpass:=0; + objectalloc^.setsection(sec_code); + { start with list 1 } + currlistidx:=1; + currlist:=list[currlistidx]; + hp:=pai(currlist^.first); + while assigned(hp) do + begin + hp:=TreePass0(hp); + MaybeNextList(hp); + end; + { leave if errors have occured } + if errorcount>0 then + exit; +{$endif} + + { Pass 1 } + currpass:=1; + objectalloc^.resetsections; + objectalloc^.setsection(sec_code); +{$ifdef GDB} + StartFileLineInfo; +{$endif GDB} + { start with list 1 } + currlistidx:=1; + currlist:=list[currlistidx]; + hp:=pai(currlist^.first); + while assigned(hp) do + begin + hp:=TreePass1(hp); + MaybeNextList(hp); + end; +{$ifdef GDB} + EndFileLineInfo; +{$endif GDB} + { check for undefined labels } + CheckAsmSymbolListUndefined; + { set section sizes } + objectoutput^.setsectionsizes(objectalloc^.secsize); + { leave if errors have occured } + if errorcount>0 then + exit; + + { Pass 2 } + currpass:=2; +{$ifdef GDB} + StartFileLineInfo; +{$endif GDB} + { start with list 1 } + currlistidx:=1; + currlist:=list[currlistidx]; + hp:=pai(currlist^.first); + while assigned(hp) do + begin + hp:=TreePass2(hp); + MaybeNextList(hp); + end; +{$ifdef GDB} + EndFileLineInfo; +{$endif GDB} + + { leave if errors have occured } + if errorcount>0 then + exit; + + { write last objectfile } + objectoutput^.donewriting; + end; + + + procedure ti386binasmlist.writetreesmart; + var + hp : pai; + startsec : tsection; + begin + objectalloc^.resetsections; + objectalloc^.setsection(sec_code); + + objectoutput^.initwriting(cut_normal); + objectoutput^.defaultsection(sec_code); + startsec:=sec_code; + { start with list 1 } + currlistidx:=1; + currlist:=list[currlistidx]; + hp:=pai(currlist^.first); + while assigned(hp) do + begin + { reset the asmsymbol list } + ResetAsmsymbolList; + +{$ifdef MULTIPASS} + { Pass 0 } + currpass:=0; + objectalloc^.resetsections; + objectalloc^.setsection(startsec); + TreePass0(hp); +{$endif} + { leave if errors have occured } + if errorcount>0 then + exit; + + { Pass 1 } + currpass:=1; + objectalloc^.resetsections; + objectalloc^.setsection(startsec); +{$ifdef GDB} + StartFileLineInfo; +{$endif GDB} + TreePass1(hp); +{$ifdef GDB} + EndFileLineInfo; +{$endif GDB} + { check for undefined labels } + CheckAsmSymbolListUndefined; + { set section sizes } + objectoutput^.setsectionsizes(objectalloc^.secsize); + { leave if errors have occured } + if errorcount>0 then + exit; + + { Pass 2 } + currpass:=2; + objectoutput^.defaultsection(startsec); +{$ifdef GDB} + StartFileLineInfo; +{$endif GDB} + hp:=TreePass2(hp); +{$ifdef GDB} + EndFileLineInfo; +{$endif GDB} + { leave if errors have occured } + if errorcount>0 then + exit; + + { if not end then write the current objectfile } + objectoutput^.donewriting; + + { end of lists? } + if not MaybeNextList(hp) then + break; + { save section for next loop } + { this leads to a problem if startsec is sec_none !! PM } + startsec:=objectalloc^.currsec; + + { we will start a new objectfile so reset everything } + if (hp^.typ=ait_cut) then + objectoutput^.initwriting(pai_cut(hp)^.place) + else + objectoutput^.initwriting(cut_normal); + + { avoid empty files } + while assigned(hp^.next) and + (pai(hp^.next)^.typ in [ait_marker,ait_comment,ait_section,ait_cut]) do + begin + if pai(hp^.next)^.typ=ait_section then + startsec:=pai_section(hp^.next)^.sec; + hp:=pai(hp^.next); + end; + + hp:=pai(hp^.next); + + { there is a problem if startsec is sec_none !! PM } + if startsec=sec_none then + startsec:=sec_code; + + if not MaybeNextList(hp) then + break; + end; + end; + + + procedure ti386binasmlist.writebin; + + procedure addlist(p:paasmoutput); + begin + inc(lists); + list[lists]:=p; + end; + + begin + + if cs_debuginfo in aktmoduleswitches then + addlist(debuglist); + addlist(codesegment); + addlist(datasegment); + addlist(consts); + addlist(rttilist); + if assigned(resourcestringlist) then + addlist(resourcestringlist); + addlist(bsssegment); + if assigned(importssection) then + addlist(importssection); + if assigned(exportssection) and not UseDeffileForExport then + addlist(exportssection); + if assigned(resourcesection) then + addlist(resourcesection); + + if SmartAsm then + writetreesmart + else + writetree; + end; + + + constructor ti386binasmlist.init(t:togtype;smart:boolean); + begin + case t of + og_none : + Message(asmw_f_no_binary_writer_selected); + og_dbg : + objectoutput:=new(pdbgoutput,init(smart)); + og_coff : + objectoutput:=new(pdjgppcoffoutput,init(smart)); + og_pecoff : + objectoutput:=new(pwin32coffoutput,init(smart)); + end; + objectalloc:=new(pobjectalloc,init); + SmartAsm:=smart; + currpass:=0; + end; + + + destructor ti386binasmlist.done; + begin + dispose(objectoutput,done); + dispose(objectalloc,done); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/04/12 12:42:28 pierre + * fix the -g-l option + + Revision 1.42 2000/04/06 07:04:51 pierre + + generate line stabs if cs_gdb_lineinfo is aktglobalswitches + + Revision 1.41 2000/03/10 16:05:57 pierre + * generate allways symbol for stabs + + Revision 1.40 2000/03/09 14:29:47 pierre + * fix for the stab section size changes with smartlinking + + Revision 1.39 2000/03/09 10:07:18 pierre + * fix a problem with smartlink and stabs + + Revision 1.38 2000/02/18 21:54:07 pierre + * avoid LeText if no stabs info + + Revision 1.37 2000/02/18 12:31:07 pierre + * Reset file name to empty at end of code section + + Revision 1.36 2000/02/09 13:22:43 peter + * log truncated + + Revision 1.35 2000/01/20 00:21:49 pierre + * avoid startsec=sec_none + + Revision 1.34 2000/01/12 10:38:17 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.33 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.32 1999/12/24 15:22:52 peter + * reset insentry/lastinsoffset so writing smartlink works correct for + short jmps + + Revision 1.31 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.30 1999/12/08 10:39:59 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.29 1999/12/01 22:05:13 pierre + * problem with unused external symbol in stabs solved + + Revision 1.28 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.27 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.26 1999/11/02 15:06:56 peter + * import library fixes for win32 + * alignment works again + + Revision 1.25 1999/09/26 21:13:40 peter + * short jmp with alignment problems fixed + + Revision 1.24 1999/08/25 11:59:33 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.23 1999/08/10 12:26:21 pierre + * avoid double .edata section if using DLLTOOL + + Revision 1.22 1999/08/04 00:22:35 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.21 1999/08/01 18:28:09 florian + * modifications for the new code generator + + Revision 1.20 1999/07/31 12:33:11 peter + * fixed smartlinking + + Revision 1.19 1999/07/22 09:37:30 florian + + resourcestring implemented + + start of longstring support + +} \ No newline at end of file diff --git a/befpc/compiler/ag386int.pas b/befpc/compiler/ag386int.pas new file mode 100644 index 0000000..d3d4039 --- /dev/null +++ b/befpc/compiler/ag386int.pas @@ -0,0 +1,694 @@ +{ + $Id: ag386int.pas,v 1.1.1.1 2001-07-23 17:15:24 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for Intel syntax with Intel i386+ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit ag386int; + + interface + + uses aasm,assemble; + + type + pi386intasmlist=^ti386intasmlist; + ti386intasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + procedure WriteExternals; + end; + + implementation + + uses + strings, + globtype,globals,systems,cobjects, + files,verbose,cpubase,cpuasm +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + +{$ifdef EXTTYPE} + extstr : array[EXT_NEAR..EXT_ABS] of String[8] = + ('NEAR','FAR','PROC','BYTE','WORD','DWORD', + 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); +{$endif} + + function single2str(d : single) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + single2str:=lower(hs); + end; + + function double2str(d : double) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + double2str:=lower(hs); + end; + + function extended2str(e : extended) : string; + var + hs : string; + p : byte; + begin + str(e,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + extended2str:=lower(hs); + end; + + + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin +{$ifdef FPC} + c:=comp(d); +{$else} + c:=d; +{$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; + + function getreferencestring(var ref : treference) : string; + var + s : string; + first : boolean; + begin + if ref.is_immediate then + begin + getreferencestring:=tostr(ref.offset); + exit; + end + else + with ref do + begin + first:=true; + inc(offset,offsetfixup); + offsetfixup:=0; + if ref.segment<>R_NO then + s:=int_reg2str[segment]+':[' + else + s:='['; + if assigned(symbol) then + begin + s:=s+symbol^.name; + first:=false; + end; + if (base<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[base]; + end; + if (index<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[index]; + if scalefactor<>0 then + s:=s+'*'+tostr(scalefactor); + end; + if offset<0 then + s:=s+tostr(offset) + else if (offset>0) then + s:=s+'+'+tostr(offset); + s:=s+']'; + end; + getreferencestring:=s; + end; + + + function getopstr(const o:toper;s : topsize; opcode: tasmop;dest : boolean) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr:=int_reg2str[o.reg]; + top_const : + getopstr:=tostr(o.val); + top_symbol : + begin + if assigned(o.sym) then + hs:='offset '+o.sym^.name + else + hs:='offset '; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs) + else + if not(assigned(o.sym)) then + hs:=hs+'0'; + getopstr:=hs; + end; + top_ref : + begin + hs:=getreferencestring(o.ref^); + if ((opcode <> A_LGS) and (opcode <> A_LSS) and + (opcode <> A_LFS) and (opcode <> A_LDS) and + (opcode <> A_LES)) then + Begin + case s of + S_B : hs:='byte ptr '+hs; + S_W : hs:='word ptr '+hs; + S_L : hs:='dword ptr '+hs; + S_IS : hs:='word ptr '+hs; + S_IL : hs:='dword ptr '+hs; + S_IQ : hs:='qword ptr '+hs; + S_FS : hs:='dword ptr '+hs; + S_FL : hs:='qword ptr '+hs; + S_FX : hs:='tbyte ptr '+hs; + S_BW : if dest then + hs:='word ptr '+hs + else + hs:='byte ptr '+hs; + S_BL : if dest then + hs:='dword ptr '+hs + else + hs:='byte ptr '+hs; + S_WL : if dest then + hs:='dword ptr '+hs + else + hs:='word ptr '+hs; + end; + end; + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(const o:toper) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr_jmp:=int_reg2str[o.reg]; + top_const : + getopstr_jmp:=tostr(o.val); + top_symbol : + begin + hs:=o.sym^.name; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs); + getopstr_jmp:=hs; + end; + top_ref : + getopstr_jmp:=getreferencestring(o.ref^); + else + internalerror(10001); + end; + end; + + +{**************************************************************************** + TI386INTASMLIST + ****************************************************************************} + + var + LastSec : tsection; + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'DD'#9,#9'DW'#9,#9'DB'#9); + + Function PadTabs(const p:string;addch:char):string; + var + s : string; + i : longint; + begin + i:=length(p); + if addch<>#0 then + begin + inc(i); + s:=p+addch; + end + else + s:=p; + if i<8 then + PadTabs:=s+#9#9 + else + PadTabs:=s+#9; + end; + + procedure ti386intasmlist.WriteTree(p:paasmoutput); + const + allocstr : array[boolean] of string[10]=(' released',' allocated'); + var + s, + prefix, + suffix : string; + hp : pai; + counter, + lines, + i,j,l : longint; + consttyp : tait; + found, + quoted : boolean; + sep : char; + begin + if not assigned(p) then + exit; + hp:=pai(p^.first); + while assigned(hp) do + begin + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + ait_regalloc, + ait_tempalloc : ; + ait_section : begin + if LastSec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWriteLn('_'+target_asm.secnames[pai_section(hp)^.sec]+#9#9+ + 'SEGMENT'#9'PARA PUBLIC USE32 '''+ + target_asm.secnames[pai_section(hp)^.sec]+''''); + end; + LastSec:=pai_section(hp)^.sec; + end; + ait_align : begin + { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION } + { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN } + { HERE UNDER TASM! } + AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); + end; + ait_datablock : begin + if pai_datablock(hp)^.is_global then + AsmWriteLn(#9'PUBLIC'#9+pai_datablock(hp)^.sym^.name); + AsmWriteLn(PadTabs(pai_datablock(hp)^.sym^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)'); + end; + ait_const_32bit, + ait_const_8bit, + ait_const_16bit : begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_symbol : begin + AsmWriteLn(#9#9'DD'#9'offset '+pai_const_symbol(hp)^.sym^.name); + if pai_const_symbol(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) + else if pai_const_symbol(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol(hp)^.offset)); + AsmLn; + end; + ait_const_rva : begin + AsmWriteLn(#9#9'RVA'#9+pai_const_symbol(hp)^.sym^.name); + end; + ait_real_32bit : AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); + ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); + ait_real_80bit : AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); + ait_comp_64bit : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); + ait_string : begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to counter+line_length do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + AsmWrite(target_os.newline); + counter := counter+line_length; + end; { end for j:=0 ... } + { do last line of lines } + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to pai_string(hp)^.len-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then + AsmWrite('"'); + end; + AsmLn; + end; + ait_label : begin + if pai_label(hp)^.l^.is_used then + begin + AsmWrite(pai_label(hp)^.l^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':'); + end; + end; + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; + ait_symbol : begin + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9'PUBLIC'#9+pai_symbol(hp)^.sym^.name); + AsmWrite(pai_symbol(hp)^.sym^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':') + end; + ait_symbol_end : begin + end; + ait_instruction : begin + { Must be done with args in ATT order } + paicpu(hp)^.CheckNonCommutativeOpcodes; + { We need intel order, no At&t } + paicpu(hp)^.SwapOperands; + { Reset } + suffix:=''; + prefix:= ''; + s:=''; + { We need to explicitely set + word prefix to get selectors + to be pushed in 2 bytes PM } + if (paicpu(hp)^.opsize=S_W) and + ((paicpu(hp)^.opcode=A_PUSH) or + (paicpu(hp)^.opcode=A_POP)) and + (paicpu(hp)^.oper[0].typ=top_reg) and + ((paicpu(hp)^.oper[0].reg>=firstsreg) and + (paicpu(hp)^.oper[0].reg<=lastsreg)) then + AsmWriteln(#9#9'DB'#9'066h'); + { added prefix instructions, must be on same line as opcode } + if (paicpu(hp)^.ops = 0) and + ((paicpu(hp)^.opcode = A_REP) or + (paicpu(hp)^.opcode = A_LOCK) or + (paicpu(hp)^.opcode = A_REPE) or + (paicpu(hp)^.opcode = A_REPNZ) or + (paicpu(hp)^.opcode = A_REPZ) or + (paicpu(hp)^.opcode = A_REPNE)) then + Begin + prefix:=int_op2str[paicpu(hp)^.opcode]+#9; + hp:=Pai(hp^.next); + { this is theorically impossible... } + if hp=nil then + begin + s:=#9#9+prefix; + AsmWriteLn(s); + break; + end; + { nasm prefers prefix on a line alone } + AsmWriteln(#9#9+prefix); + prefix:=''; + end + else + prefix:= ''; + if paicpu(hp)^.ops<>0 then + begin + if is_calljmp(paicpu(hp)^.opcode) then + s:=#9+getopstr_jmp(paicpu(hp)^.oper[0]) + else + begin + for i:=0to paicpu(hp)^.ops-1 do + begin + if i=0 then + sep:=#9 + else + sep:=','; + s:=s+sep+getopstr(paicpu(hp)^.oper[i],paicpu(hp)^.opsize,paicpu(hp)^.opcode,(i=2)); + end; + end; + end; + AsmWriteLn(#9#9+prefix+int_op2str[paicpu(hp)^.opcode]+cond2str[paicpu(hp)^.condition]+suffix+s); + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, +ait_stab_function_name : ; +{$endif GDB} + ait_cut : begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + if LastSec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[LastSec]+#9#9'ENDS'); + AsmLn; + AsmWriteLn(#9'END'); + AsmClose; + DoAssemble; + AsmCreate(pai_cut(hp)^.place); + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + begin + lastsec:=pai_section(hp^.next)^.sec; + end; + hp:=pai(hp^.next); + end; + AsmWriteLn(#9'.386p'); + { I was told that this isn't necesarry because } + { the labels generated by FPC are unique (FK) } + { AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); } + if lastsec<>sec_none then + AsmWriteLn('_'+target_asm.secnames[lastsec]+#9#9+ + 'SEGMENT'#9'PARA PUBLIC USE32 '''+ + target_asm.secnames[lastsec]+''''); + AsmStartSize:=AsmSize; + end; + ait_marker: ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + var + currentasmlist : PAsmList; + + procedure writeexternal(p:pnamedindexobject);{$ifndef FPC}far;{$endif} + begin + if pasmsymbol(p)^.typ=AS_EXTERNAL then + currentasmlist^.AsmWriteln(#9'EXTRN'#9+p^.name); + end; + + procedure ti386intasmlist.WriteExternals; + begin + currentasmlist:=@self; + AsmSymbolList^.foreach({$ifndef VER70}@{$endif}writeexternal); + end; + + + procedure ti386intasmlist.WriteAsmList; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^); +{$endif} + LastSec:=sec_none; + AsmWriteLn(#9'.386p'); + AsmWriteLn(#9'LOCALS '+target_asm.labelprefix); + AsmWriteLn('DGROUP'#9'GROUP'#9'_BSS,_DATA'); + AsmWriteLn(#9'ASSUME'#9'CS:_CODE,ES:DGROUP,DS:DGROUP,SS:DGROUP'); + AsmLn; + + countlabelref:=false; + + WriteExternals; + + { INTEL ASM doesn't support stabs + WriteTree(debuglist);} + + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(resourcestringlist); + WriteTree(bsssegment); + countlabelref:=true; + + AsmWriteLn(#9'END'); + AsmLn; + +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.62 2000/05/12 21:26:22 pierre + * fix the FDIV FDIVR FSUB FSUBR and popping equivalent + simply by swapping from reverse to normal and vice-versa + when passing from one syntax to the other ! + + Revision 1.61 2000/05/09 21:44:27 pierre + * add .byte 066h to force correct pushw %es + * handle push es as a pushl %es + + Revision 1.60 2000/04/06 07:05:57 pierre + * handle offsetfixup + + Revision 1.59 2000/02/09 13:22:43 peter + * log truncated + + Revision 1.58 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.57 1999/12/19 17:36:25 florian + * generation of LOCALS @@ removed + + Revision 1.56 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.55 1999/11/02 15:06:56 peter + * import library fixes for win32 + * alignment works again + + Revision 1.54 1999/09/10 15:41:18 peter + * added symbol_end + + Revision 1.53 1999/09/02 18:47:42 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.52 1999/08/25 11:59:36 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.51 1999/08/04 00:22:36 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.50 1999/07/22 09:37:31 florian + + resourcestring implemented + + start of longstring support + +} \ No newline at end of file diff --git a/befpc/compiler/ag386nsm.pas b/befpc/compiler/ag386nsm.pas new file mode 100644 index 0000000..ea36185 --- /dev/null +++ b/befpc/compiler/ag386nsm.pas @@ -0,0 +1,832 @@ +{ + $Id: ag386nsm.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for the Nasm assembler with + Intel syntax for the i386+ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit ag386nsm; + + interface + + uses aasm,assemble; + + type + pi386nasmasmlist=^ti386nasmasmlist; + ti386nasmasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + procedure WriteExternals; + end; + + implementation + + uses + strings, + globtype,globals,systems,cobjects, + files,verbose,cpubase,cpuasm +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 64; + + var + lastfileinfo : tfileposinfo; + infile, + lastinfile : pinputfile; +{$ifdef EXTTYPE} + extstr : array[EXT_NEAR..EXT_ABS] of String[8] = + ('NEAR','FAR','PROC','BYTE','WORD','DWORD', + 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); +{$endif} + + function fixline(s:string):string; + { + return s with all leading and ending spaces and tabs removed + } + var + i,j,k : longint; + begin + i:=length(s); + while (i>0) and (s[i] in [#9,' ']) do + dec(i); + j:=1; + while (j0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + single2str:=lower(hs); + end; + + function double2str(d : double) : string; + var + hs : string; + p : byte; + begin + str(d,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + double2str:=lower(hs); + end; + + function extended2str(e : extended) : string; + var + hs : string; + p : byte; + begin + str(e,hs); + { nasm expects a lowercase e } + p:=pos('E',hs); + if p>0 then + hs[p]:='e'; + p:=pos('+',hs); + if p>0 then + delete(hs,p,1); + extended2str:=lower(hs); + end; + + + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin +{$ifdef FPC} + c:=comp(d); +{$else} + c:=d; +{$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; + + + function getreferencestring(var ref : treference) : string; + var + s : string; + first : boolean; + begin + if ref.is_immediate then + begin + getreferencestring:=tostr(ref.offset); + exit; + end + else + with ref do + begin + first:=true; + inc(offset,offsetfixup); + offsetfixup:=0; + if ref.segment<>R_NO then + s:='['+int_reg2str[segment]+':' + else + s:='['; + if assigned(symbol) then + begin + s:=s+symbol^.name; + first:=false; + end; + if (base<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[base]; + end; + if (index<>R_NO) then + begin + if not(first) then + s:=s+'+' + else + first:=false; + s:=s+int_reg2str[index]; + if scalefactor<>0 then + s:=s+'*'+tostr(scalefactor); + end; + if offset<0 then + s:=s+tostr(offset) + else if (offset>0) then + s:=s+'+'+tostr(offset); + s:=s+']'; + end; + getreferencestring:=s; + end; + + function sizestr(s:topsize;dest:boolean):string; + begin + case s of + S_B : sizestr:='byte '; + S_W : sizestr:='word '; + S_L : sizestr:='dword '; + S_IS : sizestr:='word '; + S_IL : sizestr:='dword '; + S_IQ : sizestr:='qword '; + S_FS : sizestr:='dword '; + S_FL : sizestr:='qword '; + S_FX : sizestr:='tword '; + S_BW : if dest then + sizestr:='word ' + else + sizestr:='byte '; + S_BL : if dest then + sizestr:='dword ' + else + sizestr:='byte '; + S_WL : if dest then + sizestr:='dword ' + else + sizestr:='word '; + else { S_NO } + sizestr:=''; + end; + end; + + + function getopstr(const o:toper;s : topsize; opcode: tasmop;ops:longint;dest : boolean) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr:=int_nasmreg2str[o.reg]; + top_const : + begin + if (ops=1) and (opcode<>A_RET) then + getopstr:=sizestr(s,dest)+tostr(o.val) + else + getopstr:=tostr(o.val); + end; + top_symbol : + begin + if assigned(o.sym) then + hs:='dword '+o.sym^.name + else + hs:='dword '; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs) + else + if not(assigned(o.sym)) then + hs:=hs+'0'; + getopstr:=hs; + end; + top_ref : + begin + hs:=getreferencestring(o.ref^); + if not ((opcode = A_LEA) or (opcode = A_LGS) or + (opcode = A_LSS) or (opcode = A_LFS) or + (opcode = A_LES) or (opcode = A_LDS) or + (opcode = A_SHR) or (opcode = A_SHL) or + (opcode = A_SAR) or (opcode = A_SAL) or + (opcode = A_OUT) or (opcode = A_IN)) then + begin + hs:=sizestr(s,dest)+hs; + end; + getopstr:=hs; + end; + else + internalerror(10001); + end; + end; + + function getopstr_jmp(const o:toper; op : tasmop) : string; + var + hs : string; + begin + case o.typ of + top_reg : + getopstr_jmp:=int_nasmreg2str[o.reg]; + top_ref : + getopstr_jmp:=getreferencestring(o.ref^); + top_const : + getopstr_jmp:=tostr(o.val); + top_symbol : + begin + hs:=o.sym^.name; + if o.symofs>0 then + hs:=hs+'+'+tostr(o.symofs) + else + if o.symofs<0 then + hs:=hs+tostr(o.symofs); + if (op=A_JCXZ) or (op=A_JECXZ) or + (op=A_LOOP) or (op=A_LOOPE) or + (op=A_LOOPNE) or (op=A_LOOPNZ) or + (op=A_LOOPZ) then + getopstr_jmp:=hs + else + getopstr_jmp:='NEAR '+hs; + end; + else + internalerror(10001); + end; + end; + + +{**************************************************************************** + Ti386nasmasmlist + ****************************************************************************} + + var + LastSec : tsection; + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'DD'#9,#9'DW'#9,#9'DB'#9); + + Function PadTabs(const p:string;addch:char):string; + var + s : string; + i : longint; + begin + i:=length(p); + if addch<>#0 then + begin + inc(i); + s:=p+addch; + end + else + s:=p; + if i<8 then + PadTabs:=s+#9#9 + else + PadTabs:=s+#9; + end; + + + procedure ti386nasmasmlist.WriteTree(p:paasmoutput); + const + allocstr : array[boolean] of string[10]=(' released',' allocated'); + nolinetai =[ait_label, + ait_regalloc,ait_tempalloc, + ait_stabn,ait_stabs,ait_section, + ait_cut,ait_marker,ait_align,ait_stab_function_name]; + var + s : string; + {prefix, + suffix : string; no need here } + hp : pai; + counter, + lines, + i,j,l : longint; + InlineLevel : longint; + consttyp : tait; + found, + do_line, + quoted : boolean; + sep : char; + begin + if not assigned(p) then + exit; + InlineLevel:=0; + { lineinfo is only needed for codesegment (PFV) } + do_line:=(cs_asm_source in aktglobalswitches) or + ((cs_lineinfo in aktmoduleswitches) + and (p=codesegment)); + hp:=pai(p^.first); + while assigned(hp) do + begin + aktfilepos:=hp^.fileinfo; + + if not(hp^.typ in nolinetai) then + begin + if do_line then + begin + { load infile } + if lastfileinfo.fileindex<>hp^.fileinfo.fileindex then + begin + infile:=current_module^.sourcefiles^.get_file(hp^.fileinfo.fileindex); + if assigned(infile) then + begin + { open only if needed !! } + if (cs_asm_source in aktglobalswitches) then + infile^.open; + end; + { avoid unnecessary reopens of the same file !! } + lastfileinfo.fileindex:=hp^.fileinfo.fileindex; + { be sure to change line !! } + lastfileinfo.line:=-1; + end; + { write source } + if (cs_asm_source in aktglobalswitches) and + assigned(infile) then + begin + if (infile<>lastinfile) then + begin + AsmWriteLn(target_asm.comment+'['+infile^.name^+']'); + if assigned(lastinfile) then + lastinfile^.close; + end; + if (hp^.fileinfo.line<>lastfileinfo.line) and + ((hp^.fileinfo.line0)) then + begin + if (hp^.fileinfo.line<>0) and + ((infile^.linebuf^[hp^.fileinfo.line]>=0) or (InlineLevel>0)) then + AsmWriteLn(target_asm.comment+'['+tostr(hp^.fileinfo.line)+'] '+ + fixline(infile^.GetLineStr(hp^.fileinfo.line))); + { set it to a negative value ! + to make that is has been read already !! PM } + if (infile^.linebuf^[hp^.fileinfo.line]>=0) then + infile^.linebuf^[hp^.fileinfo.line]:=-infile^.linebuf^[hp^.fileinfo.line]-1; + end; + end; + lastfileinfo:=hp^.fileinfo; + lastinfile:=infile; + end; + end; + case hp^.typ of + ait_comment : + Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + + ait_regalloc : + begin + if (cs_asm_regalloc in aktglobalswitches) then + AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+ + allocstr[pairegalloc(hp)^.allocation]); + end; + + ait_tempalloc : + begin + if (cs_asm_tempalloc in aktglobalswitches) then + AsmWriteLn(target_asm.comment+'Temp '+tostr(paitempalloc(hp)^.temppos)+','+ + tostr(paitempalloc(hp)^.tempsize)+allocstr[paitempalloc(hp)^.allocation]); + end; + + ait_section : + begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWriteLn('SECTION '+target_asm.secnames[pai_section(hp)^.sec]); + end; + LastSec:=pai_section(hp)^.sec; + end; + + ait_align : + AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); + + ait_datablock : + begin + if pai_datablock(hp)^.is_global then + begin + AsmWrite(#9'GLOBAL '); + AsmWriteLn(pai_datablock(hp)^.sym^.name); + end; + AsmWrite(PadTabs(pai_datablock(hp)^.sym^.name,':')); + AsmWriteLn('RESB'#9+tostr(pai_datablock(hp)^.size)); + end; + + ait_const_32bit, + ait_const_16bit, + ait_const_8bit : + begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + + ait_const_symbol : + begin + AsmWrite(#9#9'DD'#9); + AsmWrite(pai_const_symbol(hp)^.sym^.name); + if pai_const_symbol(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol(hp)^.offset)) + else if pai_const_symbol(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol(hp)^.offset)); + AsmLn; + end; + + ait_const_rva : + begin + AsmWrite(#9#9'RVA'#9); + AsmWriteLn(pai_const_symbol(hp)^.sym^.name); + end; + + ait_real_32bit : + AsmWriteLn(#9#9'DD'#9+single2str(pai_real_32bit(hp)^.value)); + + ait_real_64bit : + AsmWriteLn(#9#9'DQ'#9+double2str(pai_real_64bit(hp)^.value)); + + ait_real_80bit : + AsmWriteLn(#9#9'DT'#9+extended2str(pai_real_80bit(hp)^.value)); + + ait_comp_64bit : + AsmWriteLn(#9#9'DQ'#9+comp2str(pai_real_80bit(hp)^.value)); + + ait_string : + begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DB'#9); + quoted:=false; + for i:=counter to counter+line_length-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + AsmWrite(target_os.newline); + inc(counter,line_length); + end; { end for j:=0 ... } + { do last line of lines } + if counter31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then + AsmWrite('"'); + end; + AsmLn; + end; + + ait_label : + begin + if pai_label(hp)^.l^.is_used then + AsmWriteLn(pai_label(hp)^.l^.name+':'); + end; + + ait_direct : + begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; + + ait_symbol : + begin + if pai_symbol(hp)^.is_global then + begin + AsmWrite(#9'GLOBAL '); + AsmWriteLn(pai_symbol(hp)^.sym^.name); + end; + AsmWrite(pai_symbol(hp)^.sym^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_rva, + ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_string]) then + AsmWriteLn(':') + end; + + ait_symbol_end : + begin + end; + + ait_instruction : + begin + { Must be done with args in ATT order } + paicpu(hp)^.CheckNonCommutativeOpcodes; + { We need intel order, no At&t } + paicpu(hp)^.SwapOperands; + { Reset + suffix:=''; + prefix:='';} + s:=''; + if (paicpu(hp)^.opcode=A_FADDP) and (paicpu(hp)^.ops=0) then + begin + paicpu(hp)^.ops:=2; + paicpu(hp)^.oper[0].typ:=top_reg; + paicpu(hp)^.oper[0].reg:=R_ST1; + paicpu(hp)^.oper[1].typ:=top_reg; + paicpu(hp)^.oper[1].reg:=R_ST; + end; + if paicpu(hp)^.ops<>0 then + begin + if is_calljmp(paicpu(hp)^.opcode) then + s:=#9+getopstr_jmp(paicpu(hp)^.oper[0],paicpu(hp)^.opcode) + else + begin + { We need to explicitely set + word prefix to get selectors + to be pushed in 2 bytes PM } + if (paicpu(hp)^.opsize=S_W) and + ((paicpu(hp)^.opcode=A_PUSH) or + (paicpu(hp)^.opcode=A_POP)) and + (paicpu(hp)^.oper[0].typ=top_reg) and + ((paicpu(hp)^.oper[0].reg>=firstsreg) and + (paicpu(hp)^.oper[0].reg<=lastsreg)) then + AsmWriteln(#9#9'DB'#9'066h'); + for i:=0 to paicpu(hp)^.ops-1 do + begin + if i=0 then + sep:=#9 + else + sep:=','; + s:=s+sep+getopstr(paicpu(hp)^.oper[i],paicpu(hp)^.opsize,paicpu(hp)^.opcode, + paicpu(hp)^.ops,(i=2)); + end; + end; + end; + if paicpu(hp)^.opcode=A_FWAIT then + AsmWriteln(#9#9'DB'#9'09bh') + else + AsmWriteLn(#9#9+{prefix+}int_op2str[paicpu(hp)^.opcode]+ + cond2str[paicpu(hp)^.condition]+{suffix+}s); + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, + ait_stab_function_name : ; +{$endif GDB} + + ait_cut : + begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + AsmClose; + DoAssemble; + AsmCreate(pai_cut(hp)^.place); + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + lastsec:=pai_section(hp^.next)^.sec; + hp:=pai(hp^.next); + end; + if lastsec<>sec_none then + AsmWriteLn('SECTION '+target_asm.secnames[lastsec]); + AsmStartSize:=AsmSize; + end; + + ait_marker : + if pai_marker(hp)^.kind=InlineStart then + inc(InlineLevel) + else if pai_marker(hp)^.kind=InlineEnd then + dec(InlineLevel); + + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + + var + currentasmlist : PAsmList; + + procedure writeexternal(p:pnamedindexobject);{$ifndef FPC}far;{$endif} + begin + if pasmsymbol(p)^.typ=AS_EXTERNAL then + currentasmlist^.AsmWriteln('EXTERN'#9+p^.name); + end; + + procedure ti386nasmasmlist.WriteExternals; + begin + currentasmlist:=@self; + AsmSymbolList^.foreach({$ifndef TP}@{$endif}writeexternal); + end; + + + procedure ti386nasmasmlist.WriteAsmList; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing nasm-styled assembler output for '+current_module^.mainsource^); +{$endif} + LastSec:=sec_none; + AsmWriteLn('BITS 32'); + AsmLn; + + countlabelref:=false; + lastfileinfo.line:=-1; + lastfileinfo.fileindex:=0; + lastinfile:=nil; + + WriteExternals; + + { Nasm doesn't support stabs + WriteTree(debuglist);} + + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(resourcestringlist); + WriteTree(bsssegment); + countlabelref:=true; + + AsmLn; +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing nasm-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.60 2000/05/15 14:11:45 pierre + * add implicit args for FADDP + + Revision 1.59 2000/05/12 21:26:22 pierre + * fix the FDIV FDIVR FSUB FSUBR and popping equivalent + simply by swapping from reverse to normal and vice-versa + when passing from one syntax to the other ! + + Revision 1.58 2000/05/09 21:44:27 pierre + * add .byte 066h to force correct pushw %es + * handle push es as a pushl %es + + Revision 1.57 2000/04/06 07:09:15 pierre + * handle offset fixup + + add source lines + * no NEAR for opcodes that only support short jumps + + Revision 1.56 2000/02/09 13:22:43 peter + * log truncated + + Revision 1.55 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.54 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.53 1999/11/02 15:06:56 peter + * import library fixes for win32 + * alignment works again + + Revision 1.52 1999/09/13 16:27:24 peter + * fix for jmps to be always near + * string writing fixed + + Revision 1.51 1999/09/10 15:41:18 peter + * added symbol_end + + Revision 1.50 1999/09/02 18:47:43 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.49 1999/08/25 11:59:38 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.48 1999/08/04 00:22:37 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.47 1999/08/01 18:28:10 florian + * modifications for the new code generator + + Revision 1.46 1999/07/22 09:37:33 florian + + resourcestring implemented + + start of longstring support + +} \ No newline at end of file diff --git a/befpc/compiler/ag68kgas.pas b/befpc/compiler/ag68kgas.pas new file mode 100644 index 0000000..fd349f0 --- /dev/null +++ b/befpc/compiler/ag68kgas.pas @@ -0,0 +1,738 @@ +{ + $Id: ag68kgas.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for MOTOROLA syntax with + Motorola 68000 (for GAS v2.52 AND HIGER) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{ R- Necessary for the in [] } +{$ifdef TP} + {$N+,E+,R-} +{$endif} +unit ag68kgas; + + interface + + uses cobjects,aasm,assemble; + + type + pm68kgasasmlist=^tm68kgasasmlist; + tm68kgasasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; +{$ifdef GDB} + procedure WriteFileLineInfo(var fileinfo : tfileposinfo); + procedure WriteFileEndInfo; +{$endif} + end; + + implementation + + uses + globtype,systems, + dos,globals,cpubase, + strings,files,verbose +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + + var +{$ifdef GDB} + n_line : byte; { different types of source lines } + linecount, + includecount : longint; + funcname : pchar; + stabslastfileinfo : tfileposinfo; +{$endif} + lastsec : tsection; { last section type written } + lastsecidx, + lastfileindex, + lastline : longint; + + + function double2str(d : double) : string; + var + hs : string; + begin + str(d,hs); + { replace space with + } + if hs[1]=' ' then + hs[1]:='+'; + double2str:='0d'+hs + end; + +(* TO SUPPORT SOONER OR LATER!!! + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin + {$ifdef TP} + c:=d; + {$else} + c:=comp(d); + {$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; *) + + + function getreferencestring(const ref : treference) : string; + var + s,basestr,indexstr : string; + + begin + s:=''; + if ref.isintvalue then + s:='#'+tostr(ref.offset) + else + with ref do + begin + if target_info.target=target_m68k_PalmOS then + begin + basestr:=gasPalmOS_reg2str[base]; + indexstr:=gasPalmOS_reg2str[index]; + end + else + begin + basestr:=gas_reg2str[base]; + indexstr:=gas_reg2str[index]; + end; + if assigned(symbol) then + s:=s+symbol^; + + if offset<0 then s:=s+tostr(offset) + else if (offset>0) then + begin + if (symbol=nil) then s:=tostr(offset) + else s:=s+'+'+tostr(offset); + end; + if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'(,'+indexstr+'.l)' + else + s:=s+'(,'+indexstr+'.l*'+tostr(scalefactor)+')' + end + else if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'('+basestr+')+' + else + InternalError(10002); + end + else if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'-('+basestr+')' + else + InternalError(10003); + end + else if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + s:=s+'('+basestr+')' + end + else if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'('+basestr+','+indexstr+'.l)' + else + s:=s+'('+basestr+','+indexstr+'.l*'+tostr(scalefactor)+')'; + end; + end; { end with } + getreferencestring:=s; + end; + + + function getopstr(t : byte;o : pointer) : string; + + var + hs : string; + i: tregister; + + begin + case t of + top_reg : if target_info.target=target_m68k_PalmOS then + getopstr:=gasPalmOS_reg2str[tregister(o)] + else + getopstr:=gas_reg2str[tregister(o)]; + top_ref : getopstr:=getreferencestring(preference(o)^); + top_reglist : begin + hs:=''; + for i:=R_NO to R_FPSR do + begin + if i in tregisterlist(o^) then + hs:=hs+gas_reg2str[i]+'/'; + end; + delete(hs,length(hs),1); + getopstr := hs; + end; + top_const : getopstr:='#'+tostr(longint(o)); + top_symbol : + { compare with i386, where a symbol is considered } + { a constant. } + begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); +{ inc(byte(hs[0]));} + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr:=hs; + end; + else internalerror(10001); + end; + end; + + function getopstr_jmp(t : byte;o : pointer) : string; + + var + hs : string; + + begin + case t of + top_reg : getopstr_jmp:=gas_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr_jmp:=hs; + end; + else internalerror(10001); + end; + end; + +{**************************************************************************** + T68kGASASMOUTPUT + ****************************************************************************} + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'.long'#9,#9'.short'#9,#9'.byte'#9); + + function ait_section2str(s:tsection):string; + begin + case s of + sec_code : ait_section2str:='.text'; + sec_data : ait_section2str:='.data'; + sec_bss : ait_section2str:='.bss'; + else + ait_section2str:=''; + end; + LastSec:=s; + end; + +{$ifdef GDB} + var + curr_n : byte; + infile : pinputfile; + + procedure tm68kgasasmlist.WriteFileLineInfo(var fileinfo : tfileposinfo); + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + { file changed ? (must be before line info) } + if lastfileindex<>fileinfo.fileindex then + begin + infile:=current_module^.sourcefiles^.get_file(fileinfo.fileindex); + if includecount=0 then + curr_n:=n_sourcefile + else + curr_n:=n_includefile; + if (infile^.path^<>'') then + begin + AsmWriteLn(#9'.stabs "'+lower(BsToSlash(FixPath(infile^.path^,false)))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + end; + AsmWriteLn(#9'.stabs "'+lower(FixFileName(infile^.name^))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + AsmWriteLn('Ltext'+ToStr(IncludeCount)+':'); + inc(includecount); + lastfileindex:=fileinfo.fileindex; + end; + { line changed ? } + if (fileinfo.line<>lastline) and (fileinfo.line<>0) then + begin + if (n_line=n_textline) and assigned(funcname) and + (target_os.use_function_relative_addresses) then + begin + AsmWriteLn(target_asm.labelprefix+'l'+tostr(linecount)+':'); + AsmWrite(#9'.stabn '+tostr(n_line)+',0,'+tostr(fileinfo.line)+','+ + target_asm.labelprefix+'l'+tostr(linecount)+' - '); + AsmWritePChar(FuncName); + AsmLn; + inc(linecount); + end + else + AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(fileinfo.line)); + lastline:=fileinfo.line; + end; + end; + + procedure tm68kgasasmlist.WriteFileEndInfo; + + begin + if not ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + exit; + AsmLn; + AsmWriteLn(ait_section2str(sec_code)); + AsmWriteLn(#9'.stabs "",'+tostr(n_sourcefile)+',0,0,Letext'); + AsmWriteLn('Letext:'); + end; + +{$endif GDB} + + + procedure tm68kgasasmlist.WriteTree(p:paasmoutput); + type + twowords=record + word1,word2:word; + end; + textendedarray = array[0..9] of byte; { last longint will be and $ffff } + var + hp : pai; + ch : char; + consttyp : tait; + s : string; + pos,l,i : longint; + found : boolean; + begin + if not assigned(p) then + exit; + hp:=pai(p^.first); + while assigned(hp) do + begin + { write debugger informations } +{$ifdef GDB} + if ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + begin + if not (hp^.typ in [ait_external,ait_regalloc, ait_regdealloc,ait_stabn,ait_stabs, + ait_label,ait_cut,ait_marker,ait_align,ait_stab_function_name]) then + WriteFileLineInfo(hp^.fileinfo); + end; +{$endif GDB} + + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; +{$ifdef DREGALLOC} + ait_regalloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' allocated'); + ait_regdealloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' released'); +{$endif DREGALLOC} + ait_align : AsmWriteLn(#9'.align '+tostr(pai_align(hp)^.aligntype)); + ait_section : begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWrite(ait_section2str(pai_section(hp)^.sec)); + {!!!! + if pai_section(hp)^.idataidx>0 then + AsmWrite('$'+tostr(pai_section(hp)^.idataidx)); + } + AsmLn; +{$ifdef GDB} + case pai_section(hp)^.sec of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + end; +{$endif GDB} + end; + LastSec:=pai_section(hp)^.sec; + end; + ait_datablock : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if pai_datablock(hp)^.size <> 1 then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if pai_datablock(hp)^.is_global then + AsmWrite(#9'.comm'#9) + else + AsmWrite(#9'.lcomm'#9); + AsmWriteLn(pai_datablock(hp)^.sym^.name+','+tostr(pai_datablock(hp)^.size)); + end; + ait_const_32bit, { alignment is required for 16/32 bit data! } + ait_const_16bit: begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_8bit : begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_symbol : Begin + AsmWriteLn(#9'.long'#9+StrPas(pchar(pai_const(hp)^.value))); + end; + { + ait_const_symbol_offset : + Begin + AsmWrite(#9'.long'#9); + AsmWritePChar(pai_const_symbol_offset(hp)^.name); + if pai_const_symbol_offset(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol_offset(hp)^.offset)) + else if pai_const_symbol_offset(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol_offset(hp)^.offset)); + AsmLn; + end; + } + ait_real_64bit : Begin + AsmWriteLn(#9'.double'#9+double2str(pai_real_64bit(hp)^.value)); + end; + ait_real_32bit : Begin + AsmWriteLn(#9'.single'#9+double2str(pai_real_32bit(hp)^.value)); + end; + ait_real_80bit : Begin + AsmWriteLn(#9'.extend'#9+double2str(pai_real_80bit(hp)^.value)); + { comp type is difficult to write so use double } + end; +{ TO SUPPORT SOONER OR LATER!!! + ait_comp : Begin + AsmWriteLn(#9'.double'#9+comp2str(pai_extended(hp)^.value)); + end; } + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; +{$IfDef GDB} + if strpos(pai_direct(hp)^.str,'.data')<>nil then + n_line:=n_dataline + else if strpos(pai_direct(hp)^.str,'.text')<>nil then + n_line:=n_textline + else if strpos(pai_direct(hp)^.str,'.bss')<>nil then + n_line:=n_bssline; +{$endif GDB} + end; + ait_string : begin + pos:=0; + for i:=1 to pai_string(hp)^.len do + begin + if pos=0 then + begin + AsmWrite(#9'.ascii'#9'"'); + pos:=20; + end; + ch:=pai_string(hp)^.str[i-1]; + case ch of + #0, {This can't be done by range, because a bug in FPC} + #1..#31, + #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7); + '"' : s:='\"'; + '\' : s:='\\'; + else + s:=ch; + end; + AsmWrite(s); + inc(pos,length(s)); + if (pos>line_length) or (i=pai_string(hp)^.len) then + begin + AsmWriteLn('"'); + pos:=0; + end; + end; + end; + ait_label : begin + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,{ ait_const_symbol_offset, } + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if (pai_label(hp)^.l^.is_used) then + AsmWriteLn(pai_label(hp)^.l^.name+':'); + end; +ait_labeled_instruction : begin + { labeled operand } + if pai_labeled(hp)^._op1 = R_NO then + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+pai_labeled(hp)^.lab^.name) + else + { labeled operand with register } + begin + if target_info.target=target_m68k_PalmOS then + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+ + gasPalmOS_reg2str[pai_labeled(hp)^._op1]+','+pai_labeled(hp)^.lab^.name) + else + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+ + gas_reg2str[pai_labeled(hp)^._op1]+','+pai_labeled(hp)^.lab^.name) + end; + end; + ait_symbol : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,{!!! ait_const_symbol_offset, } + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if pai_symbol(hp)^.is_global then + AsmWriteLn('.globl '+pai_symbol(hp)^.sym^.name); + AsmWriteLn(pai_symbol(hp)^.sym^.name+':'); + end; + ait_instruction : begin + { old versions of GAS don't like PEA.L and LEA.L } + if (paicpu(hp)^._operator in [ + A_LEA,A_PEA,A_ABCD,A_BCHG,A_BCLR,A_BSET,A_BTST, + A_EXG,A_NBCD,A_SBCD,A_SWAP,A_TAS,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]) then + s:=#9+mot_op2str[paicpu(hp)^._operator] + else + if target_info.target=target_m68k_PalmOS then + s:=#9+mot_op2str[paicpu(hp)^._operator]+gas_opsize2str[paicpu(hp)^.size] + else + s:=#9+mot_op2str[paicpu(hp)^._operator]+mit_opsize2str[paicpu(hp)^.size]; + if paicpu(hp)^.op1t<>top_none then + begin + { call and jmp need an extra handling } + { this code is only callded if jmp isn't a labeled instruction } + if paicpu(hp)^._operator in [A_JSR,A_JMP] then + s:=s+#9+getopstr_jmp(paicpu(hp)^.op1t,paicpu(hp)^.op1) + else + if paicpu(hp)^.op1t = top_reglist then + s:=s+#9+getopstr(paicpu(hp)^.op1t,@(paicpu(hp)^.reglist)) + else + s:=s+#9+getopstr(paicpu(hp)^.op1t,paicpu(hp)^.op1); + if paicpu(hp)^.op2t<>top_none then + begin + if paicpu(hp)^.op2t = top_reglist then + s:=s+','+getopstr(paicpu(hp)^.op2t,@paicpu(hp)^.reglist) + else + s:=s+','+getopstr(paicpu(hp)^.op2t,paicpu(hp)^.op2); + { three operands } + if paicpu(hp)^.op3t<>top_none then + begin + if (paicpu(hp)^._operator = A_DIVSL) or + (paicpu(hp)^._operator = A_DIVUL) or + (paicpu(hp)^._operator = A_MULU) or + (paicpu(hp)^._operator = A_MULS) or + (paicpu(hp)^._operator = A_DIVS) or + (paicpu(hp)^._operator = A_DIVU) then + s:=s+':'+getopstr(paicpu(hp)^.op3t,paicpu(hp)^.op3) + else + s:=s+','+getopstr(paicpu(hp)^.op3t,paicpu(hp)^.op3); + end; + end; + end; + AsmWriteLn(s); + end; +{$ifdef GDB} + ait_stabs : begin + AsmWrite(#9'.stabs '); + AsmWritePChar(pai_stabs(hp)^.str); + AsmLn; + end; + ait_stabn : begin + AsmWrite(#9'.stabn '); + AsmWritePChar(pai_stabn(hp)^.str); + AsmLn; + end; + ait_force_line : begin + stabslastfileinfo.line:=0; + end; +ait_stab_function_name : funcname:=pai_stab_function_name(hp)^.str; +{$endif GDB} + ait_cut : begin + { only reset buffer if nothing has changed } + if AsmSize=AsmStartSize then + AsmClear + else + begin + AsmClose; + DoAssemble; + AsmCreate; + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + begin + lastsec:=pai_section(hp^.next)^.sec; + {!!!!! + lastsecidx:=pai_section(hp^.next)^.idataidx; + } +{$ifdef GDB} + { this is needed for line info in data } + case pai_section(hp^.next)^.sec of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + end; +{$endif GDB} + end; + hp:=pai(hp^.next); + end; +{$ifdef GDB} + { force write of filename } + lastfileindex:=0; + includecount:=0; + funcname:=nil; + WriteFileLineInfo(hp^.fileinfo); +{$endif GDB} + if lastsec<>sec_none then + AsmWriteLn(ait_section2str(lastsec)); + AsmStartSize:=AsmSize; + end; + ait_marker : ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + + procedure tm68kgasasmlist.WriteAsmList; + var + p:dirstr; + n:namestr; + e:extstr; +{$ifdef GDB} + fileinfo : tfileposinfo; +{$endif GDB} + + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing gas-styled assembler output for '+current_module^.mainsource^); +{$endif} + + LastSec:=sec_none; + + if assigned(current_module^.mainsource) then + fsplit(current_module^.mainsource^,p,n,e) + else + begin + p:=inputdir; + n:=inputfile; + e:=inputextension; + end; + { to get symify to work } + AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"'); + +{$ifdef GDB} + includecount:=0; + n_line:=n_bssline; + lastline:=0; + lastfileindex:=0; + funcname:=nil; + linecount:=1; + fileinfo.fileindex:=1; + fileinfo.line:=1; + { Write main file } + WriteFileLineInfo(fileinfo); +{$endif GDB} + AsmStartSize:=AsmSize; + + countlabelref:=false; + { there should be nothing but externals so we don't need to process + WriteTree(externals); } + + If (cs_debuginfo in aktmoduleswitches) then + WriteTree(debuglist); + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(bsssegment); + Writetree(importssection); + Writetree(exportssection); + Writetree(resourcesection); + countlabelref:=true; + + AsmLn; +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing gas-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.26 2000/04/14 12:49:11 pierre + * some debug related updates + + Revision 1.25 2000/02/09 13:22:44 peter + * log truncated + + Revision 1.24 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.23 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} \ No newline at end of file diff --git a/befpc/compiler/ag68kmit.pas b/befpc/compiler/ag68kmit.pas new file mode 100644 index 0000000..a5f8c72 --- /dev/null +++ b/befpc/compiler/ag68kmit.pas @@ -0,0 +1,685 @@ +{ + $Id: ag68kmit.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for MIT syntax with + Motorola 68000 (for MIT syntax TEST WITH GAS v1.34) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** + + What's to do: + o Verify if this actually work as indirect mode with name of variables + o write lines numbers and file names to output file + o generate debugging informations +} + +unit ag68kmit; + + interface + + uses aasm,assemble; + + type + pm68kmitasmlist=^tm68kmitasmlist; + tm68kmitasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + + implementation + + uses + globtype,systems, + dos,globals,cobjects,cpubase, + strings,files,verbose +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + + var +{$ifdef GDB} + n_line : byte; { different types of source lines } + linecount, + includecount : longint; + funcname : pchar; + stabslastfileinfo : tfileposinfo; +{$endif} + lastsec : tsection; { last section type written } + lastsecidx, + lastfileindex, + lastline : longint; + + + function double2str(d : double) : string; + var + hs : string; + begin + str(d,hs); + { replace space with + } + if hs[1]=' ' then + hs[1]:='+'; + double2str:=hs; + end; + + +(* TO SUPPORT SOONER OR LATER!!! + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin + {$ifdef TP} + c:=d; + {$else} + c:=comp(d); + {$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; *) + + + function getreferencestring(const ref : treference) : string; + var + s : string; + begin + s:=''; + if ref.isintvalue then + s:='#'+tostr(ref.offset) + else + with ref do + begin + { symbol and offset } + if (assigned(symbol)) and (offset<>0) then + Begin + s:=s+'('+tostr(offset)+symbol^; + end + else + { symbol only } + if (assigned(symbol)) and (offset=0) then + Begin + s:=s+'('+symbol^; + end + else + { offset only } + if (symbol=nil) and (offset<>0) then + Begin + s:=s+'('+tostr(offset); + end + else + { NOTHING - put zero as offset } + if (symbol=nil) and (offset=0) then + Begin + s:=s+'('+'0'; + end + else + InternalError(10004); + if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then + InternalError(10004) + else if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + Begin + if offset<>0 then + s:=mit_reg2str[base]+'@+'+s+')' + else + s:=mit_reg2str[base]+'@+'; + end + else + InternalError(10002); + end + else if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + Begin + if offset<>0 then + s:=mit_reg2str[base]+'@-'+s+')' + else + s:=mit_reg2str[base]+'@-'; + end + else + InternalError(10003); + end + else if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + if (offset=0) and (symbol=nil) then + s:=mit_reg2str[base]+'@' + else + s:=mit_reg2str[base]+'@'+s+')'; + end + else if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + s:=mit_reg2str[base]+'@'+s+','+mit_reg2str[index]+':L'; + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+')' + else + s:=s+':'+tostr(scalefactor)+')'; + end + else + if assigned(symbol) then + Begin + s:=symbol^; + if offset<>0 then + s:=s+'+'+tostr(offset); + end + { this must be a physical address } + else + s:=s+')'; +{ else if NOT assigned(symbol) then + InternalError(10004);} + end; { end with } + getreferencestring:=s; + end; + + + function getopstr(t : byte;o : pointer) : string; + var + hs : string; + i: tregister; + begin + case t of + top_reg : getopstr:=mit_reg2str[tregister(o)]; + top_ref : getopstr:=getreferencestring(preference(o)^); + top_reglist: begin + hs:=''; + for i:=R_NO to R_FPSR do + begin + if i in tregisterlist(o^) then + hs:=hs+mit_reg2str[i]+'/'; + end; + delete(hs,length(hs),1); + getopstr := hs; + end; + top_const : getopstr:='#'+tostr(longint(o)); + top_symbol : + { compare with i386, where a symbol is considered } + { a constant. } + begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); +{ inc(byte(hs[0]));} + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr:=hs; + end; + else internalerror(10001); + end; + end; + + + function getopstr_jmp(t : byte;o : pointer) : string; + var + hs : string; + begin + case t of + top_reg : getopstr_jmp:=mit_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr_jmp:=hs; + end; + else internalerror(10001); + end; + end; + + +{**************************************************************************** + T68kGASASMOUTPUT + ****************************************************************************} + + const + ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= + (#9'.long'#9,#9'.short'#9,#9'.byte'#9); + + ait_section2str : array[tsection] of string[8]= + ('','.text','.data','.bss', + '.stab','.stabstr', + '.idata2','.idata4','.idata5','.idata6','.idata7', + '.edata',''); + + procedure tm68kmitasmlist.WriteTree(p:paasmoutput); + var + hp : pai; + ch : char; + consttyp : tait; + s : string; + pos,l,i : longint; + found : boolean; +{$ifdef GDB} + curr_n : byte; + infile : pinputfile; + funcname : pchar; + linecount : longint; +{$endif GDB} + begin + if not assigned(p) then + exit; +{$ifdef GDB} + funcname:=nil; + linecount:=1; +{$endif GDB} + hp:=pai(p^.first); + while assigned(hp) do + begin + { write debugger informations } +{$ifdef GDB} + if ((cs_debuginfo in aktmoduleswitches) or + (cs_gdb_lineinfo in aktglobalswitches)) then + begin + if not (hp^.typ in [ait_external,ait_regalloc, ait_regdealloc,ait_stabn,ait_stabs, + ait_label,ait_cut,ait_marker,ait_align,ait_stab_function_name]) then + begin + { file changed ? (must be before line info) } + if lastfileindex<>hp^.fileinfo.fileindex then + begin + infile:=current_module^.sourcefiles^.get_file(hp^.fileinfo.fileindex); + if includecount=0 then + curr_n:=n_sourcefile + else + curr_n:=n_includefile; + if (infile^.path^<>'') then + begin + AsmWriteLn(#9'.stabs "'+lower(BsToSlash(FixPath(infile^.path^,false)))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + end; + AsmWriteLn(#9'.stabs "'+lower(FixFileName(infile^.name^))+'",'+ + tostr(curr_n)+',0,0,'+'Ltext'+ToStr(IncludeCount)); + AsmWriteLn('Ltext'+ToStr(IncludeCount)+':'); + inc(includecount); + lastfileindex:=hp^.fileinfo.fileindex; + end; + { line changed ? } + if (hp^.fileinfo.line<>lastline) and (hp^.fileinfo.line<>0) then + begin + if (n_line=n_textline) and assigned(funcname) and + (target_os.use_function_relative_addresses) then + begin + AsmWriteLn(target_asm.labelprefix+'l'+tostr(linecount)+':'); + AsmWrite(#9'.stabn '+tostr(n_line)+',0,'+tostr(hp^.fileinfo.line)+','+ + target_asm.labelprefix+'l'+tostr(linecount)+' - '); + AsmWritePChar(FuncName); + AsmLn; + inc(linecount); + end + else + AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(hp^.fileinfo.line)); + lastline:=hp^.fileinfo.line; + end; + end; + end; +{$endif GDB} + case hp^.typ of + ait_external : ; { external is ignored } + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; +{$ifdef DREGALLOC} + ait_regalloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' allocated'); + ait_regdealloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' released'); +{$endif DREGALLOC} + ait_align : AsmWriteLn(#9'.align '+tostr(pai_align(hp)^.aligntype)); + ait_section : begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + AsmWrite(ait_section2str[pai_section(hp)^.sec]); + if pai_section(hp)^.idataidx>0 then + AsmWrite('$'+tostr(pai_section(hp)^.idataidx)); + AsmLn; +{$ifdef GDB} + case pai_section(hp)^.sec of + sec_code : n_line:=n_textline; + sec_data : n_line:=n_dataline; + sec_bss : n_line:=n_bssline; + end; +{$endif GDB} + end; + LastSec:=pai_section(hp)^.sec; + end; + ait_datablock : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if pai_datablock(hp)^.size <> 1 then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if pai_datablock(hp)^.is_global then + AsmWrite(#9'.comm'#9) + else + AsmWrite(#9'.lcomm'#9); + AsmWriteLn(StrPas(pai_datablock(hp)^.name)+','+tostr(pai_datablock(hp)^.size)); + end; + ait_const_32bit, { alignment is required for 16/32 bit data! } + ait_const_16bit: begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_8bit : begin + AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); + consttyp:=hp^.typ; + l:=0; + repeat + found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); + if found then + begin + hp:=Pai(hp^.next); + s:=','+tostr(pai_const(hp)^.value); + AsmWrite(s); + inc(l,length(s)); + end; + until (not found) or (l>line_length); + AsmLn; + end; + ait_const_symbol : Begin + AsmWriteLn(#9'.long'#9+StrPas(pchar(pai_const(hp)^.value))); + end; + ait_const_symbol_offset : + Begin + AsmWrite(#9'.long'#9); + AsmWritePChar(pai_const_symbol_offset(hp)^.name); + if pai_const_symbol_offset(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol_offset(hp)^.offset)) + else if pai_const_symbol_offset(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol_offset(hp)^.offset)); + AsmLn; + end; + ait_real_64bit : Begin + AsmWriteLn(#9'.double'#9+double2str(pai_double(hp)^.value)); + end; + ait_real_32bit : Begin + AsmWriteLn(#9'.single'#9+double2str(pai_single(hp)^.value)); + end; + ait_real_extended : Begin + AsmWriteLn(#9'.extend'#9+double2str(pai_extended(hp)^.value)); + { comp type is difficult to write so use double } + end; +{ TO SUPPORT SOONER OR LATER!!! + ait_comp : Begin + AsmWriteLn(#9'.double'#9+comp2str(pai_extended(hp)^.value)); + end; } + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; +{$IfDef GDB} + if strpos(pai_direct(hp)^.str,'.data')<>nil then + n_line:=n_dataline + else if strpos(pai_direct(hp)^.str,'.text')<>nil then + n_line:=n_textline + else if strpos(pai_direct(hp)^.str,'.bss')<>nil then + n_line:=n_bssline; +{$endif GDB} + end; + ait_string : begin + pos:=0; + for i:=1 to pai_string(hp)^.len do + begin + if pos=0 then + begin + AsmWrite(#9'.ascii'#9'"'); + pos:=20; + end; + ch:=pai_string(hp)^.str[i-1]; + case ch of + #0, {This can't be done by range, because a bug in FPC} + #1..#31, + #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7); + '"' : s:='\"'; + '\' : s:='\\'; + else + s:=ch; + end; + AsmWrite(s); + inc(pos,length(s)); + if (pos>line_length) or (i=pai_string(hp)^.len) then + begin + AsmWriteLn('"'); + pos:=0; + end; + end; + end; + ait_label : begin + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if (pai_label(hp)^.l^.is_used) then + AsmWriteLn(lab2str(pai_label(hp)^.l)+':'); + end; +ait_labeled_instruction : begin + { labeled operand } + if pai_labeled(hp)^._op1 = R_NO then + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab)) + else + { labeled operand with register } + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+ + mit_reg2str[pai_labeled(hp)^._op1]+','+lab2str(pai_labeled(hp)^.lab)) + end; + ait_symbol : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9#9'.align 4') + else + AsmWriteLn(#9#9'.align 2'); + end; + if pai_symbol(hp)^.is_global then + AsmWriteLn('.globl '+StrPas(pai_symbol(hp)^.name)); + AsmWriteLn(StrPas(pai_symbol(hp)^.name)+':'); + end; + ait_instruction : begin + { old versions of GAS don't like PEA.L and LEA.L } + if (pai68k(hp)^._operator in [ + A_LEA,A_PEA,A_ABCD,A_BCHG,A_BCLR,A_BSET,A_BTST, + A_EXG,A_NBCD,A_SBCD,A_SWAP,A_TAS,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]) then + s:=#9+mot_op2str[pai68k(hp)^._operator] + else + s:=#9+mot_op2str[pai68k(hp)^._operator]+mit_opsize2str[pai68k(hp)^.size]; + if pai68k(hp)^.op1t<>top_none then + begin + { call and jmp need an extra handling } + { this code is only callded if jmp isn't a labeled instruction } + if pai68k(hp)^._operator in [A_JSR,A_JMP] then + s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1) + else + if pai68k(hp)^.op1t = top_reglist then + s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist)) + else + s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1); + if pai68k(hp)^.op2t<>top_none then + begin + if pai68k(hp)^.op2t = top_reglist then + s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist) + else + s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2); + { three operands } + if pai68k(hp)^.op3t<>top_none then + begin + if (pai68k(hp)^._operator = A_DIVSL) or + (pai68k(hp)^._operator = A_DIVUL) or + (pai68k(hp)^._operator = A_MULU) or + (pai68k(hp)^._operator = A_MULS) or + (pai68k(hp)^._operator = A_DIVS) or + (pai68k(hp)^._operator = A_DIVU) then + s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3) + else + s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3); + end; + end; + end; + AsmWriteLn(s); + end; +{$ifdef GDB} + ait_stabs : begin + AsmWrite(#9'.stabs '); + AsmWritePChar(pai_stabs(hp)^.str); + AsmLn; + end; + ait_stabn : begin + AsmWrite(#9'.stabn '); + AsmWritePChar(pai_stabn(hp)^.str); + AsmLn; + end; + ait_force_line : begin + stabslastfileinfo.line:=0; + end; +ait_stab_function_name : funcname:=pai_stab_function_name(hp)^.str; +{$endif GDB} + ait_cut : begin + { create only a new file when the last is not empty } + if AsmSize>0 then + begin + AsmClose; + DoAssemble; + AsmCreate; + end; + { avoid empty files } + while assigned(hp^.next) and (pai(hp^.next)^.typ in [ait_cut,ait_section,ait_comment]) do + begin + if pai(hp^.next)^.typ=ait_section then + begin + lastsec:=pai_section(hp^.next)^.sec; + lastsecidx:=pai_section(hp^.next)^.idataidx; + end; + hp:=pai(hp^.next); + end; + if lastsec<>sec_none then + AsmWriteLn(ait_section2str[lastsec,lastsecidx]); + end; + ait_marker : ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + procedure tm68kmitasmlist.WriteAsmList; + var + p:dirstr; + n:namestr; + e:extstr; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing gas-styled assembler output for '+current_module^.mainsource^); +{$endif} + + lastline:=0; + lastfileindex:=0; + LastSec:=sec_none; +{$ifdef GDB} + includecount:=0; + n_line:=n_bssline; +{$endif GDB} + + if assigned(current_module^.mainsource) then + fsplit(current_module^.mainsource^,p,n,e) + else + begin + p:=inputdir; + n:=inputfile; + e:=inputextension; + end; + { to get symify to work } + AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"'); + + countlabelref:=false; + { there should be nothing but externals so we don't need to process + WriteTree(externals); } + + If (cs_debuginfo in aktmoduleswitches) then + WriteTree(debuglist); + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(bsssegment); + Writetree(importssection); + Writetree(exportssection); + Writetree(resourcesection); + countlabelref:=true; + + AsmLn; +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing gas-styled assembler output for '+current_module^.mainsource^); +{$endif EXTDEBUG} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.25 2000/04/14 12:49:11 pierre + * some debug related updates + + Revision 1.24 2000/02/09 13:22:44 peter + * log truncated + + Revision 1.23 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.22 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} \ No newline at end of file diff --git a/befpc/compiler/ag68kmot.pas b/befpc/compiler/ag68kmot.pas new file mode 100644 index 0000000..32c94c5 --- /dev/null +++ b/befpc/compiler/ag68kmot.pas @@ -0,0 +1,554 @@ +{ + $Id: ag68kmot.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for MOTOROLA syntax with + Motorola 68000 (recognized by the Amiga Assembler and Charlie Gibbs's + A68k) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ag68kmot; + + interface + + uses aasm,assemble; + + type + pm68kmotasmlist=^tm68kmotasmlist; + tm68kmotasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + + implementation + + uses + globtype,systems, + dos,globals,cobjects,cpubase, + strings,files,verbose +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + const + line_length = 70; + + function double2str(d : double) : string; + var + hs : string; + begin + str(d,hs); + double2str:=hs; + end; + + +(* TO SUPPORT SOONER OR LATER!!! + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin + {$ifdef TP} + c:=d; + {$else} + c:=comp(d); + {$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; *) + + + function getreferencestring(const ref : treference) : string; + var + s : string; + begin + s:=''; + if ref.isintvalue then + s:='#'+tostr(ref.offset) + else + with ref do + begin + if (index=R_NO) and (base=R_NO) and (direction=dir_none) then + begin + if assigned(symbol) then + begin + s:=s+symbol^; + if offset<0 then + s:=s+tostr(offset) + else + if (offset>0) then + s:=s+'+'+tostr(offset); + end + else + begin + { direct memory addressing } + s:=s+'('+tostr(offset)+').l'; + end; + end + else + begin + if assigned(symbol) then + s:=s+symbol^; + if offset<0 then + s:=s+tostr(offset) + else + if (offset>0) then + begin + if (symbol=nil) then s:=tostr(offset) + else s:=s+'+'+tostr(offset); + end; + if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + begin + if offset = 0 then + s:=s+'0(,'+mot_reg2str[index]+'.l)' + else + s:=s+'(,'+mot_reg2str[index]+'.l)'; + end + else + begin + if offset = 0 then + s:=s+'0(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')' + else + s:=s+'(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'; + end + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'('+mot_reg2str[base]+')+' + else + InternalError(10002); + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'-('+mot_reg2str[base]+')' + else + InternalError(10003); + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + s:=s+'('+mot_reg2str[base]+')'; + end + else + if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + begin + if offset = 0 then + s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)' + else + s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)'; + end + else + begin + if offset = 0 then + s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')' + else + s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'; + end + end + { if this is not a symbol, and is not in the above, then there is an error } + else + if NOT assigned(symbol) then + InternalError(10004); + end; { endif } + end; { end with } + getreferencestring:=s; + end; + + + function getopstr(t : byte;o : pointer) : string; + var + hs : string; + i: tregister; + begin + case t of + top_reg : getopstr:=mot_reg2str[tregister(o)]; + top_reglist: begin + hs:=''; + for i:=R_NO to R_FPSR do + begin + if i in tregisterlist(o^) then + hs:=hs+mot_reg2str[i]+'/'; + end; + delete(hs,length(hs),1); + getopstr := hs; + end; + top_ref : getopstr:=getreferencestring(preference(o)^); + top_const : getopstr:='#'+tostr(longint(o)); + top_symbol : begin + { compare with i386 version, where this is a constant. } + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); +{ inc(byte(hs[0]));} +{ hs[1]:='#';} + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr:=hs; + end; + else internalerror(10001); + end; + end; + + + function getopstr_jmp(t : byte;o : pointer) : string; + var + hs : string; + begin + case t of + top_reg : getopstr_jmp:=mot_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr_jmp:=hs; + end; + else internalerror(10001); + end; + end; + +{**************************************************************************** + TM68KMOTASMLIST + ****************************************************************************} + + var + LastSec : tsection; + + const + section2str : array[tsection] of string[6]= + ('','CODE','DATA','BSS','','','','','','','',''); + + procedure tm68kmotasmlist.WriteTree(p:paasmoutput); + var + hp : pai; + s : string; + counter, + i,j,lines : longint; + quoted : boolean; + begin + if not assigned(p) then + exit; + hp:=pai(p^.first); + while assigned(hp) do + begin + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + ait_section : begin + if pai_section(hp)^.sec<>sec_none then + begin + + AsmLn; + AsmWriteLn('SECTION _'+section2str[pai_section(hp)^.sec]+','+section2str[pai_section(hp)^.sec]); + end; + LastSec:=pai_section(hp)^.sec; + end; +{$ifdef DREGALLOC} + ait_regalloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' allocated'); + ait_regdealloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' released'); +{$endif DREGALLOC} + ait_align : AsmWriteLn(#9'CNOP 0,'+tostr(pai_align(hp)^.aligntype)); + ait_external : AsmWriteLn(#9'XREF'#9+StrPas(pai_external(hp)^.name)); + ait_real_extended : Message(assem_e_extended_not_supported); + ait_comp : Message(assem_e_comp_not_supported); + ait_datablock : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if pai_datablock(hp)^.size <> 1 then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'CNOP 0,4') + else + AsmWriteLn(#9'CNOP 0,2'); + end; + if pai_datablock(hp)^.is_global then + AsmWriteLn(#9'XDEF'#9+StrPas(pai_datablock(hp)^.name)); + AsmWriteLn(StrPas(pai_datablock(hp)^.name)+#9#9'DS.B '+tostr(pai_datablock(hp)^.size)); + end; + ait_const_32bit : Begin + AsmWriteLn(#9#9'DC.L'#9+tostr(pai_const(hp)^.value)); + end; + ait_const_16bit : Begin + AsmWriteLn(#9#9'DC.W'#9+tostr(pai_const(hp)^.value)); + end; + ait_const_8bit : AsmWriteLn(#9#9'DC.B'#9+tostr(pai_const(hp)^.value)); + ait_const_symbol : Begin + AsmWriteLn(#9#9+'DC.L '#9+StrPas(pchar(pai_const(hp)^.value))); + end; + ait_const_symbol_offset : + Begin + AsmWrite(#9#9+'DC.L '#9); + AsmWritePChar(pai_const_symbol_offset(hp)^.name); + if pai_const_symbol_offset(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol_offset(hp)^.offset)) + else if pai_const_symbol_offset(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol_offset(hp)^.offset)); + AsmLn; + end; + ait_real_64bit : Begin + AsmWriteLn(#9#9'DC.D'#9+double2str(pai_double(hp)^.value)); + end; + ait_real_32bit : Begin + AsmWriteLn(#9#9'DC.S'#9+double2str(pai_single(hp)^.value)); + end; +{ TO SUPPORT SOONER OR LATER!!! + ait_comp : AsmWriteLn(#9#9'DC.D'#9+comp2str(pai_extended(hp)^.value));} + ait_string : begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DC.B'#9); + quoted:=false; + for i:=counter to counter+line_length do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + AsmLn; + counter := counter+line_length; + end; { end for j:=0 ... } + { do last line of lines } + AsmWrite(#9#9'DC.B'#9); + quoted:=false; + for i:=counter to pai_string(hp)^.len-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'"') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite('"'); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite('"'); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite('"'); + end; { endif } + AsmLn; + end; + ait_label : begin + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'CNOP 0,4') + else + AsmWriteLn(#9'CNOP 0,2'); + end; + AsmWrite(lab2str(pai_label(hp)^.l)); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol, + ait_real_64bit,ait_string]) then + AsmWriteLn(':'); + end; + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; +ait_labeled_instruction : + Begin + { labeled operand } + if pai_labeled(hp)^._op1 = R_NO then + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab)) + else + { labeled operand with register } + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+ + mot_reg2str[pai_labeled(hp)^._op1]+','+lab2str(pai_labeled(hp)^.lab)) + end; + ait_symbol : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit, + ait_const_symbol,ait_const_symbol_offset,ait_const_8bit, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'CNOP 0,4') + else + AsmWriteLn(#9'CNOP 0,2'); + end; + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9'XDEF '+StrPas(pai_symbol(hp)^.name)); + AsmWritePChar(pai_symbol(hp)^.name); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_string,ait_real_32bit]) then + AsmWriteLn(':'); + end; + ait_instruction : begin + s:=#9+mot_op2str[pai68k(hp)^._operator]+mot_opsize2str[pai68k(hp)^.size]; + if pai68k(hp)^.op1t<>top_none then + begin + { call and jmp need an extra handling } + { this code is only called if jmp isn't a labeled instruction } + if pai68k(hp)^._operator in [A_JSR,A_JMP] then + s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1) + else + begin + if pai68k(hp)^.op1t = top_reglist then + s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist)) + else + s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1); + if pai68k(hp)^.op2t<>top_none then + begin + if pai68k(hp)^.op2t = top_reglist then + s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist) + else + s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2); + { three operands } + if pai68k(hp)^.op3t<>top_none then + begin + if (pai68k(hp)^._operator = A_DIVSL) or + (pai68k(hp)^._operator = A_DIVUL) or + (pai68k(hp)^._operator = A_MULU) or + (pai68k(hp)^._operator = A_MULS) or + (pai68k(hp)^._operator = A_DIVS) or + (pai68k(hp)^._operator = A_DIVU) then + s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3) + else + s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3); + end; + end; + end; + end; + AsmWriteLn(s); + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, + ait_stab_function_name : ; +{$endif GDB} + ait_marker : ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + procedure tm68kmotasmlist.WriteAsmList; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing motorola-styled assembler output for '+current_module^.mainsource^); +{$endif} + + countlabelref:=false; + WriteTree(externals); + { WriteTree(debuglist);} + WriteTree(codesegment); + WriteTree(datasegment); + WriteTree(consts); + WriteTree(rttilist); + WriteTree(bsssegment); + Writetree(importssection); + Writetree(exportssection); + Writetree(resourcesection); + countlabelref:=true; + + AsmLn; + AsmWriteLn(#9'END'); + AsmLn; + +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing motorola-styled assembler output for '+current_module^.mainsource^); +{$endif} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/02/09 13:22:44 peter + * log truncated + + Revision 1.19 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.18 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} diff --git a/befpc/compiler/ag68kmpw.pas b/befpc/compiler/ag68kmpw.pas new file mode 100644 index 0000000..04b6d66 --- /dev/null +++ b/befpc/compiler/ag68kmpw.pas @@ -0,0 +1,596 @@ +{ + $Id: ag68kmpw.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an asmoutput class for Macintosh MPW syntax + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ag68kmpw; + + interface + + uses aasm,assemble; + + type + pm68kmpwasmlist=^tm68kmpwasmlist; + tm68kmpwasmlist = object(tasmlist) + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + + implementation + + uses + globtype,systems, + dos,globals,cobjects,cpubase, + strings,files,verbose +{$ifdef GDB} + ,gdb +{$endif GDB} + ; + + + function double2str(d : double) : string; + var + hs : string; + begin + str(d,hs); + double2str:=hs; + end; + + +(* TO SUPPORT SOONER OR LATER!!! + function comp2str(d : bestreal) : string; + type + pdouble = ^double; + var + c : comp; + dd : pdouble; + begin + {$ifdef TP} + c:=d; + {$else} + c:=comp(d); + {$endif} + dd:=pdouble(@c); { this makes a bitwise copy of c into a double } + comp2str:=double2str(dd^); + end; *) + + const + line_length = 70; + + function getreferencestring(const ref : treference; var importstring: string) : string; + var + s : string; + begin + s:=''; + importstring:=''; + if ref.isintvalue then + s:='#'+tostr(ref.offset) + else + with ref do + begin + if (index=R_NO) and (base=R_NO) and (direction=dir_none) then + begin + if assigned(symbol) then + begin + s:=s+symbol^; + importstring:=symbol^; + if offset<0 then + s:=s+tostr(offset) + else + if (offset>0) then + s:=s+'+'+tostr(offset); + s:='('+s+').L'; + end + else + begin + { direct memory addressing } + s:=s+'('+tostr(offset)+').L'; + end; + end + { index<>R_NO or base<>R_NO } + else + begin + if assigned(symbol) then + s:=s+symbol^; + if offset<0 then + s:=s+tostr(offset) + else + if (offset>0) then + begin + if (symbol=nil) then s:=tostr(offset) + else s:=s+'+'+tostr(offset); + end; + if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + begin + if offset = 0 then + s:=s+'0(,'+mot_reg2str[index]+'.l)' + else + s:=s+'(,'+mot_reg2str[index]+'.l)'; + end + else + begin + if offset = 0 then + s:=s+'0(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')' + else + s:=s+'(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'; + end + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'('+mot_reg2str[base]+')+' + else + InternalError(10002); + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + s:=s+'-('+mot_reg2str[base]+')' + else + InternalError(10003); + end + else + if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + s:=s+'('+mot_reg2str[base]+')'; + end + else + if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then + begin + if (scalefactor = 1) or (scalefactor = 0) then + begin + if offset = 0 then + s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)' + else + s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)'; + end + else + begin + if offset = 0 then + s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')' + else + s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'; + end + end + { if this is not a symbol, and is not in the above, then there is an error } + else + if NOT assigned(symbol) then + InternalError(10004); + end; { endif } + end; { end with } + getreferencestring:=s; + end; + + + function getopstr(t : byte;o : pointer) : string; + var + hs : string; + i: tregister; + importstring: string; + begin + case t of + top_reg : getopstr:=mot_reg2str[tregister(o)]; + top_reglist: begin + hs:=''; + for i:=R_NO to R_FPSR do + begin + if i in tregisterlist(o^) then + hs:=hs+mot_reg2str[i]+'/'; + end; + delete(hs,length(hs),1); + getopstr := hs; + end; + top_ref : getopstr:=getreferencestring(preference(o)^,importstring); + top_const : getopstr:='#'+tostr(longint(o)); + top_symbol : begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + getopstr:=hs; + end; + else internalerror(10001); + end; + end; + + + function getopstr_jmp(t : byte;o : pointer; var importname: string) : string; + var + hs : string; + begin + importname:=''; + case t of + top_reg : getopstr_jmp:=mot_reg2str[tregister(o)]; + top_ref : getopstr_jmp:=getreferencestring(preference(o)^,importname); + top_const : getopstr_jmp:=tostr(longint(o)); + top_symbol : begin + hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); + move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); + if pcsymbol(o)^.offset>0 then + hs:=hs+'+'+tostr(pcsymbol(o)^.offset) + else if pcsymbol(o)^.offset<0 then + hs:=hs+tostr(pcsymbol(o)^.offset); + importname:=hs; + hs:='('+hs+').L'; + getopstr_jmp:=hs; + end; + else internalerror(10001); + end; + end; + +{**************************************************************************** + TM68KMOTASMLIST + ****************************************************************************} + var + LastSec : tsection; + + procedure tm68kmpwasmlist.WriteTree(p:paasmoutput); + var + hp : pai; + s : string; + counter, + i,j,lines : longint; + quoted : boolean; + importname: string; + begin + hp:=pai(p^.first); + while assigned(hp) do + begin + case hp^.typ of + ait_comment : Begin + AsmWrite(target_asm.comment); + AsmWritePChar(pai_asm_comment(hp)^.str); + AsmLn; + End; + ait_section : begin + if pai_section(hp)^.sec<>sec_none then + begin + AsmLn; + end; + LastSec:=pai_section(hp)^.sec; + end; +{$ifdef DREGALLOC} + ait_regalloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' allocated'); + ait_regdealloc : AsmWriteLn(target_asm.comment+'Register '+att_reg2str[pairegalloc(hp)^.reg]+' released'); +{$endif DREGALLOC} + ait_align : AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype)); + ait_external : AsmWriteLn(#9'IMPORT'#9+StrPas(pai_external(hp)^.name)); + ait_real_extended : Message(assem_e_extended_not_supported); + ait_comp : Message(assem_e_comp_not_supported); + ait_datablock : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if pai_datablock(hp)^.size <> 1 then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'ALIGN 4') + else + AsmWriteLn(#9'ALIGN 2'); + end; + if pai_datablock(hp)^.is_global then + AsmWriteLn(#9'EXPORT'#9+StrPas(pai_datablock(hp)^.name)); + AsmWriteLn(#9#9+StrPas(pai_datablock(hp)^.name)+#9#9'DS.B '+tostr(pai_datablock(hp)^.size)); + end; + ait_const_32bit : Begin + AsmWriteLn(#9#9'DC.L'#9+tostr(pai_const(hp)^.value)); + end; + ait_const_16bit : Begin + AsmWriteLn(#9#9'DC.W'#9+tostr(pai_const(hp)^.value)); + end; + ait_const_8bit : AsmWriteLn(#9#9'DC.B'#9+tostr(pai_const(hp)^.value)); + ait_const_symbol : Begin + AsmWriteLn(#9#9+'DC.L '#9+StrPas(pchar(pai_const(hp)^.value))); + end; + ait_const_symbol_offset : + Begin + AsmWrite(#9#9+'DC.L '#9); + AsmWritePChar(pai_const_symbol_offset(hp)^.name); + if pai_const_symbol_offset(hp)^.offset>0 then + AsmWrite('+'+tostr(pai_const_symbol_offset(hp)^.offset)) + else if pai_const_symbol_offset(hp)^.offset<0 then + AsmWrite(tostr(pai_const_symbol_offset(hp)^.offset)); + AsmLn; + end; + ait_real_64bit : Begin + AsmWriteLn(#9#9'DC.D'#9+double2str(pai_double(hp)^.value)); + end; + ait_real_32bit : Begin + AsmWriteLn(#9#9'DC.S'#9+double2str(pai_single(hp)^.value)); + end; +{ TO SUPPORT SOONER OR LATER!!! + ait_comp : AsmWriteLn(#9#9'DC.D'#9+comp2str(pai_extended(hp)^.value));} + ait_string : begin + counter := 0; + lines := pai_string(hp)^.len div line_length; + { separate lines in different parts } + if pai_string(hp)^.len > 0 then + Begin + for j := 0 to lines-1 do + begin + AsmWrite(#9#9'DC.B'#9); + quoted:=false; + for i:=counter to counter+line_length do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'''') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite(''''); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and ord('"') } + else + begin + if quoted then + AsmWrite(''''); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite(''''); + AsmLn; + counter := counter+line_length; + end; { end for j:=0 ... } + { do last line of lines } + AsmWrite(#9#9'DC.B'#9); + quoted:=false; + for i:=counter to pai_string(hp)^.len-1 do + begin + { it is an ascii character. } + if (ord(pai_string(hp)^.str[i])>31) and + (ord(pai_string(hp)^.str[i])<128) and + (pai_string(hp)^.str[i]<>'''') then + begin + if not(quoted) then + begin + if i>counter then + AsmWrite(','); + AsmWrite(''''); + end; + AsmWrite(pai_string(hp)^.str[i]); + quoted:=true; + end { if > 31 and < 128 and " } + else + begin + if quoted then + AsmWrite(''''); + if i>counter then + AsmWrite(','); + quoted:=false; + AsmWrite(tostr(ord(pai_string(hp)^.str[i]))); + end; + end; { end for i:=0 to... } + if quoted then AsmWrite(''''); + end; { endif } + AsmLn; + end; + ait_label : begin + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'ALIGN 4') + else + AsmWriteLn(#9'ALIGN 2'); + end; + AsmWrite(lab2str(pai_label(hp)^.l)); + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_string]) then + AsmWriteLn(':'); + end; + ait_direct : begin + AsmWritePChar(pai_direct(hp)^.str); + AsmLn; + end; +ait_labeled_instruction : + { Labeled instructions are those which don't require an } + { intersegment jump -- jmp/bra/bcc to local labels. } + Begin + { labeled operand } + if pai_labeled(hp)^._op1 = R_NO then + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab)) + else + { labeled operand with register } + AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+ + mot_reg2str[pai_labeled(hp)^._op1]+','+lab2str(pai_labeled(hp)^.lab)) + end; + ait_symbol : begin + { ------------------------------------------------------- } + { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- } + { ------------- REQUIREMENT FOR 680x0 ------------------- } + { ------------------------------------------------------- } + if assigned(hp^.next) and (pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_real_32bit,ait_string]) then + begin + if not(cs_littlesize in aktglobalswitches) then + AsmWriteLn(#9'ALIGN 4') + else + AsmWriteLn(#9'ALIGN 2'); + end; + if assigned(hp^.next) and not(pai(hp^.next)^.typ in + [ait_const_32bit,ait_const_16bit,ait_const_8bit, + ait_const_symbol,ait_const_symbol_offset, + ait_real_64bit,ait_string,ait_real_32bit]) then + { this is a subroutine } + Begin + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9+StrPas(pai_symbol(hp)^.name)+' PROC EXPORT') + else + AsmWriteLn(#9+StrPas(pai_symbol(hp)^.name)+' PROC'); + AsmWriteLn(#9'WITH _DATA'); + end + else + Begin + if pai_symbol(hp)^.is_global then + AsmWriteLn(#9'EXPORT'#9+StrPas(pai_symbol(hp)^.name)) + else + AsmWriteLn(#9'ENTRY'#9+StrPas(pai_symbol(hp)^.name)); + AsmWritePChar(pai_symbol(hp)^.name); + end; + end; + ait_instruction : begin + s:=#9+mot_op2str[pai68k(hp)^._operator]+mot_opsize2str[pai68k(hp)^.size]; + if pai68k(hp)^.op1t<>top_none then + begin + { call and jmp need an extra handling } + { this code is only called if jmp isn't a labeled instruction } + if pai68k(hp)^._operator in [A_JSR,A_JMP] then + begin + s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1,importname); + if importname <> '' then + AsmWriteLn(#9+'IMPORT '+importname); + end + else + begin + if pai68k(hp)^.op1t = top_reglist then + s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist)) + else + s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1); + if pai68k(hp)^.op2t<>top_none then + begin + if pai68k(hp)^.op2t = top_reglist then + s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist) + else + s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2); + { three operands } + if pai68k(hp)^.op3t<>top_none then + begin + if (pai68k(hp)^._operator = A_DIVSL) or + (pai68k(hp)^._operator = A_DIVUL) or + (pai68k(hp)^._operator = A_MULU) or + (pai68k(hp)^._operator = A_MULS) or + (pai68k(hp)^._operator = A_DIVS) or + (pai68k(hp)^._operator = A_DIVU) then + s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3) + else + s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3); + end; + end; + end; + end; + AsmWriteLn(s); + { if this instruction is the last before } + { returning it MIGHT be the end of a } + { pascal subroutine, if this is so, then } + if (pai68k(hp)^._operator = A_RTS) or + (pai68k(hp)^._operator = A_RTD) then + Begin + { if next is not an instruction nor a label } + { this is the end of a procedure probably } + { and not an inline assembler instruction } + if assigned(hp^.next) and ( + (pai(hp^.next)^.typ = ait_label) or + (pai(hp^.next)^.typ = ait_instruction) or + (pai(hp^.next)^.typ = ait_labeled_instruction)) then + begin + end + else + begin + AsmWriteLn(#9'ENDWITH'); + AsmWriteLn(#9'ENDPROC'); + AsmLn; + end; + end; + end; +{$ifdef GDB} + ait_stabn, + ait_stabs, + ait_force_line, + ait_stab_function_name : ; +{$endif GDB} + ait_marker : ; + else + internalerror(10000); + end; + hp:=pai(hp^.next); + end; + end; + + procedure tm68kmpwasmlist.WriteAsmList; + begin +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Start writing MPW-styled assembler output for '+current_module^.mainsource^); +{$endif} + WriteTree(externals); + AsmLn; + AsmWriteLn(#9'_DATA'#9'RECORD'); + { write a signature to the file } + AsmWriteLn(#9'ALIGN 4'); +(* now in pmodules +{$ifdef EXTDEBUG} + AsmWriteLn(#9'DC.B'#9'''compiled by FPC '+version_string+'\0'''); + AsmWriteLn(#9'DC.B'#9'''target: '+target_info.short_name+'\0'''); +{$endif EXTDEBUG} *) + WriteTree(datasegment); + WriteTree(consts); + WriteTree(bsssegment); + AsmWriteLn(#9'ENDR'); + + AsmLn; + WriteTree(codesegment); + + + AsmLn; + AsmWriteLn(#9'END'); +{$ifdef EXTDEBUG} + if assigned(current_module^.mainsource) then + comment(v_info,'Done writing MPW-styled assembler output for '+current_module^.mainsource^); +{$endif} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/02/09 13:22:44 peter + * log truncated + + Revision 1.11 2000/01/07 01:14:18 peter + * updated copyright to 2000 + + Revision 1.10 1999/11/06 14:34:16 peter + * truncated log to 20 revs + + Revision 1.9 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} diff --git a/befpc/compiler/aopt386.pas b/befpc/compiler/aopt386.pas new file mode 100644 index 0000000..db67499 --- /dev/null +++ b/befpc/compiler/aopt386.pas @@ -0,0 +1,120 @@ +{ + $Id: aopt386.pas,v 1.1.1.1 2001-07-23 17:15:25 memson Exp $ + Copyright (c) 1998-2000 by Jonas Maebe + + This unit calls the optimization procedures to optimize the assembler + code for i386+ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef newOptimizations} +{$define foropt} +{$define replacereg} +{$define arithopt} +{$define foldarithops} +{$endif newOptimizations} + +Unit aopt386; + +Interface + +Uses + aasm; + +Procedure Optimize(AsmL: PAasmOutput); + +Implementation + +Uses + globtype, + globals, + DAOpt386,POpt386,CSOpt386; + + +Procedure Optimize(AsmL: PAasmOutput); +Var BlockStart, BlockEnd, HP: Pai; +Begin +{setup labeltable, always necessary} + BlockStart := Pai(AsmL^.First); + BlockEnd := DFAPass1(AsmL, BlockStart); +{Blockend now either contains an ait_marker with Kind = AsmBlockStart, or nil} + While Assigned(BlockStart) Do + Begin +{peephole optimizations} + PeepHoleOptPass1(AsmL, BlockStart, BlockEnd); + PeepHoleOptPass1(AsmL, BlockStart, BlockEnd); +{data flow analyzer} + If (cs_slowoptimize in aktglobalswitches) Then + Begin + If DFAPass2( +{$ifdef statedebug} + AsmL, +{$endif statedebug} + BlockStart, BlockEnd) Then +{common subexpression elimination} + CSE(AsmL, BlockStart, BlockEnd); + End; +{more peephole optimizations} + PeepHoleOptPass2(AsmL, BlockStart, BlockEnd); +{dispose labeltabel} + ShutDownDFA; +{continue where we left off, BlockEnd is either the start of an assembler + block or nil} + BlockStart := BlockEnd; + While Assigned(BlockStart) And + (BlockStart^.typ = ait_Marker) And + (Pai_Marker(BlockStart)^.Kind = AsmBlockStart) Do + Begin + {we stopped at an assembler block, so skip it} + Repeat + BlockStart := Pai(BlockStart^.Next); + Until (BlockStart^.Typ = Ait_Marker) And + (Pai_Marker(Blockstart)^.Kind = AsmBlockEnd); + {blockstart now contains a pai_marker(asmblockend)} + If GetNextInstruction(BlockStart, HP) And + ((HP^.typ <> ait_Marker) Or + (Pai_Marker(HP)^.Kind <> AsmBlockStart)) Then + {there is no assembler block anymore after the current one, so + optimize the next block of "normal" instructions} + BlockEnd := DFAPass1(AsmL, BlockStart) + {otherwise, skip the next assembler block} + Else BlockStart := HP; + End + End; +End; + +End. + +{ + $Log: not supported by cvs2svn $ + Revision 1.32 2000/02/09 13:22:44 peter + * log truncated + + Revision 1.31 2000/01/07 01:14:19 peter + * updated copyright to 2000 + + Revision 1.30 1999/11/27 23:50:22 jonas + + if you define "newOptimizations", all extra optimizations that + require conditional defines will be activated (ie., it's equivalent + to "-dreplacereg -darithopt -dforopt -dfoldarithops") + + Revision 1.29 1999/10/23 14:44:24 jonas + * finally got around making GetNextInstruction return false when + the current pai object is a AsmBlockStart marker + * changed a loop in aopt386 which was incompatible with this change + +} diff --git a/befpc/compiler/assemble.pas b/befpc/compiler/assemble.pas new file mode 100644 index 0000000..4ca1142 --- /dev/null +++ b/befpc/compiler/assemble.pas @@ -0,0 +1,650 @@ +{ + $Id: assemble.pas,v 1.1.1.1 2001-07-23 17:15:26 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit handles the assemblerfile write and assembler calls of FPC + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} + +unit assemble; + +interface + +uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + cobjects,globtype,globals,aasm; + +const +{$ifdef tp} + AsmOutSize=1024; +{$else} + AsmOutSize=32768; +{$endif} + +type + PAsmList=^TAsmList; + TAsmList=object + private + procedure CreateSmartLinkPath(const s:string); + public + {filenames} + path : pathstr; + name : namestr; + asmfile, { current .s and .o file } + objfile, + as_bin : string; + SmartAsm : boolean; + smarthcount : longint; + place : TCutPlace; { special 'end' file for import dir ? } + {outfile} + AsmSize, + AsmStartSize, + outcnt : longint; + outbuf : array[0..AsmOutSize-1] of char; + outfile : file; + Constructor Init(smart:boolean); + Destructor Done; + Function FindAssembler:string; + Function CallAssembler(const command,para:string):Boolean; + Function DoAssemble:boolean; + Procedure RemoveAsm; + procedure NextSmartName; + Procedure AsmFlush; + Procedure AsmClear; + Procedure AsmWrite(const s:string); + Procedure AsmWritePChar(p:pchar); + Procedure AsmWriteLn(const s:string); + Procedure AsmLn; + procedure AsmCreate(Aplace:tcutplace); + procedure AsmClose; + procedure Synchronize; + procedure WriteTree(p:paasmoutput);virtual; + procedure WriteAsmList;virtual; + end; + +var + SmartLinkFilesCnt : longint; + +Procedure GenerateAsm(smart:boolean); +Procedure OnlyAsm; + + +Implementation + +uses + script,files,systems,verbose +{$ifdef linux} + ,linux +{$endif} + ,strings +{$ifdef i386} + {$ifndef NoAg386Bin} + ,ag386bin + {$endif} + {$ifndef NoAg386Att} + ,ag386att + {$endif NoAg386Att} + {$ifndef NoAg386Nsm} + ,ag386nsm + {$endif NoAg386Nsm} + {$ifndef NoAg386Int} + ,ag386int + {$endif NoAg386Int} + {$ifdef Ag386Cof} + ,ag386cof + {$endif Ag386Cof} +{$endif} +{$ifdef m68k} + {$ifndef NoAg68kGas} + ,ag68kgas + {$endif NoAg68kGas} + {$ifndef NoAg68kMot} + ,ag68kmot + {$endif NoAg68kMot} + {$ifndef NoAg68kMit} + ,ag68kmit + {$endif NoAg68kMit} + {$ifndef NoAg68kMpw} + ,ag68kmpw + {$endif NoAg68kMpw} +{$endif} + ; + + +{***************************************************************************** + TAsmList +*****************************************************************************} + +Function DoPipe:boolean; +begin + DoPipe:=(cs_asm_pipe in aktglobalswitches) and + not(cs_asm_leave in aktglobalswitches) +{$ifdef i386} + and (aktoutputformat=as_i386_as) +{$endif i386} +{$ifdef m68k} + and (aktoutputformat=as_m68k_as); +{$endif m68k} +end; + + +const + lastas : byte=255; +var + LastASBin : pathstr; +Function TAsmList.FindAssembler:string; +var + asfound : boolean; +begin + if lastas<>ord(target_asm.id) then + begin + lastas:=ord(target_asm.id); + { is an assembler passed ? } + if utilsdirectory<>'' then + LastASBin:=FindFile(target_asm.asmbin+source_os.exeext,utilsdirectory,asfound)+ + target_asm.asmbin+source_os.exeext; + if LastASBin='' then + LastASBin:=FindExe(target_asm.asmbin,asfound); + if (not asfound) and not(cs_asm_extern in aktglobalswitches) then + begin + Message1(exec_w_assembler_not_found,LastASBin); + aktglobalswitches:=aktglobalswitches+[cs_asm_extern]; + end; + if asfound then + Message1(exec_t_using_assembler,LastASBin); + end; + FindAssembler:=LastASBin; +end; + + +Function TAsmList.CallAssembler(const command,para:string):Boolean; +begin + callassembler:=true; + if not(cs_asm_extern in aktglobalswitches) then + begin + swapvectors; + exec(command,para); + swapvectors; + if (doserror<>0) then + begin + Message1(exec_w_cant_call_assembler,tostr(doserror)); + aktglobalswitches:=aktglobalswitches+[cs_asm_extern]; + callassembler:=false; + end + else + if (dosexitcode<>0) then + begin + Message1(exec_w_error_while_assembling,tostr(dosexitcode)); + callassembler:=false; + end; + end + else + AsmRes.AddAsmCommand(command,para,name); +end; + + +procedure TAsmList.RemoveAsm; +var + g : file; +begin + if cs_asm_leave in aktglobalswitches then + exit; + if cs_asm_extern in aktglobalswitches then + AsmRes.AddDeleteCommand(AsmFile) + else + begin + assign(g,AsmFile); + {$I-} + erase(g); + {$I+} + if ioresult<>0 then; + end; +end; + + +Function TAsmList.DoAssemble:boolean; +var + s : string; +begin + DoAssemble:=true; + if DoPipe then + exit; + if not(cs_asm_extern in aktglobalswitches) then + begin + if SmartAsm then + begin + if (SmartLinkFilesCnt<=1) then + Message1(exec_i_assembling_smart,name); + end + else + Message1(exec_i_assembling,name); + end; + s:=target_asm.asmcmd; + Replace(s,'$ASM',AsmFile); + Replace(s,'$OBJ',ObjFile); + if CallAssembler(FindAssembler,s) then + RemoveAsm + else + begin + DoAssemble:=false; + GenerateError; + end; +end; + + +procedure TAsmList.NextSmartName; +var + s : string; +begin + inc(SmartLinkFilesCnt); + if SmartLinkFilesCnt>999999 then + Message(asmw_f_too_many_asm_files); + case place of + cut_begin : + begin + inc(smarthcount); + s:=current_module^.asmprefix^+tostr(smarthcount)+'h'; + end; + cut_normal : + s:=current_module^.asmprefix^+tostr(smarthcount)+'s'; + cut_end : + s:=current_module^.asmprefix^+tostr(smarthcount)+'t'; + end; + AsmFile:=Path+FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.asmext); + ObjFile:=Path+FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.objext); + { insert in container so it can be cleared after the linking } + SmartLinkOFiles.Insert(Objfile); +end; + + +{***************************************************************************** + TAsmList AsmFile Writing +*****************************************************************************} + +Procedure TAsmList.AsmFlush; +begin + if outcnt>0 then + begin + BlockWrite(outfile,outbuf,outcnt); + outcnt:=0; + end; +end; + + +Procedure TAsmList.AsmClear; +begin + outcnt:=0; +end; + + +Procedure TAsmList.AsmWrite(const s:string); +begin + if OutCnt+length(s)>=AsmOutSize then + AsmFlush; + Move(s[1],OutBuf[OutCnt],length(s)); + inc(OutCnt,length(s)); + inc(AsmSize,length(s)); +end; + + +Procedure TAsmList.AsmWriteLn(const s:string); +begin + AsmWrite(s); + AsmLn; +end; + + +Procedure TAsmList.AsmWritePChar(p:pchar); +var + i,j : longint; +begin + i:=StrLen(p); + j:=i; + while j>0 do + begin + i:=min(j,AsmOutSize); + if OutCnt+i>=AsmOutSize then + AsmFlush; + Move(p[0],OutBuf[OutCnt],i); + inc(OutCnt,i); + inc(AsmSize,i); + dec(j,i); + p:=pchar(@p[i]); + end; +end; + + +Procedure TAsmList.AsmLn; +begin + if OutCnt>=AsmOutSize-2 then + AsmFlush; + OutBuf[OutCnt]:=target_os.newline[1]; + inc(OutCnt); + inc(AsmSize); + if length(target_os.newline)>1 then + begin + OutBuf[OutCnt]:=target_os.newline[2]; + inc(OutCnt); + inc(AsmSize); + end; +end; + + +procedure TAsmList.AsmCreate(Aplace:tcutplace); +begin + place:=Aplace; + if SmartAsm then + NextSmartName; +{$ifdef linux} + if DoPipe then + begin + Message1(exec_i_assembling_pipe,asmfile); + POpen(outfile,'as -o '+objfile,'W'); + end + else +{$endif} + begin + Assign(outfile,asmfile); + {$I-} + Rewrite(outfile,1); + {$I+} + if ioresult<>0 then + Message1(exec_d_cant_create_asmfile,asmfile); + end; + outcnt:=0; + AsmSize:=0; + AsmStartSize:=0; +end; + + +procedure TAsmList.AsmClose; +var + f : file; + l : longint; +begin + AsmFlush; +{$ifdef linux} + if DoPipe then + Close(outfile) + else +{$endif} + begin + {Touch Assembler time to ppu time is there is a ppufilename} + if Assigned(current_module^.ppufilename) then + begin + Assign(f,current_module^.ppufilename^); + {$I-} + reset(f,1); + {$I+} + if ioresult=0 then + begin + getftime(f,l); + close(f); + reset(outfile,1); + setftime(outfile,l); + end; + end; + close(outfile); + end; +end; + + +{Touch Assembler and object time to ppu time is there is a ppufilename} +procedure TAsmList.Synchronize; +begin +{Touch Assembler time to ppu time is there is a ppufilename} + if Assigned(current_module^.ppufilename) then + begin + SynchronizeFileTime(current_module^.ppufilename^,asmfile); + if not(cs_asm_extern in aktglobalswitches) then + SynchronizeFileTime(current_module^.ppufilename^,objfile); + end; +end; + + +procedure TAsmList.WriteTree(p:paasmoutput); +begin +end; + + +procedure TAsmList.WriteAsmList; +begin +end; + + +procedure TAsmList.CreateSmartLinkPath(const s:string); +var + dir : searchrec; +begin + if PathExists(s) then + begin + { the path exists, now we clean only all the .o and .s files } + { .o files } + findfirst(s+dirsep+'*'+target_info.objext,anyfile,dir); + while (doserror=0) do + begin + RemoveFile(s+dirsep+dir.name); + findnext(dir); + end; +{$ifdef fpc} + findclose(dir); +{$endif} + { .s files } + findfirst(s+dirsep+'*'+target_info.asmext,anyfile,dir); + while (doserror=0) do + begin + RemoveFile(s+dirsep+dir.name); + findnext(dir); + end; +{$ifdef fpc} + findclose(dir); +{$endif} + end + else + begin + {$I-} + mkdir(s); + {$I+} + if ioresult<>0 then; + end; +end; + + +Constructor TAsmList.Init(smart:boolean); +begin +{ load start values } + asmfile:=current_module^.asmfilename^; + objfile:=current_module^.objfilename^; + name:=FixFileName(current_module^.modulename^); + OutCnt:=0; + SmartLinkFilesCnt:=0; + SmartLinkOFiles.Clear; + place:=cut_normal; + SmartAsm:=smart; + SmartHCount:=0; +{ Which path will be used ? } + if SmartAsm then + begin + path:=current_module^.outputpath^+FixFileName(current_module^.modulename^)+target_info.smartext; + CreateSmartLinkPath(path); + path:=FixPath(path,false); + end + else + path:=current_module^.outputpath^; +end; + + +Destructor TAsmList.Done; +begin +end; + + +{***************************************************************************** + Generate Assembler Files Main Procedure +*****************************************************************************} + +Procedure GenerateAsm(smart:boolean); +var + a : PAsmList; +{$ifdef i386} + {$ifndef NoAg386Bin} + b : Pi386binasmlist; + {$endif} +{$endif} +begin + case aktoutputformat of + as_none : ; +{$ifdef i386} + {$ifndef NoAg386Bin} + as_i386_dbg, + as_i386_coff, + as_i386_pecoff : + begin + case aktoutputformat of + as_i386_dbg : + b:=new(pi386binasmlist,Init(og_dbg,smart)); + as_i386_coff : + b:=new(pi386binasmlist,Init(og_coff,smart)); + as_i386_pecoff : + b:=new(pi386binasmlist,Init(og_pecoff,smart)); + end; + b^.WriteBin; + dispose(b,done); + if assigned(current_module^.ppufilename) then + begin + if smart then + SynchronizeFileTime(current_module^.ppufilename^,current_module^.staticlibfilename^) + else + SynchronizeFileTime(current_module^.ppufilename^,current_module^.objfilename^); + end; + exit; + end; + {$endif NoAg386Bin} + {$ifndef NoAg386Att} + as_i386_as, + as_i386_as_aout, + as_i386_asw : + a:=new(pi386attasmlist,Init(smart)); + {$endif NoAg386Att} + {$ifndef NoAg386Nsm} + as_i386_nasmcoff, + as_i386_nasmwin32, + as_i386_nasmelf, + as_i386_nasmobj : + a:=new(pi386nasmasmlist,Init(smart)); + {$endif NoAg386Nsm} + {$ifndef NoAg386Int} + as_i386_tasm : + a:=new(pi386intasmlist,Init(smart)); + {$endif NoAg386Int} +{$endif} +{$ifdef m68k} + {$ifndef NoAg68kGas} + as_m68k_as, + as_m68k_gas : + a:=new(pm68kgasasmlist,Init(smart)); + {$endif NoAg86KGas} + {$ifndef NoAg68kMot} + as_m68k_mot : + a:=new(pm68kmotasmlist,Init(smart)); + {$endif NoAg86kMot} + {$ifndef NoAg68kMit} + as_m68k_mit : + a:=new(pm68kmitasmlist,Init(smart)); + {$endif NoAg86KMot} + {$ifndef NoAg68kMpw} + as_m68k_mpw : + a:=new(pm68kmpwasmlist,Init(smart)); + {$endif NoAg68kMpw} +{$endif} + else +{$ifdef TP} + exit; +{$else} + Message(asmw_f_assembler_output_not_supported); +{$endif} + end; + a^.AsmCreate(cut_normal); + a^.WriteAsmList; + a^.AsmClose; + a^.DoAssemble; + a^.synchronize; + dispose(a,Done); +end; + + +Procedure OnlyAsm; +var + a : PAsmList; +begin + a:=new(pasmlist,Init(false)); + a^.DoAssemble; + dispose(a,Done); +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.65 2000/06/01 19:11:19 peter + * added ifdef fpc around findclose + + Revision 1.64 2000/06/01 13:02:45 peter + * clean .o and .s from smartlinkpath when starting the writer + + Revision 1.63 2000/04/04 15:05:03 pierre + + accept nasmwin32 output + + Revision 1.62 2000/02/24 18:41:38 peter + * removed warnings/notes + + Revision 1.61 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.60 2000/01/11 09:52:06 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.59 2000/01/07 01:14:19 peter + * updated copyright to 2000 + + Revision 1.58 1999/11/12 11:03:49 peter + * searchpaths changed to stringqueue object + + Revision 1.57 1999/11/08 10:37:12 peter + * filename fixes for win32 imports for units with multiple needed dll's + + Revision 1.56 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.55 1999/11/02 15:06:57 peter + * import library fixes for win32 + * alignment works again + + Revision 1.54 1999/09/16 11:34:44 pierre + * typo correction + + Revision 1.53 1999/09/02 18:47:44 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + +} \ No newline at end of file diff --git a/befpc/compiler/browcol.pas b/befpc/compiler/browcol.pas new file mode 100644 index 0000000..f741863 --- /dev/null +++ b/befpc/compiler/browcol.pas @@ -0,0 +1,2175 @@ +{ + $Id: browcol.pas,v 1.1.1.1 2001-07-23 17:15:29 memson Exp $ + Copyright (c) 1998-2000 by Berczi Gabor + Modifications Copyright (c) 1999-2000 Florian Klaempfl and Pierre Muller + + Support routines for getting browser info in collections + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit browcol; +interface +uses + cobjects,objects,symconst,symtable; + +{$ifndef FPC} + type + sw_integer = integer; +{$endif FPC} + +const + SymbolTypLen : integer = 6; + + RecordTypes : set of tsymtyp = + ([typesym,unitsym,programsym]); + + sfRecord = $00000001; + sfObject = $00000002; + sfClass = $00000004; + sfPointer = $00000008; + sfHasMemInfo = $80000000; + +type + TStoreCollection = object(TStringCollection) + function Add(const S: string): PString; + end; + + PModuleNameCollection = ^TModuleNameCollection; + TModuleNameCollection = object(TStoreCollection) + end; + + PTypeNameCollection = ^TTypeNameCollection; + TTypeNameCollection = object(TStoreCollection) + end; + + PSymbolCollection = ^TSymbolCollection; + PSortedSymbolCollection = ^TSortedSymbolCollection; + PReferenceCollection = ^TReferenceCollection; + + PReference = ^TReference; + TReference = object(TObject) + FileName : PString; + Position : TPoint; + constructor Init(AFileName: PString; ALine, AColumn: Sw_integer); + function GetFileName: string; + destructor Done; virtual; + constructor Load(var S: TStream); + procedure Store(var S: TStream); + end; + + PSymbolMemInfo = ^TSymbolMemInfo; + TSymbolMemInfo = record + Addr : longint; + LocalAddr : longint; + Size : longint; + PushSize : longint; + end; + + PSymbol = ^TSymbol; + TSymbol = object(TObject) + Name : PString; + Typ : tsymtyp; + Params : PString; + References : PReferenceCollection; + Items : PSymbolCollection; + DType : PString; + VType : PString; + TypeID : longint; + RelatedTypeID : longint; + DebuggerCount : longint; + Ancestor : PSymbol; + Flags : longint; + MemInfo : PSymbolMemInfo; + constructor Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo); + procedure SetMemInfo(const AMemInfo: TSymbolMemInfo); + function GetReferenceCount: Sw_integer; + function GetReference(Index: Sw_integer): PReference; + function GetItemCount: Sw_integer; + function GetItem(Index: Sw_integer): PSymbol; + function GetName: string; + function GetText: string; + function GetTypeName: string; + destructor Done; virtual; + constructor Load(var S: TStream); + procedure Store(var S: TStream); + end; + + PExport = ^TExport; + TExport = object(TObject) + constructor Init(const AName: string; AIndex: longint; ASymbol: PSymbol); + function GetDisplayText: string; + destructor Done; virtual; + private + Name: PString; + Index: longint; + Symbol: PSymbol; + end; + + PExportCollection = ^TExportCollection; + TExportCollection = object(TSortedCollection) + function At(Index: sw_Integer): PExport; + function Compare(Key1, Key2: Pointer): sw_Integer; virtual; + end; + + PImport = ^TImport; + TImport = object(TObject) + constructor Init(const ALibName, AFuncName,ARealName: string; AIndex: longint); + function GetDisplayText: string; + destructor Done; virtual; + private + LibName: PString; + FuncName: PString; + RealName: PString; + Index: longint; + end; + + PImportCollection = ^TImportCollection; + TImportCollection = object(TSortedCollection) + function At(Index: sw_Integer): PImport; + function Compare(Key1, Key2: Pointer): sw_Integer; virtual; + end; + + PObjectSymbolCollection = ^TObjectSymbolCollection; + + PObjectSymbol = ^TObjectSymbol; + TObjectSymbol = object(TObject) + Parent : PObjectSymbol; + Symbol : PSymbol; + Expanded : boolean; + constructor Init(AParent: PObjectSymbol; ASymbol: PSymbol); + constructor InitName(const AName: string); + function GetName: string; + function GetDescendantCount: sw_integer; + function GetDescendant(Index: sw_integer): PObjectSymbol; + procedure AddDescendant(P: PObjectSymbol); + destructor Done; virtual; + constructor Load(var S: TStream); + procedure Store(S: TStream); + private + Name: PString; + Descendants: PObjectSymbolCollection; + end; + + TSymbolCollection = object(TSortedCollection) + constructor Init(ALimit, ADelta: Integer); + function At(Index: Sw_Integer): PSymbol; + procedure Insert(Item: Pointer); virtual; + function LookUp(const S: string; var Idx: sw_integer): string; virtual; + end; + + TSortedSymbolCollection = object(TSymbolCollection) + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + procedure Insert(Item: Pointer); virtual; + function LookUp(const S: string; var Idx: sw_integer): string; virtual; + end; + + PIDSortedSymbolCollection = ^TIDSortedSymbolCollection; + TIDSortedSymbolCollection = object(TSymbolCollection) + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + procedure Insert(Item: Pointer); virtual; + function SearchSymbolByID(AID: longint): PSymbol; + end; + + TObjectSymbolCollection = object(TSortedCollection) + constructor Init(ALimit, ADelta: Integer); + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + function LookUp(const S: string; var Idx: sw_integer): string; virtual; + function At(Index: Sw_Integer): PObjectSymbol; + end; + + TReferenceCollection = object(TCollection) + function At(Index: Sw_Integer): PReference; + end; + + PSourceFile = ^TSourceFile; + TSourceFile = object(TObject) + SourceFileName: PString; + ObjFileName: PString; + PPUFileName: PString; + constructor Init(ASourceFileName, AObjFileName, APPUFileName: string); + destructor Done; virtual; + function GetSourceFilename: string; + function GetObjFileName: string; + function GetPPUFileName: string; + end; + + PSourceFileCollection = ^TSourceFileCollection; + TSourceFileCollection = object(TCollection) + function At(Index: sw_Integer): PSourceFile; + end; + + PModuleSymbol = ^TModuleSymbol; + TModuleSymbol = object(TSymbol) + Exports_ : PExportCollection; + Imports : PImportCollection; + LoadedFrom : PString; + UsedUnits : PSymbolCollection; + DependentUnits: PSymbolCollection; + MainSource: PString; + SourceFiles: PStringCollection; + constructor Init(const AName, AMainSource: string); + procedure SetLoadedFrom(const AModuleName: string); + procedure AddUsedUnit(P: PSymbol); + procedure AddDependentUnit(P: PSymbol); + procedure AddSourceFile(const Path: string); + destructor Done; virtual; + end; + +const + Modules : PSymbolCollection = nil; + ModuleNames : PModuleNameCollection = nil; + TypeNames : PTypeNameCollection = nil; + ObjectTree : PObjectSymbol = nil; + SourceFiles : PSourceFileCollection = nil; + +procedure DisposeBrowserCol; +procedure NewBrowserCol; +procedure CreateBrowserCol; +procedure InitBrowserCol; +procedure DoneBrowserCol; + +function LoadBrowserCol(S: PStream): boolean; +function StoreBrowserCol(S: PStream) : boolean; + +procedure BuildObjectInfo; + +procedure BuildSourceList; + +function SearchObjectForSymbol(O: PSymbol): PObjectSymbol; + +procedure RegisterSymbols; + +implementation + +uses + Dos,Drivers,{Views,App,}{$ifndef FPC}strings,{$endif} + WUtils, + aasm,globtype,globals,files,comphook; + +const + RModuleNameCollection: TStreamRec = ( + ObjType: 3001; + VmtLink: Ofs(TypeOf(TModuleNameCollection)^); + Load: @TModuleNameCollection.Load; + Store: @TModuleNameCollection.Store + ); + RTypeNameCollection: TStreamRec = ( + ObjType: 3002; + VmtLink: Ofs(TypeOf(TTypeNameCollection)^); + Load: @TTypeNameCollection.Load; + Store: @TTypeNameCollection.Store + ); + RReference: TStreamRec = ( + ObjType: 3003; + VmtLink: Ofs(TypeOf(TReference)^); + Load: @TReference.Load; + Store: @TReference.Store + ); + RSymbol: TStreamRec = ( + ObjType: 3004; + VmtLink: Ofs(TypeOf(TSymbol)^); + Load: @TSymbol.Load; + Store: @TSymbol.Store + ); + RObjectSymbol: TStreamRec = ( + ObjType: 3005; + VmtLink: Ofs(TypeOf(TObjectSymbol)^); + Load: @TObjectSymbol.Load; + Store: @TObjectSymbol.Store + ); + RSymbolCollection: TStreamRec = ( + ObjType: 3006; + VmtLink: Ofs(TypeOf(TSymbolCollection)^); + Load: @TSymbolCollection.Load; + Store: @TSymbolCollection.Store + ); + RSortedSymbolCollection: TStreamRec = ( + ObjType: 3007; + VmtLink: Ofs(TypeOf(TSortedSymbolCollection)^); + Load: @TSortedSymbolCollection.Load; + Store: @TSortedSymbolCollection.Store + ); + RIDSortedSymbolCollection: TStreamRec = ( + ObjType: 3008; + VmtLink: Ofs(TypeOf(TIDSortedSymbolCollection)^); + Load: @TIDSortedSymbolCollection.Load; + Store: @TIDSortedSymbolCollection.Store + ); + RObjectSymbolCollection: TStreamRec = ( + ObjType: 3009; + VmtLink: Ofs(TypeOf(TObjectSymbolCollection)^); + Load: @TObjectSymbolCollection.Load; + Store: @TObjectSymbolCollection.Store + ); + RReferenceCollection: TStreamRec = ( + ObjType: 3010; + VmtLink: Ofs(TypeOf(TReferenceCollection)^); + Load: @TReferenceCollection.Load; + Store: @TReferenceCollection.Store + ); + RModuleSymbol: TStreamRec = ( + ObjType: 3011; + VmtLink: Ofs(TypeOf(TModuleSymbol)^); + Load: @TModuleSymbol.Load; + Store: @TModuleSymbol.Store + ); + +{**************************************************************************** + Helpers +****************************************************************************} + +function GetStr(P: PString): string; +begin + if P=nil then + GetStr:='' + else + GetStr:=P^; +end; + +function IntToStr(L: longint): string; +var S: string; +begin + Str(L,S); + IntToStr:=S; +end; + +function UpcaseStr(S: string): string; +var I: integer; +begin + for I:=1 to length(S) do + S[I]:=Upcase(S[I]); + UpcaseStr:=S; +end; + +function FloatToStr(E: extended): string; +var S: string; +begin + Str(E:0:24,S); + if Pos('.',S)>0 then + begin + while (length(S)>0) and (S[length(S)]='0') do + Delete(S,length(S),1); + if (length(S)>0) and (S[length(S)]='.') then + Delete(S,length(S),1); + end; + if S='' then S:='0'; + FloatToStr:=S; +end; + +{**************************************************************************** + TStoreCollection +****************************************************************************} + +function TStoreCollection.Add(const S: string): PString; +var P: PString; + Index: Sw_integer; +begin + if S='' then P:=nil else + if Search(@S,Index) then P:=At(Index) else + begin + P:=NewStr(S); + Insert(P); + end; + Add:=P; +end; + + +{**************************************************************************** + TSymbolCollection +****************************************************************************} + +constructor TSymbolCollection.Init(ALimit, ADelta: Integer); +begin + inherited Init(ALimit,ADelta); +{ Duplicates:=true;} +end; + +function TSymbolCollection.At(Index: Sw_Integer): PSymbol; +begin + At:=inherited At(Index); +end; + +procedure TSymbolCollection.Insert(Item: Pointer); +begin + TCollection.Insert(Item); +end; + +function TSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string; +begin + Idx:=-1; + LookUp:=''; +end; + +{**************************************************************************** + TReferenceCollection +****************************************************************************} + +function TReferenceCollection.At(Index: Sw_Integer): PReference; +begin + At:=inherited At(Index); +end; + + +{**************************************************************************** + TSortedSymbolCollection +****************************************************************************} + +function TSortedSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PSymbol absolute Key1; + K2: PSymbol absolute Key2; + R: Sw_integer; + S1,S2: string; +begin + S1:=Upper(K1^.GetName); + S2:=Upper(K2^.GetName); + if S1S2 then R:=1 else + if K1^.TypeID=K2^.TypeID then R:=0 else + begin + S1:=K1^.GetName; + S2:=K2^.GetName; + if S1S2 then R:=1 else + if K1^.TypeIDK2^.TypeID then R:= 1 else + R:=0; + end; + Compare:=R; +end; + +procedure TSortedSymbolCollection.Insert(Item: Pointer); +begin + TSortedCollection.Insert(Item); +end; + +function TSortedSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string; +var OLI,ORI,Left,Right,Mid: integer; + LeftP,RightP,MidP: PSymbol; + RL: integer; + LeftS,MidS,RightS: string; + FoundS: string; + UpS : string; +begin + Idx:=-1; FoundS:=''; + Left:=0; Right:=Count-1; + UpS:=Upper(S); + if Left-1 then + break; + if Mid=Left then + begin + RightP:=At(Right); + RightS:=Upper(RightP^.GetName); + if copy(RightS,1,length(UpS))=UpS then + begin + Idx:=Right; + FoundS:=RightS; + end; + end; + if Mid=Right then + begin + LeftP:=At(Left); + LeftS:=Upper(LeftP^.GetName); + if copy(LeftS,1,length(UpS))=UpS then + begin + Idx:=Left; + FoundS:=LeftS; + end; + end; + Break; + end; + end; + end; + LookUp:=FoundS; +end; + +{**************************************************************************** + TIDSortedSymbolCollection +****************************************************************************} + +function TIDSortedSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PSymbol absolute Key1; + K2: PSymbol absolute Key2; + R: Sw_integer; +begin + if K1^.TypeIDK2^.TypeID then R:= 1 else + R:=0; + Compare:=R; +end; + +procedure TIDSortedSymbolCollection.Insert(Item: Pointer); +begin + TSortedCollection.Insert(Item); +end; + +function TIDSortedSymbolCollection.SearchSymbolByID(AID: longint): PSymbol; +var S: TSymbol; + Index: sw_integer; + P: PSymbol; +begin + S.TypeID:=AID; + if Search(@S,Index)=false then P:=nil else + P:=At(Index); + SearchSymbolByID:=P; +end; + +{**************************************************************************** + TObjectSymbolCollection +****************************************************************************} + +function TObjectSymbolCollection.At(Index: Sw_Integer): PObjectSymbol; +begin + At:=inherited At(Index); +end; + +constructor TObjectSymbolCollection.Init(ALimit, ADelta: Integer); +begin + inherited Init(ALimit,ADelta); +end; + +function TObjectSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PObjectSymbol absolute Key1; + K2: PObjectSymbol absolute Key2; + R: Sw_integer; + S1,S2: string; +begin + S1:=Upper(K1^.GetName); + S2:=Upper(K2^.GetName); + if S1S2 then R:=1 else + { make sure that we distinguish between different objects with the same name } + if longint(K1^.Symbol)longint(K2^.Symbol) then R:= 1 else + R:=0; + Compare:=R; +end; + +function TObjectSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string; +var OLI,ORI,Left,Right,Mid: integer; + LeftP,RightP,MidP: PObjectSymbol; + RL: integer; + LeftS,MidS,RightS: string; + FoundS: string; + UpS : string; +begin + Idx:=-1; FoundS:=''; + Left:=0; Right:=Count-1; + UpS:=Upper(S); + if LeftModulesNames^.Item } +end; + +procedure TReference.Store(var S: TStream); +begin + S.Write(Position, SizeOf(Position)); + + { --- items needing fixup --- } + S.Write(FileName, SizeOf(FileName)); +end; + +{**************************************************************************** + TSymbol +****************************************************************************} + +constructor TSymbol.Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo); +begin + inherited Init; + Name:=NewStr(AName); Typ:=ATyp; + if AMemInfo<>nil then + SetMemInfo(AMemInfo^); + New(References, Init(20,50)); + if ATyp in RecordTypes then + begin + Items:=New(PSortedSymbolCollection, Init(50,100)); + end; +end; + +procedure TSymbol.SetMemInfo(const AMemInfo: TSymbolMemInfo); +begin + if MemInfo=nil then New(MemInfo); + Move(AMemInfo,MemInfo^,SizeOf(MemInfo^)); + Flags:=Flags or sfHasMemInfo; +end; + +function TSymbol.GetReferenceCount: Sw_integer; +var Count: Sw_integer; +begin + if References=nil then Count:=0 else + Count:=References^.Count; + GetReferenceCount:=Count; +end; + +function TSymbol.GetReference(Index: Sw_integer): PReference; +begin + GetReference:=References^.At(Index); +end; + +function TSymbol.GetItemCount: Sw_integer; +var Count: Sw_integer; +begin + if Items=nil then Count:=0 else + Count:=Items^.Count; + GetItemCount:=Count; +end; + +function TSymbol.GetItem(Index: Sw_integer): PSymbol; +begin + GetItem:=Items^.At(Index); +end; + +function TSymbol.GetName: string; +begin + GetName:=GetStr(Name); +end; + +function TSymbol.GetText: string; +var S: string; + I: Sw_integer; +begin + S:=GetTypeName; + if length(S)>SymbolTypLen then + S:=Copy(S,1,SymbolTypLen) + else + begin + while length(S)0 then + S:=S+' = record' + else + if (Flags and sfObject)<>0 then + begin + S:=S+' = '; + if (Flags and sfClass)<>0 then + S:=S+'class' + else + S:=S+'object'; + if Ancestor<>nil then + S:=S+'('+Ancestor^.GetName+')'; + end + else + begin + if Assigned(DType) then + S:=S+' = '+DType^; + if Assigned(Params) then + S:=S+'('+Params^+')'; + if Assigned(VType) then + S:=S+': '+VType^; + end; + GetText:=S; +end; + +function TSymbol.GetTypeName: string; +var S: string; +begin + case Typ of + abstractsym : S:='abst'; + varsym : S:='var'; + typesym : S:='type'; + procsym : if VType=nil then + S:='proc' + else + S:='func'; + unitsym : S:='unit'; + programsym : S:='prog'; + constsym : S:='const'; + enumsym : S:='enum'; + typedconstsym: S:='const'; + errorsym : S:='error'; + syssym : S:='sys'; + labelsym : S:='label'; + absolutesym : S:='abs'; + propertysym : S:='prop'; + funcretsym : S:='res'; + macrosym : S:='macro'; + else S:=''; + end; + GetTypeName:=S; +end; + +destructor TSymbol.Done; +begin + inherited Done; + if assigned(MemInfo) then + Dispose(MemInfo); + if assigned(References) then + Dispose(References, Done); + if assigned(Items) then + Dispose(Items, Done); + if assigned(Name) then + DisposeStr(Name); +{ if assigned(Params) then + DisposeStr(Params); + if assigned(VType) then + DisposeStr(VType); + if assigned(DType) then + DisposeStr(DType); + if assigned(Ancestor) then + DisposeStr(Ancestor);} +end; + +constructor TSymbol.Load(var S: TStream); +var MI: TSymbolMemInfo; + W: word; +begin + TObject.Init; + + S.Read(Typ,SizeOf(Typ)); + S.Read(TypeID, SizeOf(TypeID)); + S.Read(RelatedTypeID, SizeOf(RelatedTypeID)); + S.Read(Flags, SizeOf(Flags)); + Name:=S.ReadStr; + Params:=S.ReadStr; + if (Flags and sfHasMemInfo)<>0 then + begin + S.Read(MI,SizeOf(MI)); + SetMemInfo(MI); + end; + + W:=0; + S.Read(W,SizeOf(W)); + if (W and 1)<>0 then + New(References, Load(S)); + if (W and 2)<>0 then + New(Items, Load(S)); + + { --- items needing fixup --- } + S.Read(DType, SizeOf(DType)); + S.Read(VType, SizeOf(VType)); + {S.Read(Ancestor, SizeOf(Ancestor));} +end; + +procedure TSymbol.Store(var S: TStream); +var W: word; +begin + S.Write(Typ,SizeOf(Typ)); + S.Write(TypeID, SizeOf(TypeID)); + S.Write(RelatedTypeID, SizeOf(RelatedTypeID)); + S.Write(Flags, SizeOf(Flags)); + S.WriteStr(Name); + S.WriteStr(Params); + + if (Flags and sfHasMemInfo)<>0 then + S.Write(MemInfo^,SizeOf(MemInfo^)); + + W:=0; + if Assigned(References) then W:=W or 1; + if Assigned(Items) then W:=W or 2; + S.Write(W,SizeOf(W)); + if Assigned(References) then References^.Store(S); + if Assigned(Items) then Items^.Store(S); + + { --- items needing fixup --- } + S.Write(DType, SizeOf(DType)); + S.Write(VType, SizeOf(VType)); + {S.Write(Ancestor, SizeOf(Ancestor));} +end; + +constructor TExport.Init(const AName: string; AIndex: longint; ASymbol: PSymbol); +begin + inherited Init; + Name:=NewStr(AName); Index:=AIndex; + Symbol:=ASymbol; +end; + +function TExport.GetDisplayText: string; +var S: string; +begin + S:=GetStr(Name)+' '+IntToStr(Index); + if Assigned(Symbol) and (UpcaseStr(Symbol^.GetName)<>UpcaseStr(GetStr(Name))) then + S:=S+' ('+Symbol^.GetName+')'; + GetDisplayText:=S; +end; + +destructor TExport.Done; +begin + if Assigned(Name) then DisposeStr(Name); + inherited Done; +end; + +constructor TImport.Init(const ALibName, AFuncName,ARealName: string; AIndex: longint); +begin + inherited Init; + LibName:=NewStr(ALibName); + FuncName:=NewStr(AFuncName); RealName:=NewStr(ARealName); + Index:=AIndex; +end; + +function TImport.GetDisplayText: string; +var S: string; +begin + S:=GetStr(RealName); + if Assigned(FuncName) then S:=GetStr(FuncName)+' ('+S+')'; + if S='' then S:=IntToStr(Index); + S:=GetStr(LibName)+' '+S; + GetDisplayText:=S; +end; + +destructor TImport.Done; +begin + if Assigned(LibName) then DisposeStr(LibName); + if Assigned(FuncName) then DisposeStr(FuncName); + if Assigned(RealName) then DisposeStr(RealName); + inherited Done; +end; + +function TImportCollection.At(Index: sw_Integer): PImport; +begin + At:=inherited At(Index); +end; + +function TImportCollection.Compare(Key1, Key2: Pointer): sw_Integer; +var K1: PImport absolute Key1; + K2: PImport absolute Key2; + S1: string; + S2: string; + R: sw_integer; +begin + if (K1^.RealName=nil) and (K2^.RealName<>nil) then R:= 1 else + if (K1^.RealName<>nil) and (K2^.RealName=nil) then R:=-1 else + if (K1^.RealName=nil) and (K2^.RealName=nil) then + begin + if K1^.IndexK2^.Index then R:= 1 else + R:=0; + end + else + begin + if K1^.FuncName=nil then S1:=GetStr(K1^.RealName) else S1:=GetStr(K1^.FuncName); + if K2^.FuncName=nil then S2:=GetStr(K2^.RealName) else S2:=GetStr(K2^.FuncName); + S1:=UpcaseStr(S1); S2:=UpcaseStr(S2); + if S1S2 then R:= 1 else + R:=0; + end; + Compare:=R; +end; + +function TExportCollection.At(Index: sw_Integer): PExport; +begin + At:=inherited At(Index); +end; + +function TExportCollection.Compare(Key1, Key2: Pointer): sw_Integer; +var K1: PExport absolute Key1; + K2: PExport absolute Key2; + S1: string; + S2: string; + R: sw_integer; +begin + S1:=UpcaseStr(GetStr(K1^.Name)); S2:=UpcaseStr(GetStr(K2^.Name)); + if S1S2 then R:= 1 else + R:=0; + Compare:=R; +end; + +constructor TModuleSymbol.Init(const AName, AMainSource: string); +begin + inherited Init(AName,unitsym,'',nil); + MainSource:=NewStr(AMainSource); +end; + +procedure TModuleSymbol.SetLoadedFrom(const AModuleName: string); +begin + SetStr(LoadedFrom,AModuleName); +end; + +procedure TModuleSymbol.AddUsedUnit(P: PSymbol); +begin + if Assigned(UsedUnits)=false then + New(UsedUnits, Init(10,10)); + UsedUnits^.Insert(P); +end; + +procedure TModuleSymbol.AddDependentUnit(P: PSymbol); +begin + if Assigned(DependentUnits)=false then + New(DependentUnits, Init(10,10)); + DependentUnits^.Insert(P); +end; + +procedure TModuleSymbol.AddSourceFile(const Path: string); +begin + if Assigned(SourceFiles)=false then + New(SourceFiles, Init(10,10)); + SourceFiles^.Insert(NewStr(Path)); +end; + +destructor TModuleSymbol.Done; +begin + inherited Done; + if Assigned(MainSource) then DisposeStr(MainSource); + if assigned(Exports_) then + Dispose(Exports_, Done); + if Assigned(Imports) then + Dispose(Imports, Done); + if Assigned(LoadedFrom) then + DisposeStr(LoadedFrom); + if Assigned(UsedUnits) then + begin + UsedUnits^.DeleteAll; + Dispose(UsedUnits, Done); + end; + if Assigned(DependentUnits) then + begin + DependentUnits^.DeleteAll; + Dispose(DependentUnits, Done); + end; + if Assigned(SourceFiles) then Dispose(SourceFiles, Done); +end; + + +constructor TObjectSymbol.Init(AParent: PObjectSymbol; ASymbol: PSymbol); +begin + inherited Init; + Parent:=AParent; + Symbol:=ASymbol; +end; + +constructor TObjectSymbol.InitName(const AName: string); +begin + inherited Init; + Name:=NewStr(AName); +end; + +function TObjectSymbol.GetName: string; +begin + if Name<>nil then + GetName:=Name^ + else + GetName:=Symbol^.GetName; +end; + +function TObjectSymbol.GetDescendantCount: sw_integer; +var Count: sw_integer; +begin + if Descendants=nil then Count:=0 else + Count:=Descendants^.Count; + GetDescendantCount:=Count; +end; + +function TObjectSymbol.GetDescendant(Index: sw_integer): PObjectSymbol; +begin + GetDescendant:=Descendants^.At(Index); +end; + +procedure TObjectSymbol.AddDescendant(P: PObjectSymbol); +begin + if Descendants=nil then + New(Descendants, Init(50,10)); + Descendants^.Insert(P); +end; + +destructor TObjectSymbol.Done; +begin + if Assigned(Name) then DisposeStr(Name); Name:=nil; + if Assigned(Descendants) then Dispose(Descendants, Done); Descendants:=nil; + inherited Done; +end; + +constructor TObjectSymbol.Load(var S: TStream); +begin +end; + +procedure TObjectSymbol.Store(S: TStream); +begin +end; + +{**************************************************************************** + TSourceFile +****************************************************************************} + +constructor TSourceFile.Init(ASourceFileName, AObjFileName, APPUFileName: string); +begin + inherited Init; + SourceFileName:=NewStr(ASourceFileName); + ObjFileName:=NewStr(AObjFileName); + PPUFileName:=NewStr(APPUFileName); +end; + +destructor TSourceFile.Done; +begin + inherited Done; + if assigned(SourceFileName) then DisposeStr(SourceFileName); + if assigned(ObjFileName) then DisposeStr(ObjFileName); + if assigned(PPUFileName) then DisposeStr(PPUFileName); +end; + +function TSourceFile.GetSourceFilename: string; +begin + GetSourceFilename:=GetStr(SourceFileName); +end; + +function TSourceFile.GetObjFileName: string; +begin + GetObjFilename:=GetStr(ObjFileName); +end; + +function TSourceFile.GetPPUFileName: string; +begin + GetPPUFilename:=GetStr(PPUFileName); +end; + +function TSourceFileCollection.At(Index: sw_Integer): PSourceFile; +begin + At:=inherited At(Index); +end; + +{***************************************************************************** + Main Routines +*****************************************************************************} + +procedure DisposeBrowserCol; +begin + if assigned(Modules) then + begin + dispose(Modules,Done); + Modules:=nil; + end; + if assigned(ModuleNames) then + begin + dispose(ModuleNames,Done); + ModuleNames:=nil; + end; + if assigned(TypeNames) then + begin + dispose(TypeNames,Done); + TypeNames:=nil; + end; + if assigned(ObjectTree) then + begin + Dispose(ObjectTree, Done); + ObjectTree:=nil; + end; +end; + + +procedure NewBrowserCol; +begin + New(Modules, Init(50,50)); + New(ModuleNames, Init(50,50)); + New(TypeNames, Init(1000,5000)); +end; + + + procedure ProcessSymTable(OwnerSym: PSymbol; var Owner: PSymbolCollection; Table: PSymTable); + var I,J,defcount,symcount: longint; + Ref: PRef; + Sym,ParSym: PSym; + Symbol: PSymbol; + Reference: PReference; + ParamCount: Sw_integer; + Params: array[0..20] of PString; + inputfile : pinputfile; + Idx: sw_integer; + S: string; + procedure SetVType(Symbol: PSymbol; VType: string); + begin + Symbol^.VType:=TypeNames^.Add(VType); + end; + procedure SetDType(Symbol: PSymbol; DType: string); + begin + Symbol^.DType:=TypeNames^.Add(DType); + end; + function GetDefinitionStr(def: pdef): string; forward; + function GetEnumDefStr(def: penumdef): string; + var Name: string; + esym: penumsym; + Count: integer; + begin + Name:='('; + esym:=def^.Firstenum; Count:=0; + while (esym<>nil) do + begin + if Count>0 then + Name:=Name+', '; + Name:=Name+esym^.name; + esym:=esym^.nextenum; + Inc(Count); + end; + Name:=Name+')'; + GetEnumDefStr:=Name; + end; + function GetArrayDefStr(def: parraydef): string; + var Name: string; + begin + Name:='array ['+IntToStr(def^.lowrange)+'..'+IntToStr(def^.highrange)+'] of '; + if assigned(def^.elementtype.def) then + Name:=Name+GetDefinitionStr(def^.elementtype.def); + GetArrayDefStr:=Name; + end; + function GetFileDefStr(def: pfiledef): string; + var Name: string; + begin + Name:=''; + case def^.filetyp of + ft_text : Name:='text'; + ft_untyped : Name:='file'; + ft_typed : Name:='file of '+GetDefinitionStr(def^.typedfiletype.def); + end; + GetFileDefStr:=Name; + end; + function GetStringDefStr(def: pstringdef): string; + var Name: string; + begin + Name:=''; + case def^.string_typ of + st_shortstring : + if def^.len=255 then + Name:='shortstring' + else + Name:='string['+IntToStr(def^.len)+']'; + st_longstring : + Name:='longstring'; + st_ansistring : + Name:='ansistring'; + st_widestring : + Name:='widestring'; + else ; + end; + GetStringDefStr:=Name; + end; + function retdefassigned(def: pabstractprocdef): boolean; + var OK: boolean; + begin + OK:=false; + if assigned(def^.rettype.def) then + if UpcaseStr(GetDefinitionStr(def^.rettype.def))<>'VOID' then + OK:=true; + retdefassigned:=OK; + end; + function GetAbsProcParmDefStr(def: pabstractprocdef): string; + var Name: string; + dc: pparaitem; + Count: integer; + CurName: string; + begin + Name:=''; + dc:=pparaitem(def^.para^.first); + Count:=0; + while assigned(dc) do + begin + CurName:=''; + case dc^.paratyp of + vs_Value : ; + vs_Const : CurName:=CurName+'const '; + vs_Var : CurName:=CurName+'var '; + end; + if assigned(dc^.paratype.def) then + CurName:=CurName+GetDefinitionStr(dc^.paratype.def); + if dc^.next<>nil then + CurName:=', '+CurName; + Name:=CurName+Name; + dc:=pparaitem(dc^.next); + Inc(Count); + end; + GetAbsProcParmDefStr:=Name; + end; + function GetAbsProcDefStr(def: pabstractprocdef): string; + var Name: string; + begin + Name:=GetAbsProcParmDefStr(def); + if Name<>'' then Name:='('+Name+')'; + if retdefassigned(def) then + Name:='function'+Name+': '+GetDefinitionStr(def^.rettype.def) + else + Name:='procedure'+Name; + GetAbsProcDefStr:=Name; + end; + function GetProcDefStr(def: pprocdef): string; + var DName: string; + J: integer; + begin +{ DName:=''; + if assigned(def) then + begin + if assigned(def^.parast) then + begin + with def^.parast^ do + for J:=1 to number_symbols do + begin + if J<>1 then DName:=DName+', '; + ParSym:=GetsymNr(J); + if ParSym=nil then Break; + DName:=DName+ParSym^.Name; + end; + end + end;} + DName:=GetAbsProcDefStr(def); + GetProcDefStr:=DName; + end; + function GetProcVarDefStr(def: pprocvardef): string; + begin + GetProcVarDefStr:=GetAbsProcDefStr(def); + end; + function GetSetDefStr(def: psetdef): string; + var Name: string; + begin + Name:=''; + case def^.settype of + normset : Name:='set'; + smallset : Name:='set'; + varset : Name:='varset'; + end; + Name:=Name+' of '; + Name:=Name+GetDefinitionStr(def^.elementtype.def); + GetSetDefStr:=Name; + end; + function GetPointerDefStr(def: ppointerdef): string; + begin + GetPointerDefStr:='^'+GetDefinitionStr(def^.pointertype.def); + end; + function GetDefinitionStr(def: pdef): string; + var Name: string; + sym: psym; + begin + Name:=''; + if def<>nil then + begin + if assigned(def^.typesym) then + Name:=def^.typesym^.name; + if Name='' then + case def^.deftype of + arraydef : + Name:=GetArrayDefStr(parraydef(def)); + stringdef : + Name:=GetStringDefStr(pstringdef(def)); + enumdef : + Name:=GetEnumDefStr(penumdef(def)); + procdef : + Name:=GetProcDefStr(pprocdef(def)); + procvardef : + Name:=GetProcVarDefStr(pprocvardef(def)); + filedef : + Name:=GetFileDefStr(pfiledef(def)); + setdef : + Name:=GetSetDefStr(psetdef(def)); + end; + end; + GetDefinitionStr:=Name; + end; + function GetEnumItemName(Sym: penumsym): string; + var Name: string; + ES: penumsym; + begin + Name:=''; + if assigned(sym) and assigned(sym^.definition) then + if assigned(sym^.definition^.typesym) then + begin +{ ES:=sym^.definition^.First; + while (ES<>nil) and (ES^.Value<>sym^.Value) do + ES:=ES^.next; + if assigned(es) and (es^.value=sym^.value) then + Name:=} + Name:=sym^.definition^.typesym^.name; + if Name<>'' then + Name:=Name+'('+IntToStr(sym^.value)+')'; + end; + GetEnumItemName:=Name; + end; + function GetConstValueName(sym: pconstsym): string; + var Name: string; + begin + Name:=''; +{ if assigned(sym^.definition) then + if assigned(sym^.definition^.sym) then + Name:=sym^.definition^.sym^.name;} + if Name='' then + case sym^.consttyp of + constord : + Name:=sym^.consttype.def^.typesym^.name+'('+IntToStr(sym^.value)+')'; + constresourcestring, + conststring : +{ Name:=''''+GetStr(PString(sym^.Value))+'''';} + Name:=''''+StrPas(pointer(sym^.Value))+''''; + constreal: + Name:=FloatToStr(PBestReal(sym^.Value)^); + constbool: +{ if boolean(sym^.Value)=true then + Name:='TRUE' + else + Name:='FALSE';} + Name:='Longbool('+IntToStr(sym^.Value)+')'; + constint: + Name:=IntToStr(sym^.value); + constchar: + Name:=''''+chr(sym^.Value)+''''; + constset: +{ Name:=SetToStr(pnormalset(sym^.Value))}; + constnil: ; + end; + GetConstValueName:=Name; + end; + procedure ProcessDefIfStruct(definition: pdef); + begin + { still led to infinite recursions + only usefull for unamed types PM } + if assigned(definition) and not assigned(definition^.typesym) then + begin + case definition^.deftype of + recorddef : + if precorddef(definition)^.symtable<>Table then + ProcessSymTable(Symbol,Symbol^.Items,precorddef(definition)^.symtable); + objectdef : + if pobjectdef(definition)^.symtable<>Table then + ProcessSymTable(Symbol,Symbol^.Items,pobjectdef(definition)^.symtable); + { leads to infinite loops !! + pointerdef : + with ppointerdef(definition)^ do + if assigned(definition) then + if assigned(definition^.sym) then + ProcessDefIfStruct(definition^.sym^.definition);} + end; + end; + end; + var MemInfo: TSymbolMemInfo; + ObjDef: pobjectdef; + begin + if not Assigned(Table) then + Exit; + if Owner=nil then + Owner:=New(PSortedSymbolCollection, Init(10,50)); + sym:=psym(Table^.symindex^.first); + while assigned(sym) do + begin + ParamCount:=0; + New(Symbol, Init(Sym^.Name,Sym^.Typ,'',nil)); + case Sym^.Typ of + varsym : + with pvarsym(sym)^ do + begin + if assigned(vartype.def) then + if assigned(vartype.def^.typesym) then + SetVType(Symbol,vartype.def^.typesym^.name) + else + SetVType(Symbol,GetDefinitionStr(vartype.def)); + ProcessDefIfStruct(vartype.def); + if assigned(vartype.def) then + if (vartype.def^.deftype=pointerdef) and + assigned(ppointerdef(vartype.def)^.pointertype.def) then + begin + Symbol^.Flags:=(Symbol^.Flags or sfPointer); + Symbol^.RelatedTypeID:=longint(ppointerdef(vartype.def)^.pointertype.def); + end; + MemInfo.Addr:=address; + if assigned(localvarsym) then + MemInfo.LocalAddr:=localvarsym^.address + else + MemInfo.LocalAddr:=0; + if assigned(vartype.def) and (vartype.def^.deftype=arraydef) then + begin + if parraydef(vartype.def)^.highrangestaticsymtable) then + ProcessSymTable(Symbol,Symbol^.Items,definition^.localst); + end; + end; + end; + typesym : + begin + with ptypesym(sym)^ do + if assigned(restype.def) then + begin + Symbol^.TypeID:=longint(restype.def); + case restype.def^.deftype of + arraydef : + SetDType(Symbol,GetArrayDefStr(parraydef(restype.def))); + enumdef : + SetDType(Symbol,GetEnumDefStr(penumdef(restype.def))); + procdef : + SetDType(Symbol,GetProcDefStr(pprocdef(restype.def))); + procvardef : + SetDType(Symbol,GetProcVarDefStr(pprocvardef(restype.def))); + objectdef : + with pobjectdef(restype.def)^ do + begin + ObjDef:=childof; + if ObjDef<>nil then + Symbol^.RelatedTypeID:=longint(ObjDef);{TypeNames^.Add(S);} + Symbol^.Flags:=(Symbol^.Flags or sfObject); + if is_class then + Symbol^.Flags:=(Symbol^.Flags or sfClass); + ProcessSymTable(Symbol,Symbol^.Items,pobjectdef(restype.def)^.symtable); + end; + recorddef : + begin + Symbol^.Flags:=(Symbol^.Flags or sfRecord); + ProcessSymTable(Symbol,Symbol^.Items,precorddef(restype.def)^.symtable); + end; + pointerdef : + begin + Symbol^.Flags:=(Symbol^.Flags or sfPointer); + Symbol^.RelatedTypeID:=longint(ppointerdef(restype.def)^.pointertype.def);{TypeNames^.Add(S);} + SetDType(Symbol,GetPointerDefStr(ppointerdef(restype.def))); + end; + + filedef : + SetDType(Symbol,GetFileDefStr(pfiledef(restype.def))); + setdef : + SetDType(Symbol,GetSetDefStr(psetdef(restype.def))); + end; + end; + end; + end; + Ref:=Sym^.defref; + while Assigned(Symbol) and assigned(Ref) do + begin + inputfile:=get_source_file(ref^.moduleindex,ref^.posinfo.fileindex); + if Assigned(inputfile) and Assigned(inputfile^.name) then + begin + New(Reference, Init(ModuleNames^.Add(inputfile^.name^), + ref^.posinfo.line,ref^.posinfo.column)); + Symbol^.References^.Insert(Reference); + end; + Ref:=Ref^.nextref; + end; + if Assigned(Symbol) then + Owner^.Insert(Symbol); + sym:=psym(sym^.next); + end; + end; + +function SearchModule(const Name: string): PModuleSymbol; +function Match(P: PModuleSymbol): boolean; {$ifndef FPC}far;{$endif} +begin + Match:=CompareText(P^.GetName,Name)=0; +end; +var P: PModuleSymbol; +begin + P:=nil; + if Assigned(Modules) then + P:=Modules^.FirstThat(@Match); + SearchModule:=P; +end; + +procedure CreateBrowserCol; +var + T: PSymTable; + UnitS,PM: PModuleSymbol; + hp : pmodule; + puu: pused_unit; + pdu: pdependent_unit; + pif: pinputfile; +begin + DisposeBrowserCol; + if (cs_browser in aktmoduleswitches) then + NewBrowserCol; + hp:=pmodule(loaded_units.first); + if (cs_browser in aktmoduleswitches) then + while assigned(hp) do + begin + t:=psymtable(hp^.globalsymtable); + if assigned(t) then + begin + New(UnitS, Init(T^.Name^,hp^.mainsource^)); + if Assigned(hp^.loaded_from) then + if assigned(hp^.loaded_from^.globalsymtable) then + UnitS^.SetLoadedFrom(psymtable(hp^.loaded_from^.globalsymtable)^.name^); +{ pimportlist(current_module^.imports^.first);} + + if assigned(hp^.sourcefiles) then + begin + pif:=hp^.sourcefiles^.files; + while (pif<>nil) do + begin + UnitS^.AddSourceFile(pif^.path^+pif^.name^); + pif:=pif^.next; + end; + end; + + Modules^.Insert(UnitS); + ProcessSymTable(UnitS,UnitS^.Items,T); + if cs_local_browser in aktmoduleswitches then + begin + t:=psymtable(hp^.localsymtable); + if assigned(t) then + ProcessSymTable(UnitS,UnitS^.Items,T); + end; + end; + hp:=pmodule(hp^.next); + end; + + hp:=pmodule(loaded_units.first); + if (cs_browser in aktmoduleswitches) then + while assigned(hp) do + begin + t:=psymtable(hp^.globalsymtable); + if assigned(t) then + begin + UnitS:=SearchModule(T^.Name^); + puu:=pused_unit(hp^.used_units.first); + while (puu<>nil) do + begin + PM:=SearchModule(puu^.name^); + if Assigned(PM) then + UnitS^.AddUsedUnit(PM); + puu:=pused_unit(puu^.next); + end; + pdu:=pdependent_unit(hp^.dependent_units.first); + while (pdu<>nil) do + begin + PM:=SearchModule(psymtable(pdu^.u^.globalsymtable)^.name^); + if Assigned(PM) then + UnitS^.AddDependentUnit(PM); + pdu:=pdependent_unit(pdu^.next); + end; + end; + hp:=pmodule(hp^.next); + end; + + if (cs_browser in aktmoduleswitches) then + BuildObjectInfo; + { can allways be done + needed to know when recompilation of sources is necessary } + BuildSourceList; +end; + +procedure BuildObjectInfo; +var C,D: PIDSortedSymbolCollection; + E : PCollection; + ObjectC: PObjectSymbolCollection; + ObjectsSymbol: PObjectSymbol; +procedure InsertSymbolCollection(Symbols: PSymbolCollection); +var I: sw_integer; + P: PSymbol; +begin + for I:=0 to Symbols^.Count-1 do + begin + P:=Symbols^.At(I); + if (P^.Flags and sfObject)<>0 then + C^.Insert(P); + if (P^.typ=typesym) then + D^.Insert(P); + if (P^.typ=varsym) and ((P^.flags and sfPointer)<>0) then + E^.Insert(P); + if P^.Items<>nil then + InsertSymbolCollection(P^.Items); + end; +end; +function SearchObjectForSym(O: PSymbol): PObjectSymbol; +var I,Idx: sw_integer; + OS,P: PObjectSymbol; +begin + P:=nil; + for I:=0 to ObjectC^.Count-1 do + begin + OS:=ObjectC^.At(I); + if OS^.Symbol=O then + begin P:=OS; Break; end; + end; + SearchObjectForSym:=P; +end; +procedure BuildTree; +var I: sw_integer; + Symbol: PSymbol; + Parent,OS: PObjectSymbol; +begin + I:=0; + while (Inil then + begin + New(OS, Init(Parent, Symbol)); + Parent^.AddDescendant(OS); + ObjectC^.Insert(OS); + C^.AtDelete(I); + end + else + Inc(I); + end; +end; +var Pass: integer; + I: sw_integer; + P: PSymbol; +begin + New(C, Init(1000,5000)); + New(D, Init(1000,5000)); + New(E, Init(1000,5000)); + InsertSymbolCollection(Modules); + + { --- Resolve ancestor<->descendant references --- } + for I:=0 to C^.Count-1 do + begin + P:=C^.At(I); + if P^.RelatedTypeID<>0 then + P^.Ancestor:=C^.SearchSymbolByID(P^.RelatedTypeID); + end; + + { --- Resolve pointer definition references --- } + for I:=0 to D^.Count-1 do + begin + P:=D^.At(I); + if P^.RelatedTypeID<>0 then + P^.Ancestor:=D^.SearchSymbolByID(P^.RelatedTypeID); + end; + + { --- Resolve pointer var definition references --- } + for I:=0 to E^.Count-1 do + begin + P:=PSymbol(E^.At(I)); + if P^.RelatedTypeID<>0 then + P^.Ancestor:=D^.SearchSymbolByID(P^.RelatedTypeID); + end; + + { E is not needed anymore } + E^.DeleteAll; + Dispose(E,Done); + + { D is not needed anymore } + D^.DeleteAll; + Dispose(D,Done); + + { --- Build object tree --- } + if assigned(ObjectTree) then Dispose(ObjectTree, Done); + New(ObjectsSymbol, InitName('Objects')); + ObjectTree:=ObjectsSymbol; + + New(ObjectC, Init(C^.Count,100)); + + Pass:=0; + if C^.Count>0 then + repeat + BuildTree; + Inc(Pass); + until (C^.Count=0) or (Pass>20); { more than 20 levels ? - then there must be a bug } + + ObjectC^.DeleteAll; Dispose(ObjectC, Done); + C^.DeleteAll; Dispose(C, Done); +end; + +function SearchObjectForSymbol(O: PSymbol): PObjectSymbol; +function ScanObjectCollection(Parent: PObjectSymbol): PObjectSymbol; +var I: sw_integer; + OS,P: PObjectSymbol; + ObjectC: PObjectSymbolCollection; +begin + P:=nil; + if Parent<>nil then + if Parent^.Descendants<>nil then + begin + ObjectC:=Parent^.Descendants; + for I:=0 to ObjectC^.Count-1 do + begin + OS:=ObjectC^.At(I); + if OS^.Symbol=O then + begin P:=OS; Break; end; + if OS^.Descendants<>nil then + begin + P:=ScanObjectCollection(OS); + if P<>nil then Break; + end; + end; + end; + ScanObjectCollection:=P; +end; +begin + SearchObjectForSymbol:=ScanObjectCollection(ObjectTree); +end; + +procedure BuildSourceList; +var m: pmodule; + s: pinputfile; + p: cobjects.pstring; + ppu,obj: string; + source: string; +begin + if Assigned(SourceFiles) then + begin Dispose(SourceFiles, Done); SourceFiles:=nil; end; + if assigned(loaded_units.first) then + begin + New(SourceFiles, Init(50,10)); + m:=pmodule(loaded_units.first); + while assigned(m) do + begin + obj:=fexpand(m^.objfilename^); + ppu:=''; source:=''; + if m^.is_unit then + ppu:=fexpand(m^.ppufilename^); + if (m^.is_unit=false) and (m^.islibrary=false) then + ppu:=fexpand(m^.exefilename^); + if assigned(m^.sourcefiles) then + begin + s:=m^.sourcefiles^.files; + while assigned(s) do + begin + source:=''; + p:=s^.path; + if assigned(p) then + source:=source+p^; + p:=s^.name; + if assigned(p) then + source:=source+p^; + source:=fexpand(source); + + SourceFiles^.Insert(New(PSourceFile, Init(source,obj,ppu))); + s:=s^.next; + end; + end; + m:=pmodule(m^.next); + end; + end; +end; + +{***************************************************************************** + Initialize +*****************************************************************************} + + + +var + oldexit : pointer; + +procedure browcol_exit;{$ifndef FPC}far;{$endif} +begin + exitproc:=oldexit; + DisposeBrowserCol; +end; + + +procedure InitBrowserCol; +begin +end; + + +procedure DoneBrowserCol; +begin + { nothing, the collections are freed in the exitproc - ??? } + { nothing? then why do we've this routine for ? IMHO, either we should + remove this, or it should destroy the browser info when it's called. - BG } +end; + +type + PPointerXRef = ^TPointerXRef; + TPointerXRef = record + PtrValue : pointer; + DataPtr : pointer; + end; + + PPointerDictionary = ^TPointerDictionary; + TPointerDictionary = object(TSortedCollection) + function At(Index: sw_Integer): PPointerXRef; + function Compare(Key1, Key2: Pointer): sw_Integer; virtual; + procedure FreeItem(Item: Pointer); virtual; + function SearchXRef(PtrValue: pointer): PPointerXRef; + function AddPtr(PtrValue, DataPtr: pointer): PPointerXRef; + procedure Resolve(var P); + end; + +function NewPointerXRef(APtrValue, ADataPtr: pointer): PPointerXRef; +var P: PPointerXRef; +begin + New(P); FillChar(P^,SizeOf(P^),0); + with P^ do begin PtrValue:=APtrValue; DataPtr:=ADataPtr; end; + NewPointerXRef:=P; +end; + +procedure DisposePointerXRef(P: PPointerXRef); +begin + if Assigned(P) then Dispose(P); +end; + +function TPointerDictionary.At(Index: sw_Integer): PPointerXRef; +begin + At:=inherited At(Index); +end; + +function TPointerDictionary.Compare(Key1, Key2: Pointer): sw_Integer; +var K1: PPointerXRef absolute Key1; + K2: PPointerXRef absolute Key2; + R: integer; +begin + if longint(K1^.PtrValue)longint(K2^.PtrValue) then R:= 1 else + R:=0; + Compare:=R; +end; + +procedure TPointerDictionary.FreeItem(Item: Pointer); +begin + if Assigned(Item) then DisposePointerXRef(Item); +end; + +function TPointerDictionary.SearchXRef(PtrValue: pointer): PPointerXRef; +var P: PPointerXRef; + T: TPointerXRef; + Index: sw_integer; +begin + T.PtrValue:=PtrValue; + if Search(@T,Index)=false then P:=nil else + P:=At(Index); + SearchXRef:=P; +end; + +function TPointerDictionary.AddPtr(PtrValue, DataPtr: pointer): PPointerXRef; +var P: PPointerXRef; +begin + P:=NewPointerXRef(PtrValue,DataPtr); + Insert(P); + AddPtr:=P; +end; + +procedure TPointerDictionary.Resolve(var P); +var X: PPointerXRef; + V: pointer; +begin + Move(P,V,SizeOf(V)); + X:=SearchXRef(V); + if X=nil then V:=nil else + V:=X^.DataPtr; + Move(V,P,SizeOf(V)); +end; + +procedure ReadPointers(S: PStream; C: PCollection; D: PPointerDictionary); +var W,I: sw_integer; + P: pointer; +begin + S^.Read(W,SizeOf(W)); + for I:=0 to W-1 do + begin + S^.Read(P,SizeOf(P)); + D^.AddPtr(P,C^.At(I)); + end; +end; + +function LoadBrowserCol(S: PStream): boolean; +var PD: PPointerDictionary; +procedure FixupPointers; +procedure FixupReference(P: PReference); {$ifndef FPC}far;{$endif} +begin + PD^.Resolve(P^.FileName); +end; +procedure FixupSymbol(P: PSymbol); {$ifndef FPC}far;{$endif} +var I: sw_integer; +begin + PD^.Resolve(P^.DType); + PD^.Resolve(P^.VType); + {PD^.Resolve(P^.Ancestor);} + if Assigned(P^.References) then + with P^.References^ do + for I:=0 to Count-1 do + FixupReference(At(I)); + if Assigned(P^.Items) then + with P^.Items^ do + for I:=0 to Count-1 do + FixupSymbol(At(I)); +end; +begin + Modules^.ForEach(@FixupSymbol); +end; +procedure ReadSymbolPointers(P: PSymbol); {$ifndef FPC}far;{$endif} +var I: sw_integer; + PV: pointer; +begin + S^.Read(PV, SizeOf(PV)); + PD^.AddPtr(PV,P); + if Assigned(P^.Items) then + with P^.Items^ do + for I:=0 to Count-1 do + ReadSymbolPointers(At(I)); +end; +begin + DisposeBrowserCol; + + New(ModuleNames, Load(S^)); + New(TypeNames, Load(S^)); + New(Modules, Load(S^)); + + New(PD, Init(4000,1000)); + ReadPointers(S,ModuleNames,PD); + ReadPointers(S,TypeNames,PD); + ReadPointers(S,Modules,PD); + Modules^.ForEach(@ReadSymbolPointers); + FixupPointers; + Dispose(PD, Done); + + BuildObjectInfo; + LoadBrowserCol:=(S^.Status=stOK); +end; + +procedure StorePointers(S: PStream; C: PCollection); +var W,I: sw_integer; + P: pointer; +begin + W:=C^.Count; + S^.Write(W,SizeOf(W)); + for I:=0 to W-1 do + begin + P:=C^.At(I); + S^.Write(P,SizeOf(P)); + end; +end; + +function StoreBrowserCol(S: PStream) : boolean; +procedure WriteSymbolPointers(P: PSymbol); {$ifndef FPC}far;{$endif} +var I: sw_integer; +begin + S^.Write(P, SizeOf(P)); + if Assigned(P^.Items) then + with P^.Items^ do + for I:=0 to Count-1 do + WriteSymbolPointers(At(I)); +end; +var W: sw_integer; +begin + ModuleNames^.Store(S^); + TypeNames^.Store(S^); + Modules^.Store(S^); + + StorePointers(S,ModuleNames); + StorePointers(S,TypeNames); + StorePointers(S,Modules); + Modules^.ForEach(@WriteSymbolPointers); + StoreBrowserCol:=(S^.Status=stOK); +end; + +procedure RegisterSymbols; +begin + RegisterType(RModuleNameCollection); + RegisterType(RTypeNameCollection); + RegisterType(RReference); + RegisterType(RSymbol); + RegisterType(RObjectSymbol); + RegisterType(RSymbolCollection); + RegisterType(RSortedSymbolCollection); + RegisterType(RIDSortedSymbolCollection); + RegisterType(RObjectSymbolCollection); + RegisterType(RReferenceCollection); + RegisterType(RModuleSymbol); +end; + +begin + oldexit:=exitproc; + exitproc:=@browcol_exit; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/07/05 21:20:48 pierre + + Register TModuleSymbol + + Revision 1.42 2000/07/05 10:17:38 pierre + * avoid internalerror on open arrays + + Revision 1.41 2000/06/19 19:56:43 pierre + * small error fix + + Revision 1.40 2000/06/16 06:08:44 pierre + *Gabor's changes + + Revision 1.39 2000/05/29 10:04:40 pierre + * New bunch of Gabor changes + + Revision 1.38 2000/04/20 08:52:01 pierre + * allow to view objects having the same name + + Revision 1.37 2000/03/14 15:04:19 pierre + * DebuggerValue moved to fpsymbol unit + + Revision 1.36 2000/03/13 20:28:12 pierre + * X was not found in TSortedSymbolCollection.LookUp + + Revision 1.35 2000/03/08 12:25:29 pierre + * more fixes for TSymbol + + Revision 1.34 2000/03/07 21:55:59 pierre + * Tsymbol and Ancestor fixes + + Revision 1.33 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.32 2000/01/20 00:24:06 pierre + * StoreBrowserCol changed to boolean function + + Revision 1.31 2000/01/07 01:14:19 peter + * updated copyright to 2000 + + Revision 1.30 1999/12/01 11:11:19 pierre + * don't redefine sw_integer for FPC : corrected version + + Revision 1.29 1999/12/01 11:05:47 pierre + * don't redefine sw_integer for FPC + + Revision 1.28 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.27 1999/11/10 00:42:42 pierre + * LookUp function now returns the complete name in browcol + and fpsymbol only yakes a part of LoopUpStr + + Revision 1.26 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.25 1999/10/26 12:30:40 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.24 1999/09/16 07:54:48 pierre + * BuildSourceList allways called for dependency in FP + + Revision 1.23 1999/09/07 15:07:49 pierre + * avoid some infinite recursions + + Revision 1.22 1999/08/16 18:25:49 peter + * fixes from gabor + + Revision 1.21 1999/08/09 14:09:04 peter + * updated for symtable updates + + Revision 1.20 1999/08/03 22:02:29 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/browlog.pas b/befpc/compiler/browlog.pas new file mode 100644 index 0000000..1f3d851 --- /dev/null +++ b/befpc/compiler/browlog.pas @@ -0,0 +1,468 @@ +{ + $Id: browlog.pas,v 1.1.1.1 2001-07-23 17:15:29 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl and Pierre Muller + + Support routines for creating the browser log + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit browlog; + +interface +uses + cobjects,globtype,files,symconst,symtable; + +const +{$ifdef TP} + logbufsize = 1024; +{$else} + logbufsize = 16384; +{$endif} + +type + pbrowserlog=^tbrowserlog; + tbrowserlog=object + fname : string; + logopen : boolean; + stderrlog : boolean; + f : file; + elements_to_list : pstringqueue; + buf : pchar; + bufidx : longint; + identidx : longint; + constructor init; + destructor done; + procedure setfilename(const fn:string); + procedure createlog; + procedure flushlog; + procedure addlog(const s:string); + procedure addlogrefs(p:pref); + procedure closelog; + procedure ident; + procedure unident; + procedure browse_symbol(const sr : string); + procedure list_elements; + procedure list_debug_infos; + end; + +var + browserlog : tbrowserlog; + + procedure WriteBrowserLog; + + procedure InitBrowserLog; + procedure DoneBrowserLog; + + +implementation + + uses + comphook,globals,systems,verbose; + + function get_file_line(ref:pref): string; + var + inputfile : pinputfile; + begin + get_file_line:=''; + with ref^ do + begin + inputfile:=get_source_file(moduleindex,posinfo.fileindex); + if assigned(inputfile) then + if status.use_gccoutput then + { for use with rhide + add warning so that it does not interpret + this as an error !! } + get_file_line:=lower(inputfile^.name^) + +':'+tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':' + else + get_file_line:=inputfile^.name^ + +'('+tostr(posinfo.line)+','+tostr(posinfo.column)+')' + else + if status.use_gccoutput then + get_file_line:='file_unknown:' + +tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':' + else + get_file_line:='file_unknown(' + +tostr(posinfo.line)+','+tostr(posinfo.column)+')' + end; + end; + +{**************************************************************************** + TBrowser +****************************************************************************} + + constructor tbrowserlog.init; + begin + fname:=FixFileName('browser.log'); + logopen:=false; + elements_to_list:=new(pstringqueue,init); + end; + + + destructor tbrowserlog.done; + begin + if logopen then + closelog; + dispose(elements_to_list,done); + end; + + + procedure tbrowserlog.setfilename(const fn:string); + begin + fname:=FixFileName(fn); + end; + + + procedure tbrowserlog.createlog; + begin + if logopen then + closelog; + assign(f,fname); + {$I-} + rewrite(f,1); + {$I+} + if ioresult<>0 then + exit; + logopen:=true; + getmem(buf,logbufsize); + bufidx:=0; + identidx:=0; + end; + + + procedure tbrowserlog.flushlog; + begin + if logopen then + if not stderrlog then + blockwrite(f,buf^,bufidx) + else + begin + buf[bufidx]:=#0; +{$ifndef TP} + write(stderr,buf); +{$else TP} + write(buf); +{$endif TP} + end; + bufidx:=0; + end; + + + procedure tbrowserlog.closelog; + begin + if logopen then + begin + flushlog; + close(f); + freemem(buf,logbufsize); + logopen:=false; + end; + end; + + procedure tbrowserlog.list_elements; + + begin + + stderrlog:=true; + getmem(buf,logbufsize); + logopen:=true; + while not elements_to_list^.empty do + browse_symbol(elements_to_list^.get); + flushlog; + logopen:=false; + freemem(buf,logbufsize); + stderrlog:=false; + end; + + procedure tbrowserlog.list_debug_infos; +{$ifndef debug} + begin + end; +{$else debug} + var + hp : pmodule; + ff : pinputfile; + begin + hp:=pmodule(loaded_units.first); + while assigned(hp) do + begin + addlog('Unit '+hp^.modulename^+' has index '+tostr(hp^.unit_index)); + ff:=hp^.sourcefiles^.files; + while assigned(ff) do + begin + addlog('File '+ff^.name^+' index '+tostr(ff^.ref_index)); + ff:=ff^.ref_next; + end; + hp:=pmodule(hp^.next); + end; + end; +{$endif debug} + + procedure tbrowserlog.addlog(const s:string); + begin + if not logopen then + exit; + { add ident } + if (identidx>0) and not stderrlog then + begin + if bufidx+identidx>logbufsize then + flushlog; + fillchar(buf[bufidx],identidx,' '); + inc(bufidx,identidx); + end; + { add text } + if bufidx+length(s)>logbufsize-2 then + flushlog; + move(s[1],buf[bufidx],length(s)); + inc(bufidx,length(s)); + { add crlf } + buf[bufidx]:=target_os.newline[1]; + inc(bufidx); + if length(target_os.newline)=2 then + begin + buf[bufidx]:=target_os.newline[2]; + inc(bufidx); + end; + end; + + + procedure tbrowserlog.addlogrefs(p:pref); + var + ref : pref; + begin + ref:=p; + Ident; + while assigned(ref) do + begin + Browserlog.AddLog(get_file_line(ref)); + ref:=ref^.nextref; + end; + Unident; + end; + + + procedure tbrowserlog.browse_symbol(const sr : string); + var + sym,symb : psym; + symt : psymtable; + hp : pmodule; + s,ss : string; + p : byte; + + procedure next_substring; + begin + p:=pos('.',s); + if p>0 then + begin + ss:=copy(s,1,p-1); + s:=copy(s,p+1,255); + end + else + begin + ss:=s; + s:=''; + end; + addlog('substring : '+ss); + end; + begin + { don't create a new reference when + looking for the symbol !! } + make_ref:=false; + s:=sr; + symt:=symtablestack; + next_substring; + if assigned(symt) then + begin + sym:=symt^.search(ss); + if sym=nil then + sym:=symt^.search(upper(ss)); + end + else + sym:=nil; + if assigned(sym) and (sym^.typ=unitsym) and (s<>'') then + begin + addlog('Unitsym found !'); + symt:=punitsym(sym)^.unitsymtable; + if assigned(symt) then + begin + next_substring; + sym:=symt^.search(ss); + end + else + sym:=nil; + end; + if not assigned(sym) then + begin + symt:=nil; + { try all loaded_units } + hp:=pmodule(loaded_units.first); + while assigned(hp) do + begin + if hp^.modulename^=upper(ss) then + begin + symt:=hp^.globalsymtable; + break; + end; + hp:=pmodule(hp^.next); + end; + if not assigned(symt) then + begin + addlog('!!!Symbol '+ss+' not found !!!'); + make_ref:=true; + exit; + end + else + begin + next_substring; + sym:=symt^.search(ss); + if sym=nil then + sym:=symt^.search(upper(ss)); + end; + end; + + while assigned(sym) and (s<>'') do + begin + next_substring; + case sym^.typ of + typesym : + begin + if ptypesym(sym)^.restype.def^.deftype in [recorddef,objectdef] then + begin + if ptypesym(sym)^.restype.def^.deftype=recorddef then + symt:=precorddef(ptypesym(sym)^.restype.def)^.symtable + else + symt:=pobjectdef(ptypesym(sym)^.restype.def)^.symtable; + sym:=symt^.search(ss); + if sym=nil then + sym:=symt^.search(upper(ss)); + end; + end; + varsym : + begin + if pvarsym(sym)^.vartype.def^.deftype in [recorddef,objectdef] then + begin + if pvarsym(sym)^.vartype.def^.deftype=recorddef then + symt:=precorddef(pvarsym(sym)^.vartype.def)^.symtable + else + symt:=pobjectdef(pvarsym(sym)^.vartype.def)^.symtable; + sym:=symt^.search(ss); + if sym=nil then + sym:=symt^.search(upper(ss)); + end; + end; + procsym : + begin + symt:=pprocsym(sym)^.definition^.parast; + symb:=symt^.search(ss); + if symb=nil then + symb:=symt^.search(upper(ss)); + if not assigned(symb) then + begin + symt:=pprocsym(sym)^.definition^.parast; + sym:=symt^.search(ss); + if symb=nil then + symb:=symt^.search(upper(ss)); + end + else + sym:=symb; + end; + {else + sym^.add_to_browserlog;} + end; + end; + if assigned(sym) then + sym^.add_to_browserlog + else + addlog('!!!Symbol '+ss+' not found !!!'); + make_ref:=true; + end; + + procedure tbrowserlog.ident; + begin + inc(identidx,2); + end; + + + procedure tbrowserlog.unident; + begin + dec(identidx,2); + end; + + +{**************************************************************************** + Helpers +****************************************************************************} + + procedure WriteBrowserLog; + var + p : psymtable; + hp : pmodule; + begin + browserlog.CreateLog; + browserlog.list_debug_infos; + hp:=pmodule(loaded_units.first); + while assigned(hp) do + begin + p:=psymtable(hp^.globalsymtable); + if assigned(p) then + p^.writebrowserlog; + if cs_local_browser in aktmoduleswitches then + begin + p:=psymtable(hp^.localsymtable); + if assigned(p) then + p^.writebrowserlog; + end; + hp:=pmodule(hp^.next); + end; + browserlog.CloseLog; + end; + + + procedure InitBrowserLog; + begin + browserlog.init; + end; + + procedure DoneBrowserLog; + begin + browserlog.done; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.6 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.5 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.4 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.3 1999/11/17 17:04:58 pierre + * Notes/hints changes + + Revision 1.2 1999/08/03 22:02:30 peter + * moved bitmask constants to sets + * some other type/const renamings + +} + diff --git a/befpc/compiler/catch.pas b/befpc/compiler/catch.pas new file mode 100644 index 0000000..a44c35e --- /dev/null +++ b/befpc/compiler/catch.pas @@ -0,0 +1,134 @@ +{ + $Id: catch.pas,v 1.1.1.1 2001-07-23 17:15:29 memson Exp $ + Copyright (c) 1998-2000 by Michael Van Canneyt + + Unit to catch segmentation faults and Ctrl-C and exit gracefully + under linux and go32v2 + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ********************************************************************* +} +Unit catch; + +{$ifdef go32v2} + { go32v2 stack check goes nuts if ss is not the data selector (PM) } + {$S-} +{$endif} + +{$ifdef BSD} + {$define NOCATCH} +{$endif} + +{$ifdef DEBUG} + {$define NOCATCH} +{$endif DEBUG} + + +interface +uses +{$ifdef linux} +{$define has_signal} + linux, +{$endif} +{$ifdef go32v2} +{$define has_signal} + dpmiexcp, +{$endif} + verbose; + + +{$ifdef has_signal} +Var + NewSignal,OldSigSegm, + OldSigInt,OldSigFPE : SignalHandler; +{$endif} + +Const in_const_evaluation : boolean = false; + +Implementation + +{$ifdef has_signal} +{$ifdef linux} +Procedure CatchSignal(Sig : Integer);cdecl; +{$else} +Function CatchSignal(Sig : longint):longint; +{$endif} +begin + case Sig of + SIGSEGV : begin + { Temporary message - until we get an error number... } + writeln ('Panic : Internal compiler error, exiting.'); + internalerror(9999); + end; + SIGFPE : begin + If in_const_evaluation then + Writeln('FPE error computing constant expression') + else + Writeln('FPE error inside compiler'); + Stop; + end; + SIGINT : begin + WriteLn('Ctrl-C Signaled!'); + Stop; + end; + end; +{$ifndef linux} + CatchSignal:=0; +{$endif} +end; +{$endif def has_signal} + + +begin +{$ifndef nocatch} +{$ifdef has_signal} +{$ifndef TP} + NewSignal:=SignalHandler(@CatchSignal); +{$else TP} + NewSignal:=SignalHandler(CatchSignal); +{$endif TP} + OldSigSegm:=Signal (SIGSEGV,NewSignal); + OldSigInt:=Signal (SIGINT,NewSignal); + OldSigFPE:=Signal (SIGFPE,NewSignal); +{$endif} +{$endif nocatch} +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.14 2000/04/07 20:52:24 marco + * For BSD signals are off for now + + Revision 1.13 2000/03/20 09:37:51 florian + * catching of exceptions is switched off on all targets if the define + DEBUG is used + + Revision 1.12 2000/02/18 12:34:43 pierre + DEBUG implies NOCATCH for go32v2 + + Revision 1.11 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.10 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.9 1999/08/25 16:41:04 peter + * resources are working again + + Revision 1.8 1999/08/10 12:27:15 pierre + * not stack check inside catch !! + +} diff --git a/befpc/compiler/cg386add.pas b/befpc/compiler/cg386add.pas new file mode 100644 index 0000000..4204455 --- /dev/null +++ b/befpc/compiler/cg386add.pas @@ -0,0 +1,2494 @@ + { + $Id: cg386add.pas,v 1.1.1.1 2001-07-23 17:15:31 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for in add node + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg386add; +interface + +{$define usecreateset} + + uses + tree; + + procedure secondadd(var p : ptree); + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386; + +{***************************************************************************** + Helpers +*****************************************************************************} + + procedure locflags2reg(var l:tlocation;opsize:topsize); + var + hregister : tregister; + begin + if (l.loc=LOC_FLAGS) then + begin + case opsize of + S_L : hregister:=getregister32; + S_W : hregister:=reg32toreg16(getregister32); + S_B : hregister:=reg32toreg8(getregister32); + end; + emit_flag2reg(l.resflags,hregister); + l.loc:=LOC_REGISTER; + l.register:=hregister; + end; + end; + + function getresflags(p : ptree;unsigned : boolean) : tresflags; + + begin + if not(unsigned) then + begin + if p^.swaped then + case p^.treetype of + equaln : getresflags:=F_E; + unequaln : getresflags:=F_NE; + ltn : getresflags:=F_G; + lten : getresflags:=F_GE; + gtn : getresflags:=F_L; + gten : getresflags:=F_LE; + end + else + case p^.treetype of + equaln : getresflags:=F_E; + unequaln : getresflags:=F_NE; + ltn : getresflags:=F_L; + lten : getresflags:=F_LE; + gtn : getresflags:=F_G; + gten : getresflags:=F_GE; + end; + end + else + begin + if p^.swaped then + case p^.treetype of + equaln : getresflags:=F_E; + unequaln : getresflags:=F_NE; + ltn : getresflags:=F_A; + lten : getresflags:=F_AE; + gtn : getresflags:=F_B; + gten : getresflags:=F_BE; + end + else + case p^.treetype of + equaln : getresflags:=F_E; + unequaln : getresflags:=F_NE; + ltn : getresflags:=F_B; + lten : getresflags:=F_BE; + gtn : getresflags:=F_A; + gten : getresflags:=F_AE; + end; + end; + end; + + + procedure SetResultLocation(cmpop,unsigned:boolean;var p :ptree); + + begin + { remove temporary location if not a set or string } + { that's a bad hack (FK) who did this ? } + if (p^.left^.resulttype^.deftype<>stringdef) and + ((p^.left^.resulttype^.deftype<>setdef) or (psetdef(p^.left^.resulttype)^.settype=smallset)) and + (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(p^.left^.location.reference); + if (p^.right^.resulttype^.deftype<>stringdef) and + ((p^.right^.resulttype^.deftype<>setdef) or (psetdef(p^.right^.resulttype)^.settype=smallset)) and + (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(p^.right^.location.reference); + { in case of comparison operation the put result in the flags } + if cmpop then + begin + clear_location(p^.location); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=getresflags(p,unsigned); + end; + end; + + +{***************************************************************************** + Addstring +*****************************************************************************} + + procedure addstring(var p : ptree); + var +{$ifdef newoptimizations2} + l: pasmlabel; + hreg: tregister; + href2: preference; + oldregisterdef: boolean; +{$endif newoptimizations2} + pushedregs : tpushed; + href : treference; + pushed, + cmpop : boolean; + regstopush : byte; + begin + { string operations are not commutative } + if p^.swaped then + swaptree(p); + case pstringdef(p^.left^.resulttype)^.string_typ of + st_ansistring: + begin + case p^.treetype of + addn: + begin + cmpop:=false; + secondpass(p^.left); + { to avoid problem with maybe_push and restore } + set_location(p^.location,p^.left^.location); + pushed:=maybe_push(p^.right^.registers32,p,false); + secondpass(p^.right); + if pushed then + begin + restore(p,false); + set_location(p^.left^.location,p^.location); + end; + { get the temp location, must be done before regs are + released/pushed because after the release the regs are + still used for the push (PFV) } + clear_location(p^.location); + p^.location.loc:=LOC_MEM; + gettempansistringreference(p^.location.reference); + decrstringref(cansistringdef,p^.location.reference); + { release used registers } + del_location(p^.right^.location); + del_location(p^.left^.location); + { push the still used registers } + pushusedregisters(pushedregs,$ff); + { push data } + emitpushreferenceaddr(p^.location.reference); + emit_push_loc(p^.right^.location); + emit_push_loc(p^.left^.location); + emitcall('FPC_ANSISTR_CONCAT'); + popusedregisters(pushedregs); + maybe_loadesi; + ungetiftempansi(p^.left^.location.reference); + ungetiftempansi(p^.right^.location.reference); + end; + ltn,lten,gtn,gten, + equaln,unequaln: + begin + cmpop:=true; + if (p^.treetype in [equaln,unequaln]) and + (p^.left^.treetype=stringconstn) and + (p^.left^.length=0) then + begin + secondpass(p^.right); + { release used registers } + del_location(p^.right^.location); + del_location(p^.left^.location); + case p^.right^.location.loc of + LOC_REFERENCE,LOC_MEM: + emit_const_ref(A_CMP,S_L,0,newreference(p^.right^.location.reference)); + LOC_REGISTER,LOC_CREGISTER: + emit_const_reg(A_CMP,S_L,0,p^.right^.location.register); + end; + ungetiftempansi(p^.left^.location.reference); + ungetiftempansi(p^.right^.location.reference); + end + else if (p^.treetype in [equaln,unequaln]) and + (p^.right^.treetype=stringconstn) and + (p^.right^.length=0) then + begin + secondpass(p^.left); + { release used registers } + del_location(p^.right^.location); + del_location(p^.left^.location); + case p^.right^.location.loc of + LOC_REFERENCE,LOC_MEM: + emit_const_ref(A_CMP,S_L,0,newreference(p^.left^.location.reference)); + LOC_REGISTER,LOC_CREGISTER: + emit_const_reg(A_CMP,S_L,0,p^.left^.location.register); + end; + ungetiftempansi(p^.left^.location.reference); + ungetiftempansi(p^.right^.location.reference); + end + else + begin + secondpass(p^.left); + pushed:=maybe_push(p^.right^.registers32,p^.left,false); + secondpass(p^.right); + if pushed then + restore(p^.left,false); + { release used registers } + del_location(p^.right^.location); + del_location(p^.left^.location); + { push the still used registers } + pushusedregisters(pushedregs,$ff); + { push data } + case p^.right^.location.loc of + LOC_REFERENCE,LOC_MEM: + emit_push_mem(p^.right^.location.reference); + LOC_REGISTER,LOC_CREGISTER: + emit_reg(A_PUSH,S_L,p^.right^.location.register); + end; + case p^.left^.location.loc of + LOC_REFERENCE,LOC_MEM: + emit_push_mem(p^.left^.location.reference); + LOC_REGISTER,LOC_CREGISTER: + emit_reg(A_PUSH,S_L,p^.left^.location.register); + end; + emitcall('FPC_ANSISTR_COMPARE'); + emit_reg_reg(A_OR,S_L,R_EAX,R_EAX); + popusedregisters(pushedregs); + maybe_loadesi; + ungetiftempansi(p^.left^.location.reference); + ungetiftempansi(p^.right^.location.reference); + end; + end; + end; + { the result of ansicompare is signed } + SetResultLocation(cmpop,false,p); + end; + st_shortstring: + begin + case p^.treetype of + addn: + begin + cmpop:=false; + secondpass(p^.left); + { if str_concat is set in expr + s:=s+ ... no need to create a temp string (PM) } + + if (p^.left^.treetype<>addn) and not (p^.use_strconcat) then + begin + + { can only reference be } + { string in register would be funny } + { therefore produce a temporary string } + + gettempofsizereference(256,href); + copyshortstring(href,p^.left^.location.reference,255,false,true); + { release the registers } +{ done by copyshortstring now (JM) } +{ del_reference(p^.left^.location.reference); } + ungetiftemp(p^.left^.location.reference); + + { does not hurt: } + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_MEM; + p^.left^.location.reference:=href; + +{$ifdef newoptimizations2} + { length of temp string = 255 (JM) } + { *** redefining a type is not allowed!! (thanks, Pierre) } + { also problem with constant string! } + pstringdef(p^.left^.resulttype)^.len := 255; + +{$endif newoptimizations2} + end; + + secondpass(p^.right); + +{$ifdef newoptimizations2} + { special case for string := string + char (JM) } + { needs string length stuff from above! } + hreg := R_NO; + if is_shortstring(p^.left^.resulttype) and + is_char(p^.right^.resulttype) then + begin + getlabel(l); + getexplicitregister32(R_EDI); + { load the current string length } + emit_ref_reg(A_MOVZX,S_BL, + newreference(p^.left^.location.reference),R_EDI); + { is it already maximal? } + emit_const_reg(A_CMP,S_L, + pstringdef(p^.left^.resulttype)^.len,R_EDI); + emitjmp(C_E,l); + { no, so add the new character } + { is it a constant char? } + if (p^.right^.treetype <> ordconstn) then + { no, make sure it is in a register } + if p^.right^.location.loc in [LOC_REFERENCE,LOC_MEM] then + begin + { free the registers of p^.right } + del_reference(p^.right^.location.reference); + { get register for the char } + hreg := reg32toreg8(getregister32); + emit_ref_reg(A_MOV,S_B, + newreference(p^.right^.location.reference), + hreg); + { I don't think a temp char exists, but it won't hurt (JM)} + ungetiftemp(p^.right^.location.reference); + end + else hreg := p^.right^.location.register; + href2 := newreference(p^.left^.location.reference); + { we need a new reference to store the character } + { at the end of the string. Check if the base or } + { index register is still free } + if (p^.left^.location.reference.base <> R_NO) and + (p^.left^.location.reference.index <> R_NO) then + begin + { they're not free, so add the base reg to } + { the string length (since the index can } + { have a scalefactor) and use EDI as base } + emit_reg_reg(A_ADD,S_L, + p^.left^.location.reference.base,R_EDI); + href2^.base := R_EDI; + end + else + { at least one is still free, so put EDI there } + if href2^.base = R_NO then + href2^.base := R_EDI + else + begin + href2^.index := R_EDI; + href2^.scalefactor := 1; + end; + { we need to be one position after the last char } + inc(href2^.offset); + { increase the string length } + emit_ref(A_INC,S_B,newreference(p^.left^.location.reference)); + { and store the character at the end of the string } + if (p^.right^.treetype <> ordconstn) then + begin + { no new_reference(href2) because it's only } + { used once (JM) } + emit_reg_ref(A_MOV,S_B,hreg,href2); + ungetregister(hreg); + end + else + emit_const_ref(A_MOV,S_B,p^.right^.value,href2); + emitlab(l); + ungetregister32(R_EDI); + end + else + begin +{$endif newoptimizations2} + { on the right we do not need the register anymore too } + { Instead of releasing them already, simply do not } + { push them (so the release is in the right place, } + { because emitpushreferenceaddr doesn't need extra } + { registers) (JM) } + regstopush := $ff; + remove_non_regvars_from_loc(p^.right^.location, + regstopush); + pushusedregisters(pushedregs,regstopush); + { push the maximum possible length of the result } +{$ifdef newoptimizations2} + { string (could be < 255 chars now) (JM) } + emit_const(A_PUSH,S_L, + pstringdef(p^.left^.resulttype)^.len); +{$endif newoptimizations2} + emitpushreferenceaddr(p^.left^.location.reference); + { the optimizer can more easily put the } + { deallocations in the right place if it happens } + { too early than when it happens too late (if } + { the pushref needs a "lea (..),edi; push edi") } + del_reference(p^.right^.location.reference); + emitpushreferenceaddr(p^.right^.location.reference); +{$ifdef newoptimizations2} + emitcall('FPC_SHORTSTR_CONCAT_LEN'); +{$else newoptimizations2} + emitcall('FPC_SHORTSTR_CONCAT'); +{$endif newoptimizations2} + ungetiftemp(p^.right^.location.reference); + maybe_loadesi; + popusedregisters(pushedregs); +{$ifdef newoptimizations2} + end; +{$endif newoptimizations2} + set_location(p^.location,p^.left^.location); + end; + ltn,lten,gtn,gten, + equaln,unequaln : + begin + cmpop:=true; + { generate better code for s='' and s<>'' } + if (p^.treetype in [equaln,unequaln]) and + (((p^.left^.treetype=stringconstn) and (str_length(p^.left)=0)) or + ((p^.right^.treetype=stringconstn) and (str_length(p^.right)=0))) then + begin + secondpass(p^.left); + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p^.left,false); + secondpass(p^.right); + if pushed then + restore(p^.left,false); + { only one node can be stringconstn } + { else pass 1 would have evaluted } + { this node } + if p^.left^.treetype=stringconstn then + emit_const_ref( + A_CMP,S_B,0,newreference(p^.right^.location.reference)) + else + emit_const_ref( + A_CMP,S_B,0,newreference(p^.left^.location.reference)); + del_reference(p^.right^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + pushusedregisters(pushedregs,$ff); + secondpass(p^.left); + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + secondpass(p^.right); + emitpushreferenceaddr(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + emitcall('FPC_SHORTSTR_COMPARE'); + maybe_loadesi; + popusedregisters(pushedregs); + end; + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + end; + else CGMessage(type_e_mismatch); + end; + SetResultLocation(cmpop,true,p); + end; + end; + end; + + +{***************************************************************************** + Addset +*****************************************************************************} + + procedure addset(var p : ptree); + var + createset, + cmpop, + pushed : boolean; + href : treference; + pushedregs : tpushed; + regstopush: byte; + begin + cmpop:=false; + + { not commutative } + if p^.swaped then + swaptree(p); + + { optimize first loading of a set } +{$ifdef usecreateset} + if (p^.right^.treetype=setelementn) and + not(assigned(p^.right^.right)) and + is_emptyset(p^.left) then + createset:=true + else +{$endif} + begin + createset:=false; + secondpass(p^.left); + end; + + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p^.left,false); + secondpass(p^.right); + if codegenerror then + exit; + if pushed then + restore(p^.left,false); + + set_location(p^.location,p^.left^.location); + + { handle operations } + + case p^.treetype of + equaln, + unequaln +{$IfNDef NoSetInclusion} + ,lten, gten +{$EndIf NoSetInclusion} + : begin + cmpop:=true; + del_location(p^.left^.location); + del_location(p^.right^.location); + pushusedregisters(pushedregs,$ff); +{$IfNDef NoSetInclusion} + If (p^.treetype in [equaln, unequaln, lten]) Then + Begin +{$EndIf NoSetInclusion} + emitpushreferenceaddr(p^.right^.location.reference); + emitpushreferenceaddr(p^.left^.location.reference); +{$IfNDef NoSetInclusion} + End + Else {gten = lten, if the arguments are reversed} + Begin + emitpushreferenceaddr(p^.left^.location.reference); + emitpushreferenceaddr(p^.right^.location.reference); + End; + Case p^.treetype of + equaln, unequaln: +{$EndIf NoSetInclusion} + emitcall('FPC_SET_COMP_SETS'); +{$IfNDef NoSetInclusion} + lten, gten: + Begin + emitcall('FPC_SET_CONTAINS_SETS'); + { we need a jne afterwards, not a jnbe/jnae } + p^.treetype := equaln; + End; + End; +{$EndIf NoSetInclusion} + maybe_loadesi; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + end; + addn : begin + { add can be an other SET or Range or Element ! } + { del_location(p^.right^.location); + done in pushsetelement below PM + + And someone added it again because those registers must + not be pushed by the pushusedregisters, however this + breaks the optimizer (JM) + + del_location(p^.right^.location); + pushusedregisters(pushedregs,$ff);} + + regstopush := $ff; + remove_non_regvars_from_loc(p^.right^.location,regstopush); + remove_non_regvars_from_loc(p^.left^.location,regstopush); + pushusedregisters(pushedregs,regstopush); + { this is still right before the instruction that uses } + { p^.left^.location, but that can be fixed by the } + { optimizer. There must never be an additional } + { between the release and the use, because that is not } + { detected/fixed. As Pierre said above, p^.right^.loc } + { will be released in pushsetelement (JM) } + del_location(p^.left^.location); + href.symbol:=nil; + gettempofsizereference(32,href); + if createset then + begin + pushsetelement(p^.right^.left); + emitpushreferenceaddr(href); + emitcall('FPC_SET_CREATE_ELEMENT'); + end + else + begin + { add a range or a single element? } + if p^.right^.treetype=setelementn then + begin +{$IfNDef regallocfix} + concatcopy(p^.left^.location.reference,href,32,false,false); +{$Else regallocfix} + concatcopy(p^.left^.location.reference,href,32,true,false); +{$EndIf regallocfix} + if assigned(p^.right^.right) then + begin + pushsetelement(p^.right^.right); + pushsetelement(p^.right^.left); + emitpushreferenceaddr(href); + emitcall('FPC_SET_SET_RANGE'); + end + else + begin + pushsetelement(p^.right^.left); + emitpushreferenceaddr(href); + emitcall('FPC_SET_SET_BYTE'); + end; + end + else + begin + { must be an other set } + emitpushreferenceaddr(href); + emitpushreferenceaddr(p^.right^.location.reference); +{$IfDef regallocfix} + del_location(p^.right^.location); +{$EndIf regallocfix} + emitpushreferenceaddr(p^.left^.location.reference); +{$IfDef regallocfix} + del_location(p^.left^.location); +{$EndIf regallocfix} + emitcall('FPC_SET_ADD_SETS'); + end; + end; + maybe_loadesi; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + p^.location.loc:=LOC_MEM; + p^.location.reference:=href; + end; + subn, + symdifn, + muln : begin + { Find out which registers have to pushed (JM) } + regstopush := $ff; + remove_non_regvars_from_loc(p^.left^.location,regstopush); + remove_non_regvars_from_loc(p^.right^.location,regstopush); + { Push them (JM) } + pushusedregisters(pushedregs,regstopush); + href.symbol:=nil; + gettempofsizereference(32,href); + emitpushreferenceaddr(href); + { Release the registers right before they're used, } + { see explanation in cgai386.pas:loadansistring for } + { info why this is done right before the push (JM) } + del_location(p^.right^.location); + emitpushreferenceaddr(p^.right^.location.reference); + { The same here } + del_location(p^.left^.location); + emitpushreferenceaddr(p^.left^.location.reference); + case p^.treetype of + subn : emitcall('FPC_SET_SUB_SETS'); + symdifn : emitcall('FPC_SET_SYMDIF_SETS'); + muln : emitcall('FPC_SET_MUL_SETS'); + end; + maybe_loadesi; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + p^.location.loc:=LOC_MEM; + p^.location.reference:=href; + end; + else + CGMessage(type_e_mismatch); + end; + SetResultLocation(cmpop,true,p); + end; + + +{***************************************************************************** + SecondAdd +*****************************************************************************} + + procedure secondadd(var p : ptree); + { is also being used for xor, and "mul", "sub, or and comparative } + { operators } + + label do_normal; + + var + hregister,hregister2 : tregister; + noswap,popeax,popedx, + pushed,mboverflow,cmpop : boolean; + op,op2 : tasmop; + flags : tresflags; + otl,ofl,hl : pasmlabel; + power : longint; + opsize : topsize; + hl4: pasmlabel; + hr : preference; + + { true, if unsigned types are compared } + unsigned : boolean; + { true, if a small set is handled with the longint code } + is_set : boolean; + { is_in_dest if the result is put directly into } + { the resulting refernce or varregister } + is_in_dest : boolean; + { true, if for sets subtractions the extra not should generated } + extra_not : boolean; + +{$ifdef SUPPORT_MMX} + mmxbase : tmmxtype; +{$endif SUPPORT_MMX} + pushedreg : tpushed; + hloc : tlocation; + regstopush: byte; + + procedure firstjmp64bitcmp; + + var + oldtreetype : ttreetyp; + + begin + { the jump the sequence is a little bit hairy } + case p^.treetype of + ltn,gtn: + begin + emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel); + { cheat a little bit for the negative test } + p^.swaped:=not(p^.swaped); + emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel); + p^.swaped:=not(p^.swaped); + end; + lten,gten: + begin + oldtreetype:=p^.treetype; + if p^.treetype=lten then + p^.treetype:=ltn + else + p^.treetype:=gtn; + emitjmp(flag_2_cond[getresflags(p,unsigned)],truelabel); + { cheat for the negative test } + if p^.treetype=ltn then + p^.treetype:=gtn + else + p^.treetype:=ltn; + emitjmp(flag_2_cond[getresflags(p,unsigned)],falselabel); + p^.treetype:=oldtreetype; + end; + equaln: + emitjmp(C_NE,falselabel); + unequaln: + emitjmp(C_NE,truelabel); + end; + end; + + procedure secondjmp64bitcmp; + + begin + { the jump the sequence is a little bit hairy } + case p^.treetype of + ltn,gtn,lten,gten: + begin + { the comparisaion of the low dword have to be } + { always unsigned! } + emitjmp(flag_2_cond[getresflags(p,true)],truelabel); + emitjmp(C_None,falselabel); + end; + equaln: + begin + emitjmp(C_NE,falselabel); + emitjmp(C_None,truelabel); + end; + unequaln: + begin + emitjmp(C_NE,truelabel); + emitjmp(C_None,falselabel); + end; + end; + end; + + begin + { to make it more readable, string and set (not smallset!) have their + own procedures } + case p^.left^.resulttype^.deftype of + stringdef : begin + addstring(p); + exit; + end; + setdef : begin + { normalsets are handled separate } + if not(psetdef(p^.left^.resulttype)^.settype=smallset) then + begin + addset(p); + exit; + end; + end; + end; + + { defaults } + unsigned:=false; + is_in_dest:=false; + extra_not:=false; + noswap:=false; + opsize:=S_L; + + { are we a (small)set, must be set here because the side can be + swapped ! (PFV) } + is_set:=(p^.left^.resulttype^.deftype=setdef); + + { calculate the operator which is more difficult } + firstcomplex(p); + + { handling boolean expressions extra: } + if is_boolean(p^.left^.resulttype) and + is_boolean(p^.right^.resulttype) then + begin + if (porddef(p^.left^.resulttype)^.typ=bool8bit) or + (porddef(p^.right^.resulttype)^.typ=bool8bit) then + opsize:=S_B + else + if (porddef(p^.left^.resulttype)^.typ=bool16bit) or + (porddef(p^.right^.resulttype)^.typ=bool16bit) then + opsize:=S_W + else + opsize:=S_L; + case p^.treetype of + andn, + orn : begin + clear_location(p^.location); + p^.location.loc:=LOC_JUMP; + cmpop:=false; + case p^.treetype of + andn : begin + otl:=truelabel; + getlabel(truelabel); + secondpass(p^.left); + maketojumpbool(p^.left); + emitlab(truelabel); + truelabel:=otl; + end; + orn : begin + ofl:=falselabel; + getlabel(falselabel); + secondpass(p^.left); + maketojumpbool(p^.left); + emitlab(falselabel); + falselabel:=ofl; + end; + else + CGMessage(type_e_mismatch); + end; + secondpass(p^.right); + maketojumpbool(p^.right); + end; + unequaln,ltn,lten,gtn,gten, + equaln,xorn : begin + if p^.left^.treetype=ordconstn then + swaptree(p); + if p^.left^.location.loc=LOC_JUMP then + begin + otl:=truelabel; + getlabel(truelabel); + ofl:=falselabel; + getlabel(falselabel); + end; + + secondpass(p^.left); + { if in flags then copy first to register, because the + flags can be destroyed } + case p^.left^.location.loc of + LOC_FLAGS: + locflags2reg(p^.left^.location,opsize); + LOC_JUMP: + begin + case opsize of + S_L : hregister:=getregister32; + S_W : hregister:=reg32toreg16(getregister32); + S_B : hregister:=reg32toreg8(getregister32); + end; + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hregister; + emitlab(truelabel); + truelabel:=otl; + emit_const_reg(A_MOV,opsize,1,hregister); + getlabel(hl); + emitjmp(C_None,hl); + emitlab(falselabel); + falselabel:=ofl; + emit_reg_reg(A_XOR,S_L,makereg32(hregister), + makereg32(hregister)); + emitlab(hl); + end; + end; + set_location(p^.location,p^.left^.location); + pushed:=maybe_push(p^.right^.registers32,p,false); + if p^.right^.location.loc=LOC_JUMP then + begin + otl:=truelabel; + getlabel(truelabel); + ofl:=falselabel; + getlabel(falselabel); + end; + secondpass(p^.right); + if pushed then + begin + restore(p,false); + set_location(p^.left^.location,p^.location); + end; + case p^.right^.location.loc of + LOC_FLAGS: + locflags2reg(p^.right^.location,opsize); + LOC_JUMP: + begin + case opsize of + S_L : hregister:=getregister32; + S_W : hregister:=reg32toreg16(getregister32); + S_B : hregister:=reg32toreg8(getregister32); + end; + p^.right^.location.loc:=LOC_REGISTER; + p^.right^.location.register:=hregister; + emitlab(truelabel); + truelabel:=otl; + emit_const_reg(A_MOV,opsize,1,hregister); + getlabel(hl); + emitjmp(C_None,hl); + emitlab(falselabel); + falselabel:=ofl; + emit_reg_reg(A_XOR,S_L,makereg32(hregister), + makereg32(hregister)); + emitlab(hl); + end; + end; + goto do_normal; + end + else + CGMessage(type_e_mismatch); + end + end + else + begin + { in case of constant put it to the left } + if (p^.left^.treetype=ordconstn) then + swaptree(p); + secondpass(p^.left); + { this will be complicated as + a lot of code below assumes that + p^.location and p^.left^.location are the same } + +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) and + ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then + begin + set_location(p^.location,dest_loc); + in_dest_loc:=true; + is_in_dest:=true; + end + else +{$endif test_dest_loc} + set_location(p^.location,p^.left^.location); + + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p,is_64bitint(p^.left^.resulttype)); + secondpass(p^.right); + if pushed then + begin + restore(p,is_64bitint(p^.left^.resulttype)); + set_location(p^.left^.location,p^.location); + end; + + if (p^.left^.resulttype^.deftype=pointerdef) or + + (p^.right^.resulttype^.deftype=pointerdef) or + + ((p^.right^.resulttype^.deftype=objectdef) and + pobjectdef(p^.right^.resulttype)^.is_class and + (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class + ) or + + (p^.left^.resulttype^.deftype=classrefdef) or + + (p^.left^.resulttype^.deftype=procvardef) or + + ((p^.left^.resulttype^.deftype=enumdef) and + (p^.left^.resulttype^.size=4)) or + + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=s32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=s32bit)) or + + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=u32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=u32bit)) or + + { as well as small sets } + is_set then + begin + do_normal: + mboverflow:=false; + cmpop:=false; +{$ifndef cardinalmulfix} + unsigned := + (p^.left^.resulttype^.deftype=pointerdef) or + (p^.right^.resulttype^.deftype=pointerdef) or + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=u32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=u32bit)); +{$else cardinalmulfix} + unsigned := not(is_signed(p^.left^.resulttype)) or + not(is_signed(p^.right^.resulttype)); +{$endif cardinalmulfix} + case p^.treetype of + addn : begin + { this is a really ugly hack!!!!!!!!!! } + { this could be done later using EDI } + { as it is done for subn } + { instead of two registers!!!! } + if is_set then + begin + { adding elements is not commutative } + if p^.swaped and (p^.left^.treetype=setelementn) then + swaptree(p); + { are we adding set elements ? } + if p^.right^.treetype=setelementn then + begin + { no range support for smallsets! } + if assigned(p^.right^.right) then + internalerror(43244); + { bts requires both elements to be registers } + if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then + begin + ungetiftemp(p^.left^.location.reference); + del_location(p^.left^.location); +{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!} + hregister:=getregister32; + emit_ref_reg(A_MOV,opsize, + newreference(p^.left^.location.reference),hregister); + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hregister; + set_location(p^.location,p^.left^.location); + end; + if p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE] then + begin + ungetiftemp(p^.right^.location.reference); + del_location(p^.right^.location); + hregister:=getregister32; + emit_ref_reg(A_MOV,opsize, + newreference(p^.right^.location.reference),hregister); + clear_location(p^.right^.location); + p^.right^.location.loc:=LOC_REGISTER; + p^.right^.location.register:=hregister; + end; + op:=A_BTS; + noswap:=true; + end + else + op:=A_OR; + mboverflow:=false; + unsigned:=false; + end + else + begin + op:=A_ADD; + mboverflow:=true; + end; + end; + symdifn : begin + { the symetric diff is only for sets } + if is_set then + begin + op:=A_XOR; + mboverflow:=false; + unsigned:=false; + end + else + CGMessage(type_e_mismatch); + end; + muln : begin + if is_set then + begin + op:=A_AND; + mboverflow:=false; + unsigned:=false; + end + else + begin + if unsigned then + op:=A_MUL + else + op:=A_IMUL; + mboverflow:=true; + end; + end; + subn : begin + if is_set then + begin + op:=A_AND; + mboverflow:=false; + unsigned:=false; +{$IfNDef NoSetConstNot} + If (p^.right^.treetype = setconstn) then + p^.right^.location.reference.offset := not(p^.right^.location.reference.offset) + Else +{$EndIf NoNosetConstNot} + extra_not:=true; + end + else + begin + op:=A_SUB; + mboverflow:=true; + end; + end; + ltn,lten, + gtn,gten, + equaln,unequaln : begin +{$IfNDef NoSetInclusion} + If is_set Then + Case p^.treetype of + lten,gten: + Begin + If p^.treetype = lten then + swaptree(p); + if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then + begin + ungetiftemp(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + hregister:=getregister32; + emit_ref_reg(A_MOV,opsize, + newreference(p^.left^.location.reference),hregister); + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hregister; + set_location(p^.location,p^.left^.location); + end + else + if p^.left^.location.loc = LOC_CREGISTER Then + {save the register var in a temp register, because + its value is going to be modified} + begin + hregister := getregister32; + emit_reg_reg(A_MOV,opsize, + p^.left^.location.register,hregister); + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hregister; + set_location(p^.location,p^.left^.location); + end; + {here, p^.left^.location should be LOC_REGISTER} + If p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE] Then + emit_ref_reg(A_AND,opsize, + newreference(p^.right^.location.reference),p^.left^.location.register) + Else + emit_reg_reg(A_AND,opsize, + p^.right^.location.register,p^.left^.location.register); + {warning: ugly hack ahead: we need a "jne" after the cmp, so + change the treetype from lten/gten to equaln} + p^.treetype := equaln + End; + {no < or > support for sets} + ltn,gtn: CGMessage(type_e_mismatch); + End; +{$EndIf NoSetInclusion} + op:=A_CMP; + cmpop:=true; + end; + xorn : op:=A_XOR; + orn : op:=A_OR; + andn : op:=A_AND; + else + CGMessage(type_e_mismatch); + end; + + { filter MUL, which requires special handling } + if op=A_MUL then + begin + popeax:=false; + popedx:=false; + { here you need to free the symbol first } + { p^.left^.location and p^.right^.location must } + { only be freed when they are really released, } + { because the optimizer NEEDS correct regalloc } + { info!!! (JM) } + clear_location(p^.location); + + { the p^.location.register will be filled in later (JM) } + p^.location.loc:=LOC_REGISTER; +{$IfNDef NoShlMul} + if p^.right^.treetype=ordconstn then + swaptree(p); + If (p^.left^.treetype = ordconstn) and + ispowerof2(p^.left^.value, power) and + not(cs_check_overflow in aktlocalswitches) then + Begin + { This release will be moved after the next } + { instruction by the optimizer. No need to } + { release p^.left^.location, since it's a } + { constant (JM) } + release_loc(p^.right^.location); + p^.location.register := getregister32; + emitloadord2reg(p^.right^.location,u32bitdef,p^.location.register,false); + emit_const_reg(A_SHL,S_L,power,p^.location.register) + End + Else + Begin +{$EndIf NoShlMul} + regstopush := $ff; + remove_non_regvars_from_loc(p^.right^.location,regstopush); + remove_non_regvars_from_loc(p^.left^.location,regstopush); + { now, regstopush does NOT contain EAX and/or EDX if they are } + { used in either the left or the right location, excepts if } + {they are regvars. It DOES contain them if they are used in } + { another location (JM) } + if not(R_EAX in unused) and ((regstopush and ($80 shr byte(R_EAX))) <> 0) then + begin + emit_reg(A_PUSH,S_L,R_EAX); + popeax:=true; + end; + if not(R_EDX in unused) and ((regstopush and ($80 shr byte(R_EDX))) <> 0) then + begin + emit_reg(A_PUSH,S_L,R_EDX); + popedx:=true; + end; + { p^.left^.location can be R_EAX !!! } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + { load the left value } + emitloadord2reg(p^.left^.location,u32bitdef,R_EDI,true); + release_loc(p^.left^.location); + { allocate EAX } + if R_EAX in unused then + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + { load he right value } + emitloadord2reg(p^.right^.location,u32bitdef,R_EAX,true); + release_loc(p^.right^.location); + { allocate EAX if it isn't yet allocated (JM) } + if (R_EAX in unused) then + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); +{$ifndef noAllocEdi} + { also allocate EDX, since it is also modified by } + { a mul (JM) } + if R_EDX in unused then + exprasmlist^.concat(new(pairegalloc,alloc(R_EDX))); +{$endif noAllocEdi} + emit_reg(A_MUL,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); + if R_EDX in unused then + exprasmlist^.concat(new(pairegalloc,dealloc(R_EDX))); +{$endif noAllocEdi} + if R_EAX in unused then + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + p^.location.register := getregister32; + emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.register); + if popedx then + emit_reg(A_POP,S_L,R_EDX); + if popeax then + emit_reg(A_POP,S_L,R_EAX); +{$IfNDef NoShlMul} + End; +{$endif NoShlMul} + SetResultLocation(false,true,p); + exit; + end; + + { Convert flags to register first } + if (p^.left^.location.loc=LOC_FLAGS) then + locflags2reg(p^.left^.location,opsize); + if (p^.right^.location.loc=LOC_FLAGS) then + locflags2reg(p^.right^.location,opsize); + + { left and right no register? } + { then one must be demanded } + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + { register variable ? } + if (p^.left^.location.loc=LOC_CREGISTER) then + begin + { it is OK if this is the destination } + if is_in_dest then + begin + hregister:=p^.location.register; + emit_reg_reg(A_MOV,opsize,p^.left^.location.register, + hregister); + end + else + if cmpop then + begin + { do not disturb the register } + hregister:=p^.location.register; + end + else + begin + case opsize of + S_L : hregister:=getregister32; + S_B : hregister:=reg32toreg8(getregister32); + end; + emit_reg_reg(A_MOV,opsize,p^.left^.location.register, + hregister); + end + end + else + begin + ungetiftemp(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + if is_in_dest then + begin + hregister:=p^.location.register; + emit_ref_reg(A_MOV,opsize, + newreference(p^.left^.location.reference),hregister); + end + else + begin + { first give free, then demand new register } + case opsize of + S_L : hregister:=getregister32; + S_W : hregister:=reg32toreg16(getregister32); + S_B : hregister:=reg32toreg8(getregister32); + end; + emit_ref_reg(A_MOV,opsize, + newreference(p^.left^.location.reference),hregister); + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end + else + { if on the right the register then swap } + if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + { at this point, p^.location.loc should be LOC_REGISTER } + { and p^.location.register should be a valid register } + { containing the left result } + + if p^.right^.location.loc<>LOC_REGISTER then + begin + if (p^.treetype=subn) and p^.swaped then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + if extra_not then + emit_reg(A_NOT,opsize,p^.location.register); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI); + emit_reg_reg(op,opsize,p^.location.register,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + if extra_not then + emit_reg(A_NOT,opsize,p^.location.register); + +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,opsize, + newreference(p^.right^.location.reference),R_EDI); + emit_reg_reg(op,opsize,p^.location.register,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + ungetiftemp(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + end; + end + else + begin + if (p^.right^.treetype=ordconstn) and + (op=A_CMP) and + (p^.right^.value=0) then + begin + emit_reg_reg(A_TEST,opsize,p^.location.register, + p^.location.register); + end + else if (p^.right^.treetype=ordconstn) and + (op=A_ADD) and + (p^.right^.value=1) and + not(cs_check_overflow in aktlocalswitches) then + begin + emit_reg(A_INC,opsize, + p^.location.register); + end + else if (p^.right^.treetype=ordconstn) and + (op=A_SUB) and + (p^.right^.value=1) and + not(cs_check_overflow in aktlocalswitches) then + begin + emit_reg(A_DEC,opsize, + p^.location.register); + end + else if (p^.right^.treetype=ordconstn) and + (op=A_IMUL) and + (ispowerof2(p^.right^.value,power)) and + not(cs_check_overflow in aktlocalswitches) then + begin + emit_const_reg(A_SHL,opsize,power, + p^.location.register); + end + else + begin + if (p^.right^.location.loc=LOC_CREGISTER) then + begin + if extra_not then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI); + emit_reg(A_NOT,S_L,R_EDI); + emit_reg_reg(A_AND,S_L,R_EDI, + p^.location.register); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + emit_reg_reg(op,opsize,p^.right^.location.register, + p^.location.register); + end; + end + else + begin + if extra_not then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,newreference( + p^.right^.location.reference),R_EDI); + emit_reg(A_NOT,S_L,R_EDI); + emit_reg_reg(A_AND,S_L,R_EDI, + p^.location.register); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + emit_ref_reg(op,opsize,newreference( + p^.right^.location.reference),p^.location.register); + end; + ungetiftemp(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + end; + end; + end; + end + else + begin + { when swapped another result register } + if (p^.treetype=subn) and p^.swaped then + begin + if extra_not then + emit_reg(A_NOT,S_L,p^.location.register); + + emit_reg_reg(op,opsize, + p^.location.register,p^.right^.location.register); + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + { just to maintain ordering } + p^.swaped:=not(p^.swaped); + end + else + begin + if extra_not then + emit_reg(A_NOT,S_L,p^.right^.location.register); + emit_reg_reg(op,opsize, + p^.right^.location.register, + p^.location.register); + end; + case opsize of + S_L : ungetregister32(p^.right^.location.register); + S_B : ungetregister32(reg8toreg32(p^.right^.location.register)); + end; + end; + + if cmpop then + case opsize of + S_L : ungetregister32(p^.location.register); + S_B : ungetregister32(reg8toreg32(p^.location.register)); + end; + + { only in case of overflow operations } + { produce overflow code } + { we must put it here directly, because sign of operation } + { is in unsigned VAR!! } + if mboverflow then + begin + if cs_check_overflow in aktlocalswitches then + begin + getlabel(hl4); + if unsigned then + emitjmp(C_NB,hl4) + else + emitjmp(C_NO,hl4); + emitcall('FPC_OVERFLOW'); + emitlab(hl4); + end; + end; + end + else + + { Char type } + if ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=uchar)) or + { enumeration type 16 bit } + ((p^.left^.resulttype^.deftype=enumdef) and + (p^.left^.resulttype^.size=1)) then + begin + case p^.treetype of + ltn,lten,gtn,gten, + equaln,unequaln : + cmpop:=true; + else CGMessage(type_e_mismatch); + end; + unsigned:=true; + { left and right no register? } + { the one must be demanded } + if (p^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + if p^.location.loc=LOC_CREGISTER then + begin + if cmpop then + { do not disturb register } + hregister:=p^.location.register + else + begin + hregister:=reg32toreg8(getregister32); + emit_reg_reg(A_MOV,S_B,p^.location.register, + hregister); + end; + end + else + begin + del_reference(p^.location.reference); + + { first give free then demand new register } + hregister:=reg32toreg8(getregister32); + emit_ref_reg(A_MOV,S_B,newreference(p^.location.reference), + hregister); + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end; + + { now p always a register } + + if (p^.right^.location.loc=LOC_REGISTER) and + (p^.location.loc<>LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + emit_reg_reg(A_CMP,S_B, + p^.right^.location.register,p^.location.register); + end + else + begin + emit_ref_reg(A_CMP,S_B,newreference( + p^.right^.location.reference),p^.location.register); + del_reference(p^.right^.location.reference); + end; + end + else + begin + emit_reg_reg(A_CMP,S_B,p^.right^.location.register, + p^.location.register); + ungetregister32(reg8toreg32(p^.right^.location.register)); + end; + ungetregister32(reg8toreg32(p^.location.register)); + end + else + { 16 bit enumeration type } + if ((p^.left^.resulttype^.deftype=enumdef) and + (p^.left^.resulttype^.size=2)) then + begin + case p^.treetype of + ltn,lten,gtn,gten, + equaln,unequaln : + cmpop:=true; + else CGMessage(type_e_mismatch); + end; + unsigned:=true; + { left and right no register? } + { the one must be demanded } + if (p^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + if p^.location.loc=LOC_CREGISTER then + begin + if cmpop then + { do not disturb register } + hregister:=p^.location.register + else + begin + hregister:=reg32toreg16(getregister32); + emit_reg_reg(A_MOV,S_W,p^.location.register, + hregister); + end; + end + else + begin + del_reference(p^.location.reference); + + { first give free then demand new register } + hregister:=reg32toreg16(getregister32); + emit_ref_reg(A_MOV,S_W,newreference(p^.location.reference), + hregister); + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end; + + { now p always a register } + + if (p^.right^.location.loc=LOC_REGISTER) and + (p^.location.loc<>LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + emit_reg_reg(A_CMP,S_W, + p^.right^.location.register,p^.location.register); + end + else + begin + emit_ref_reg(A_CMP,S_W,newreference( + p^.right^.location.reference),p^.location.register); + del_reference(p^.right^.location.reference); + end; + end + else + begin + emit_reg_reg(A_CMP,S_W,p^.right^.location.register, + p^.location.register); + ungetregister32(reg16toreg32(p^.right^.location.register)); + end; + ungetregister32(reg16toreg32(p^.location.register)); + end + else + { 64 bit types } + if is_64bitint(p^.left^.resulttype) then + begin + mboverflow:=false; + cmpop:=false; + unsigned:=((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=u64bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=u64bit)); + case p^.treetype of + addn : begin + begin + op:=A_ADD; + op2:=A_ADC; + mboverflow:=true; + end; + end; + subn : begin + op:=A_SUB; + op2:=A_SBB; + mboverflow:=true; + end; + ltn,lten, + gtn,gten, + equaln,unequaln: + begin + op:=A_CMP; + op2:=A_CMP; + cmpop:=true; + end; + + xorn: + begin + op:=A_XOR; + op2:=A_XOR; + end; + + orn: + begin + op:=A_OR; + op2:=A_OR; + end; + + andn: + begin + op:=A_AND; + op2:=A_AND; + end; + muln: + ; + else + CGMessage(type_e_mismatch); + end; + + if p^.treetype=muln then + begin + { save p^.lcoation, because we change it now } + set_location(hloc,p^.location); + release_qword_loc(p^.location); + release_qword_loc(p^.right^.location); + p^.location.registerlow:=getexplicitregister32(R_EAX); + p^.location.registerhigh:=getexplicitregister32(R_EDX); + pushusedregisters(pushedreg,$ff + and not($80 shr byte(p^.location.registerlow)) + and not($80 shr byte(p^.location.registerhigh))); + if cs_check_overflow in aktlocalswitches then + push_int(1) + else + push_int(0); + { the left operand is in hloc, because the + location of left is p^.location but p^.location + is already destroyed + } + emit_pushq_loc(hloc); + clear_location(hloc); + emit_pushq_loc(p^.right^.location); + if porddef(p^.resulttype)^.typ=u64bit then + emitcall('FPC_MUL_QWORD') + else + emitcall('FPC_MUL_INT64'); + emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.registerlow); + emit_reg_reg(A_MOV,S_L,R_EDX,p^.location.registerhigh); + popusedregisters(pushedreg); + p^.location.loc:=LOC_REGISTER; + end + else + begin + { left and right no register? } + { then one must be demanded } + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + { register variable ? } + if (p^.left^.location.loc=LOC_CREGISTER) then + begin + { it is OK if this is the destination } + if is_in_dest then + begin + hregister:=p^.location.registerlow; + hregister2:=p^.location.registerhigh; + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, + hregister); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, + hregister2); + end + else + if cmpop then + begin + { do not disturb the register } + hregister:=p^.location.registerlow; + hregister2:=p^.location.registerhigh; + end + else + begin + hregister:=getregister32; + hregister2:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, + hregister); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh, + hregister2); + end + end + else + begin + ungetiftemp(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + if is_in_dest then + begin + hregister:=p^.location.registerlow; + hregister2:=p^.location.registerhigh; + emit_mov_ref_reg64(p^.left^.location.reference,hregister,hregister2); + end + else + begin + hregister:=getregister32; + hregister2:=getregister32; + emit_mov_ref_reg64(p^.left^.location.reference,hregister,hregister2); + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.registerlow:=hregister; + p^.location.registerhigh:=hregister2; + end + else + { if on the right the register then swap } + if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + { at this point, p^.location.loc should be LOC_REGISTER } + { and p^.location.register should be a valid register } + { containing the left result } + + if p^.right^.location.loc<>LOC_REGISTER then + begin + if (p^.treetype=subn) and p^.swaped then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI); + emit_reg_reg(op,opsize,p^.location.register,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,opsize,p^.right^.location.registerhigh,R_EDI); + { the carry flag is still ok } + emit_reg_reg(op2,opsize,p^.location.registerhigh,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.registerhigh); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,opsize, + newreference(p^.right^.location.reference),R_EDI); + emit_reg_reg(op,opsize,p^.location.registerlow,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.registerlow); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + hr:=newreference(p^.right^.location.reference); + inc(hr^.offset,4); + emit_ref_reg(A_MOV,opsize, + hr,R_EDI); + { here the carry flag is still preserved } + emit_reg_reg(op2,opsize,p^.location.registerhigh,R_EDI); + emit_reg_reg(A_MOV,opsize,R_EDI, + p^.location.registerhigh); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + ungetiftemp(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + end; + end + else if cmpop then + begin + if (p^.right^.location.loc=LOC_CREGISTER) then + begin + emit_reg_reg(A_CMP,S_L,p^.right^.location.registerhigh, + p^.location.registerhigh); + firstjmp64bitcmp; + emit_reg_reg(A_CMP,S_L,p^.right^.location.registerlow, + p^.location.registerlow); + secondjmp64bitcmp; + end + else + begin + hr:=newreference(p^.right^.location.reference); + inc(hr^.offset,4); + + emit_ref_reg(A_CMP,S_L, + hr,p^.location.registerhigh); + firstjmp64bitcmp; + + emit_ref_reg(A_CMP,S_L,newreference( + p^.right^.location.reference),p^.location.registerlow); + secondjmp64bitcmp; + + emitjmp(C_None,falselabel); + + ungetiftemp(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + end; + end + else + begin + { + if (p^.right^.treetype=ordconstn) and + (op=A_CMP) and + (p^.right^.value=0) then + begin + emit_reg_reg(A_TEST,opsize,p^.location.register, + p^.location.register); + end + else if (p^.right^.treetype=ordconstn) and + (op=A_IMUL) and + (ispowerof2(p^.right^.value,power)) then + begin + emit_const_reg(A_SHL,opsize,power, + p^.location.register); + end + else + } + begin + if (p^.right^.location.loc=LOC_CREGISTER) then + begin + emit_reg_reg(op,S_L,p^.right^.location.registerlow, + p^.location.registerlow); + emit_reg_reg(op2,S_L,p^.right^.location.registerhigh, + p^.location.registerhigh); + end + else + begin + emit_ref_reg(op,S_L,newreference( + p^.right^.location.reference),p^.location.registerlow); + hr:=newreference(p^.right^.location.reference); + inc(hr^.offset,4); + emit_ref_reg(op2,S_L, + hr,p^.location.registerhigh); + ungetiftemp(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + end; + end; + end; + end + else + begin + { when swapped another result register } + if (p^.treetype=subn) and p^.swaped then + begin + emit_reg_reg(op,S_L, + p^.location.registerlow, + p^.right^.location.registerlow); + emit_reg_reg(op2,S_L, + p^.location.registerhigh, + p^.right^.location.registerhigh); + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + { just to maintain ordering } + p^.swaped:=not(p^.swaped); + end + else if cmpop then + begin + emit_reg_reg(A_CMP,S_L, + p^.right^.location.registerhigh, + p^.location.registerhigh); + firstjmp64bitcmp; + emit_reg_reg(A_CMP,S_L, + p^.right^.location.registerlow, + p^.location.registerlow); + secondjmp64bitcmp; + end + else + begin + emit_reg_reg(op,S_L, + p^.right^.location.registerlow, + p^.location.registerlow); + emit_reg_reg(op2,S_L, + p^.right^.location.registerhigh, + p^.location.registerhigh); + end; + ungetregister32(p^.right^.location.registerlow); + ungetregister32(p^.right^.location.registerhigh); + end; + + if cmpop then + begin + ungetregister32(p^.location.registerlow); + ungetregister32(p^.location.registerhigh); + end; + + { only in case of overflow operations } + { produce overflow code } + { we must put it here directly, because sign of operation } + { is in unsigned VAR!! } + if mboverflow then + begin + if cs_check_overflow in aktlocalswitches then + begin + getlabel(hl4); + if unsigned then + emitjmp(C_NB,hl4) + else + emitjmp(C_NO,hl4); + emitcall('FPC_OVERFLOW'); + emitlab(hl4); + end; + end; + { we have LOC_JUMP as result } + if cmpop then + begin + clear_location(p^.location); + p^.location.loc:=LOC_JUMP; + cmpop:=false; + end; + end; + end + else + { Floating point } + if (p^.left^.resulttype^.deftype=floatdef) and + (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then + begin + { real constants to the right, but only if it + isn't on the FPU stack, i.e. 1.0 or 0.0! } + if (p^.left^.treetype=realconstn) and + (p^.left^.location.loc<>LOC_FPU) then + swaptree(p); + cmpop:=false; + case p^.treetype of + addn : op:=A_FADDP; + muln : op:=A_FMULP; + subn : op:=A_FSUBP; + slashn : op:=A_FDIVP; + ltn,lten,gtn,gten, + equaln,unequaln : begin + op:=A_FCOMPP; + cmpop:=true; + end; + else CGMessage(type_e_mismatch); + end; + + if (p^.right^.location.loc<>LOC_FPU) then + begin + if p^.right^.location.loc=LOC_CFPUREGISTER then + begin + emit_reg( A_FLD,S_NO, + correct_fpuregister(p^.right^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + end + else + floatload(pfloatdef(p^.right^.resulttype)^.typ,p^.right^.location.reference); + if (p^.left^.location.loc<>LOC_FPU) then + begin + if p^.left^.location.loc=LOC_CFPUREGISTER then + begin + emit_reg( A_FLD,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + end + else + floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference) + end + { left was on the stack => swap } + else + p^.swaped:=not(p^.swaped); + + { releases the right reference } + del_reference(p^.right^.location.reference); + end + { the nominator in st0 } + else if (p^.left^.location.loc<>LOC_FPU) then + begin + if p^.left^.location.loc=LOC_CFPUREGISTER then + begin + emit_reg( A_FLD,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + end + else + floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference) + end + { fpu operands are always in the wrong order on the stack } + else + p^.swaped:=not(p^.swaped); + + { releases the left reference } + if (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + del_reference(p^.left^.location.reference); + + { if we swaped the tree nodes, then use the reverse operator } + if p^.swaped then + begin + if (p^.treetype=slashn) then + op:=A_FDIVRP + else if (p^.treetype=subn) then + op:=A_FSUBRP; + end; + { to avoid the pentium bug + if (op=FDIVP) and (opt_processors=pentium) then + emitcall('EMUL_FDIVP') + else + } + { the Intel assemblers want operands } + if op<>A_FCOMPP then + begin + emit_reg_reg(op,S_NO,R_ST,R_ST1); + dec(fpuvaroffset); + end + else + begin + emit_none(op,S_NO); + dec(fpuvaroffset,2); + end; + + { on comparison load flags } + if cmpop then + begin + if not(R_EAX in unused) then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI); + end; + emit_reg(A_FNSTSW,S_NO,R_AX); + emit_none(A_SAHF,S_NO); + if not(R_EAX in unused) then + begin + emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + if p^.swaped then + begin + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_A; + lten : flags:=F_AE; + gtn : flags:=F_B; + gten : flags:=F_BE; + end; + end + else + begin + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_B; + lten : flags:=F_BE; + gtn : flags:=F_A; + gten : flags:=F_AE; + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=flags; + cmpop:=false; + end + else + begin + clear_location(p^.location); + p^.location.loc:=LOC_FPU; + end; + end +{$ifdef SUPPORT_MMX} + else + + { MMX Arrays } + if is_mmx_able_array(p^.left^.resulttype) then + begin + cmpop:=false; + mmxbase:=mmx_type(p^.left^.resulttype); + case p^.treetype of + addn : begin + if (cs_mmx_saturation in aktlocalswitches) then + begin + case mmxbase of + mmxs8bit: + op:=A_PADDSB; + mmxu8bit: + op:=A_PADDUSB; + mmxs16bit,mmxfixed16: + op:=A_PADDSB; + mmxu16bit: + op:=A_PADDUSW; + end; + end + else + begin + case mmxbase of + mmxs8bit,mmxu8bit: + op:=A_PADDB; + mmxs16bit,mmxu16bit,mmxfixed16: + op:=A_PADDW; + mmxs32bit,mmxu32bit: + op:=A_PADDD; + end; + end; + end; + muln : begin + case mmxbase of + mmxs16bit,mmxu16bit: + op:=A_PMULLW; + mmxfixed16: + op:=A_PMULHW; + end; + end; + subn : begin + if (cs_mmx_saturation in aktlocalswitches) then + begin + case mmxbase of + mmxs8bit: + op:=A_PSUBSB; + mmxu8bit: + op:=A_PSUBUSB; + mmxs16bit,mmxfixed16: + op:=A_PSUBSB; + mmxu16bit: + op:=A_PSUBUSW; + end; + end + else + begin + case mmxbase of + mmxs8bit,mmxu8bit: + op:=A_PSUBB; + mmxs16bit,mmxu16bit,mmxfixed16: + op:=A_PSUBW; + mmxs32bit,mmxu32bit: + op:=A_PSUBD; + end; + end; + end; + { + ltn,lten,gtn,gten, + equaln,unequaln : + begin + op:=A_CMP; + cmpop:=true; + end; + } + xorn: + op:=A_PXOR; + orn: + op:=A_POR; + andn: + op:=A_PAND; + else CGMessage(type_e_mismatch); + end; + { left and right no register? } + { then one must be demanded } + if (p^.left^.location.loc<>LOC_MMXREGISTER) and + (p^.right^.location.loc<>LOC_MMXREGISTER) then + begin + { register variable ? } + if (p^.left^.location.loc=LOC_CMMXREGISTER) then + begin + { it is OK if this is the destination } + if is_in_dest then + begin + hregister:=p^.location.register; + emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, + hregister); + end + else + begin + hregister:=getregistermmx; + emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, + hregister); + end + end + else + begin + del_reference(p^.left^.location.reference); + + if is_in_dest then + begin + hregister:=p^.location.register; + emit_ref_reg(A_MOVQ,S_NO, + newreference(p^.left^.location.reference),hregister); + end + else + begin + hregister:=getregistermmx; + emit_ref_reg(A_MOVQ,S_NO, + newreference(p^.left^.location.reference),hregister); + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_MMXREGISTER; + p^.location.register:=hregister; + end + else + { if on the right the register then swap } + if (p^.right^.location.loc=LOC_MMXREGISTER) then + begin + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + { at this point, p^.location.loc should be LOC_MMXREGISTER } + { and p^.location.register should be a valid register } + { containing the left result } + if p^.right^.location.loc<>LOC_MMXREGISTER then + begin + if (p^.treetype=subn) and p^.swaped then + begin + if p^.right^.location.loc=LOC_CMMXREGISTER then + begin + emit_reg_reg(A_MOVQ,S_NO,p^.right^.location.register,R_MM7); + emit_reg_reg(op,S_NO,p^.location.register,R_MM0); + emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register); + end + else + begin + emit_ref_reg(A_MOVQ,S_NO, + newreference(p^.right^.location.reference),R_MM7); + emit_reg_reg(op,S_NO,p^.location.register, + R_MM7); + emit_reg_reg(A_MOVQ,S_NO, + R_MM7,p^.location.register); + del_reference(p^.right^.location.reference); + end; + end + else + begin + if (p^.right^.location.loc=LOC_CREGISTER) then + begin + emit_reg_reg(op,S_NO,p^.right^.location.register, + p^.location.register); + end + else + begin + emit_ref_reg(op,S_NO,newreference( + p^.right^.location.reference),p^.location.register); + del_reference(p^.right^.location.reference); + end; + end; + end + else + begin + { when swapped another result register } + if (p^.treetype=subn) and p^.swaped then + begin + emit_reg_reg(op,S_NO, + p^.location.register,p^.right^.location.register); + swap_location(p^.location,p^.right^.location); + { newly swapped also set swapped flag } + { just to maintain ordering } + p^.swaped:=not(p^.swaped); + end + else + begin + emit_reg_reg(op,S_NO, + p^.right^.location.register, + p^.location.register); + end; + ungetregistermmx(p^.right^.location.register); + end; + end +{$endif SUPPORT_MMX} + else CGMessage(type_e_mismatch); + end; + SetResultLocation(cmpop,unsigned,p); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.103 2000/06/10 17:32:44 jonas + * fixed bug in shlmul code + + Revision 1.102 2000/05/26 20:16:00 jonas + * fixed wrong register deallocations in several ansistring related + procedures. The IDE's now function fine when compiled with -OG3p3r + + Revision 1.101 2000/04/25 14:43:36 jonas + - disabled "string_var := string_var + ... " and "string_var + char_var" + optimizations (were only active with -dnewoptimizations) because of + several internal issues + + Revision 1.100 2000/04/23 09:28:19 jonas + * use FPC_SHPRTSTR_CONCAT_LEN for -dnewoptimizations (temp) + * more precise reg deallocation when calling the above) + + Revision 1.99 2000/04/21 12:35:05 jonas + + special code for string + char, between -dnewoptimizations + + Revision 1.98 2000/04/10 12:23:19 jonas + * modified copyshortstring so it takes an extra paramter which allows it + to delete the sref itself (so the reg deallocations are put in the + right place for the optimizer) + + Revision 1.97 2000/02/29 23:57:36 pierre + Use $GOTO ON + + Revision 1.96 2000/02/18 21:25:48 florian + * fixed a bug in int64/qword handling was a quite ugly one + + Revision 1.95 2000/02/18 16:13:28 florian + * optimized ansistring compare with '' + * fixed 852 + + Revision 1.94 2000/02/14 22:34:28 florian + * fixed another internalerror + + Revision 1.93 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.92 2000/01/23 13:57:52 jonas + * fixed bug introduced by my regalloc fixed :( + + Revision 1.91 2000/01/23 11:11:36 michael + + Fixes from Jonas. + + Revision 1.90 2000/01/22 16:02:38 jonas + * fixed more regalloc bugs (for set adding and unsigned + multiplication) + + Revision 1.89 2000/01/13 16:52:47 jonas + * moved deallocation of registers used in reference that points to string after + copyshortstring (this routine doesn't require extra regs) + + Revision 1.88 2000/01/09 19:44:53 florian + * bug in secondadd(subn) with swaped mmx operands fixed + + Revision 1.87 2000/01/09 16:35:39 jonas + + comment about badly placed release_loc calls for a_mul which + causes wrong regdeallocations. Don't know how to fix :( + + Revision 1.86 2000/01/09 12:34:59 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.85 2000/01/09 01:44:18 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.84 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.83 1999/12/11 18:53:31 jonas + * fixed type conversions of results of operations with cardinals + (between -dcardinalmulfix) + + Revision 1.82 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.81 1999/09/28 19:43:45 florian + * the maybe_push fix of Pierre wasn't 100%, the tree parameter + must contain a valid location (which is saved if necessary) + + Revision 1.80 1999/09/26 13:26:01 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + + Revision 1.79 1999/09/21 20:53:21 florian + * fixed 1/s problem from mailing list + + Revision 1.78 1999/09/07 07:52:19 peter + * > < >= <= support for boolean + * boolean constants are now calculated like integer constants + + Revision 1.77 1999/08/30 12:00:45 pierre + * problem with maybe_push/restore solved hopefully + + Revision 1.76 1999/08/23 23:31:00 pierre + * double del_location removed in add_set + + Revision 1.75 1999/08/23 10:35:13 jonas + * fixed <= and >= for sets + + Revision 1.74 1999/08/19 13:08:43 pierre + * emit_??? used + + Revision 1.73 1999/08/07 11:29:26 peter + * better fix for muln register allocation + +} \ No newline at end of file diff --git a/befpc/compiler/cg386cal.pas b/befpc/compiler/cg386cal.pas new file mode 100644 index 0000000..4aca87c --- /dev/null +++ b/befpc/compiler/cg386cal.pas @@ -0,0 +1,1609 @@ +{ + $Id: cg386cal.pas,v 1.1.1.1 2001-07-23 17:15:32 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for in call nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published bymethodpointer + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg386cal; +interface + +{ $define AnsiStrRef} + + uses + symtable,tree; + + procedure secondcallparan(var p : ptree;defcoll : pparaitem; + push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint); + procedure secondcalln(var p : ptree); + procedure secondprocinline(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,aasm,types, +{$ifdef GDB} + strings,gdb, +{$endif GDB} + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386,cg386ld; + +{***************************************************************************** + SecondCallParaN +*****************************************************************************} + + procedure secondcallparan(var p : ptree;defcoll : pparaitem; + push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint); + + procedure maybe_push_high; + begin + { open array ? } + { defcoll^.data can be nil for read/write } + if assigned(defcoll^.paratype.def) and + push_high_param(defcoll^.paratype.def) then + begin + if assigned(p^.hightree) then + begin + secondpass(p^.hightree); + { this is a longint anyway ! } + push_value_para(p^.hightree,inlined,false,para_offset,4); + end + else + internalerror(432645); + end; + end; + + var + otlabel,oflabel : pasmlabel; + { temporary variables: } + tempdeftype : tdeftype; + r : preference; + begin + { set default para_alignment to target_os.stackalignment } + if para_alignment=0 then + para_alignment:=target_os.stackalignment; + + { push from left to right if specified } + if push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,pparaitem(defcoll^.next),push_from_left_to_right, + inlined,is_cdecl,para_alignment,para_offset); + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left); + { filter array constructor with c styled args } + if is_array_constructor(p^.left^.resulttype) and p^.left^.cargs then + begin + { nothing, everything is already pushed } + end + { in codegen.handleread.. defcoll^.data is set to nil } + else if assigned(defcoll^.paratype.def) and + (defcoll^.paratype.def^.deftype=formaldef) then + begin + { allow @var } + inc(pushedparasize,4); + if (p^.left^.treetype=addrn) and + (not p^.left^.procvarload) then + begin + { always a register } + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_reg_ref(A_MOV,S_L, + p^.left^.location.register,r); + end + else + emit_reg(A_PUSH,S_L,p^.left^.location.register); + ungetregister32(p^.left^.location.register); + end + else + begin + if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + CGMessage(type_e_mismatch) + else + begin + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_reg_ref(A_MOV,S_L,R_EDI,r); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end; + end; + end + { handle call by reference parameter } + else if (defcoll^.paratyp=vs_var) then + begin + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_var_must_be_reference); + maybe_push_high; + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_reg_ref(A_MOV,S_L,R_EDI,r); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + tempdeftype:=p^.resulttype^.deftype; + if tempdeftype=filedef then + CGMessage(cg_e_file_must_call_by_reference); + { open array must always push the address, this is needed to + also push addr of small arrays (PFV) } + + if ((assigned(defcoll^.paratype.def) and + is_open_array(defcoll^.paratype.def)) or + push_addr_param(p^.resulttype)) and + not is_cdecl then + begin + maybe_push_high; + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_reg_ref(A_MOV,S_L,R_EDI,r); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + push_value_para(p^.left,inlined,is_cdecl, + para_offset,para_alignment); + end; + end; + truelabel:=otlabel; + falselabel:=oflabel; + { push from right to left } + if not push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,pparaitem(defcoll^.next),push_from_left_to_right, + inlined,is_cdecl,para_alignment,para_offset); + end; + + +{***************************************************************************** + SecondCallN +*****************************************************************************} + + procedure secondcalln(var p : ptree); + var + unusedregisters : tregisterset; + usablecount : byte; + pushed : tpushed; + hr,funcretref : treference; + hregister,hregister2 : tregister; + oldpushedparasize : longint; + { true if ESI must be loaded again after the subroutine } + loadesi : boolean; + { true if a virtual method must be called directly } + no_virtual_call : boolean; + { true if we produce a con- or destrutor in a call } + is_con_or_destructor : boolean; + { true if a constructor is called again } + extended_new : boolean; + { adress returned from an I/O-error } + iolabel : pasmlabel; + { lexlevel count } + i : longint; + { help reference pointer } + r : preference; + hp, + pp,params : ptree; + inlined : boolean; + inlinecode : ptree; + para_alignment, + para_offset : longint; + { instruction for alignement correction } +{ corr : paicpu;} + { we must pop this size also after !! } +{ must_pop : boolean; } + pop_size : longint; + pop_allowed : boolean; +{$ifdef OPTALIGN} + pop_esp : boolean; + push_size : longint; +{$endif OPTALIGN} + + + label + dont_call; + + begin + reset_reference(p^.location.reference); + extended_new:=false; + iolabel:=nil; + inlinecode:=nil; + inlined:=false; + loadesi:=true; + no_virtual_call:=false; + unusedregisters:=unused; + usablecount:=usablereg32; + + if (pocall_cdecl in p^.procdefinition^.proccalloptions) or + (pocall_stdcall in p^.procdefinition^.proccalloptions) then + para_alignment:=4 + else + para_alignment:=target_os.stackalignment; + + if not assigned(p^.procdefinition) then + exit; + + { Deciding whether we may still need the parameters happens next (JM) } + params:=p^.left; + + if (pocall_inline in p^.procdefinition^.proccalloptions) then + begin + { make a copy for the next time the procedure is inlined (JM) } + p^.left:=getcopy(p^.left); + inlined:=true; + inlinecode:=p^.right; + { set it to the same lexical level as the local symtable, becuase + the para's are stored there } + pprocdef(p^.procdefinition)^.parast^.symtablelevel:=aktprocsym^.definition^.localst^.symtablelevel; + if assigned(params) then + inlinecode^.para_offset:=gettempofsizepersistant(inlinecode^.para_size); + pprocdef(p^.procdefinition)^.parast^.address_fixup:=inlinecode^.para_offset; +{$ifdef extdebug} + Comment(V_debug, + 'inlined parasymtable is at offset ' + +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup)); + exprasmlist^.concat(new(pai_asm_comment,init( + strpnew('inlined parasymtable is at offset ' + +tostr(pprocdef(p^.procdefinition)^.parast^.address_fixup))))); +{$endif extdebug} + { copy for the next time the procedure is inlined (JM) } + p^.right:=getcopy(p^.right); + { disable further inlining of the same proc + in the args } +{$ifdef INCLUDEOK} + exclude(p^.procdefinition^.proccalloptions,pocall_inline); +{$else} + p^.procdefinition^.proccalloptions:=p^.procdefinition^.proccalloptions-[pocall_inline]; +{$endif} + end + else + { parameters not necessary anymore (JM) } + p^.left := nil; + { only if no proc var } + if inlined or + not(assigned(p^.right)) then + is_con_or_destructor:=(p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]); + { proc variables destroy all registers } + if (inlined or + (p^.right=nil)) and + { virtual methods too } + not(po_virtualmethod in p^.procdefinition^.procoptions) then + begin + if (cs_check_io in aktlocalswitches) and + (po_iocheck in p^.procdefinition^.procoptions) and + not(po_iocheck in aktprocsym^.definition^.procoptions) then + begin + getlabel(iolabel); + emitlab(iolabel); + end + else + iolabel:=nil; + + { save all used registers } + pushusedregisters(pushed,pprocdef(p^.procdefinition)^.usedregisters); + + { give used registers through } + usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters; + end + else + begin + pushusedregisters(pushed,$ff); + usedinproc:=$ff; + { no IO check for methods and procedure variables } + iolabel:=nil; + end; + + { generate the code for the parameter and push them } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + pop_size:=0; + { no inc esp for inlined procedure + and for objects constructors PM } + if (inlined or + (p^.right=nil)) and + (p^.procdefinition^.proctypeoption=potype_constructor) and + { quick'n'dirty check if it is a class or an object } + (p^.resulttype^.deftype=orddef) then + pop_allowed:=false + else + pop_allowed:=true; + if pop_allowed then + begin + { Old pushedsize aligned on 4 ? } + i:=oldpushedparasize and 3; + if i>0 then + inc(pop_size,4-i); + { This parasize aligned on 4 ? } + i:=p^.procdefinition^.para_size(para_alignment) and 3; + if i>0 then + inc(pop_size,4-i); + { insert the opcode and update pushedparasize } + { never push 4 or more !! } + pop_size:=pop_size mod 4; + if pop_size>0 then + begin + inc(pushedparasize,pop_size); + emit_const_reg(A_SUB,S_L,pop_size,R_ESP); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (exprasmlist^.first=exprasmlist^.last) then + exprasmlist^.concat(new(pai_force_line,init)); +{$endif GDB} + end; + end; +{$ifdef OPTALIGN} + if pop_allowed and (cs_align in aktglobalswitches) then + begin + pop_esp:=true; + push_size:=p^.procdefinition^.para_size(para_alignment); + { !!!! here we have to take care of return type, self + and nested procedures + } + inc(push_size,12); + emit_reg_reg(A_MOV,S_L,R_ESP,R_EDI); + if (push_size mod 8)=0 then + emit_const_reg(A_AND,S_L,$fffffff8,R_ESP) + else + begin + emit_const_reg(A_SUB,S_L,push_size,R_ESP); + emit_const_reg(A_AND,S_L,$fffffff8,R_ESP); + emit_const_reg(A_SUB,S_L,push_size,R_ESP); + end; + emit_reg(A_PUSH,S_L,R_EDI); + end + else + pop_esp:=false; +{$endif OPTALIGN} + if (p^.resulttype<>pdef(voiddef)) and + ret_in_param(p^.resulttype) then + begin + funcretref.symbol:=nil; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) and + (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then + begin + funcretref:=dest_loc.reference; + if assigned(dest_loc.reference.symbol) then + funcretref.symbol:=stringdup(dest_loc.reference.symbol^); + in_dest_loc:=true; + end + else +{$endif test_dest_loc} + if inlined then + begin + reset_reference(funcretref); + funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.rettype.def^.size); + funcretref.base:=procinfo^.framepointer; + end + else + gettempofsizereference(p^.procdefinition^.rettype.def^.size,funcretref); + end; + if assigned(params) then + begin + { be found elsewhere } + if inlined then + para_offset:=pprocdef(p^.procdefinition)^.parast^.address_fixup+ + pprocdef(p^.procdefinition)^.parast^.datasize + else + para_offset:=0; + if not(inlined) and + assigned(p^.right) then + secondcallparan(params,pparaitem(pabstractprocdef(p^.right^.resulttype)^.para^.first), + (pocall_leftright in p^.procdefinition^.proccalloptions),inlined, + (pocall_cdecl in p^.procdefinition^.proccalloptions), + para_alignment,para_offset) + else + secondcallparan(params,pparaitem(p^.procdefinition^.para^.first), + (pocall_leftright in p^.procdefinition^.proccalloptions),inlined, + (pocall_cdecl in p^.procdefinition^.proccalloptions), + para_alignment,para_offset); + end; + if inlined then + inlinecode^.retoffset:=gettempofsizepersistant(4); + if ret_in_param(p^.resulttype) then + begin + { This must not be counted for C code + complex return address is removed from stack + by function itself ! } +{$ifdef OLD_C_STACK} + inc(pushedparasize,4); { lets try without it PM } +{$endif not OLD_C_STACK} + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(funcretref),R_EDI); + r:=new_reference(procinfo^.framepointer,inlinecode^.retoffset); + emit_reg_ref(A_MOV,S_L,R_EDI,r); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emitpushreferenceaddr(funcretref); + end; + { procedure variable ? } + if inlined or + (p^.right=nil) then + begin + { overloaded operator have no symtable } + { push self } + if assigned(p^.symtable) and + (p^.symtable^.symtabletype=withsymtable) then + begin + { dirty trick to avoid the secondcall below } + p^.methodpointer:=genzeronode(callparan); + p^.methodpointer^.location.loc:=LOC_REGISTER; +{$ifndef noAllocEDI} + getexplicitregister32(R_ESI); +{$endif noAllocEDI} + p^.methodpointer^.location.register:=R_ESI; + { ARGHHH this is wrong !!! + if we can init from base class for a child + class that the wrong VMT will be + transfered to constructor !! } + p^.methodpointer^.resulttype:= + ptree(pwithsymtable(p^.symtable)^.withnode)^.left^.resulttype; + { change dispose type !! } + p^.disposetyp:=dt_mbleft_and_method; + { make a reference } + new(r); + reset_reference(r^); + { if assigned(ptree(pwithsymtable(p^.symtable)^.withnode)^.pref) then + begin + r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.pref^; + end + else + begin + r^.offset:=p^.symtable^.datasize; + r^.base:=procinfo^.framepointer; + end; } + r^:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; + if (not pwithsymtable(p^.symtable)^.direct_with) or + pobjectdef(p^.methodpointer^.resulttype)^.is_class then + emit_ref_reg(A_MOV,S_L,r,R_ESI) + else + emit_ref_reg(A_LEA,S_L,r,R_ESI); + end; + + { push self } + if assigned(p^.symtable) and + ((p^.symtable^.symtabletype=objectsymtable) or + (p^.symtable^.symtabletype=withsymtable)) then + begin + if assigned(p^.methodpointer) then + begin + { + if p^.methodpointer^.resulttype=classrefdef then + begin + two possibilities: + 1. constructor + 2. class method + + end + else } + begin + case p^.methodpointer^.treetype of + typen: + begin + { direct call to inherited method } + if (po_abstractmethod in p^.procdefinition^.procoptions) then + begin + CGMessage(cg_e_cant_call_abstract_method); + goto dont_call; + end; + { generate no virtual call } + no_virtual_call:=true; + + if (sp_static in p^.symtableprocentry^.symoptions) then + begin + { well lets put the VMT address directly into ESI } + { it is kind of dirty but that is the simplest } + { way to accept virtual static functions (PM) } + loadesi:=true; + { if no VMT just use $0 bug0214 PM } +{$ifndef noAllocEDI} + getexplicitregister32(R_ESI); +{$endif noAllocEDI} + if not(oo_has_vmt in pobjectdef(p^.methodpointer^.resulttype)^.objectoptions) then + emit_const_reg(A_MOV,S_L,0,R_ESI) + else + begin + emit_sym_ofs_reg(A_MOV,S_L, + newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname), + 0,R_ESI); + end; + { emit_reg(A_PUSH,S_L,R_ESI); + this is done below !! } + end + else + { this is a member call, so ESI isn't modfied } + loadesi:=false; + + { a class destructor needs a flag } + if pobjectdef(p^.methodpointer^.resulttype)^.is_class and + {assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption=potype_destructor)} + (p^.procdefinition^.proctypeoption=potype_destructor) then + begin + push_int(0); + emit_reg(A_PUSH,S_L,R_ESI); + end; + + if not(is_con_or_destructor and + pobjectdef(p^.methodpointer^.resulttype)^.is_class and + {assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])} + (p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) + ) then + emit_reg(A_PUSH,S_L,R_ESI); + { if an inherited con- or destructor should be } + { called in a con- or destructor then a warning } + { will be made } + { con- and destructors need a pointer to the vmt } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and + assigned(aktprocsym) then + begin + if not(aktprocsym^.definition^.proctypeoption in + [potype_constructor,potype_destructor]) then + CGMessage(cg_w_member_cd_call_from_method); + end; + { class destructors get there flag above } + { constructor flags ? } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and + assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption=potype_destructor)) then + begin + { a constructor needs also a flag } + if pobjectdef(p^.methodpointer^.resulttype)^.is_class then + push_int(0); + push_int(0); + end; + end; + hnewn: + begin + { extended syntax of new } + { ESI must be zero } +{$ifndef noAllocEDI} + getexplicitregister32(R_ESI); +{$endif noAllocEDI} + emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI); + emit_reg(A_PUSH,S_L,R_ESI); + { insert the vmt } + emit_sym(A_PUSH,S_L, + newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)); + extended_new:=true; + end; + hdisposen: + begin + secondpass(p^.methodpointer); + + { destructor with extended syntax called from dispose } + { hdisposen always deliver LOC_REFERENCE } +{$ifndef noAllocEDI} + getexplicitregister32(R_ESI); +{$endif noAllocEDI} + emit_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI); + del_reference(p^.methodpointer^.location.reference); + emit_reg(A_PUSH,S_L,R_ESI); + emit_sym(A_PUSH,S_L, + newasmsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)); + end; + else + begin + { call to an instance member } + if (p^.symtable^.symtabletype<>withsymtable) then + begin + secondpass(p^.methodpointer); +{$ifndef noAllocEDI} + getexplicitregister32(R_ESI); +{$endif noAllocEDI} + case p^.methodpointer^.location.loc of + LOC_CREGISTER, + LOC_REGISTER: + begin + emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI); + ungetregister32(p^.methodpointer^.location.register); + end; + else + begin + if (p^.methodpointer^.resulttype^.deftype=classrefdef) or + ((p^.methodpointer^.resulttype^.deftype=objectdef) and + pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + emit_ref_reg(A_MOV,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI) + else + emit_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_ESI); + del_reference(p^.methodpointer^.location.reference); + end; + end; + end; + { when calling a class method, we have to load ESI with the VMT ! + But, not for a class method via self } + if not(po_containsself in p^.procdefinition^.procoptions) then + begin + if (po_classmethod in p^.procdefinition^.procoptions) and + not(p^.methodpointer^.resulttype^.deftype=classrefdef) then + begin + { class method needs current VMT } + getexplicitregister32(R_ESI); + new(r); + reset_reference(r^); + r^.base:=R_ESI; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + emit_ref_reg(A_MOV,S_L,r,R_ESI); + end; + + { direct call to destructor: remove data } + if (p^.procdefinition^.proctypeoption=potype_destructor) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + emit_const(A_PUSH,S_L,1); + + { direct call to class constructor, don't allocate memory } + if (p^.procdefinition^.proctypeoption=potype_constructor) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + begin + emit_const(A_PUSH,S_L,0); + emit_const(A_PUSH,S_L,0); + end + else + begin + { constructor call via classreference => allocate memory } + if (p^.procdefinition^.proctypeoption=potype_constructor) and + (p^.methodpointer^.resulttype^.deftype=classrefdef) and + (pobjectdef(pclassrefdef(p^.methodpointer^.resulttype)^. + pointertype.def)^.is_class) then + emit_const(A_PUSH,S_L,1); + emit_reg(A_PUSH,S_L,R_ESI); + end; + end; + + if is_con_or_destructor then + begin + { classes don't get a VMT pointer pushed } + if (p^.methodpointer^.resulttype^.deftype=objectdef) and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + begin + if (p^.procdefinition^.proctypeoption=potype_constructor) then + begin + { it's no bad idea, to insert the VMT } + emit_sym(A_PUSH,S_L,newasmsymbol( + pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)); + end + { destructors haven't to dispose the instance, if this is } + { a direct call } + else + push_int(0); + end; + end; + end; + end; + end; + end + else + begin + if (po_classmethod in p^.procdefinition^.procoptions) and + not( + assigned(aktprocsym) and + (po_classmethod in aktprocsym^.definition^.procoptions) + ) then + begin + { class method needs current VMT } + getexplicitregister32(R_ESI); + new(r); + reset_reference(r^); + r^.base:=R_ESI; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + emit_ref_reg(A_MOV,S_L,r,R_ESI); + end + else + begin + { member call, ESI isn't modified } + loadesi:=false; + end; + { direct call to destructor: don't remove data! } + if procinfo^._class^.is_class then + begin + if (p^.procdefinition^.proctypeoption=potype_destructor) then + begin + emit_const(A_PUSH,S_L,0); + emit_reg(A_PUSH,S_L,R_ESI); + end + else if (p^.procdefinition^.proctypeoption=potype_constructor) then + begin + emit_const(A_PUSH,S_L,0); + emit_const(A_PUSH,S_L,0); + end + else + emit_reg(A_PUSH,S_L,R_ESI); + end + else + begin + emit_reg(A_PUSH,S_L,R_ESI); + if is_con_or_destructor then + begin + if (p^.procdefinition^.proctypeoption=potype_constructor) then + begin + { it's no bad idea, to insert the VMT } + emit_sym(A_PUSH,S_L,newasmsymbol( + procinfo^._class^.vmt_mangledname)); + end + { destructors haven't to dispose the instance, if this is } + { a direct call } + else + push_int(0); + end; + end; + end; + end; + + { push base pointer ?} + if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and + ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then + begin + { if we call a nested function in a method, we must } + { push also SELF! } + { THAT'S NOT TRUE, we have to load ESI via frame pointer } + { access } + { + begin + loadesi:=false; + emit_reg(A_PUSH,S_L,R_ESI); + end; + } + if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + new(r); + reset_reference(r^); + r^.offset:=procinfo^.framepointer_offset; + r^.base:=procinfo^.framepointer; + emit_ref(A_PUSH,S_L,r) + end + { this is only true if the difference is one !! + but it cannot be more !! } + else if (lexlevel=pprocdef(p^.procdefinition)^.parast^.symtablelevel-1) then + begin + emit_reg(A_PUSH,S_L,procinfo^.framepointer) + end + else if (lexlevel>pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + hregister:=getregister32; + new(r); + reset_reference(r^); + r^.offset:=procinfo^.framepointer_offset; + r^.base:=procinfo^.framepointer; + emit_ref_reg(A_MOV,S_L,r,hregister); + for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do + begin + new(r); + reset_reference(r^); + {we should get the correct frame_pointer_offset at each level + how can we do this !!! } + r^.offset:=procinfo^.framepointer_offset; + r^.base:=hregister; + emit_ref_reg(A_MOV,S_L,r,hregister); + end; + emit_reg(A_PUSH,S_L,hregister); + ungetregister32(hregister); + end + else + internalerror(25000); + end; + + if (po_virtualmethod in p^.procdefinition^.procoptions) and + not(no_virtual_call) then + begin + { static functions contain the vmt_address in ESI } + { also class methods } + { Here it is quite tricky because it also depends } + { on the methodpointer PM } + getexplicitregister32(R_ESI); + if assigned(aktprocsym) then + begin + if (((sp_static in aktprocsym^.symoptions) or + (po_classmethod in aktprocsym^.definition^.procoptions)) and + ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen))) + or + (po_staticmethod in p^.procdefinition^.procoptions) or + ((p^.procdefinition^.proctypeoption=potype_constructor) and + { esi contains the vmt if we call a constructor via a class ref } + assigned(p^.methodpointer) and + (p^.methodpointer^.resulttype^.deftype=classrefdef) + ) or + { ESI is loaded earlier } + (po_classmethod in p^.procdefinition^.procoptions) then + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + end + else + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + { this is one point where we need vmt_offset (PM) } + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,r,R_EDI); + new(r); + reset_reference(r^); + r^.base:=R_EDI; + end; + end + else + { aktprocsym should be assigned, also in main program } + internalerror(12345); + { + begin + new(r); + reset_reference(r^); + r^.base:=R_ESI; + emit_ref_reg(A_MOV,S_L,r,R_EDI); + new(r); + reset_reference(r^); + r^.base:=R_EDI; + end; + } + if pprocdef(p^.procdefinition)^.extnumber=-1 then + internalerror(44584); + r^.offset:=pprocdef(p^.procdefinition)^._class^.vmtmethodoffset(pprocdef(p^.procdefinition)^.extnumber); + if (cs_check_object_ext in aktlocalswitches) then + begin + emit_sym(A_PUSH,S_L, + newasmsymbol(pprocdef(p^.procdefinition)^._class^.vmt_mangledname)); + emit_reg(A_PUSH,S_L,r^.base); + emitcall('FPC_CHECK_OBJECT_EXT'); + end + else if (cs_check_range in aktlocalswitches) then + begin + emit_reg(A_PUSH,S_L,r^.base); + emitcall('FPC_CHECK_OBJECT'); + end; + emit_ref(A_CALL,S_NO,r); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else if not inlined then + begin + { We can call interrupts from within the smae code + by just pushing the flags and CS PM } + if (po_interrupt in p^.procdefinition^.procoptions) then + begin + emit_none(A_PUSHF,S_L); + emit_reg(A_PUSH,S_L,R_CS); + end; + emitcall(pprocdef(p^.procdefinition)^.mangledname); + end + else { inlined proc } + { inlined code is in inlinecode } + begin + { set poinline again } +{$ifdef INCLUDEOK} + include(p^.procdefinition^.proccalloptions,pocall_inline); +{$else} + p^.procdefinition^.proccalloptions:=p^.procdefinition^.proccalloptions+[pocall_inline]; +{$endif} + { process the inlinecode } + secondpass(inlinecode); + { free the args } + if pprocdef(p^.procdefinition)^.parast^.datasize>0 then + ungetpersistanttemp(pprocdef(p^.procdefinition)^.parast^.address_fixup); + end; + end + else + { now procedure variable case } + begin + secondpass(p^.right); + if (po_interrupt in p^.procdefinition^.procoptions) then + begin + emit_none(A_PUSHF,S_L); + emit_reg(A_PUSH,S_L,R_CS); + end; + { procedure of object? } + if (po_methodpointer in p^.procdefinition^.procoptions) then + begin + { method pointer can't be in a register } + hregister:=R_NO; + + { do some hacking if we call a method pointer } + { which is a class member } + { else ESI is overwritten ! } + if (p^.right^.location.reference.base=R_ESI) or + (p^.right^.location.reference.index=R_ESI) then + begin + del_reference(p^.right^.location.reference); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(p^.right^.location.reference),R_EDI); + hregister:=R_EDI; + end; + + { load self, but not if it's already explicitly pushed } + if not(po_containsself in p^.procdefinition^.procoptions) then + begin + { load ESI } + inc(p^.right^.location.reference.offset,4); + getexplicitregister32(R_ESI); + emit_ref_reg(A_MOV,S_L, + newreference(p^.right^.location.reference),R_ESI); + dec(p^.right^.location.reference.offset,4); + { push self pointer } + emit_reg(A_PUSH,S_L,R_ESI); + end; + + if hregister=R_NO then + emit_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)) + else + begin +{$ifndef noAllocEdi} + ungetregister32(hregister); +{$else noAllocEdi} + { the same code, the previous line is just to } + { indicate EDI actually is deallocated if allocated } + { above (JM) } + ungetregister32(hregister); +{$endif noAllocEdi} + emit_reg(A_CALL,S_NO,hregister); + end; + + del_reference(p^.right^.location.reference); + end + else + begin + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_CALL,S_NO,p^.right^.location.register); + ungetregister32(p^.right^.location.register); + end + else + emit_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)); + del_reference(p^.right^.location.reference); + end; + end; + end; + + { this was only for normal functions + displaced here so we also get + it to work for procvars PM } + if (not inlined) and (pocall_clearstack in p^.procdefinition^.proccalloptions) then + begin + { we also add the pop_size which is included in pushedparasize } + pop_size:=0; + { better than an add on all processors } + if pushedparasize=4 then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + { the pentium has two pipes and pop reg is pairable } + { but the registers must be different! } + else if (pushedparasize=8) and + not(cs_littlesize in aktglobalswitches) and + (aktoptprocessor=ClassP5) and + (procinfo^._class=nil) then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} +{$ifndef noAllocEdi} + exprasmlist^.concat(new(pairegalloc,alloc(R_ESI))); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_ESI); +{$ifndef noAllocEdi} + exprasmlist^.concat(new(pairegalloc,alloc(R_ESI))); +{$endif noAllocEdi} + end + else if pushedparasize<>0 then + emit_const_reg(A_ADD,S_L,pushedparasize,R_ESP); + end; +{$ifdef OPTALIGN} + if pop_esp then + emit_reg(A_POP,S_L,R_ESP); +{$endif OPTALIGN} + dont_call: + pushedparasize:=oldpushedparasize; + unused:=unusedregisters; + usablereg32:=usablecount; +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + + { a constructor could be a function with boolean result } + { if calling constructor called fail we + must jump directly to quickexitlabel PM + but only if it is a call of an inherited constructor } + if (inlined or + (p^.right=nil)) and + (p^.procdefinition^.proctypeoption=potype_constructor) and + assigned(p^.methodpointer) and + (p^.methodpointer^.treetype=typen) and + (aktprocsym^.definition^.proctypeoption=potype_constructor) then + begin + emitjmp(C_Z,faillabel); + end; + { handle function results } + { structured results are easy to handle.... } + { needed also when result_no_used !! } + if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.symbol:=nil; + p^.location.reference:=funcretref; + end; + { we have only to handle the result if it is used, but } + { ansi/widestrings must be registered, so we can dispose them } + if (p^.resulttype<>pdef(voiddef)) and (p^.return_value_used or + is_ansistring(p^.resulttype) or is_widestring(p^.resulttype)) then + begin + { a contructor could be a function with boolean result } + if (inlined or + (p^.right=nil)) and + (p^.procdefinition^.proctypeoption=potype_constructor) and + { quick'n'dirty check if it is a class or an object } + (p^.resulttype^.deftype=orddef) then + begin + { this fails if popsize > 0 PM } + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_NE; + + + if extended_new then + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + end + { structed results are easy to handle.... } + else if ret_in_param(p^.resulttype) then + begin + {p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=funcretref; + already done above (PM) } + end + else + begin + if (p^.resulttype^.deftype in [orddef,enumdef]) then + begin + p^.location.loc:=LOC_REGISTER; + case p^.resulttype^.size of + 4 : + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + 1 : + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_B,R_AL) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); + p^.location.register:=reg32toreg8(hregister); + end; + end; + 2 : + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_W,R_AX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); + p^.location.register:=reg32toreg16(hregister); + end; + end; + 8 : + begin +{$ifdef test_dest_loc} +{$error Don't know what to do here} +{$endif test_dest_loc} + hregister:=getexplicitregister32(R_EAX); + hregister2:=getexplicitregister32(R_EDX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + emit_reg_reg(A_MOV,S_L,R_EDX,hregister2); + p^.location.registerlow:=hregister; + p^.location.registerhigh:=hregister2; + end; + else internalerror(7); + end + + end + else if (p^.resulttype^.deftype=floatdef) then + case pfloatdef(p^.resulttype)^.typ of + f32bit: + begin + p^.location.loc:=LOC_REGISTER; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + else + begin + p^.location.loc:=LOC_FPU; + inc(fpuvaroffset); + end; + end + else if is_ansistring(p^.resulttype) or + is_widestring(p^.resulttype) then + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + gettempansistringreference(hr); + decrstringref(p^.resulttype,hr); + emit_reg_ref(A_MOV,S_L,hregister, + newreference(hr)); + ungetregister32(hregister); + p^.location.loc:=LOC_MEM; + p^.location.reference:=hr; + end + else + begin + p^.location.loc:=LOC_REGISTER; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + begin + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + p^.location.register:=hregister; + end; + end; + end; + end; + + { perhaps i/o check ? } + if iolabel<>nil then + begin + emit_sym(A_PUSH,S_L,iolabel); + emitcall('FPC_IOCHECK'); + end; + if pop_size>0 then + emit_const_reg(A_ADD,S_L,pop_size,R_ESP); + + { restore registers } + popusedregisters(pushed); + + { at last, restore instance pointer (SELF) } + if loadesi then + maybe_loadesi; + pp:=params; + while assigned(pp) do + begin + if assigned(pp^.left) then + begin + if (pp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) then + ungetiftemp(pp^.left^.location.reference); + { process also all nodes of an array of const } + if pp^.left^.treetype=arrayconstructn then + begin + if assigned(pp^.left^.left) then + begin + hp:=pp^.left; + while assigned(hp) do + begin + if (hp^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) then + ungetiftemp(hp^.left^.location.reference); + hp:=hp^.right; + end; + end; + end; + end; + pp:=pp^.right; + end; + if inlined then + ungetpersistanttemp(inlinecode^.retoffset); + if assigned(inlinecode) then + disposetree(inlinecode); + disposetree(params); + + + { from now on the result can be freed normally } + if inlined and ret_in_param(p^.resulttype) then + persistanttemptonormal(funcretref.offset); + + { if return value is not used } + if (not p^.return_value_used) and (p^.resulttype<>pdef(voiddef)) then + begin + if p^.location.loc in [LOC_MEM,LOC_REFERENCE] then + begin + { data which must be finalized ? } + if (p^.resulttype^.needs_inittable) and + ( (p^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.resulttype)^.is_class)) then + finalize(p^.resulttype,p^.location.reference,ret_in_param(p^.resulttype)); + { release unused temp } + ungetiftemp(p^.location.reference) + end + else if p^.location.loc=LOC_FPU then + begin + { release FPU stack } + emit_reg(A_FSTP,S_NO,R_ST0); + { + dec(fpuvaroffset); + do NOT decrement as the increment before + is not called for unused results PM } + end; + end; + end; + + +{***************************************************************************** + SecondProcInlineN +*****************************************************************************} + + + procedure secondprocinline(var p : ptree); + var st : psymtable; + oldprocsym : pprocsym; + para_size : longint; + oldprocinfo : pprocinfo; + oldinlining_procedure, + nostackframe,make_global : boolean; + proc_names : tstringcontainer; + inlineentrycode,inlineexitcode : paasmoutput; + oldexitlabel,oldexit2label,oldquickexitlabel:Pasmlabel; +{$ifdef GDB} + startlabel,endlabel : pasmlabel; + pp : pchar; + mangled_length : longint; +{$endif GDB} + begin + oldinlining_procedure:=inlining_procedure; + oldexitlabel:=aktexitlabel; + oldexit2label:=aktexit2label; + oldquickexitlabel:=quickexitlabel; + getlabel(aktexitlabel); + getlabel(aktexit2label); + oldprocsym:=aktprocsym; + { we're inlining a procedure } + inlining_procedure:=true; + { save old procinfo } + getmem(oldprocinfo,sizeof(tprocinfo)); + move(procinfo^,oldprocinfo^,sizeof(tprocinfo)); + { set the return value } + aktprocsym:=p^.inlineprocsym; + procinfo^.returntype:=aktprocsym^.definition^.rettype; + procinfo^.return_offset:=p^.retoffset; + procinfo^.para_offset:=p^.para_offset; + { arg space has been filled by the parent secondcall } + st:=aktprocsym^.definition^.localst; + { set it to the same lexical level } + st^.symtablelevel:=oldprocsym^.definition^.localst^.symtablelevel; + if st^.datasize>0 then + begin + st^.address_fixup:=gettempofsizepersistant(st^.datasize)+st^.datasize; +{$ifdef extdebug} + Comment(V_debug,'local symtable is at offset '+tostr(st^.address_fixup)); + exprasmlist^.concat(new(pai_asm_comment,init(strpnew( + 'local symtable is at offset '+tostr(st^.address_fixup))))); +{$endif extdebug} + end; + exprasmlist^.concat(new(Pai_Marker, Init(InlineStart))); +{$ifdef extdebug} + exprasmlist^.concat(new(pai_asm_comment,init(strpnew('Start of inlined proc')))); +{$endif extdebug} +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + getlabel(startlabel); + getlabel(endlabel); + emitlab(startlabel); + p^.inlineprocsym^.definition^.localst^.symtabletype:=inlinelocalsymtable; + p^.inlineprocsym^.definition^.parast^.symtabletype:=inlineparasymtable; + + { Here we must include the para and local symtable info } + p^.inlineprocsym^.concatstabto(withdebuglist); + + { set it back for savety } + p^.inlineprocsym^.definition^.localst^.symtabletype:=localsymtable; + p^.inlineprocsym^.definition^.parast^.symtabletype:=parasymtable; + + mangled_length:=length(oldprocsym^.definition^.mangledname); + getmem(pp,mangled_length+50); + strpcopy(pp,'192,0,0,'+startlabel^.name); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(pp),'-'); + strpcopy(strend(pp),oldprocsym^.definition^.mangledname); + end; + withdebuglist^.concat(new(pai_stabn,init(strnew(pp)))); + end; +{$endif GDB} + { takes care of local data initialization } + inlineentrycode:=new(paasmoutput,init); + inlineexitcode:=new(paasmoutput,init); + proc_names.init; + para_size:=p^.para_size; + make_global:=false; { to avoid warning } + genentrycode(inlineentrycode,proc_names,make_global,0,para_size,nostackframe,true); + exprasmlist^.concatlist(inlineentrycode); + secondpass(p^.inlinetree); + genexitcode(inlineexitcode,0,false,true); + exprasmlist^.concatlist(inlineexitcode); + + dispose(inlineentrycode,done); + dispose(inlineexitcode,done); +{$ifdef extdebug} + exprasmlist^.concat(new(pai_asm_comment,init(strpnew('End of inlined proc')))); +{$endif extdebug} + exprasmlist^.concat(new(Pai_Marker, Init(InlineEnd))); + + {we can free the local data now, reset also the fixup address } + if st^.datasize>0 then + begin + ungetpersistanttemp(st^.address_fixup-st^.datasize); + st^.address_fixup:=0; + end; + { restore procinfo } + move(oldprocinfo^,procinfo^,sizeof(tprocinfo)); + freemem(oldprocinfo,sizeof(tprocinfo)); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + emitlab(endlabel); + strpcopy(pp,'224,0,0,'+endlabel^.name); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(pp),'-'); + strpcopy(strend(pp),oldprocsym^.definition^.mangledname); + end; + withdebuglist^.concat(new(pai_stabn,init(strnew(pp)))); + freemem(pp,mangled_length+50); + end; +{$endif GDB} + { restore } + aktprocsym:=oldprocsym; + aktexitlabel:=oldexitlabel; + aktexit2label:=oldexit2label; + quickexitlabel:=oldquickexitlabel; + inlining_procedure:=oldinlining_procedure; + end; + + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.138 2000/07/05 20:39:55 florian + * virtual contructors weren't handled properly if they were called via a class + variable + + Revision 1.137 2000/06/29 13:50:30 jonas + * fixed inline bugs (calling an inlined procedure more than once didn't + work) + + Revision 1.136 2000/06/04 09:05:05 peter + * fix addrn with procvar, also detected by testpva2 ! + + Revision 1.135 2000/05/31 09:29:15 florian + * stack alignment to 8 byte boundaries with -Oa switch + + Revision 1.134 2000/05/16 20:19:05 pierre + + -CR option to enable check for object virtual method + + Revision 1.133 2000/05/15 19:30:27 peter + * fixed calling of inherited methods from destructors + + Revision 1.132 2000/05/09 14:15:03 pierre + * also allow interrupt procvars + + Revision 1.131 2000/05/09 10:54:03 pierre + add code to allow calling interrupt routines + + Revision 1.130 2000/03/31 22:56:45 pierre + * fix the handling of value parameters in cdecl function + + Revision 1.129 2000/03/19 08:17:36 peter + * tp7 fix + + Revision 1.128 2000/03/16 15:18:13 pierre + * avoid wrong ungetpersistanttemp + + Revision 1.127 2000/03/01 00:03:11 pierre + * fixes for locals in inlined procedures + fix for bug797 + + stabs generation for inlined paras and locals + + Revision 1.126 2000/02/09 18:08:33 jonas + * added regallocs for esi + + Revision 1.125 2000/02/09 13:22:45 peter + * log truncated + + Revision 1.124 2000/02/04 20:00:21 florian + * an exception in a construcor calls now the destructor (this applies only + to classes) + + Revision 1.123 2000/01/26 15:03:59 peter + * fixed pop_size included twice with clearstack + + Revision 1.122 2000/01/26 12:02:29 peter + * abstractprocdef.para_size needs alignment parameter + * secondcallparan gets para_alignment size instead of dword_align + + Revision 1.121 2000/01/23 18:50:07 peter + * fixed missing push esi for constructor calling + + Revision 1.120 2000/01/21 22:06:16 florian + * fixed for the fix of bug 793 + * fpu variables modified by nested subroutines aren't regable anymore + * $maxfpuregisters doesn't modify anymore the behavior of a procedure before + + Revision 1.119 2000/01/21 12:17:41 jonas + * regallocation fixes + + Revision 1.118 2000/01/20 12:14:47 florian + * bug 793 fixed + + Revision 1.117 2000/01/16 22:17:11 peter + * renamed call_offset to para_offset + + Revision 1.116 2000/01/09 12:35:00 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.115 2000/01/09 01:44:19 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.114 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.113 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.112 1999/12/13 21:49:54 pierre + * bug in extdebugg code for inlined procedures + + Revision 1.111 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.110 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.109 1999/11/04 00:23:58 pierre + * fix for fpuvaroffset for unused return value + + Revision 1.108 1999/10/26 12:30:40 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.107 1999/10/08 15:40:47 pierre + * use and remember that C functions with complex data results use ret $4 + + Revision 1.106 1999/09/27 23:44:46 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.105 1999/09/26 13:26:02 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + +} \ No newline at end of file diff --git a/befpc/compiler/cg386cnv.pas b/befpc/compiler/cg386cnv.pas new file mode 100644 index 0000000..affe32f --- /dev/null +++ b/befpc/compiler/cg386cnv.pas @@ -0,0 +1,1627 @@ +{ + $Id: cg386cnv.pas,v 1.1.1.1 2001-07-23 17:15:33 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for type converting nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$E+,F+,N+,D+,L+,Y+} +{$endif} +unit cg386cnv; +interface + + uses + tree; + + procedure loadshortstring(p:ptree); + procedure loadlongstring(p:ptree); + procedure loadansi2short(source,dest : ptree); + + procedure secondtypeconv(var p : ptree); + procedure secondas(var p : ptree); + procedure secondis(var p : ptree); + + +implementation + + uses + cobjects,verbose,globtype,globals,systems, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2,pass_1, + cpubase,cpuasm, + cgai386,tgeni386; + + + + procedure push_shortstring_length(p:ptree); + var + hightree : ptree; + begin + if is_open_string(p^.resulttype) then + begin + getsymonlyin(p^.symtable,'high'+pvarsym(p^.symtableentry)^.name); + hightree:=genloadnode(pvarsym(srsym),p^.symtable); + firstpass(hightree); + secondpass(hightree); + push_value_para(hightree,false,false,0,4); + disposetree(hightree); + end + else + begin + push_int(pstringdef(p^.resulttype)^.len); + end; + end; + + + procedure loadshortstring(p:ptree); + { + Load a string, handles stringdef and orddef (char) types + } + begin + case p^.right^.resulttype^.deftype of + stringdef: + begin + if (p^.right^.treetype=stringconstn) and + (str_length(p^.right)=0) then + emit_const_ref( + A_MOV,S_B,0,newreference(p^.left^.location.reference)) + else + begin + emitpushreferenceaddr(p^.left^.location.reference); + emitpushreferenceaddr(p^.right^.location.reference); + push_shortstring_length(p^.left); + emitcall('FPC_SHORTSTR_COPY'); + maybe_loadesi; + end; + end; + orddef: + begin + if p^.right^.treetype=ordconstn then + emit_const_ref( + A_MOV,S_W,p^.right^.value*256+1,newreference(p^.left^.location.reference)) + else + begin + { not so elegant (goes better with extra register } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + emit_reg_reg(A_MOV,S_L,makereg32(p^.right^.location.register),R_EDI); + ungetregister(p^.right^.location.register); + end + else + begin + emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI); + del_reference(p^.right^.location.reference); + end; + emit_const_reg(A_SHL,S_L,8,R_EDI); + emit_const_reg(A_OR,S_L,1,R_EDI); + emit_reg_ref(A_MOV,S_W,R_DI,newreference(p^.left^.location.reference)); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; + else + CGMessage(type_e_mismatch); + end; + end; + + procedure loadlongstring(p:ptree); + { + Load a string, handles stringdef and orddef (char) types + } + var + r : preference; + + begin + case p^.right^.resulttype^.deftype of + stringdef: + begin + if (p^.right^.treetype=stringconstn) and + (str_length(p^.right)=0) then + emit_const_ref(A_MOV,S_L,0,newreference(p^.left^.location.reference)) + else + begin + emitpushreferenceaddr(p^.left^.location.reference); + emitpushreferenceaddr(p^.right^.location.reference); + push_shortstring_length(p^.left); + emitcall('FPC_LONGSTR_COPY'); + maybe_loadesi; + end; + end; + orddef: + begin + emit_const_ref(A_MOV,S_L,1,newreference(p^.left^.location.reference)); + + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + + if p^.right^.treetype=ordconstn then + emit_const_ref(A_MOV,S_B,p^.right^.value,r) + else + begin + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg_ref(A_MOV,S_B,p^.right^.location.register,r); + ungetregister(p^.right^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + if not(R_EAX in unused) then + emit_reg(A_PUSH,S_L,R_EAX); + emit_ref_reg(A_MOV,S_B,newreference(p^.right^.location.reference),R_AL); + emit_reg_ref(A_MOV,S_B,R_AL,r); + + if not(R_EAX in unused) then + emit_reg(A_POP,S_L,R_EAX); + del_reference(p^.right^.location.reference); + end + else + internalerror(20799); + end; + end; + end; + else + CGMessage(type_e_mismatch); + end; + end; + + + procedure loadansi2short(source,dest : ptree); + var + pushed : tpushed; + regs_to_push: byte; + begin + { Find out which registers have to be pushed (JM) } + regs_to_push := $ff; + remove_non_regvars_from_loc(source^.location,regs_to_push); + remove_non_regvars_from_loc(dest^.location,regs_to_push); + { Push them (JM) } + pushusedregisters(pushed,regs_to_push); + case source^.location.loc of + LOC_REFERENCE,LOC_MEM: + begin + { Now release the location and registers (see cgai386.pas: } + { loadansistring for more info on the order) (JM) } + ungetiftemp(source^.location.reference); + del_reference(source^.location.reference); + emit_push_mem(source^.location.reference); + end; + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_PUSH,S_L,source^.location.register); + { Now release the register (JM) } + ungetregister32(source^.location.register); + end; + end; + push_shortstring_length(dest); + emitpushreferenceaddr(dest^.location.reference); + { Only now release the destination (JM) } + del_reference(dest^.location.reference); + emitcall('FPC_ANSISTR_TO_SHORTSTR'); + popusedregisters(pushed); + maybe_loadesi; + end; + + + +{***************************************************************************** + SecondTypeConv +*****************************************************************************} + + type + tsecondconvproc = procedure(var pto,pfrom : ptree;convtyp : tconverttype); + + procedure second_int_to_int(var pto,pfrom : ptree;convtyp : tconverttype); + var + op : tasmop; + opsize : topsize; + hregister, + hregister2 : tregister; + l : pasmlabel; + + begin + { insert range check if not explicit conversion } + if not(pto^.explizit) then + emitrangecheck(pfrom,pto^.resulttype); + + { is the result size smaller ? } + if pto^.resulttype^.sizepfrom^.resulttype^.size then + begin + { remove reference } + if not(pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + del_reference(pfrom^.location.reference); + { we can do this here as we need no temp inside } + ungetiftemp(pfrom^.location.reference); + end; + + { get op and opsize, handle separate for constants, because + movz doesn't support constant values } + if (pfrom^.location.loc=LOC_MEM) and (pfrom^.location.reference.is_immediate) then + begin + if is_64bitint(pto^.resulttype) then + opsize:=S_L + else + opsize:=def_opsize(pto^.resulttype); + op:=A_MOV; + end + else + begin + opsize:=def2def_opsize(pfrom^.resulttype,pto^.resulttype); + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + if is_signed(pfrom^.resulttype) then + op:=A_MOVSX + else + op:=A_MOVZX; + end; + { load the register we need } + if pfrom^.location.loc<>LOC_REGISTER then + hregister:=getregister32 + else + hregister:=pfrom^.location.register; + + { set the correct register size and location } + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + + { do we need a second register for a 64 bit type ? } + if is_64bitint(pto^.resulttype) then + begin + hregister2:=getregister32; + pto^.location.registerhigh:=hregister2; + end; + case pto^.resulttype^.size of + 1: + pto^.location.register:=makereg8(hregister); + 2: + pto^.location.register:=makereg16(hregister); + 4,8: + pto^.location.register:=makereg32(hregister); + end; + { insert the assembler code } + if pfrom^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then + emit_reg_reg(op,opsize,pfrom^.location.register,pto^.location.register) + else + emit_ref_reg(op,opsize, + newreference(pfrom^.location.reference),pto^.location.register); + + { do we need a sign extension for int64? } + if is_64bitint(pto^.resulttype) then + begin + emit_reg_reg(A_XOR,S_L, + hregister2,hregister2); + if (porddef(pto^.resulttype)^.typ=s64bit) and + is_signed(pfrom^.resulttype) then + begin + getlabel(l); + emit_const_reg(A_TEST,S_L,$80000000,makereg32(hregister)); + emitjmp(C_Z,l); + emit_reg(A_NOT,S_L, + hregister2); + emitlab(l); + end; + end; + end; + end; + + procedure second_string_to_string(var pto,pfrom : ptree;convtyp : tconverttype); + + var + pushed : tpushed; + + begin + { does anybody know a better solution than this big case statement ? } + { ok, a proc table would do the job } + case pstringdef(pto^.resulttype)^.string_typ of + + st_shortstring: + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring: + begin + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + copyshortstring(pto^.location.reference,pfrom^.location.reference, + pstringdef(pto^.resulttype)^.len,false,true); +{ done by copyshortstring now (JM) } +{ del_reference(pfrom^.location.reference); } + ungetiftemp(pfrom^.location.reference); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + loadansi2short(pfrom,pto); + { this is done in secondtypeconv (FK) + removetemps(exprasmlist,temptoremove); + destroys:=true; + } + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_longstring: + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_ansistring: + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring: + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REFERENCE; + gettempansistringreference(pto^.location.reference); + decrstringref(cansistringdef,pto^.location.reference); + pushusedregisters(pushed,$ff); + emit_push_lea_loc(pfrom^.location,true); + emit_push_lea_loc(pto^.location,false); + emitcall('FPC_SHORTSTR_TO_ANSISTR'); + maybe_loadesi; + popusedregisters(pushed); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_widestring: + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + end; + end; + + + procedure second_cstring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype); + var + hr : preference; + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring : + begin + inc(pfrom^.location.reference.offset); + emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), + pto^.location.register); + end; + st_ansistring : + begin + if (pfrom^.treetype=stringconstn) and + (str_length(pfrom)=0) then + begin + new(hr); + reset_reference(hr^); + hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + emit_ref_reg(A_LEA,S_L,hr,pto^.location.register); + end + else + emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + pto^.location.register); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + end; + + + procedure second_string_to_chararray(var pto,pfrom : ptree;convtyp : tconverttype); + var + l1 : pasmlabel; + hr : preference; + begin + case pstringdef(pfrom^.resulttype)^.string_typ of + st_shortstring : + begin + inc(pto^.location.reference.offset); + end; + st_ansistring : + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REFERENCE; + reset_reference(pto^.location.reference); + getlabel(l1); + case pfrom^.location.loc of + LOC_CREGISTER,LOC_REGISTER: + pto^.location.reference.base:=pfrom^.location.register; + LOC_MEM,LOC_REFERENCE: + begin + pto^.location.reference.base:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + pto^.location.reference.base); + del_reference(pfrom^.location.reference); + end; + end; + emit_const_reg(A_CMP,S_L,0,pto^.location.reference.base); + emitjmp(C_NZ,l1); + new(hr); + reset_reference(hr^); + hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + emit_ref_reg(A_LEA,S_L,hr,pto^.location.reference.base); + emitlab(l1); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + end; + + + procedure second_array_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype); + begin + del_reference(pfrom^.location.reference); + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), + pto^.location.register); + end; + + + procedure second_pointer_to_array(var pto,pfrom : ptree;convtyp : tconverttype); + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REFERENCE; + reset_reference(pto^.location.reference); + case pfrom^.location.loc of + LOC_REGISTER : + pto^.location.reference.base:=pfrom^.location.register; + LOC_CREGISTER : + begin + pto^.location.reference.base:=getregister32; + emit_reg_reg(A_MOV,S_L,pfrom^.location.register,pto^.location.reference.base); + end + else + begin + del_reference(pfrom^.location.reference); + pto^.location.reference.base:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + pto^.location.reference.base); + end; + end; + end; + + + { generates the code for the type conversion from an array of char } + { to a string } + procedure second_chararray_to_string(var pto,pfrom : ptree;convtyp : tconverttype); + var + pushed : tpushed; + l : longint; + begin + { calc the length of the array } + l:=parraydef(pfrom^.resulttype)^.highrange-parraydef(pfrom^.resulttype)^.lowrange+1; + { this is a type conversion which copies the data, so we can't } + { return a reference } + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; + case pstringdef(pto^.resulttype)^.string_typ of + st_shortstring : + begin + if l>255 then + begin + CGMessage(type_e_mismatch); + l:=255; + end; + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + pushusedregisters(pushed,$ff); + if l>=pto^.resulttype^.size then + push_int(pto^.resulttype^.size-1) + else + push_int(l); + { we've also to release the registers ... } + del_reference(pfrom^.location.reference); + { ... here only the temp. location is released } + emit_push_lea_loc(pfrom^.location,true); + emitpushreferenceaddr(pto^.location.reference); + emitcall('FPC_CHARARRAY_TO_SHORTSTR'); + maybe_loadesi; + popusedregisters(pushed); + end; + st_ansistring : + begin + gettempansistringreference(pto^.location.reference); + decrstringref(cansistringdef,pto^.location.reference); + release_loc(pfrom^.location); + pushusedregisters(pushed,$ff); + push_int(l); + emitpushreferenceaddr(pfrom^.location.reference); + emitpushreferenceaddr(pto^.location.reference); + emitcall('FPC_CHARARRAY_TO_ANSISTR'); + popusedregisters(pushed); + maybe_loadesi; + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + end; + + + procedure second_char_to_string(var pto,pfrom : ptree;convtyp : tconverttype); + var + pushed : tpushed; + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; + case pstringdef(pto^.resulttype)^.string_typ of + st_shortstring : + begin + gettempofsizereference(256,pto^.location.reference); + { call loadstring with correct left and right } + pto^.right:=pfrom; + pto^.left:=pto; + loadshortstring(pto); + pto^.left:=nil; { reset left tree, which is empty } + { pto^.right is not disposed for typeconv !! PM } + disposetree(pto^.right); + pto^.right:=nil; + end; + st_ansistring : + begin + gettempansistringreference(pto^.location.reference); + decrstringref(cansistringdef,pto^.location.reference); + release_loc(pfrom^.location); + pushusedregisters(pushed,$ff); + emit_pushw_loc(pfrom^.location); + emitpushreferenceaddr(pto^.location.reference); + emitcall('FPC_CHAR_TO_ANSISTR'); + popusedregisters(pushed); + maybe_loadesi; + end; + else + internalerror(4179); + end; + end; + + + procedure second_int_to_real(var pto,pfrom : ptree;convtyp : tconverttype); + + var + r : preference; + hregister : tregister; + l1,l2 : pasmlabel; + + begin + { for u32bit a solution is to push $0 and to load a comp } + { does this first, it destroys maybe EDI } + hregister:=R_EDI; + if porddef(pfrom^.resulttype)^.typ=u32bit then + push_int(0); + if (pfrom^.location.loc=LOC_REGISTER) or + (pfrom^.location.loc=LOC_CREGISTER) then + begin +{$ifndef noAllocEdi} + if not (porddef(pfrom^.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + case porddef(pfrom^.resulttype)^.typ of + s8bit : emit_reg_reg(A_MOVSX,S_BL,pfrom^.location.register,R_EDI); + u8bit : emit_reg_reg(A_MOVZX,S_BL,pfrom^.location.register,R_EDI); + s16bit : emit_reg_reg(A_MOVSX,S_WL,pfrom^.location.register,R_EDI); + u16bit : emit_reg_reg(A_MOVZX,S_WL,pfrom^.location.register,R_EDI); + u32bit,s32bit: + hregister:=pfrom^.location.register; + u64bit,s64bit: + begin + emit_reg(A_PUSH,S_L,pfrom^.location.registerhigh); + hregister:=pfrom^.location.registerlow; + end; + end; + ungetregister(pfrom^.location.register); + end + else + begin + r:=newreference(pfrom^.location.reference); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + case porddef(pfrom^.resulttype)^.typ of + s8bit: + emit_ref_reg(A_MOVSX,S_BL,r,R_EDI); + u8bit: + emit_ref_reg(A_MOVZX,S_BL,r,R_EDI); + s16bit: + emit_ref_reg(A_MOVSX,S_WL,r,R_EDI); + u16bit: + emit_ref_reg(A_MOVZX,S_WL,r,R_EDI); + u32bit,s32bit: + emit_ref_reg(A_MOV,S_L,r,R_EDI); + u64bit,s64bit: + begin + inc(r^.offset,4); + emit_ref_reg(A_MOV,S_L,r,R_EDI); + emit_reg(A_PUSH,S_L,R_EDI); + r:=newreference(pfrom^.location.reference); + emit_ref_reg(A_MOV,S_L,r,R_EDI); + end; + end; + del_reference(pfrom^.location.reference); + ungetiftemp(pfrom^.location.reference); + end; + { for 64 bit integers, the high dword is already pushed } + emit_reg(A_PUSH,S_L,hregister); +{$ifndef noAllocEdi} + if hregister = R_EDI then + ungetregister32(R_EDI); +{$endif noAllocEdi} + r:=new_reference(R_ESP,0); + case porddef(pfrom^.resulttype)^.typ of + u32bit: + begin + emit_ref(A_FILD,S_IQ,r); + emit_const_reg(A_ADD,S_L,8,R_ESP); + end; + s64bit: + begin + emit_ref(A_FILD,S_IQ,r); + emit_const_reg(A_ADD,S_L,8,R_ESP); + end; + u64bit: + begin + { unsigned 64 bit ints are harder to handle: } + { we load bits 0..62 and then check bit 63: } + { if it is 1 then we add $80000000 000000000 } + { as double } + inc(r^.offset,4); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,r,R_EDI); + r:=new_reference(R_ESP,4); + emit_const_ref(A_AND,S_L,$7fffffff,r); + emit_const_reg(A_TEST,S_L,$80000000,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + r:=new_reference(R_ESP,0); + emit_ref(A_FILD,S_IQ,r); + getdatalabel(l1); + getlabel(l2); + emitjmp(C_Z,l2); + consts^.concat(new(pai_label,init(l1))); + { I got this constant from a test progtram (FK) } + consts^.concat(new(pai_const,init_32bit(0))); + consts^.concat(new(pai_const,init_32bit(1138753536))); + r:=new_reference(R_NO,0); + r^.symbol:=l1; + emit_ref(A_FADD,S_FL,r); + emitlab(l2); + emit_const_reg(A_ADD,S_L,8,R_ESP); + end + else + begin + emit_ref(A_FILD,S_IL,r); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; + inc(fpuvaroffset); + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; + end; + + + procedure second_real_to_fix(var pto,pfrom : ptree;convtyp : tconverttype); + var + rreg : tregister; + ref : treference; + begin + { real must be on fpu stack } + if (pfrom^.location.loc<>LOC_FPU) then + emit_ref(A_FLD,S_FL,newreference(pfrom^.location.reference)); + push_int($1f3f); + push_int(65536); + reset_reference(ref); + ref.base:=R_ESP; + + emit_ref(A_FIMUL,S_IL,newreference(ref)); + + ref.offset:=4; + emit_ref(A_FSTCW,S_NO,newreference(ref)); + + ref.offset:=6; + emit_ref(A_FLDCW,S_NO,newreference(ref)); + + ref.offset:=0; + emit_ref(A_FISTP,S_IL,newreference(ref)); + + ref.offset:=4; + emit_ref(A_FLDCW,S_NO,newreference(ref)); + + rreg:=getregister32; + emit_reg(A_POP,S_L,rreg); + { better than an add on all processors } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=rreg; + inc(fpuvaroffset); + end; + + + procedure second_real_to_real(var pto,pfrom : ptree;convtyp : tconverttype); + begin + case pfrom^.location.loc of + LOC_FPU : ; + LOC_CFPUREGISTER: + begin + pto^.location:=pfrom^.location; + exit; + end; + LOC_MEM, + LOC_REFERENCE: + begin + floatload(pfloatdef(pfrom^.resulttype)^.typ, + pfrom^.location.reference); + { we have to free the reference } + del_reference(pfrom^.location.reference); + end; + end; + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; + end; + + + procedure second_fix_to_real(var pto,pfrom : ptree;convtyp : tconverttype); + var + popeax,popebx,popecx,popedx : boolean; + startreg : tregister; + hl : pasmlabel; + r : treference; + begin + if (pfrom^.location.loc=LOC_REGISTER) or + (pfrom^.location.loc=LOC_CREGISTER) then + begin + startreg:=pfrom^.location.register; + ungetregister(startreg); + popeax:=(startreg<>R_EAX) and not (R_EAX in unused); + if popeax then + emit_reg(A_PUSH,S_L,R_EAX); + { mov eax,eax is removed by emit_reg_reg } + emit_reg_reg(A_MOV,S_L,startreg,R_EAX); + end + else + begin + emit_ref_reg(A_MOV,S_L,newreference( + pfrom^.location.reference),R_EAX); + del_reference(pfrom^.location.reference); + startreg:=R_NO; + end; + + popebx:=(startreg<>R_EBX) and not (R_EBX in unused); + if popebx then + emit_reg(A_PUSH,S_L,R_EBX); + + popecx:=(startreg<>R_ECX) and not (R_ECX in unused); + if popecx then + emit_reg(A_PUSH,S_L,R_ECX); + + popedx:=(startreg<>R_EDX) and not (R_EDX in unused); + if popedx then + emit_reg(A_PUSH,S_L,R_EDX); + + emit_none(A_CDQ,S_NO); + emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX); + emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX); + getlabel(hl); + emitjmp(C_Z,hl); + emit_const_reg(A_RCL,S_L,1,R_EBX); + emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX); + emit_const_reg(A_MOV,S_B,32,R_CL); + emit_reg_reg(A_SUB,S_B,R_DL,R_CL); + emit_reg_reg(A_SHL,S_L,R_CL,R_EAX); + emit_const_reg(A_ADD,S_W,1007,R_DX); + emit_const_reg(A_SHL,S_W,5,R_DX); + emit_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX); + emit_const_reg_reg(A_SHLD,S_L,20,R_EAX,R_EBX); + + emit_const_reg(A_SHL,S_L,20,R_EAX); + emitlab(hl); + { better than an add on all processors } + emit_reg(A_PUSH,S_L,R_EBX); + emit_reg(A_PUSH,S_L,R_EAX); + + reset_reference(r); + r.base:=R_ESP; + emit_ref(A_FLD,S_FL,newreference(r)); + emit_const_reg(A_ADD,S_L,8,R_ESP); + if popedx then + emit_reg(A_POP,S_L,R_EDX); + if popecx then + emit_reg(A_POP,S_L,R_ECX); + if popebx then + emit_reg(A_POP,S_L,R_EBX); + if popeax then + emit_reg(A_POP,S_L,R_EAX); + + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; + end; + + + procedure second_cord_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype); + begin + { this can't happend, because constants are already processed in + pass 1 } + internalerror(47423985); + end; + + + procedure second_int_to_fix(var pto,pfrom : ptree;convtyp : tconverttype); + var + hregister : tregister; + begin + if (pfrom^.location.loc=LOC_REGISTER) then + hregister:=pfrom^.location.register + else if (pfrom^.location.loc=LOC_CREGISTER) then + hregister:=getregister32 + else + begin + del_reference(pfrom^.location.reference); + hregister:=getregister32; + case porddef(pfrom^.resulttype)^.typ of + s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(pfrom^.location.reference), + hregister); + u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(pfrom^.location.reference), + hregister); + s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(pfrom^.location.reference), + hregister); + u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(pfrom^.location.reference), + hregister); + u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + hregister); + {!!!! u32bit } + end; + end; + emit_const_reg(A_SHL,S_L,16,hregister); + + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=hregister; + end; + + + procedure second_proc_to_procvar(var pto,pfrom : ptree;convtyp : tconverttype); + begin + { method pointer ? } + if assigned(pfrom^.left) then + begin + set_location(pto^.location,pfrom^.location); + end + else + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + del_reference(pfrom^.location.reference); + emit_ref_reg(A_LEA,S_L, + newreference(pfrom^.location.reference),pto^.location.register); + end; + end; + + + procedure second_bool_to_int(var pto,pfrom : ptree;convtyp : tconverttype); + var + oldtruelabel,oldfalselabel,hlabel : pasmlabel; + hregister : tregister; + newsize, + opsize : topsize; + op : tasmop; + begin + oldtruelabel:=truelabel; + oldfalselabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(pfrom); + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (pto^.explizit) and + (pfrom^.resulttype^.size=pto^.resulttype^.size) and + (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + begin + set_location(pto^.location,pfrom^.location); + truelabel:=oldtruelabel; + falselabel:=oldfalselabel; + exit; + end; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + del_reference(pfrom^.location.reference); + case pfrom^.resulttype^.size of + 1 : begin + case pto^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_BW; + 4 : opsize:=S_BL; + end; + end; + 2 : begin + case pto^.resulttype^.size of + 1 : begin + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg16toreg8(pfrom^.location.register); + opsize:=S_B; + end; + 2 : opsize:=S_W; + 4 : opsize:=S_WL; + end; + end; + 4 : begin + case pto^.resulttype^.size of + 1 : begin + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg32toreg8(pfrom^.location.register); + opsize:=S_B; + end; + 2 : begin + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg32toreg16(pfrom^.location.register); + opsize:=S_W; + end; + 4 : opsize:=S_L; + end; + end; + end; + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + if is_signed(pto^.resulttype) then + op:=A_MOVSX + else + op:=A_MOVZX; + hregister:=getregister32; + case pto^.resulttype^.size of + 1 : begin + pto^.location.register:=reg32toreg8(hregister); + newsize:=S_B; + end; + 2 : begin + pto^.location.register:=reg32toreg16(hregister); + newsize:=S_W; + end; + 4 : begin + pto^.location.register:=hregister; + newsize:=S_L; + end; + else + internalerror(10060); + end; + + case pfrom^.location.loc of + LOC_MEM, + LOC_REFERENCE : emit_ref_reg(op,opsize, + newreference(pfrom^.location.reference),pto^.location.register); + LOC_REGISTER, + LOC_CREGISTER : begin + { remove things like movb %al,%al } + if pfrom^.location.register<>pto^.location.register then + emit_reg_reg(op,opsize, + pfrom^.location.register,pto^.location.register); + end; + LOC_FLAGS : begin + emit_flag2reg(pfrom^.location.resflags,pto^.location.register); + end; + LOC_JUMP : begin + getlabel(hlabel); + emitlab(truelabel); + emit_const_reg(A_MOV,newsize,1,pto^.location.register); + emitjmp(C_None,hlabel); + emitlab(falselabel); + emit_reg_reg(A_XOR,newsize,pto^.location.register, + pto^.location.register); + emitlab(hlabel); + end; + else + internalerror(10061); + end; + truelabel:=oldtruelabel; + falselabel:=oldfalselabel; + end; + + + procedure second_int_to_bool(var pto,pfrom : ptree;convtyp : tconverttype); + var + hregister : tregister; + flags : tresflags; + opsize : topsize; + begin + clear_location(pto^.location); + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (pto^.explizit) and + (pfrom^.resulttype^.size=pto^.resulttype^.size) and + (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + begin + set_location(pto^.location,pfrom^.location); + exit; + end; + pto^.location.loc:=LOC_REGISTER; + del_reference(pfrom^.location.reference); + opsize:=def_opsize(pfrom^.resulttype); + case pfrom^.location.loc of + LOC_MEM,LOC_REFERENCE : + begin + hregister:=def_getreg(pfrom^.resulttype); + emit_ref_reg(A_MOV,opsize, + newreference(pfrom^.location.reference),hregister); + emit_reg_reg(A_OR,opsize,hregister,hregister); + flags:=F_NE; + end; + LOC_FLAGS : + begin + hregister:=getregister32; + flags:=pfrom^.location.resflags; + end; + LOC_REGISTER,LOC_CREGISTER : + begin + hregister:=pfrom^.location.register; + emit_reg_reg(A_OR,opsize,hregister,hregister); + flags:=F_NE; + end; + else + internalerror(10062); + end; + case pto^.resulttype^.size of + 1 : pto^.location.register:=makereg8(hregister); + 2 : pto^.location.register:=makereg16(hregister); + 4 : pto^.location.register:=makereg32(hregister); + else + internalerror(10064); + end; + emit_flag2reg(flags,pto^.location.register); + end; + + + procedure second_load_smallset(var pto,pfrom : ptree;convtyp : tconverttype); + var + href : treference; + pushedregs : tpushed; + begin + href.symbol:=nil; + pushusedregisters(pushedregs,$ff); + gettempofsizereference(32,href); + emitpushreferenceaddr(pfrom^.location.reference); + emitpushreferenceaddr(href); + emitcall('FPC_SET_LOAD_SMALL'); + maybe_loadesi; + popusedregisters(pushedregs); + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; + pto^.location.reference:=href; + end; + + + procedure second_ansistring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype); + var + l1 : pasmlabel; + hr : preference; + begin + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + getlabel(l1); + case pfrom^.location.loc of + LOC_CREGISTER,LOC_REGISTER: + pto^.location.register:=pfrom^.location.register; + LOC_MEM,LOC_REFERENCE: + begin + pto^.location.register:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + pto^.location.register); + del_reference(pfrom^.location.reference); + end; + end; + emit_const_reg(A_CMP,S_L,0,pto^.location.register); + emitjmp(C_NZ,l1); + new(hr); + reset_reference(hr^); + hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + emit_ref_reg(A_LEA,S_L,hr,pto^.location.register); + emitlab(l1); + end; + + + procedure second_pchar_to_string(var pto,pfrom : ptree;convtyp : tconverttype); + var + pushed : tpushed; + regs_to_push: byte; + begin + case pstringdef(pto^.resulttype)^.string_typ of + st_shortstring: + begin + pto^.location.loc:=LOC_REFERENCE; + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + pushusedregisters(pushed,$ff); + case pfrom^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_PUSH,S_L,pfrom^.location.register); + ungetregister32(pfrom^.location.register); + end; + LOC_REFERENCE,LOC_MEM: + begin + { Now release the registers (see cgai386.pas: } + { loadansistring for more info on the order) (JM) } + del_reference(pfrom^.location.reference); + emit_push_mem(pfrom^.location.reference); + end; + end; + emitpushreferenceaddr(pto^.location.reference); + emitcall('FPC_PCHAR_TO_SHORTSTR'); + maybe_loadesi; + popusedregisters(pushed); + end; + st_ansistring: + begin + pto^.location.loc:=LOC_REFERENCE; + gettempansistringreference(pto^.location.reference); + decrstringref(cansistringdef,pto^.location.reference); + { Find out which regs have to be pushed (JM) } + regs_to_push := $ff; + remove_non_regvars_from_loc(pfrom^.location,regs_to_push); + pushusedregisters(pushed,regs_to_push); + case pfrom^.location.loc of + LOC_REFERENCE,LOC_MEM: + begin + { Now release the registers (see cgai386.pas: } + { loadansistring for more info on the order) (JM) } + del_reference(pfrom^.location.reference); + emit_push_mem(pfrom^.location.reference); + end; + LOC_REGISTER,LOC_CREGISTER: + begin + { Now release the registers (see cgai386.pas: } + { loadansistring for more info on the order) (JM) } + emit_reg(A_PUSH,S_L,pfrom^.location.register); + ungetregister32(pfrom^.location.register); + end; + end; + emitpushreferenceaddr(pto^.location.reference); + emitcall('FPC_PCHAR_TO_ANSISTR'); + maybe_loadesi; + popusedregisters(pushed); + end; + else + begin + internalerror(12121); + end; + end; + end; + + + procedure second_nothing(var pto,pfrom : ptree;convtyp : tconverttype); + begin + end; + + +{**************************************************************************** + SecondTypeConv +****************************************************************************} + + procedure secondtypeconv(var p : ptree); + const + secondconvert : array[tconverttype] of tsecondconvproc = ( + second_nothing, {equal} + second_nothing, {not_possible} + second_string_to_string, + second_char_to_string, + second_pchar_to_string, + second_nothing, {cchar_to_pchar} + second_cstring_to_pchar, + second_ansistring_to_pchar, + second_string_to_chararray, + second_chararray_to_string, + second_array_to_pointer, + second_pointer_to_array, + second_int_to_int, + second_int_to_bool, + second_bool_to_int, { bool_to_bool } + second_bool_to_int, + second_real_to_real, + second_int_to_real, + second_int_to_fix, + second_real_to_fix, + second_fix_to_real, + second_proc_to_procvar, + second_nothing, {arrayconstructor_to_set} + second_load_smallset, + second_cord_to_pointer + ); +{$ifdef TESTOBJEXT2} + var + r : preference; + nillabel : plabel; +{$endif TESTOBJEXT2} + begin + + { this isn't good coding, I think tc_bool_2_int, shouldn't be } + { type conversion (FK) } + + if not(p^.convtyp in [tc_bool_2_int,tc_bool_2_bool]) then + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + if codegenerror then + exit; + end; + { the second argument only is for maybe_range_checking !} + secondconvert[p^.convtyp](p,p^.left,p^.convtyp); + +{$ifdef TESTOBJEXT2} + { Check explicit conversions to objects pointers !! } + if p^.explizit and + (p^.resulttype^.deftype=pointerdef) and + (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) and not + (pobjectdef(ppointerdef(p^.resulttype)^.definition)^.isclass) and + ((pobjectdef(ppointerdef(p^.resulttype)^.definition)^.options and oo_hasvmt)<>0) and + (cs_check_range in aktlocalswitches) then + begin + new(r); + reset_reference(r^); + if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + r^.base:=p^.location.register + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_mov_loc_reg(p^.location,R_EDI); + r^.base:=R_EDI; + end; + { NIL must be accepted !! } + emit_reg_reg(A_OR,S_L,r^.base,r^.base); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + getlabel(nillabel); + emitjmp(C_E,nillabel); + { this is one point where we need vmt_offset (PM) } + r^.offset:= pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_offset; +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,r,R_EDI); + emit_sym(A_PUSH,S_L, + newasmsymbol(pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_mangledname)); + emit_reg(A_PUSH,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + emitcall('FPC_CHECK_OBJECT_EXT'); + emitlab(nillabel); + end; +{$endif TESTOBJEXT2} + end; + + +{***************************************************************************** + SecondIs +*****************************************************************************} + + procedure secondis(var p : ptree); + var + pushed : tpushed; + + begin + { save all used registers } + pushusedregisters(pushed,$ff); + secondpass(p^.left); + clear_location(p^.location); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_NE; + + { push instance to check: } + case p^.left^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_PUSH, + S_L,p^.left^.location.register); + ungetregister32(p^.left^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + emit_ref(A_PUSH, + S_L,newreference(p^.left^.location.reference)); + del_reference(p^.left^.location.reference); + end; + else internalerror(100); + end; + + { generate type checking } + secondpass(p^.right); + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_PUSH, + S_L,p^.right^.location.register); + ungetregister32(p^.right^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + emit_ref(A_PUSH, + S_L,newreference(p^.right^.location.reference)); + del_reference(p^.right^.location.reference); + end; + else internalerror(100); + end; + emitcall('FPC_DO_IS'); + emit_reg_reg(A_OR,S_B,R_AL,R_AL); + popusedregisters(pushed); + maybe_loadesi; + end; + + +{***************************************************************************** + SecondAs +*****************************************************************************} + + procedure secondas(var p : ptree); + var + pushed : tpushed; + begin + secondpass(p^.left); + { save all used registers } + pushusedregisters(pushed,$ff); + + { push instance to check: } + case p^.left^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + emit_reg(A_PUSH, + S_L,p^.left^.location.register); + LOC_MEM,LOC_REFERENCE: + emit_ref(A_PUSH, + S_L,newreference(p^.left^.location.reference)); + else internalerror(100); + end; + + { we doesn't modifiy the left side, we check only the type } + set_location(p^.location,p^.left^.location); + + { generate type checking } + secondpass(p^.right); + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + emit_reg(A_PUSH, + S_L,p^.right^.location.register); + ungetregister32(p^.right^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + emit_ref(A_PUSH, + S_L,newreference(p^.right^.location.reference)); + del_reference(p^.right^.location.reference); + end; + else internalerror(100); + end; + emitcall('FPC_DO_AS'); + { restore register, this restores automatically the } + { result } + popusedregisters(pushed); + maybe_loadesi; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.106 2000/05/26 20:16:00 jonas + * fixed wrong register deallocations in several ansistring related + procedures. The IDE's now function fine when compiled with -OG3p3r + + Revision 1.105 2000/04/10 12:23:19 jonas + * modified copyshortstring so it takes an extra paramter which allows it + to delete the sref itself (so the reg deallocations are put in the + right place for the optimizer) + + Revision 1.104 2000/03/31 22:56:45 pierre + * fix the handling of value parameters in cdecl function + + Revision 1.103 2000/02/19 10:12:47 florian + * fixed one more internalerror 10 + + Revision 1.102 2000/02/09 13:22:46 peter + * log truncated + + Revision 1.101 2000/01/13 16:52:48 jonas + * moved deallocation of registers used in reference that points to string after + copyshortstring (this routine doesn't require extra regs) + + Revision 1.100 2000/01/09 12:35:00 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.99 2000/01/09 01:44:19 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.98 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.97 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.96 1999/12/21 11:49:51 pierre + * array of char to short string bug fixed + + Revision 1.95 1999/12/01 12:42:31 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.94 1999/11/29 22:15:25 pierre + * fix for internalerror(12) on ord(booleanarray[1]) + + Revision 1.93 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.92 1999/10/25 10:32:43 peter + * ansistring 2 chararray support + * optimized ansitring 2 pchar + + Revision 1.91 1999/10/22 14:36:04 peter + * fixed esi reload with as + + Revision 1.90 1999/10/06 08:32:00 peter + * fixed empty const ansistring 2 pchar + + Revision 1.89 1999/09/26 21:30:15 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.88 1999/09/26 13:26:04 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + + Revision 1.87 1999/09/23 21:20:37 peter + * fixed temp allocation for short->ansi + + Revision 1.86 1999/09/01 09:42:13 peter + * update for new push_lea_loc + + Revision 1.85 1999/08/19 13:08:46 pierre + * emit_??? used + + Revision 1.84 1999/08/05 14:58:03 florian + * some fixes for the floating point registers + * more things for the new code generator + + Revision 1.83 1999/08/04 13:45:19 florian + + floating point register variables !! + * pairegalloc is now generated for register variables + + Revision 1.82 1999/08/04 00:22:43 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/cg386con.pas b/befpc/compiler/cg386con.pas new file mode 100644 index 0000000..e74c633 --- /dev/null +++ b/befpc/compiler/cg386con.pas @@ -0,0 +1,475 @@ +{ + $Id: cg386con.pas,v 1.1.1.1 2001-07-23 17:15:33 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386con; +interface + + uses + tree; + + procedure secondrealconst(var p : ptree); + procedure secondfixconst(var p : ptree); + procedure secondordconst(var p : ptree); + procedure secondpointerconst(var p : ptree); + procedure secondstringconst(var p : ptree); + procedure secondsetconst(var p : ptree); + procedure secondniln(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386; + +{***************************************************************************** + SecondRealConst +*****************************************************************************} + + procedure secondrealconst(var p : ptree); + const + floattype2ait:array[tfloattype] of tait= + (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_none,ait_none); + + var + hp1 : pai; + lastlabel : pasmlabel; + realait : tait; + + begin + if (p^.value_real=1.0) then + begin + emit_none(A_FLD1,S_NO); + p^.location.loc:=LOC_FPU; + inc(fpuvaroffset); + end + else if (p^.value_real=0.0) then + begin + emit_none(A_FLDZ,S_NO); + p^.location.loc:=LOC_FPU; + inc(fpuvaroffset); + end + else + begin + lastlabel:=nil; + realait:=floattype2ait[pfloatdef(p^.resulttype)^.typ]; + { const already used ? } + if not assigned(p^.lab_real) then + begin + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + if (hp1^.typ=realait) and (lastlabel<>nil) then + begin + if( + ((realait=ait_real_32bit) and (pai_real_32bit(hp1)^.value=p^.value_real)) or + ((realait=ait_real_64bit) and (pai_real_64bit(hp1)^.value=p^.value_real)) or + ((realait=ait_real_80bit) and (pai_real_80bit(hp1)^.value=p^.value_real)) or + ((realait=ait_comp_64bit) and (pai_comp_64bit(hp1)^.value=p^.value_real)) + ) then + begin + { found! } + p^.lab_real:=lastlabel; + break; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_real) then + begin + getdatalabel(lastlabel); + p^.lab_real:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + case realait of + ait_real_32bit : + consts^.concat(new(pai_real_32bit,init(p^.value_real))); + ait_real_64bit : + consts^.concat(new(pai_real_64bit,init(p^.value_real))); + ait_real_80bit : + consts^.concat(new(pai_real_80bit,init(p^.value_real))); + ait_comp_64bit : + consts^.concat(new(pai_comp_64bit,init(p^.value_real))); + else + internalerror(10120); + end; + end; + end; + reset_reference(p^.location.reference); + p^.location.reference.symbol:=p^.lab_real; + p^.location.loc:=LOC_MEM; + end; + end; + + +{***************************************************************************** + SecondFixConst +*****************************************************************************} + + procedure secondfixconst(var p : ptree); + begin + { an fix comma const. behaves as a memory reference } + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=p^.value_fix; + end; + + +{***************************************************************************** + SecondOrdConst +*****************************************************************************} + + procedure secondordconst(var p : ptree); + begin + { an integer const. behaves as a memory reference } + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=p^.value; + end; + + +{***************************************************************************** + SecondPointerConst +*****************************************************************************} + + procedure secondpointerconst(var p : ptree); + begin + { an integer const. behaves as a memory reference } + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=p^.value; + end; + + +{***************************************************************************** + SecondStringConst +*****************************************************************************} + + procedure secondstringconst(var p : ptree); + var + hp1 : pai; + l1,l2, + lastlabel : pasmlabel; + pc : pchar; + same_string : boolean; + l,j, + i,mylength : longint; + begin + { for empty ansistrings we could return a constant 0 } + if is_ansistring(p^.resulttype) and + (p^.length=0) then + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=0; + exit; + end; + { const already used ? } + lastlabel:=nil; + if not assigned(p^.lab_str) then + begin + if is_shortstring(p^.resulttype) then + mylength:=p^.length+2 + else + mylength:=p^.length+1; + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + { when changing that code, be careful that } + { you don't use typed consts, which are } + { are also written to consts } + { currently, this is no problem, because } + { typed consts have no leading length or } + { they have no trailing zero } + if (hp1^.typ=ait_string) and (lastlabel<>nil) and + (pai_string(hp1)^.len=mylength) then + begin + same_string:=true; + { if shortstring then check the length byte first and + set the start index to 1 } + if is_shortstring(p^.resulttype) then + begin + if p^.length<>ord(pai_string(hp1)^.str[0]) then + same_string:=false; + j:=1; + end + else + j:=0; + { don't check if the length byte was already wrong } + if same_string then + begin + for i:=0 to p^.length do + begin + if pai_string(hp1)^.str[j]<>p^.value_str[i] then + begin + same_string:=false; + break; + end; + inc(j); + end; + end; + { found ? } + if same_string then + begin + p^.lab_str:=lastlabel; + { create a new entry for ansistrings, but reuse the data } + if (p^.stringtype in [st_ansistring,st_widestring]) then + begin + getdatalabel(l2); + consts^.concat(new(pai_label,init(l2))); + consts^.concat(new(pai_const_symbol,init(p^.lab_str))); + { return the offset of the real string } + p^.lab_str:=l2; + end; + break; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_str) then + begin + getdatalabel(lastlabel); + p^.lab_str:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + { generate an ansi string ? } + case p^.stringtype of + st_ansistring: + begin + { an empty ansi string is nil! } + if p^.length=0 then + consts^.concat(new(pai_const,init_32bit(0))) + else + begin + getdatalabel(l1); + getdatalabel(l2); + consts^.concat(new(pai_label,init(l2))); + consts^.concat(new(pai_const_symbol,init(l1))); + consts^.concat(new(pai_const,init_32bit(p^.length))); + consts^.concat(new(pai_const,init_32bit(p^.length))); + consts^.concat(new(pai_const,init_32bit(-1))); + consts^.concat(new(pai_label,init(l1))); + getmem(pc,p^.length+2); + move(p^.value_str^,pc^,p^.length); + pc[p^.length]:=#0; + { to overcome this problem we set the length explicitly } + { with the ending null char } + consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1))); + { return the offset of the real string } + p^.lab_str:=l2; + end; + end; + st_shortstring: + begin + { truncate strings larger than 255 chars } + if p^.length>255 then + l:=255 + else + l:=p^.length; + { also length and terminating zero } + getmem(pc,l+3); + move(p^.value_str^,pc[1],l+1); + pc[0]:=chr(l); + { to overcome this problem we set the length explicitly } + { with the ending null char } + pc[l+1]:=#0; + consts^.concat(new(pai_string,init_length_pchar(pc,l+2))); + end; + end; + end; + end; + reset_reference(p^.location.reference); + p^.location.reference.symbol:=p^.lab_str; + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + SecondSetCons +*****************************************************************************} + + procedure secondsetconst(var p : ptree); + var + hp1 : pai; + lastlabel : pasmlabel; + i : longint; + neededtyp : tait; + begin + { small sets are loaded as constants } + if psetdef(p^.resulttype)^.settype=smallset then + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=plongint(p^.value_set)^; + exit; + end; + if psetdef(p^.resulttype)^.settype=smallset then + neededtyp:=ait_const_32bit + else + neededtyp:=ait_const_8bit; + lastlabel:=nil; + { const already used ? } + if not assigned(p^.lab_set) then + begin + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + if (lastlabel<>nil) and (hp1^.typ=neededtyp) then + begin + if (hp1^.typ=ait_const_8bit) then + begin + { compare normal set } + i:=0; + while assigned(hp1) and (i<32) do + begin + if pai_const(hp1)^.value<>p^.value_set^[i] then + break; + inc(i); + hp1:=pai(hp1^.next); + end; + if i=32 then + begin + { found! } + p^.lab_set:=lastlabel; + break; + end; + { leave when the end of consts is reached, so no + hp1^.next is done } + if not assigned(hp1) then + break; + end + else + begin + { compare small set } + if plongint(p^.value_set)^=pai_const(hp1)^.value then + begin + { found! } + p^.lab_set:=lastlabel; + break; + end; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_set) then + begin + getdatalabel(lastlabel); + p^.lab_set:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + if psetdef(p^.resulttype)^.settype=smallset then + begin + move(p^.value_set^,i,sizeof(longint)); + consts^.concat(new(pai_const,init_32bit(i))); + end + else + begin + for i:=0 to 31 do + consts^.concat(new(pai_const,init_8bit(p^.value_set^[i]))); + end; + end; + end; + reset_reference(p^.location.reference); + p^.location.reference.symbol:=p^.lab_set; + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + SecondNilN +*****************************************************************************} + + procedure secondniln(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=0; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.46 2000/06/18 18:09:31 peter + * empty ansistring now use constant value of 0 + + Revision 1.45 2000/02/09 13:22:46 peter + * log truncated + + Revision 1.44 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.43 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.42 1999/09/26 21:30:15 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.41 1999/09/20 16:38:52 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.40 1999/09/04 20:53:06 florian + * bug 580 fixed + + Revision 1.39 1999/08/04 00:22:45 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.38 1999/08/03 22:02:38 peter + * moved bitmask constants to sets + * some other type/const renamings + +} diff --git a/befpc/compiler/cg386flw.pas b/befpc/compiler/cg386flw.pas new file mode 100644 index 0000000..e849fc3 --- /dev/null +++ b/befpc/compiler/cg386flw.pas @@ -0,0 +1,1345 @@ +{ + $Id: cg386flw.pas,v 1.1.1.1 2001-07-23 17:15:34 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for nodes that influence the flow + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg386flw; +interface + + uses + tree; + + procedure second_while_repeatn(var p : ptree); + procedure secondifn(var p : ptree); + procedure secondfor(var p : ptree); + procedure secondexitn(var p : ptree); + procedure secondbreakn(var p : ptree); + procedure secondcontinuen(var p : ptree); + procedure secondgoto(var p : ptree); + procedure secondlabel(var p : ptree); + procedure secondraise(var p : ptree); + procedure secondtryexcept(var p : ptree); + procedure secondtryfinally(var p : ptree); + procedure secondon(var p : ptree); + procedure secondfail(var p : ptree); + + type + tenumflowcontrol = (fc_exit,fc_break,fc_continue); + tflowcontrol = set of tenumflowcontrol; + + var + flowcontrol : tflowcontrol; + +implementation + + uses + cobjects,verbose,globtype,globals,systems, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386,tcflw; + +{***************************************************************************** + Second_While_RepeatN +*****************************************************************************} + + procedure second_while_repeatn(var p : ptree); + var + lcont,lbreak,lloop, + oldclabel,oldblabel : pasmlabel; + otlabel,oflabel : pasmlabel; + + begin + getlabel(lloop); + getlabel(lcont); + getlabel(lbreak); + { arrange continue and breaklabels: } + oldclabel:=aktcontinuelabel; + oldblabel:=aktbreaklabel; + + { handling code at the end as it is much more efficient, and makes + while equal to repeat loop, only the end true/false is swapped (PFV) } + if p^.treetype=whilen then + emitjmp(C_None,lcont); + + emitlab(lloop); + + aktcontinuelabel:=lcont; + aktbreaklabel:=lbreak; + cleartempgen; + if assigned(p^.right) then + secondpass(p^.right); + emitlab(lcont); + otlabel:=truelabel; + oflabel:=falselabel; + if p^.treetype=whilen then + begin + truelabel:=lloop; + falselabel:=lbreak; + end + { repeatn } + else + begin + truelabel:=lbreak; + falselabel:=lloop; + end; + cleartempgen; + secondpass(p^.left); + maketojumpbool(p^.left); + emitlab(lbreak); + truelabel:=otlabel; + falselabel:=oflabel; + + aktcontinuelabel:=oldclabel; + aktbreaklabel:=oldblabel; + { a break/continue in a while/repeat block can't be seen outside } + flowcontrol:=flowcontrol-[fc_break,fc_continue]; + end; + + +{***************************************************************************** + SecondIfN +*****************************************************************************} + + procedure secondifn(var p : ptree); + + var + hl,otlabel,oflabel : pasmlabel; + + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + cleartempgen; + secondpass(p^.left); + maketojumpbool(p^.left); + if assigned(p^.right) then + begin + emitlab(truelabel); + cleartempgen; + secondpass(p^.right); + end; + if assigned(p^.t1) then + begin + if assigned(p^.right) then + begin + getlabel(hl); + { do go back to if line !! } + aktfilepos:=exprasmlist^.getlasttaifilepos^; + emitjmp(C_None,hl); + end; + emitlab(falselabel); + cleartempgen; + secondpass(p^.t1); + if assigned(p^.right) then + emitlab(hl); + end + else + begin + emitlab(falselabel); + end; + if not(assigned(p^.right)) then + begin + emitlab(truelabel); + end; + truelabel:=otlabel; + falselabel:=oflabel; + end; + + +{***************************************************************************** + SecondFor +*****************************************************************************} + + procedure secondfor(var p : ptree); + var + l3,oldclabel,oldblabel : pasmlabel; + omitfirstcomp,temptovalue : boolean; + hs : byte; + temp1 : treference; + hop : tasmop; + hcond : tasmcond; + cmpreg,cmp32 : tregister; + opsize : topsize; + count_var_is_signed : boolean; + + begin + oldclabel:=aktcontinuelabel; + oldblabel:=aktbreaklabel; + getlabel(aktcontinuelabel); + getlabel(aktbreaklabel); + getlabel(l3); + + { could we spare the first comparison ? } + omitfirstcomp:=false; + if p^.right^.treetype=ordconstn then + if p^.left^.right^.treetype=ordconstn then + omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value)) + or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value)); + + { only calculate reference } + cleartempgen; + secondpass(p^.t2); + hs:=p^.t2^.resulttype^.size; + if p^.t2^.location.loc <> LOC_CREGISTER then + cmp32:=getregister32; + case hs of + 1 : begin + opsize:=S_B; + if p^.t2^.location.loc <> LOC_CREGISTER then + cmpreg:=reg32toreg8(cmp32); + end; + 2 : begin + opsize:=S_W; + if p^.t2^.location.loc <> LOC_CREGISTER then + cmpreg:=reg32toreg16(cmp32); + end; + 4 : begin + opsize:=S_L; + if p^.t2^.location.loc <> LOC_CREGISTER then + cmpreg:=cmp32; + end; + end; + + { first set the to value + because the count var can be in the expression !! } + cleartempgen; + secondpass(p^.right); + { calculate pointer value and check if changeable and if so } + { load into temporary variable } + if p^.right^.treetype<>ordconstn then + begin + temp1.symbol:=nil; + gettempofsizereference(hs,temp1); + temptovalue:=true; + if (p^.right^.location.loc=LOC_REGISTER) or + (p^.right^.location.loc=LOC_CREGISTER) then + begin + emit_reg_ref(A_MOV,opsize,p^.right^.location.register, + newreference(temp1)); + end + else + concatcopy(p^.right^.location.reference,temp1,hs,false,false); + end + else + temptovalue:=false; + + { produce start assignment } + cleartempgen; + secondpass(p^.left); + count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype)); + if temptovalue then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + begin + emit_ref_reg(A_CMP,opsize,newreference(temp1), + p^.t2^.location.register); + end + else + begin + emit_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), + cmpreg); + emit_ref_reg(A_CMP,opsize,newreference(temp1), + cmpreg); + { temp register not necessary anymore currently (JM) } + ungetregister32(cmp32); + end; + end + else + begin + if not(omitfirstcomp) then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + emit_const_reg(A_CMP,opsize,p^.right^.value, + p^.t2^.location.register) + else + emit_const_ref(A_CMP,opsize,p^.right^.value, + newreference(p^.t2^.location.reference)); + end; + end; + if p^.backward then + if count_var_is_signed then + hcond:=C_L + else + hcond:=C_B + else + if count_var_is_signed then + hcond:=C_G + else + hcond:=C_A; + + if not(omitfirstcomp) or temptovalue then + emitjmp(hcond,aktbreaklabel); + + { align loop target } + if not(cs_littlesize in aktglobalswitches) then + exprasmlist^.concat(new(pai_align,init_op(4,$90))); + + emitlab(l3); + + { help register must not be in instruction block } + cleartempgen; + if assigned(p^.t1) then + secondpass(p^.t1); + + emitlab(aktcontinuelabel); + + { makes no problems there } + cleartempgen; + + if (p^.t2^.location.loc <> LOC_CREGISTER) then + begin + { demand help register again } + cmp32:=getregister32; + case hs of + 1 : cmpreg:=reg32toreg8(cmp32); + 2 : cmpreg:=reg32toreg16(cmp32); + 4 : cmpreg:=cmp32; + end; + end; + + { produce comparison and the corresponding } + { jump } + if temptovalue then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + begin + emit_ref_reg(A_CMP,opsize,newreference(temp1), + p^.t2^.location.register); + end + else + begin + emit_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), + cmpreg); + emit_ref_reg(A_CMP,opsize,newreference(temp1), + cmpreg); + end; + end + else + begin + if p^.t2^.location.loc=LOC_CREGISTER then + emit_const_reg(A_CMP,opsize,p^.right^.value, + p^.t2^.location.register) + else + emit_const_ref(A_CMP,opsize,p^.right^.value, + newreference(p^.t2^.location.reference)); + end; + if p^.backward then + if count_var_is_signed then + hcond:=C_LE + else + hcond:=C_BE + else + if count_var_is_signed then + hcond:=C_GE + else + hcond:=C_AE; + emitjmp(hcond,aktbreaklabel); + { according to count direction DEC or INC... } + { must be after the test because of 0to 255 for bytes !! } + if p^.backward then + hop:=A_DEC + else + hop:=A_INC; + + if p^.t2^.location.loc=LOC_CREGISTER then + emit_reg(hop,opsize,p^.t2^.location.register) + else + emit_ref(hop,opsize,newreference(p^.t2^.location.reference)); + emitjmp(C_None,l3); + + if (p^.t2^.location.loc <> LOC_CREGISTER) then + ungetregister32(cmp32); + if temptovalue then + ungetiftemp(temp1); + + { this is the break label: } + emitlab(aktbreaklabel); + + aktcontinuelabel:=oldclabel; + aktbreaklabel:=oldblabel; + { a break/continue in a for block can't be seen outside } + flowcontrol:=flowcontrol-[fc_break,fc_continue]; + end; + + +{***************************************************************************** + SecondExitN +*****************************************************************************} + + procedure secondexitn(var p : ptree); + var + is_mem : boolean; + {op : tasmop; + s : topsize;} + otlabel,oflabel : pasmlabel; + r : preference; + + label + do_jmp; + begin + include(flowcontrol,fc_exit); + if assigned(p^.left) then + if p^.left^.treetype=assignn then + begin + { just do a normal assignment followed by exit } + secondpass(p^.left); + emitjmp(C_None,aktexitlabel); + end + else + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left); + case p^.left^.location.loc of + LOC_FPU : goto do_jmp; + LOC_MEM, + LOC_REFERENCE : is_mem:=true; + LOC_CREGISTER, + LOC_REGISTER : is_mem:=false; + LOC_FLAGS : begin + emit_flag2reg(p^.left^.location.resflags,R_AL); + goto do_jmp; + end; + LOC_JUMP : begin + emitlab(truelabel); + emit_const_reg(A_MOV,S_B,1,R_AL); + emitjmp(C_None,aktexit2label); + emitlab(falselabel); + emit_reg_reg(A_XOR,S_B,R_AL,R_AL); + goto do_jmp; + end; + else + internalerror(2001); + end; + case procinfo^.returntype.def^.deftype of + pointerdef, + procvardef : begin + if is_mem then + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EAX) + else + emit_reg_reg(A_MOV,S_L, + p^.left^.location.register,R_EAX); + end; + floatdef : begin + if pfloatdef(procinfo^.returntype.def)^.typ=f32bit then + begin + if is_mem then + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EAX) + else + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX); + end + else + if is_mem then + floatload(pfloatdef(procinfo^.returntype.def)^.typ,p^.left^.location.reference); + end; + { orddef, + enumdef : } + else + { it can be anything shorter than 4 bytes PM + this caused form bug 711 } + begin + case procinfo^.returntype.def^.size of + { it can be a qword/int64 too ... } + 8 : if is_mem then + begin + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EAX); + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + emit_ref_reg(A_MOV,S_L,r,R_EDX); + end + else + begin + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,R_EAX); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,R_EDX); + end; + { if its 3 bytes only we can still + copy one of garbage ! PM } + 4,3 : if is_mem then + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EAX) + else + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX); + 2 : if is_mem then + emit_ref_reg(A_MOV,S_W, + newreference(p^.left^.location.reference),R_AX) + else + emit_reg_reg(A_MOV,S_W,makereg16(p^.left^.location.register),R_AX); + 1 : if is_mem then + emit_ref_reg(A_MOV,S_B, + newreference(p^.left^.location.reference),R_AL) + else + emit_reg_reg(A_MOV,S_B,makereg8(p^.left^.location.register),R_AL); + else internalerror(605001); + end; + end; + end; +do_jmp: + truelabel:=otlabel; + falselabel:=oflabel; + emitjmp(C_None,aktexit2label); + end + else + begin + emitjmp(C_None,aktexitlabel); + end; + end; + + +{***************************************************************************** + SecondBreakN +*****************************************************************************} + + procedure secondbreakn(var p : ptree); + begin + include(flowcontrol,fc_break); + if aktbreaklabel<>nil then + emitjmp(C_None,aktbreaklabel) + else + CGMessage(cg_e_break_not_allowed); + end; + + +{***************************************************************************** + SecondContinueN +*****************************************************************************} + + procedure secondcontinuen(var p : ptree); + begin + include(flowcontrol,fc_continue); + if aktcontinuelabel<>nil then + emitjmp(C_None,aktcontinuelabel) + else + CGMessage(cg_e_continue_not_allowed); + end; + + +{***************************************************************************** + SecondGoto +*****************************************************************************} + + procedure secondgoto(var p : ptree); + + begin + emitjmp(C_None,p^.labelnr); + { the assigned avoids only crashes if the label isn't defined } + if assigned(p^.labsym) and + assigned(p^.labsym^.code) and + (aktexceptblock<>ptree(p^.labsym^.code)^.exceptionblock) then + CGMessage(cg_e_goto_inout_of_exception_block); + end; + + +{***************************************************************************** + SecondLabel +*****************************************************************************} + + procedure secondlabel(var p : ptree); + begin + emitlab(p^.labelnr); + cleartempgen; + secondpass(p^.left); + end; + + +{***************************************************************************** + SecondRaise +*****************************************************************************} + + procedure secondraise(var p : ptree); + + var + a : pasmlabel; + begin + if assigned(p^.left) then + begin + { multiple parameters? } + if assigned(p^.right) then + begin + { push frame } + if assigned(p^.frametree) then + begin + secondpass(p^.frametree); + if codegenerror then + exit; + emit_push_loc(p^.frametree^.location); + end + else + emit_const(A_PUSH,S_L,0); + { push address } + secondpass(p^.right); + if codegenerror then + exit; + emit_push_loc(p^.right^.location); + end + else + begin + getlabel(a); + emitlab(a); + emit_const(A_PUSH,S_L,0); + emit_sym(A_PUSH,S_L,a); + end; + { push object } + secondpass(p^.left); + if codegenerror then + exit; + emit_push_loc(p^.left^.location); + emitcall('FPC_RAISEEXCEPTION'); + end + else + begin + emitcall('FPC_POPADDRSTACK'); + emitcall('FPC_RERAISE'); + end; + end; + + +{***************************************************************************** + SecondTryExcept +*****************************************************************************} + + var + endexceptlabel : pasmlabel; + + { does the necessary things to clean up the object stack } + { in the except block } + procedure cleanupobjectstack; + + begin + emitcall('FPC_POPOBJECTSTACK'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_PUSH,S_L,R_EAX); + emitcall('FPC_DESTROYEXCEPTION'); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + maybe_loadesi; + end; + + { pops one element from the exception address stack } + { and removes the flag } + procedure cleanupaddrstack; + + begin + emitcall('FPC_POPADDRSTACK'); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + end; + + procedure secondtryexcept(var p : ptree); + + var + exceptlabel,doexceptlabel,oldendexceptlabel, + lastonlabel, + exitexceptlabel, + continueexceptlabel, + breakexceptlabel, + exittrylabel, + continuetrylabel, + breaktrylabel, + doobjectdestroy, + doobjectdestroyandreraise, + oldaktexitlabel, + oldaktexit2label, + oldaktcontinuelabel, + oldaktbreaklabel : pasmlabel; + oldexceptblock : ptree; + + + oldflowcontrol,tryflowcontrol, + exceptflowcontrol : tflowcontrol; + + begin + oldflowcontrol:=flowcontrol; + flowcontrol:=[]; + { this can be called recursivly } + oldendexceptlabel:=endexceptlabel; + + { we modify EAX } + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + + { save the old labels for control flow statements } + oldaktexitlabel:=aktexitlabel; + oldaktexit2label:=aktexit2label; + if assigned(aktbreaklabel) then + begin + oldaktcontinuelabel:=aktcontinuelabel; + oldaktbreaklabel:=aktbreaklabel; + end; + + { get new labels for the control flow statements } + getlabel(exittrylabel); + getlabel(exitexceptlabel); + if assigned(aktbreaklabel) then + begin + getlabel(breaktrylabel); + getlabel(continuetrylabel); + getlabel(breakexceptlabel); + getlabel(continueexceptlabel); + end; + + getlabel(exceptlabel); + getlabel(doexceptlabel); + getlabel(endexceptlabel); + getlabel(lastonlabel); + push_int (1); { push type of exceptionframe } + emitcall('FPC_PUSHEXCEPTADDR'); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_PUSH,S_L,R_EAX); + emitcall('FPC_SETJMP'); + emit_reg(A_PUSH,S_L,R_EAX); + emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX); + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_NE,exceptlabel); + + { try block } + { set control flow labels for the try block } + aktexitlabel:=exittrylabel; + aktexit2label:=exittrylabel; + if assigned(oldaktbreaklabel) then + begin + aktcontinuelabel:=continuetrylabel; + aktbreaklabel:=breaktrylabel; + end; + + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.left; + flowcontrol:=[]; + secondpass(p^.left); + tryflowcontrol:=flowcontrol; + aktexceptblock:=oldexceptblock; + if codegenerror then + exit; + + emitlab(exceptlabel); + emitcall('FPC_POPADDRSTACK'); + + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + + emitjmp(C_E,endexceptlabel); + emitlab(doexceptlabel); + + { set control flow labels for the except block } + { and the on statements } + aktexitlabel:=exitexceptlabel; + aktexit2label:=exitexceptlabel; + if assigned(oldaktbreaklabel) then + begin + aktcontinuelabel:=continueexceptlabel; + aktbreaklabel:=breakexceptlabel; + end; + + flowcontrol:=[]; + { on statements } + if assigned(p^.right) then + begin + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + secondpass(p^.right); + aktexceptblock:=oldexceptblock; + end; + + emitlab(lastonlabel); + { default handling except handling } + if assigned(p^.t1) then + begin + { FPC_CATCHES must be called with + 'default handler' flag (=-1) + } + push_int (-1); + emitcall('FPC_CATCHES'); + maybe_loadesi; + + { the destruction of the exception object must be also } + { guarded by an exception frame } + getlabel(doobjectdestroy); + getlabel(doobjectdestroyandreraise); + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1))); + emitcall('FPC_PUSHEXCEPTADDR'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitcall('FPC_SETJMP'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_NE,doobjectdestroyandreraise); + + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.t1; + { here we don't have to reset flowcontrol } + { the default and on flowcontrols are handled equal } + secondpass(p^.t1); + exceptflowcontrol:=flowcontrol; + aktexceptblock:=oldexceptblock; + + emitlab(doobjectdestroyandreraise); + emitcall('FPC_POPADDRSTACK'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_E,doobjectdestroy); + emitcall('FPC_POPSECONDOBJECTSTACK'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_PUSH,S_L,R_EAX); + emitcall('FPC_DESTROYEXCEPTION'); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + { we don't need to restore esi here because reraise never } + { returns } + emitcall('FPC_RERAISE'); + + emitlab(doobjectdestroy); + cleanupobjectstack; + emitjmp(C_None,endexceptlabel); + end + else + begin + emitcall('FPC_RERAISE'); + exceptflowcontrol:=flowcontrol; + end; + + if fc_exit in exceptflowcontrol then + begin + { do some magic for exit in the try block } + emitlab(exitexceptlabel); + { we must also destroy the address frame which guards } + { exception object } + cleanupaddrstack; + cleanupobjectstack; + emitjmp(C_None,oldaktexitlabel); + end; + + if fc_break in exceptflowcontrol then + begin + emitlab(breakexceptlabel); + { we must also destroy the address frame which guards } + { exception object } + cleanupaddrstack; + cleanupobjectstack; + emitjmp(C_None,oldaktbreaklabel); + end; + + if fc_continue in exceptflowcontrol then + begin + emitlab(continueexceptlabel); + { we must also destroy the address frame which guards } + { exception object } + cleanupaddrstack; + cleanupobjectstack; + emitjmp(C_None,oldaktcontinuelabel); + end; + + if fc_exit in tryflowcontrol then + begin + { do some magic for exit in the try block } + emitlab(exittrylabel); + cleanupaddrstack; + emitjmp(C_None,oldaktexitlabel); + end; + + if fc_break in tryflowcontrol then + begin + emitlab(breaktrylabel); + cleanupaddrstack; + emitjmp(C_None,oldaktbreaklabel); + end; + + if fc_continue in tryflowcontrol then + begin + emitlab(continuetrylabel); + cleanupaddrstack; + emitjmp(C_None,oldaktcontinuelabel); + end; + + emitlab(endexceptlabel); + + endexceptlabel:=oldendexceptlabel; + + { restore the control flow labels } + aktexitlabel:=oldaktexitlabel; + aktexit2label:=oldaktexit2label; + if assigned(oldaktbreaklabel) then + begin + aktcontinuelabel:=oldaktcontinuelabel; + aktbreaklabel:=oldaktbreaklabel; + end; + + { return all used control flow statements } + flowcontrol:=oldflowcontrol+exceptflowcontrol+ + tryflowcontrol; + end; + + procedure secondon(var p : ptree); + + var + nextonlabel, + exitonlabel, + continueonlabel, + breakonlabel, + oldaktexitlabel, + oldaktexit2label, + oldaktcontinuelabel, + doobjectdestroyandreraise, + doobjectdestroy, + oldaktbreaklabel : pasmlabel; + ref : treference; + oldexceptblock : ptree; + oldflowcontrol : tflowcontrol; + + begin + oldflowcontrol:=flowcontrol; + flowcontrol:=[]; + getlabel(nextonlabel); + + { push the vmt } + emit_sym(A_PUSH,S_L, + newasmsymbol(p^.excepttype^.vmt_mangledname)); + emitcall('FPC_CATCHES'); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX); + emitjmp(C_E,nextonlabel); + ref.symbol:=nil; + gettempofsizereference(4,ref); + + { what a hack ! } + if assigned(p^.exceptsymtable) then + pvarsym(p^.exceptsymtable^.symindex^.first)^.address:=ref.offset; + + emit_reg_ref(A_MOV,S_L, + R_EAX,newreference(ref)); + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + + { in the case that another exception is risen } + { we've to destroy the old one } + getlabel(doobjectdestroyandreraise); + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1))); + emitcall('FPC_PUSHEXCEPTADDR'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitcall('FPC_SETJMP'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_NE,doobjectdestroyandreraise); + + if assigned(p^.right) then + begin + oldaktexitlabel:=aktexitlabel; + oldaktexit2label:=aktexit2label; + getlabel(exitonlabel); + aktexitlabel:=exitonlabel; + aktexit2label:=exitonlabel; + if assigned(aktbreaklabel) then + begin + oldaktcontinuelabel:=aktcontinuelabel; + oldaktbreaklabel:=aktbreaklabel; + getlabel(breakonlabel); + getlabel(continueonlabel); + aktcontinuelabel:=continueonlabel; + aktbreaklabel:=breakonlabel; + end; + + { esi is destroyed by FPC_CATCHES } + maybe_loadesi; + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + secondpass(p^.right); + aktexceptblock:=oldexceptblock; + end; + getlabel(doobjectdestroy); + emitlab(doobjectdestroyandreraise); + emitcall('FPC_POPADDRSTACK'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_E,doobjectdestroy); + emitcall('FPC_POPSECONDOBJECTSTACK'); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_PUSH,S_L,R_EAX); + emitcall('FPC_DESTROYEXCEPTION'); + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + { we don't need to restore esi here because reraise never } + { returns } + emitcall('FPC_RERAISE'); + + emitlab(doobjectdestroy); + cleanupobjectstack; + { clear some stuff } + ungetiftemp(ref); + emitjmp(C_None,endexceptlabel); + + if assigned(p^.right) then + begin + { special handling for control flow instructions } + if fc_exit in flowcontrol then + begin + { the address and object pop does secondtryexcept } + emitlab(exitonlabel); + emitjmp(C_None,oldaktexitlabel); + end; + + if fc_break in flowcontrol then + begin + { the address and object pop does secondtryexcept } + emitlab(breakonlabel); + emitjmp(C_None,oldaktbreaklabel); + end; + + if fc_continue in flowcontrol then + begin + { the address and object pop does secondtryexcept } + emitlab(continueonlabel); + emitjmp(C_None,oldaktcontinuelabel); + end; + + aktexitlabel:=oldaktexitlabel; + aktexit2label:=oldaktexit2label; + if assigned(oldaktbreaklabel) then + begin + aktcontinuelabel:=oldaktcontinuelabel; + aktbreaklabel:=oldaktbreaklabel; + end; + end; + + emitlab(nextonlabel); + flowcontrol:=oldflowcontrol+flowcontrol; + { next on node } + if assigned(p^.left) then + begin + cleartempgen; + secondpass(p^.left); + end; + end; + +{***************************************************************************** + SecondTryFinally +*****************************************************************************} + + procedure secondtryfinally(var p : ptree); + + var + reraiselabel, + finallylabel, + endfinallylabel, + exitfinallylabel, + continuefinallylabel, + breakfinallylabel, + oldaktexitlabel, + oldaktexit2label, + oldaktcontinuelabel, + oldaktbreaklabel : pasmlabel; + oldexceptblock : ptree; + oldflowcontrol,tryflowcontrol : tflowcontrol; + decconst : longint; + + begin + { check if child nodes do a break/continue/exit } + oldflowcontrol:=flowcontrol; + flowcontrol:=[]; + { we modify EAX } + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + getlabel(finallylabel); + getlabel(endfinallylabel); + getlabel(reraiselabel); + + { the finally block must catch break, continue and exit } + { statements } + oldaktexitlabel:=aktexitlabel; + oldaktexit2label:=aktexit2label; + getlabel(exitfinallylabel); + aktexitlabel:=exitfinallylabel; + aktexit2label:=exitfinallylabel; + if assigned(aktbreaklabel) then + begin + oldaktcontinuelabel:=aktcontinuelabel; + oldaktbreaklabel:=aktbreaklabel; + getlabel(breakfinallylabel); + getlabel(continuefinallylabel); + aktcontinuelabel:=continuefinallylabel; + aktbreaklabel:=breakfinallylabel; + end; + + push_int(1); { Type of stack-frame must be pushed} + emitcall('FPC_PUSHEXCEPTADDR'); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_PUSH,S_L,R_EAX); + emitcall('FPC_SETJMP'); + emit_reg(A_PUSH,S_L,R_EAX); + emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX); + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitjmp(C_NE,finallylabel); + + { try code } + if assigned(p^.left) then + begin + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.left; + secondpass(p^.left); + tryflowcontrol:=flowcontrol; + if codegenerror then + exit; + aktexceptblock:=oldexceptblock; + end; + + emitlab(finallylabel); + emitcall('FPC_POPADDRSTACK'); + { finally code } + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + flowcontrol:=[]; + secondpass(p^.right); + if flowcontrol<>[] then + CGMessage(cg_e_control_flow_outside_finally); + aktexceptblock:=oldexceptblock; + if codegenerror then + exit; + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + emit_reg_reg(A_TEST,S_L,R_EAX,R_EAX); + emitjmp(C_E,endfinallylabel); + emit_reg(A_DEC,S_L,R_EAX); + emitjmp(C_Z,reraiselabel); + if fc_exit in tryflowcontrol then + begin + emit_reg(A_DEC,S_L,R_EAX); + emitjmp(C_Z,oldaktexitlabel); + decconst:=1; + end + else + decconst:=2; + if fc_break in tryflowcontrol then + begin + emit_const_reg(A_SUB,S_L,decconst,R_EAX); + emitjmp(C_Z,oldaktbreaklabel); + decconst:=1; + end + else + inc(decconst); + if fc_continue in tryflowcontrol then + begin + emit_const_reg(A_SUB,S_L,decconst,R_EAX); + emitjmp(C_Z,oldaktcontinuelabel); + end; + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emitlab(reraiselabel); + emitcall('FPC_RERAISE'); + { do some magic for exit,break,continue in the try block } + if fc_exit in tryflowcontrol then + begin + emitlab(exitfinallylabel); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_const(A_PUSH,S_L,2); + emitjmp(C_NONE,finallylabel); + end; + if fc_break in tryflowcontrol then + begin + emitlab(breakfinallylabel); + { allocate eax } + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + { deallocate eax } + exprasmlist^.concat(new(pairegalloc,dealloc(R_EAX))); + emit_const(A_PUSH,S_L,3); + emitjmp(C_NONE,finallylabel); + end; + if fc_continue in tryflowcontrol then + begin + emitlab(continuefinallylabel); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_reg(A_POP,S_L,R_EAX); + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + emit_const(A_PUSH,S_L,4); + emitjmp(C_NONE,finallylabel); + end; + + emitlab(endfinallylabel); + + aktexitlabel:=oldaktexitlabel; + aktexit2label:=oldaktexit2label; + if assigned(aktbreaklabel) then + begin + aktcontinuelabel:=oldaktcontinuelabel; + aktbreaklabel:=oldaktbreaklabel; + end; + flowcontrol:=oldflowcontrol+tryflowcontrol; + end; + + +{***************************************************************************** + SecondFail +*****************************************************************************} + + procedure secondfail(var p : ptree); + begin + emitjmp(C_None,faillabel); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.75 2000/07/06 20:43:44 florian + * the on statement has to clear the temp. gen before calling secondpass for + the next on statement + + Revision 1.74 2000/05/09 19:05:56 florian + * fixed a problem when returning int64/qword from a function in -Or: in some + cases a wrong result was returned + + Revision 1.73 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.72 2000/04/22 15:29:26 jonas + * cleaner register (de)allocation in secondfor (for optimizer) + + Revision 1.71 2000/04/16 08:08:44 jonas + * release register used in for-loop before end label (for better + optimizations) + + Revision 1.70 2000/02/29 23:58:19 pierre + Use $GOTO ON + + Revision 1.69 2000/02/10 23:44:42 florian + * big update for exception handling code generation: possible mem holes + fixed, break/continue/exit should work always now as expected + + Revision 1.68 2000/02/09 13:22:47 peter + * log truncated + + Revision 1.67 2000/01/21 12:17:42 jonas + * regallocation fixes + + Revision 1.66 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.65 1999/12/22 23:30:06 peter + * nested try blocks work again + + Revision 1.64 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.63 1999/12/19 17:02:45 peter + * support exit,break,continue in try...except + * support break,continue in try...finally + + Revision 1.62 1999/12/17 11:20:06 florian + * made the goto checking for excpetions more fool proof against errors + + Revision 1.61 1999/12/14 09:58:41 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.60 1999/12/01 12:36:23 peter + * fixed selfpointer after destroyexception + + Revision 1.59 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.58 1999/11/28 23:15:23 pierre + * fix for form bug 721 + + Revision 1.57 1999/11/15 21:49:09 peter + * push address also for raise at + + Revision 1.56 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.55 1999/10/30 17:35:26 peter + * fpc_freemem fpc_getmem new callings updated + + Revision 1.54 1999/10/21 16:41:37 florian + * problems with readln fixed: esi wasn't restored correctly when + reading ordinal fields of objects futher the register allocation + didn't take care of the extra register when reading ordinal values + * enumerations can now be used in constant indexes of properties + + Revision 1.53 1999/10/05 22:01:52 pierre + * bug exit('test') + fail for classes + + Revision 1.52 1999/09/27 23:44:46 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.51 1999/09/26 13:26:05 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + + Revision 1.50 1999/09/20 16:35:43 peter + * restored old alignment, saves 40k on ppc386 + + Revision 1.49 1999/09/15 20:35:37 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.48 1999/09/07 07:56:37 peter + * reload esi in except block to allow virtual methods + + Revision 1.47 1999/08/25 11:59:42 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) +} \ No newline at end of file diff --git a/befpc/compiler/cg386inl.pas b/befpc/compiler/cg386inl.pas new file mode 100644 index 0000000..287f903 --- /dev/null +++ b/befpc/compiler/cg386inl.pas @@ -0,0 +1,1660 @@ +{ + $Id: cg386inl.pas,v 1.1.1.1 2001-07-23 17:15:35 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 inline nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386inl; +interface + + uses + tree; + + procedure secondinline(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals,files, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_1,pass_2, + cpubase,cpuasm, + cgai386,tgeni386,cg386cal; + + +{***************************************************************************** + Helpers +*****************************************************************************} + + { reverts the parameter list } + var nb_para : integer; + + function reversparameter(p : ptree) : ptree; + + var + hp1,hp2 : ptree; + + begin + hp1:=nil; + nb_para := 0; + while assigned(p) do + begin + { pull out } + hp2:=p; + p:=p^.right; + inc(nb_para); + { pull in } + hp2^.right:=hp1; + hp1:=hp2; + end; + reversparameter:=hp1; + end; + + +{***************************************************************************** + SecondInLine +*****************************************************************************} + + procedure StoreDirectFuncResult(var dest:ptree); + var + hp : ptree; + hdef : porddef; + hreg : tregister; + hregister : tregister; + oldregisterdef : boolean; + op : tasmop; + opsize : topsize; + + begin + { Get the accumulator first so it can't be used in the dest } + if (dest^.resulttype^.deftype=orddef) and + not(is_64bitint(dest^.resulttype)) then + hregister:=getexplicitregister32(accumulator); + { process dest } + SecondPass(dest); + if Codegenerror then + exit; + { store the value } + Case dest^.resulttype^.deftype of + floatdef: + if dest^.location.loc=LOC_CFPUREGISTER then + begin + floatstoreops(pfloatdef(dest^.resulttype)^.typ,op,opsize); + emit_reg(op,opsize,correct_fpuregister(dest^.location.register,fpuvaroffset+1)); + end + else + begin + inc(fpuvaroffset); + floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference); + { floatstore decrements the fpu var offset } + { but in fact we didn't increment it } + end; + orddef: + begin + if is_64bitint(dest^.resulttype) then + begin + emit_movq_reg_loc(R_EDX,R_EAX,dest^.location); + end + else + begin + Case dest^.resulttype^.size of + 1 : hreg:=regtoreg8(hregister); + 2 : hreg:=regtoreg16(hregister); + 4 : hreg:=hregister; + End; + emit_mov_reg_loc(hreg,dest^.location); + If (cs_check_range in aktlocalswitches) and + {no need to rangecheck longints or cardinals on 32bit processors} + not((porddef(dest^.resulttype)^.typ = s32bit) and + (porddef(dest^.resulttype)^.low = longint($80000000)) and + (porddef(dest^.resulttype)^.high = $7fffffff)) and + not((porddef(dest^.resulttype)^.typ = u32bit) and + (porddef(dest^.resulttype)^.low = 0) and + (porddef(dest^.resulttype)^.high = longint($ffffffff))) then + Begin + {do not register this temporary def} + OldRegisterDef := RegisterDef; + RegisterDef := False; + hdef:=nil; + Case PordDef(dest^.resulttype)^.typ of + u8bit,u16bit,u32bit: + begin + new(hdef,init(u32bit,0,$ffffffff)); + hreg:=hregister; + end; + s8bit,s16bit,s32bit: + begin + new(hdef,init(s32bit,$80000000,$7fffffff)); + hreg:=hregister; + end; + end; + { create a fake node } + hp := genzeronode(nothingn); + hp^.location.loc := LOC_REGISTER; + hp^.location.register := hreg; + if assigned(hdef) then + hp^.resulttype:=hdef + else + hp^.resulttype:=dest^.resulttype; + { emit the range check } + emitrangecheck(hp,dest^.resulttype); + hp^.right := nil; + if assigned(hdef) then + Dispose(hdef, Done); + RegisterDef := OldRegisterDef; + disposetree(hp); + End; + ungetregister(hregister); + end; + End; + else + internalerror(66766766); + end; + { free used registers } + del_locref(dest^.location); + end; + + + procedure secondinline(var p : ptree); + const + {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);} +{ float_name: array[tfloattype] of string[8]= + ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); } + incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC); + addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); + var + aktfile : treference; + ft : tfiletyp; + opsize : topsize; + op, + asmop : tasmop; + pushed : tpushed; + {inc/dec} + addconstant : boolean; + addvalue : longint; + + + procedure handlereadwrite(doread,doln : boolean); + { produces code for READ(LN) and WRITE(LN) } + + procedure loadstream; + const + io:array[boolean] of string[7]=('_OUTPUT','_INPUT'); + var + r : preference; + begin + new(r); + reset_reference(r^); + r^.symbol:=newasmsymbol( + 'U_'+upper(target_info.system_unit)+io[doread]); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L,r,R_EDI) + end; + + const + rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_'); + var + node,hp : ptree; + typedtyp, + pararesult : pdef; + orgfloattype : tfloattype; + dummycoll : tparaitem; + iolabel : pasmlabel; + npara : longint; + esireloaded : boolean; + + begin + { here we don't use register calling conventions } + dummycoll.init; + dummycoll.register:=R_NO; + { I/O check } + if (cs_check_io in aktlocalswitches) and + not(po_iocheck in aktprocsym^.definition^.procoptions) then + begin + getlabel(iolabel); + emitlab(iolabel); + end + else + iolabel:=nil; + { for write of real with the length specified } + hp:=nil; + { reserve temporary pointer to data variable } + aktfile.symbol:=nil; + gettempofsizereference(4,aktfile); + { first state text data } + ft:=ft_text; + { and state a parameter ? } + if p^.left=nil then + begin + { the following instructions are for "writeln;" } + loadstream; + { save @aktfile in temporary variable } + emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + { revers paramters } + node:=reversparameter(p^.left); + + p^.left := node; + npara := nb_para; + { calculate data variable } + { is first parameter a file type ? } + if node^.left^.resulttype^.deftype=filedef then + begin + ft:=pfiledef(node^.left^.resulttype)^.filetyp; + if ft=ft_typed then + typedtyp:=pfiledef(node^.left^.resulttype)^.typedfiletype.def; + secondpass(node^.left); + if codegenerror then + exit; + + { save reference in temporary variables } + if node^.left^.location.loc<>LOC_REFERENCE then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + + emit_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI); + del_reference(node^.left^.location.reference); + { skip to the next parameter } + node:=node^.right; + end + else + begin + { load stdin/stdout stream } + loadstream; + end; + + { save @aktfile in temporary variable } + emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + if doread then + { parameter by READ gives call by reference } + dummycoll.paratyp:=vs_var + { an WRITE Call by "Const" } + else + dummycoll.paratyp:=vs_const; + + { because of secondcallparan, which otherwise attaches } + if ft=ft_typed then + { this is to avoid copy of simple const parameters } + {dummycoll.data:=new(pformaldef,init)} + dummycoll.paratype.setdef(cformaldef) + else + { I think, this isn't a good solution (FK) } + dummycoll.paratype.reset; + + while assigned(node) do + begin + esireloaded:=false; + pushusedregisters(pushed,$ff); + hp:=node; + node:=node^.right; + hp^.right:=nil; + if hp^.is_colon_para then + CGMessage(parser_e_illegal_colon_qualifier); + { when float is written then we need bestreal to be pushed + convert here else we loose the old float type } + if (not doread) and + (ft<>ft_typed) and + (hp^.left^.resulttype^.deftype=floatdef) then + begin + orgfloattype:=pfloatdef(hp^.left^.resulttype)^.typ; + hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); + firstpass(hp^.left); + end; + { when read ord,floats are functions, so they need this + parameter as their destination instead of being pushed } + if doread and + (ft<>ft_typed) and + (hp^.resulttype^.deftype in [orddef,floatdef]) then + begin + end + else + begin + if ft=ft_typed then + never_copy_const_param:=true; + { reset data type } + dummycoll.paratype.reset; + { create temporary defs for high tree generation } + if doread and (is_shortstring(hp^.resulttype)) then + dummycoll.paratype.setdef(openshortstringdef) + else + if (is_chararray(hp^.resulttype)) then + dummycoll.paratype.setdef(openchararraydef); + secondcallparan(hp,@dummycoll,false,false,false,0,0); + if ft=ft_typed then + never_copy_const_param:=false; + end; + hp^.right:=node; + if codegenerror then + exit; + + emit_push_mem(aktfile); + if (ft=ft_typed) then + begin + { OK let's try this } + { first we must only allow the right type } + { we have to call blockread or blockwrite } + { but the real problem is that } + { reset and rewrite should have set } + { the type size } + { as recordsize for that file !!!! } + { how can we make that } + { I think that is only possible by adding } + { reset and rewrite to the inline list a call } + { allways read only one record by element } + push_int(typedtyp^.size); + if doread then + emitcall('FPC_TYPED_READ') + else + emitcall('FPC_TYPED_WRITE'); + end + else + begin + { save current position } + pararesult:=hp^.left^.resulttype; + { handle possible field width } + { of course only for write(ln) } + if not doread then + begin + { handle total width parameter } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + dummycoll.paratype.setdef(hp^.resulttype); + dummycoll.paratyp:=vs_value; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + hp^.right:=node; + if codegenerror then + exit; + end + else + if pararesult^.deftype<>floatdef then + push_int(0) + else + push_int(-32767); + { a second colon para for a float ? } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + dummycoll.paratype.setdef(hp^.resulttype); + dummycoll.paratyp:=vs_value; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + hp^.right:=node; + if pararesult^.deftype<>floatdef then + CGMessage(parser_e_illegal_colon_qualifier); + if codegenerror then + exit; + end + else + begin + if pararesult^.deftype=floatdef then + push_int(-1); + end; + { push also the real type for floats } + if pararesult^.deftype=floatdef then + push_int(ord(orgfloattype)); + end; + case pararesult^.deftype of + stringdef : + begin + emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname); + end; + pointerdef : + begin + if is_pchar(pararesult) then + emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER') + end; + arraydef : + begin + if is_chararray(pararesult) then + emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY') + end; + floatdef : + begin + emitcall(rdwrprefix[doread]+'FLOAT'); + { + if pfloatdef(p^.resulttype)^.typ<>f32bit then + dec(fpuvaroffset); + } + if doread then + begin + maybe_loadesi; + esireloaded:=true; + StoreDirectFuncResult(hp^.left); + end; + end; + orddef : + begin + case porddef(pararesult)^.typ of + s8bit,s16bit,s32bit : + emitcall(rdwrprefix[doread]+'SINT'); + u8bit,u16bit,u32bit : + emitcall(rdwrprefix[doread]+'UINT'); + uchar : + emitcall(rdwrprefix[doread]+'CHAR'); + s64bit : + emitcall(rdwrprefix[doread]+'INT64'); + u64bit : + emitcall(rdwrprefix[doread]+'QWORD'); + bool8bit, + bool16bit, + bool32bit : + emitcall(rdwrprefix[doread]+'BOOLEAN'); + end; + if doread then + begin + maybe_loadesi; + esireloaded:=true; + StoreDirectFuncResult(hp^.left); + end; + end; + end; + end; + { load ESI in methods again } + popusedregisters(pushed); + if not(esireloaded) then + maybe_loadesi; + end; + end; + { Insert end of writing for textfiles } + if ft=ft_text then + begin + pushusedregisters(pushed,$ff); + emit_push_mem(aktfile); + if doread then + begin + if doln then + emitcall('FPC_READLN_END') + else + emitcall('FPC_READ_END'); + end + else + begin + if doln then + emitcall('FPC_WRITELN_END') + else + emitcall('FPC_WRITE_END'); + end; + popusedregisters(pushed); + maybe_loadesi; + end; + { Insert IOCheck if set } + if assigned(iolabel) then + begin + { registers are saved in the procedure } + emit_sym(A_PUSH,S_L,iolabel); + emitcall('FPC_IOCHECK'); + end; + { Freeup all used temps } + ungetiftemp(aktfile); + if assigned(p^.left) then + begin + p^.left:=reversparameter(p^.left); + if npara<>nb_para then + CGMessage(cg_f_internal_error_in_secondinline); + hp:=p^.left; + while assigned(hp) do + begin + if assigned(hp^.left) then + if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(hp^.left^.location.reference); + hp:=hp^.right; + end; + end; + end; + + procedure handle_str; + + var + hp,node : ptree; + dummycoll : tparaitem; + is_real : boolean; + realtype : tfloattype; + procedureprefix : string; + + begin + dummycoll.init; + dummycoll.register:=R_NO; + pushusedregisters(pushed,$ff); + node:=p^.left; + is_real:=false; + while assigned(node^.right) do node:=node^.right; + { if a real parameter somewhere then call REALSTR } + if (node^.left^.resulttype^.deftype=floatdef) then + begin + is_real:=true; + realtype:=pfloatdef(node^.left^.resulttype)^.typ; + end; + + node:=p^.left; + { we have at least two args } + { with at max 2 colon_para in between } + + { string arg } + hp:=node; + node:=node^.right; + hp^.right:=nil; + dummycoll.paratyp:=vs_var; + if is_shortstring(hp^.resulttype) then + dummycoll.paratype.setdef(openshortstringdef) + else + dummycoll.paratype.setdef(hp^.resulttype); + procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_'; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + + dummycoll.paratyp:=vs_const; + disposetree(p^.left); + p^.left:=nil; + { second arg } + hp:=node; + node:=node^.right; + hp^.right:=nil; + + { if real push real type } + if is_real then + push_int(ord(realtype)); + + { frac para } + if hp^.is_colon_para and assigned(node) and + node^.is_colon_para then + begin + dummycoll.paratype.setdef(hp^.resulttype); + dummycoll.paratyp:=vs_value; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + end + else + if is_real then + push_int(-1); + + { third arg, length only if is_real } + if hp^.is_colon_para then + begin + dummycoll.paratype.setdef(hp^.resulttype); + dummycoll.paratyp:=vs_value; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + end + else + if is_real then + push_int(-32767) + else + push_int(-1); + + { Convert float to bestreal } + if is_real then + begin + hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); + firstpass(hp^.left); + end; + + { last arg longint or real } + dummycoll.paratype.setdef(hp^.resulttype); + dummycoll.paratyp:=vs_value; + secondcallparan(hp,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + + if is_real then + emitcall(procedureprefix+'FLOAT') + else + case porddef(hp^.resulttype)^.typ of + u32bit: + emitcall(procedureprefix+'CARDINAL'); + + u64bit: + emitcall(procedureprefix+'QWORD'); + + s64bit: + emitcall(procedureprefix+'INT64'); + + else + emitcall(procedureprefix+'LONGINT'); + end; + disposetree(hp); + + popusedregisters(pushed); + end; + + + Procedure Handle_Val; + var + hp,node, code_para, dest_para : ptree; + hreg,hreg2: TRegister; + hdef: POrdDef; + procedureprefix : string; + hr, hr2: TReference; + dummycoll : tparaitem; + has_code, has_32bit_code, oldregisterdef: boolean; + r : preference; + + begin + dummycoll.init; + dummycoll.register:=R_NO; + node:=p^.left; + hp:=node; + node:=node^.right; + hp^.right:=nil; + {if we have 3 parameters, we have a code parameter} + has_code := Assigned(node^.right); + has_32bit_code := false; + reset_reference(hr); + hreg := R_NO; + + If has_code then + Begin + {code is an orddef, that's checked in tcinl} + code_para := hp; + hp := node; + node := node^.right; + hp^.right := nil; + has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]); + End; + + {hp = destination now, save for later use} + dest_para := hp; + + {if EAX is already in use, it's a register variable. Since we don't + need another register besides EAX, release the one we got} + If hreg <> R_EAX Then ungetregister32(hreg); + + {load and push the address of the destination} + dummycoll.paratyp:=vs_var; + dummycoll.paratype.setdef(dest_para^.resulttype); + secondcallparan(dest_para,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + + {save the regvars} + pushusedregisters(pushed,$ff); + + {now that we've already pushed the addres of dest_para^.left on the + stack, we can put the real parameters on the stack} + + If has_32bit_code Then + Begin + dummycoll.paratyp:=vs_var; + dummycoll.paratype.setdef(code_para^.resulttype); + secondcallparan(code_para,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + Disposetree(code_para); + End + Else + Begin + {only 32bit code parameter is supported, so fake one} + GetTempOfSizeReference(4,hr); + emitpushreferenceaddr(hr); + End; + + {node = first parameter = string} + dummycoll.paratyp:=vs_const; + dummycoll.paratype.setdef(node^.resulttype); + secondcallparan(node,@dummycoll,false,false,false,0,0); + if codegenerror then + exit; + + Case dest_para^.resulttype^.deftype of + floatdef: + begin + procedureprefix := 'FPC_VAL_REAL_'; + if pfloatdef(p^.resulttype)^.typ<>f32bit then + inc(fpuvaroffset); + end; + orddef: + if is_64bitint(dest_para^.resulttype) then + begin + if is_signed(dest_para^.resulttype) then + procedureprefix := 'FPC_VAL_INT64_' + else + procedureprefix := 'FPC_VAL_QWORD_'; + end + else + begin + if is_signed(dest_para^.resulttype) then + begin + {if we are converting to a signed number, we have to include the + size of the destination, so the Val function can extend the sign + of the result to allow proper range checking} + emit_const(A_PUSH,S_L,dest_para^.resulttype^.size); + procedureprefix := 'FPC_VAL_SINT_' + end + else + procedureprefix := 'FPC_VAL_UINT_'; + end; + End; + emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname); + { before disposing node we need to ungettemp !! PM } + if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then + ungetiftemp(node^.left^.location.reference); + disposetree(node); + p^.left := nil; + + {reload esi in case the dest_para/code_para is a class variable or so} + maybe_loadesi; + + If (dest_para^.resulttype^.deftype = orddef) Then + Begin + {store the result in a safe place, because EAX may be used by a + register variable} + hreg := getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hreg); + if is_64bitint(dest_para^.resulttype) then + begin + hreg2:=getexplicitregister32(R_EDX); + emit_reg_reg(A_MOV,S_L,R_EDX,hreg2); + end; + {as of now, hreg now holds the location of the result, if it was + integer} + End; + + { restore the register vars} + + popusedregisters(pushed); + + If has_code and Not(has_32bit_code) Then + {only 16bit code is possible} + Begin + {load the address of the code parameter} + secondpass(code_para^.left); + {move the code to its destination} +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI); + emit_mov_reg_loc(R_DI,code_para^.left^.location); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + Disposetree(code_para); + End; + + {restore the address of the result} +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg(A_POP,S_L,R_EDI); + + {set up hr2 to a refernce with EDI as base register} + reset_reference(hr2); + hr2.base := R_EDI; + + {save the function result in the destination variable} + Case dest_para^.left^.resulttype^.deftype of + floatdef: + floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, hr2); + orddef: + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,s8bit: + emit_reg_ref(A_MOV, S_B, + RegToReg8(hreg),newreference(hr2)); + u16bit,s16bit: + emit_reg_ref(A_MOV, S_W, + RegToReg16(hreg),newreference(hr2)); + u32bit,s32bit: + emit_reg_ref(A_MOV, S_L, + hreg,newreference(hr2)); + u64bit,s64bit: + begin + emit_reg_ref(A_MOV, S_L, + hreg,newreference(hr2)); + r:=newreference(hr2); + inc(r^.offset,4); + emit_reg_ref(A_MOV, S_L, + hreg2,r); + end; + End; + End; +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + If (cs_check_range in aktlocalswitches) and + (dest_para^.left^.resulttype^.deftype = orddef) and + (not(is_64bitint(dest_para^.left^.resulttype))) and + {the following has to be changed to 64bit checking, once Val + returns 64 bit values (unless a special Val function is created + for that)} + {no need to rangecheck longints or cardinals on 32bit processors} + not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and + (porddef(dest_para^.left^.resulttype)^.low = longint($80000000)) and + (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and + not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and + (porddef(dest_para^.left^.resulttype)^.low = 0) and + (porddef(dest_para^.left^.resulttype)^.high = longint($ffffffff))) then + Begin + hp := getcopy(dest_para^.left); + hp^.location.loc := LOC_REGISTER; + hp^.location.register := hreg; + {do not register this temporary def} + OldRegisterDef := RegisterDef; + RegisterDef := False; + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff)); + s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff)); + end; + hp^.resulttype := hdef; + emitrangecheck(hp,dest_para^.left^.resulttype); + hp^.right := nil; + Dispose(hp^.resulttype, Done); + RegisterDef := OldRegisterDef; + disposetree(hp); + End; + {dest_para^.right is already nil} + disposetree(dest_para); + UnGetIfTemp(hr); + end; + + var + r : preference; + hp : ptree; + l : longint; + ispushed : boolean; + hregister : tregister; + otlabel,oflabel,l1 : pasmlabel; + oldpushedparasize : longint; + + begin + { save & reset pushedparasize } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + case p^.inlinenumber of + in_assert_x_y: + begin + { the node should be removed in the firstpass } + if not (cs_do_assertion in aktlocalswitches) then + internalerror(7123458); + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left^.left); + maketojumpbool(p^.left^.left); + emitlab(falselabel); + { erroraddr } + emit_reg(A_PUSH,S_L,R_EBP); + { lineno } + emit_const(A_PUSH,S_L,aktfilepos.line); + { filename string } + hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex),st_shortstring); + secondpass(hp); + if codegenerror then + exit; + emitpushreferenceaddr(hp^.location.reference); + disposetree(hp); + { push msg } + secondpass(p^.left^.right^.left); + emitpushreferenceaddr(p^.left^.right^.left^.location.reference); + { call } + emitcall('FPC_ASSERT'); + emitlab(truelabel); + truelabel:=otlabel; + falselabel:=oflabel; + end; + in_lo_word, + in_hi_word : + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=reg32toreg16(getregister32); + emit_reg_reg(A_MOV,S_W,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=reg32toreg16(getregister32); + emit_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference), + p^.location.register); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_word then + emit_const_reg(A_SHR,S_W,8,p^.location.register); + p^.location.register:=reg16toreg8(p^.location.register); + end; + in_sizeof_x, + in_typeof_x : + begin + { for both cases load vmt } + if p^.left^.treetype=typen then + begin + p^.location.register:=getregister32; + emit_sym_ofs_reg(A_MOV, + S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0, + p^.location.register); + end + else + begin + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + { load VMT pointer } + inc(p^.left^.location.reference.offset, + pobjectdef(p^.left^.resulttype)^.vmt_offset); + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.register); + end; + { in sizeof load size } + if p^.inlinenumber=in_sizeof_x then + begin + new(r); + reset_reference(r^); + r^.base:=p^.location.register; + emit_ref_reg(A_MOV,S_L,r, + p^.location.register); + end; + end; + in_lo_long, + in_hi_long : + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + p^.location.register); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_long then + emit_const_reg(A_SHR,S_L,16,p^.location.register); + p^.location.register:=reg32toreg16(p^.location.register); + end; + in_lo_qword, + in_hi_qword: + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_CREGISTER: + begin + p^.location.register:=getregister32; + if p^.inlinenumber=in_hi_qword then + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh, + p^.location.register) + else + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, + p^.location.register) + end; + LOC_MEM,LOC_REFERENCE: + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + r:=newreference(p^.left^.location.reference); + if p^.inlinenumber=in_hi_qword then + inc(r^.offset,4); + emit_ref_reg(A_MOV,S_L, + r,p^.location.register); + end; + LOC_REGISTER: + begin + if p^.inlinenumber=in_hi_qword then + begin + p^.location.register:=p^.left^.location.registerhigh; + ungetregister32(p^.left^.location.registerlow); + end + else + begin + p^.location.register:=p^.left^.location.registerlow; + ungetregister32(p^.left^.location.registerhigh); + end; + end; + end; + end; + in_length_string : + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + { length in ansi strings is at offset -8 } + if is_ansistring(p^.left^.resulttype) then + dec(p^.location.reference.offset,8) + { char is always 1, so make it a constant value } + else if is_char(p^.left^.resulttype) then + begin + clear_location(p^.location); + p^.location.loc:=LOC_MEM; + p^.location.reference.is_immediate:=true; + p^.location.reference.offset:=1; + end; + end; + in_pred_x, + in_succ_x: + begin + secondpass(p^.left); + if not (cs_check_overflow in aktlocalswitches) then + if p^.inlinenumber=in_pred_x then + asmop:=A_DEC + else + asmop:=A_INC + else + if p^.inlinenumber=in_pred_x then + asmop:=A_SUB + else + asmop:=A_ADD; + case p^.resulttype^.size of + 8 : opsize:=S_L; + 4 : opsize:=S_L; + 2 : opsize:=S_W; + 1 : opsize:=S_B; + else + internalerror(10080); + end; + p^.location.loc:=LOC_REGISTER; + if p^.resulttype^.size=8 then + begin + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_reg_reg(A_MOV,opsize,p^.left^.location.registerlow, + p^.location.registerlow); + emit_reg_reg(A_MOV,opsize,p^.left^.location.registerhigh, + p^.location.registerhigh); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), + p^.location.registerlow); + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + emit_ref_reg(A_MOV,opsize,r, + p^.location.registerhigh); + end; + end + else + begin + p^.location.registerhigh:=p^.left^.location.registerhigh; + p^.location.registerlow:=p^.left^.location.registerlow; + end; + if p^.inlinenumber=in_succ_x then + begin + emit_const_reg(A_ADD,opsize,1, + p^.location.registerlow); + emit_const_reg(A_ADC,opsize,0, + p^.location.registerhigh); + end + else + begin + emit_const_reg(A_SUB,opsize,1, + p^.location.registerlow); + emit_const_reg(A_SBB,opsize,0, + p^.location.registerhigh); + end; + end + else + begin + if p^.left^.location.loc<>LOC_REGISTER then + begin + { first, we've to release the source location ... } + if p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE] then + del_reference(p^.left^.location.reference); + + p^.location.register:=getregister32; + if (p^.resulttype^.size=2) then + p^.location.register:=reg32toreg16(p^.location.register); + if (p^.resulttype^.size=1) then + p^.location.register:=reg32toreg8(p^.location.register); + if p^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(A_MOV,opsize,p^.left^.location.register, + p^.location.register) + else + if p^.left^.location.loc=LOC_FLAGS then + emit_flag2reg(p^.left^.location.resflags,p^.location.register) + else + emit_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), + p^.location.register); + end + else p^.location.register:=p^.left^.location.register; + if not (cs_check_overflow in aktlocalswitches) then + emit_reg(asmop,opsize, + p^.location.register) + else + emit_const_reg(asmop,opsize,1, + p^.location.register); + end; + emitoverflowcheck(p); + emitrangecheck(p,p^.resulttype); + end; + in_dec_x, + in_inc_x : + begin + { set defaults } + addvalue:=1; + addconstant:=true; + { load first parameter, must be a reference } + secondpass(p^.left^.left); + case p^.left^.left^.resulttype^.deftype of + orddef, + enumdef : begin + case p^.left^.left^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + 8 : opsize:=S_L; + end; + end; + pointerdef : begin + opsize:=S_L; + if porddef(ppointerdef(p^.left^.left^.resulttype)^.pointertype.def)=voiddef then + addvalue:=1 + else + addvalue:=ppointerdef(p^.left^.left^.resulttype)^.pointertype.def^.size; + end; + else + internalerror(10081); + end; + { second argument specified?, must be a s32bit in register } + if assigned(p^.left^.right) then + begin + ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left,false); + secondpass(p^.left^.right^.left); + if ispushed then + restore(p^.left^.left,false); + { when constant, just multiply the addvalue } + if is_constintnode(p^.left^.right^.left) then + addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left) + else + begin + case p^.left^.right^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register; + LOC_MEM, + LOC_REFERENCE : begin + del_reference(p^.left^.right^.left^.location.reference); + hregister:=getregister32; + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.right^.left^.location.reference),hregister); + end; + else + internalerror(10082); + end; + { insert multiply with addvalue if its >1 } + if addvalue>1 then + emit_const_reg(A_IMUL,opsize, + addvalue,hregister); + addconstant:=false; + end; + end; + { write the add instruction } + if addconstant then + begin + if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then + begin + if p^.left^.left^.location.loc=LOC_CREGISTER then + emit_reg(incdecop[p^.inlinenumber],opsize, + p^.left^.left^.location.register) + else + emit_ref(incdecop[p^.inlinenumber],opsize, + newreference(p^.left^.left^.location.reference)) + end + else + begin + if p^.left^.left^.location.loc=LOC_CREGISTER then + emit_const_reg(addsubop[p^.inlinenumber],opsize, + addvalue,p^.left^.left^.location.register) + else + emit_const_ref(addsubop[p^.inlinenumber],opsize, + addvalue,newreference(p^.left^.left^.location.reference)); + end + end + else + begin + { BUG HERE : detected with nasm : + hregister is allways 32 bit + it should be converted to 16 or 8 bit depending on op_size PM } + { still not perfect : + if hregister is already a 16 bit reg ?? PM } + { makeregXX is the solution (FK) } + case opsize of + S_B : hregister:=makereg8(hregister); + S_W : hregister:=makereg16(hregister); + end; + if p^.left^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(addsubop[p^.inlinenumber],opsize, + hregister,p^.left^.left^.location.register) + else + emit_reg_ref(addsubop[p^.inlinenumber],opsize, + hregister,newreference(p^.left^.left^.location.reference)); + case opsize of + S_B : hregister:=reg8toreg32(hregister); + S_W : hregister:=reg16toreg32(hregister); + end; + ungetregister32(hregister); + end; + emitoverflowcheck(p^.left^.left); + emitrangecheck(p^.left^.left,p^.left^.left^.resulttype); + end; + in_assigned_x : + begin + secondpass(p^.left^.left); + p^.location.loc:=LOC_FLAGS; + if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + emit_reg_reg(A_OR,S_L, + p^.left^.left^.location.register, + p^.left^.left^.location.register); + ungetregister32(p^.left^.left^.location.register); + end + else + begin + emit_const_ref(A_CMP,S_L,0, + newreference(p^.left^.left^.location.reference)); + del_reference(p^.left^.left^.location.reference); + end; + p^.location.resflags:=F_NE; + end; + in_reset_typedfile,in_rewrite_typedfile : + begin + pushusedregisters(pushed,$ff); + emit_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typedfiletype.def^.size); + secondpass(p^.left); + emitpushreferenceaddr(p^.left^.location.reference); + if p^.inlinenumber=in_reset_typedfile then + emitcall('FPC_RESET_TYPED') + else + emitcall('FPC_REWRITE_TYPED'); + popusedregisters(pushed); + end; + in_write_x : + handlereadwrite(false,false); + in_writeln_x : + handlereadwrite(false,true); + in_read_x : + handlereadwrite(true,false); + in_readln_x : + handlereadwrite(true,true); + in_str_x_string : + begin + handle_str; + maybe_loadesi; + end; + in_val_x : + Begin + handle_val; + End; + in_include_x_y, + in_exclude_x_y: + begin + secondpass(p^.left^.left); + if p^.left^.right^.left^.treetype=ordconstn then + begin + { calculate bit position } + l:=1 shl (p^.left^.right^.left^.value mod 32); + + { determine operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_OR + else + begin + asmop:=A_AND; + l:=not(l); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + begin + inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4); + emit_const_ref(asmop,S_L, + l,newreference(p^.left^.left^.location.reference)); + del_reference(p^.left^.left^.location.reference); + end + else + { LOC_CREGISTER } + emit_const_reg(asmop,S_L, + l,p^.left^.left^.location.register); + end + else + begin + { generate code for the element to set } + ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left,false); + secondpass(p^.left^.right^.left); + if ispushed then + restore(p^.left^.left,false); + { determine asm operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_BTS + else + asmop:=A_BTR; + if psetdef(p^.left^.resulttype)^.settype=smallset then + begin + if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then + { we don't need a mod 32 because this is done automatically } + { by the bts instruction. For proper checking we would } + { need a cmp and jmp, but this should be done by the } + { type cast code which does range checking if necessary (FK) } + hregister:=makereg32(p^.left^.right^.left^.location.register) + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + hregister:=R_EDI; + opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef); + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + op:=A_MOVZX; + emit_ref_reg(op,opsize, + newreference(p^.left^.right^.left^.location.reference),R_EDI); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + emit_reg_ref(asmop,S_L,hregister, + newreference(p^.left^.left^.location.reference)) + else + emit_reg_reg(asmop,S_L,hregister, + p^.left^.left^.location.register); +{$ifndef noAllocEdi} + if hregister = R_EDI then + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + pushsetelement(p^.left^.right^.left); + { normset is allways a ref } + emitpushreferenceaddr(p^.left^.left^.location.reference); + if p^.inlinenumber=in_include_x_y then + emitcall('FPC_SET_SET_BYTE') + else + emitcall('FPC_SET_UNSET_BYTE'); + {CGMessage(cg_e_include_not_implemented);} + end; + end; + end; + in_pi: + begin + emit_none(A_FLDPI,S_NO); + inc(fpuvaroffset); + end; + in_sin_extended, + in_arctan_extended, + in_abs_extended, + in_sqr_extended, + in_sqrt_extended, + in_ln_extended, + in_cos_extended: + begin + secondpass(p^.left); + case p^.left^.location.loc of + LOC_FPU: + ; + LOC_CFPUREGISTER: + begin + emit_reg(A_FLD,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + end; + LOC_REFERENCE,LOC_MEM: + begin + floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + internalerror(309991); + end; + case p^.inlinenumber of + in_sin_extended, + in_cos_extended: + begin + getlabel(l1); + if p^.inlinenumber=in_sin_extended then + emit_none(A_FSIN,S_NO) + else + emit_none(A_FCOS,S_NO); + { + emit_reg(A_FNSTSW,S_NO,R_AX); + emit_none(A_SAHF,S_NO); + emitjmp(C_NP,l1); + emit_reg(A_FSTP,S_NO,R_ST0); + emit_none(A_FLDZ,S_NO); + emitlab(l1); + } + end; + in_arctan_extended: + begin + emit_none(A_FLD1,S_NO); + emit_none(A_FPATAN,S_NO); + end; + in_abs_extended: + emit_none(A_FABS,S_NO); + in_sqr_extended: + begin + (* emit_reg(A_FLD,S_NO,R_ST0); + { emit_none(A_FMULP,S_NO); nasm does not accept this PM } + emit_reg_reg(A_FMULP,S_NO,R_ST0,R_ST1); + can be shorten to *) + emit_reg_reg(A_FMUL,S_NO,R_ST0,R_ST0); + end; + in_sqrt_extended: + emit_none(A_FSQRT,S_NO); + in_ln_extended: + begin + emit_none(A_FLDLN2,S_NO); + emit_none(A_FXCH,S_NO); + emit_none(A_FYL2X,S_NO); + end; + end; + end; +{$ifdef SUPPORT_MMX} + in_mmx_pcmpeqb..in_mmx_pcmpgtw: + begin + if p^.left^.location.loc=LOC_REGISTER then + begin + {!!!!!!!} + end + else if p^.left^.left^.location.loc=LOC_REGISTER then + begin + {!!!!!!!} + end + else + begin + {!!!!!!!} + end; + end; +{$endif SUPPORT_MMX} + else internalerror(9); + end; + { reset pushedparasize } + pushedparasize:=oldpushedparasize; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.103 2000/07/05 20:29:16 florian + * fixed my previous commit :/ + + Revision 1.102 2000/07/05 20:19:47 florian + * fixed fpuvaroffset calculation in read statements + + Revision 1.101 2000/05/11 09:56:20 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.100 2000/04/14 12:33:40 pierre + * better inlined real sqr function + + Revision 1.99 2000/04/04 21:41:56 pierre + * generate code accepted by nasm + + Revision 1.98 2000/04/02 18:30:11 florian + * fixed another problem with readln(); + * the register allocator takes now care of necessary pushes/pops for + readln/writeln + + Revision 1.97 2000/04/02 17:47:47 florian + * readln(r); works now, if r is a fpu register variable + + Revision 1.96 2000/03/31 22:56:46 pierre + * fix the handling of value parameters in cdecl function + + Revision 1.95 2000/03/21 16:24:43 florian + * fixed bug 881: for the include/exclude instruction sometimes wrong + code was generated + + Revision 1.94 2000/02/13 22:46:27 florian + * fixed an internalerror with writeln + * fixed arrayconstructor_to_set to force the generation of better code + and added a more strict type checking + + Revision 1.93 2000/02/09 13:22:47 peter + * log truncated + + Revision 1.92 2000/01/26 12:02:29 peter + * abstractprocdef.para_size needs alignment parameter + * secondcallparan gets para_alignment size instead of dword_align + + Revision 1.91 2000/01/24 20:11:10 florian + * internalerror 10 for inlined math functions fixed + + Revision 1.90 2000/01/09 23:16:05 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.89 2000/01/09 12:35:00 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.88 2000/01/09 01:44:19 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.87 2000/01/07 01:14:20 peter + * updated copyright to 2000 + + Revision 1.86 1999/12/22 01:01:46 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.85 1999/12/20 21:42:35 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.84 1999/12/14 10:17:40 florian + * fixed an internalerror 10 with pred(...) + + Revision 1.83 1999/12/02 12:38:45 florian + + added support for succ/pred() + + Revision 1.82 1999/12/01 12:42:31 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.81 1999/11/30 10:40:42 peter + + ttype, tsymlist + + Revision 1.80 1999/11/29 00:30:06 pierre + * fix for form bug 699 + + Revision 1.79 1999/11/20 01:22:18 pierre + + cond FPC_USE_CPREFIX (needs also some RTL changes) + this allows to use unit global vars as DLL exports + (the underline prefix seems needed by dlltool) + + Revision 1.78 1999/11/09 22:54:45 peter + * fixed wrong asm with inc(qword), but not it's not correctly supported + + Revision 1.77 1999/11/06 14:34:17 peter + * truncated log to 20 revs + + Revision 1.76 1999/10/29 15:28:51 peter + * fixed assert, the tree is now disposed in firstpass if assertions + are off. + + Revision 1.75 1999/10/26 12:30:40 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.74 1999/10/21 16:41:38 florian + * problems with readln fixed: esi wasn't restored correctly when + reading ordinal fields of objects futher the register allocation + didn't take care of the extra register when reading ordinal values + * enumerations can now be used in constant indexes of properties + + Revision 1.73 1999/09/28 20:48:23 florian + * fixed bug 610 + + added $D- for TP in symtable.pas else it can't be compiled anymore + (too much symbols :() + +} \ No newline at end of file diff --git a/befpc/compiler/cg386ld.pas b/befpc/compiler/cg386ld.pas new file mode 100644 index 0000000..0ef1549 --- /dev/null +++ b/befpc/compiler/cg386ld.pas @@ -0,0 +1,1121 @@ +{ + $Id: cg386ld.pas,v 1.1.1.1 2001-07-23 17:15:36 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for load/assignment nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386ld; +interface + + uses + tree; + + procedure secondload(var p : ptree); + procedure secondassignment(var p : ptree); + procedure secondfuncret(var p : ptree); + procedure secondarrayconstruct(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals,files, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386,cg386cnv,cresstr; + +{***************************************************************************** + SecondLoad +*****************************************************************************} + + procedure secondload(var p : ptree); + var + hregister : tregister; + symtabletype : tsymtabletype; + i : longint; + hp : preference; + s : pasmsymbol; + popeax : boolean; + pushed : tpushed; + hr : treference; + + begin + simple_loadn:=true; + reset_reference(p^.location.reference); + case p^.symtableentry^.typ of + { this is only for toasm and toaddr } + absolutesym : + begin + p^.location.reference.symbol:=nil; + if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then + begin + if pabsolutesym(p^.symtableentry)^.absseg then + p^.location.reference.segment:=R_FS; + p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address; + end + else + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end; + constsym: + begin + if pconstsym(p^.symtableentry)^.consttyp=constresourcestring then + begin + pushusedregisters(pushed,$ff); + emit_const(A_PUSH,S_L, + pconstsym(p^.symtableentry)^.resstrindex); + emit_sym(A_PUSH,S_L,newasmsymbol(pconstsym(p^.symtableentry)^.owner^.name^+'_RESOURCESTRINGLIST')); + emitcall('FPC_GETRESOURCESTRING'); + + hregister:=getexplicitregister32(R_EAX); + emit_reg_reg(A_MOV,S_L,R_EAX,hregister); + gettempansistringreference(hr); + decrstringref(p^.resulttype,hr); + emit_reg_ref(A_MOV,S_L,hregister, + newreference(hr)); + ungetregister32(hregister); + popusedregisters(pushed); + + p^.location.loc:=LOC_MEM; + p^.location.reference:=hr; + end + else + internalerror(22798); + end; + varsym : + begin + hregister:=R_NO; + { C variable } + if (vo_is_C_var in pvarsym(p^.symtableentry)^.varoptions) then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end + { DLL variable } + else if (vo_is_dll_var in pvarsym(p^.symtableentry)^.varoptions) then + begin + hregister:=getregister32; + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + emit_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister); + p^.location.reference.symbol:=nil; + p^.location.reference.base:=hregister; + end + { external variable } + else if (vo_is_external in pvarsym(p^.symtableentry)^.varoptions) then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end + { thread variable } + else if (vo_is_thread_var in pvarsym(p^.symtableentry)^.varoptions) then + begin + popeax:=not(R_EAX in unused); + if popeax then + emit_reg(A_PUSH,S_L,R_EAX); + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + emit_ref(A_PUSH,S_L,newreference(p^.location.reference)); + { the called procedure isn't allowed to change } + { any register except EAX } + emitcall('FPC_RELOCATE_THREADVAR'); + + reset_reference(p^.location.reference); + p^.location.reference.base:=getregister32; + emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.reference.base); + if popeax then + emit_reg(A_POP,S_L,R_EAX); + + end + { normal variable } + else + begin + symtabletype:=p^.symtable^.symtabletype; + { in case it is a register variable: } + if pvarsym(p^.symtableentry)^.reg<>R_NO then + begin + if pvarsym(p^.symtableentry)^.reg in [R_ST0..R_ST7] then + begin + p^.location.loc:=LOC_CFPUREGISTER; + p^.location.register:=pvarsym(p^.symtableentry)^.reg; + end + else + begin + p^.location.loc:=LOC_CREGISTER; + p^.location.register:=pvarsym(p^.symtableentry)^.reg; + unused:=unused-[pvarsym(p^.symtableentry)^.reg]; + end; + end + else + begin + { first handle local and temporary variables } + if (symtabletype in [parasymtable,inlinelocalsymtable, + inlineparasymtable,localsymtable]) then + begin + p^.location.reference.base:=procinfo^.framepointer; + if (symtabletype in [inlinelocalsymtable, + localsymtable]) then + p^.location.reference.offset:= + pvarsym(p^.symtableentry)^.address-p^.symtable^.address_fixup + else + p^.location.reference.offset:= + pvarsym(p^.symtableentry)^.address+p^.symtable^.address_fixup; + + if (symtabletype in [localsymtable,inlinelocalsymtable]) then + begin + if use_esp_stackframe then + dec(p^.location.reference.offset, + pvarsym(p^.symtableentry)^.getvaluesize) + else + p^.location.reference.offset:=-p^.location.reference.offset; + end; + if (lexlevel>(p^.symtable^.symtablelevel)) then + begin + hregister:=getregister32; + + { make a reference } + hp:=new_reference(procinfo^.framepointer, + procinfo^.framepointer_offset); + + emit_ref_reg(A_MOV,S_L,hp,hregister); + + simple_loadn:=false; + i:=lexlevel-1; + while i>(p^.symtable^.symtablelevel) do + begin + { make a reference } + hp:=new_reference(hregister,8); + emit_ref_reg(A_MOV,S_L,hp,hregister); + dec(i); + end; + p^.location.reference.base:=hregister; + end; + end + else + case symtabletype of + unitsymtable,globalsymtable, + staticsymtable : + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end; + stt_exceptsymtable: + begin + p^.location.reference.base:=procinfo^.framepointer; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + end; + objectsymtable: + begin + getexplicitregister32(R_ESI); + if (sp_static in pvarsym(p^.symtableentry)^.symoptions) then + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end + else + begin + p^.location.reference.base:=R_ESI; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + end; + end; + withsymtable: + begin + { make a reference } + { symtable datasize field + contains the offset of the temp + stored } +{ hp:=new_reference(procinfo^.framepointer, + p^.symtable^.datasize); + + emit_ref_reg(A_MOV,S_L,hp,hregister);} + + if ptree(pwithsymtable(p^.symtable)^.withnode)^.islocal then + begin + p^.location.reference:=ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^; + end + else + begin + hregister:=getregister32; + p^.location.reference.base:=hregister; + emit_ref_reg(A_MOV,S_L, + newreference(ptree(pwithsymtable(p^.symtable)^.withnode)^.withreference^), + hregister); + end; + inc(p^.location.reference.offset,pvarsym(p^.symtableentry)^.address); + end; + end; + end; + { in case call by reference, then calculate. Open array + is always an reference! } + if (pvarsym(p^.symtableentry)^.varspez=vs_var) or + is_open_array(pvarsym(p^.symtableentry)^.vartype.def) or + is_array_of_const(pvarsym(p^.symtableentry)^.vartype.def) or + ((pvarsym(p^.symtableentry)^.varspez=vs_const) and + push_addr_param(pvarsym(p^.symtableentry)^.vartype.def)) then + begin + simple_loadn:=false; + if hregister=R_NO then + hregister:=getregister32; + if p^.location.loc=LOC_CREGISTER then + begin + emit_reg_reg(A_MOV,S_L, + p^.location.register,hregister); + p^.location.loc:=LOC_REFERENCE; + end + else + begin + emit_ref_reg(A_MOV,S_L, + newreference(p^.location.reference), + hregister); + end; + reset_reference(p^.location.reference); + p^.location.reference.base:=hregister; + end; + end; + end; + procsym: + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + p^.location.loc:=LOC_MEM; + gettempofsizereference(8,p^.location.reference); + + { load class instance address } + case p^.left^.location.loc of + + LOC_CREGISTER, + LOC_REGISTER: + begin + hregister:=p^.left^.location.register; + ungetregister32(p^.left^.location.register); + if (p^.left^.resulttype^.deftype<>classrefdef) and + (p^.left^.resulttype^.deftype<>objectdef) and + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(cg_e_illegal_expression); + end; + + LOC_MEM, + LOC_REFERENCE: + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + hregister:=R_EDI; + if pobjectdef(p^.left^.resulttype)^.is_class then + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),R_EDI) + else + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_EDI); + del_reference(p^.left^.location.reference); + ungetiftemp(p^.left^.location.reference); + end; + else internalerror(26019); + end; + + { store the class instance address } + new(hp); + hp^:=p^.location.reference; + inc(hp^.offset,4); + emit_reg_ref(A_MOV,S_L, + hregister,hp); + + { virtual method ? } + if (po_virtualmethod in pprocsym(p^.symtableentry)^.definition^.procoptions) then + begin + new(hp); + reset_reference(hp^); + hp^.base:=hregister; + { load vmt pointer } + emit_ref_reg(A_MOV,S_L, + hp,R_EDI); +{$IfDef regallocfix} + del_reference(hp^); +{$EndIf regallocfix} + { load method address } + new(hp); + reset_reference(hp^); + hp^.base:=R_EDI; + hp^.offset:=pprocsym(p^.symtableentry)^.definition^._class^.vmtmethodoffset( + pprocsym(p^.symtableentry)^.definition^.extnumber); + emit_ref_reg(A_MOV,S_L, + hp,R_EDI); + { ... and store it } + emit_reg_ref(A_MOV,S_L, + R_EDI,newreference(p^.location.reference)); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + s:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); + emit_sym_ofs_ref(A_MOV,S_L,s,0, + newreference(p^.location.reference)); + end; + end + else + begin + {!!!!! Be aware, work on virtual methods too } + p^.location.reference.symbol:=newasmsymbol(pprocsym(p^.symtableentry)^.definition^.mangledname); + end; + end; + typedconstsym : + begin + p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname); + end; + else internalerror(4); + end; + end; + + +{***************************************************************************** + SecondAssignment +*****************************************************************************} + + procedure secondassignment(var p : ptree); + var + opsize : topsize; + otlabel,hlabel,oflabel : pasmlabel; + fputyp : tfloattype; + loc : tloc; + r : preference; + ai : paicpu; + op : tasmop; + pushed : boolean; + + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + { calculate left sides } + if not(p^.concat_string) then + secondpass(p^.left); + + if codegenerror then + exit; + + if not(p^.left^.location.loc in [LOC_REFERENCE,LOC_CFPUREGISTER, + LOC_CREGISTER,LOC_CMMXREGISTER]) then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; + + + loc:=p^.left^.location.loc; + { lets try to optimize this (PM) } + { define a dest_loc that is the location } + { and a ptree to verify that it is the right } + { place to insert it } +{$ifdef test_dest_loc} + if (aktexprlevel<4) then + begin + dest_loc_known:=true; + dest_loc:=p^.left^.location; + dest_loc_tree:=p^.right; + end; +{$endif test_dest_loc} + + { left can't be never a 64 bit LOC_REGISTER, so the 3. arg } + { can be false } + pushed:=maybe_push(p^.right^.registers32,p^.left,false); + secondpass(p^.right); + + { restoring here is nonsense for LOC_JMP !! } + { This generated code that was after a jmp and before any + label => unreachable !! + Could this be tested somehow ?? PM } + if pushed and (p^.right^.location.loc <>LOC_JUMP) then + restore(p^.left,false); + + if codegenerror then + exit; + +{$ifdef test_dest_loc} + dest_loc_known:=false; + if in_dest_loc then + begin + truelabel:=otlabel; + falselabel:=oflabel; + in_dest_loc:=false; + exit; + end; +{$endif test_dest_loc} + if p^.left^.resulttype^.deftype=stringdef then + begin + if is_ansistring(p^.left^.resulttype) then + begin + { the source and destinations are released + in loadansistring, because an ansi string can + also be in a register + } + loadansistring(p); + end + else + if is_shortstring(p^.left^.resulttype) and + not (p^.concat_string) then + begin + if is_ansistring(p^.right^.resulttype) then + begin + if (p^.right^.treetype=stringconstn) and + (p^.right^.length=0) then + begin + emit_const_ref(A_MOV,S_B, + 0,newreference(p^.left^.location.reference)); + del_reference(p^.left^.location.reference); + end + else + loadansi2short(p^.right,p^.left); + end + else + begin + { we do not need destination anymore } + del_reference(p^.left^.location.reference); + {del_reference(p^.right^.location.reference); + done in loadshortstring } + loadshortstring(p); + ungetiftemp(p^.right^.location.reference); + end; + end + else if is_longstring(p^.left^.resulttype) then + begin + end + else + begin + { its the only thing we have to do } + del_reference(p^.right^.location.reference); + end + end + else case p^.right^.location.loc of + LOC_REFERENCE, + LOC_MEM : begin + { extra handling for ordinal constants } + if (p^.right^.treetype in [ordconstn,fixconstn]) or + (loc=LOC_CREGISTER) then + begin + case p^.left^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + { S_L is correct, the copy is done } + { with two moves } + 8 : opsize:=S_L; + end; + if loc=LOC_CREGISTER then + begin + emit_ref_reg(A_MOV,opsize, + newreference(p^.right^.location.reference), + p^.left^.location.register); + if is_64bitint(p^.right^.resulttype) then + begin + r:=newreference(p^.right^.location.reference); + inc(r^.offset,4); + emit_ref_reg(A_MOV,opsize,r, + p^.left^.location.registerhigh); + end; +{$IfDef regallocfix} + del_reference(p^.right^.location.reference); +{$EndIf regallocfix} + end + else + begin + emit_const_ref(A_MOV,opsize, + p^.right^.location.reference.offset, + newreference(p^.left^.location.reference)); + if is_64bitint(p^.right^.resulttype) then + begin + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + emit_const_ref(A_MOV,opsize, + 0,r); + end; +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + {emit_const_loc(A_MOV,opsize, + p^.right^.location.reference.offset, + p^.left^.location);} + end; + + end + else if loc=LOC_CFPUREGISTER then + begin + floatloadops(pfloatdef(p^.right^.resulttype)^.typ,op,opsize); + emit_ref(op,opsize, + newreference(p^.right^.location.reference)); + emit_reg(A_FSTP,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset+1)); + end + else + begin + if (p^.right^.resulttype^.needs_inittable) and + ( (p^.right^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.right^.resulttype)^.is_class)) then + begin + { this would be a problem } + if not(p^.left^.resulttype^.needs_inittable) then + internalerror(3457); + + { increment source reference counter } + new(r); + reset_reference(r^); + r^.symbol:=p^.right^.resulttype^.get_inittable_label; + emitpushreferenceaddr(r^); + + emitpushreferenceaddr(p^.right^.location.reference); + emitcall('FPC_ADDREF'); + { decrement destination reference counter } + new(r); + reset_reference(r^); + r^.symbol:=p^.left^.resulttype^.get_inittable_label; + emitpushreferenceaddr(r^); + emitpushreferenceaddr(p^.left^.location.reference); + emitcall('FPC_DECREF'); + end; + +{$ifdef regallocfix} + concatcopy(p^.right^.location.reference, + p^.left^.location.reference,p^.left^.resulttype^.size,true,false); + ungetiftemp(p^.right^.location.reference); +{$Else regallocfix} + concatcopy(p^.right^.location.reference, + p^.left^.location.reference,p^.left^.resulttype^.size,false,false); + ungetiftemp(p^.right^.location.reference); +{$endif regallocfix} + end; + end; +{$ifdef SUPPORT_MMX} + LOC_CMMXREGISTER, + LOC_MMXREGISTER: + begin + if loc=LOC_CMMXREGISTER then + emit_reg_reg(A_MOVQ,S_NO, + p^.right^.location.register,p^.left^.location.register) + else + emit_reg_ref(A_MOVQ,S_NO, + p^.right^.location.register,newreference(p^.left^.location.reference)); + end; +{$endif SUPPORT_MMX} + LOC_REGISTER, + LOC_CREGISTER : begin + case p^.right^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + 8 : opsize:=S_L; + end; + { simplified with op_reg_loc } + if loc=LOC_CREGISTER then + begin + emit_reg_reg(A_MOV,opsize, + p^.right^.location.register, + p^.left^.location.register); + ungetregister(p^.right^.location.register); + end + else + Begin + emit_reg_ref(A_MOV,opsize, + p^.right^.location.register, + newreference(p^.left^.location.reference)); + ungetregister(p^.right^.location.register); +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + if is_64bitint(p^.right^.resulttype) then + begin + { simplified with op_reg_loc } + if loc=LOC_CREGISTER then + emit_reg_reg(A_MOV,opsize, + p^.right^.location.registerhigh, + p^.left^.location.registerhigh) + else + begin + r:=newreference(p^.left^.location.reference); + inc(r^.offset,4); + emit_reg_ref(A_MOV,opsize, + p^.right^.location.registerhigh,r); + end; + end; + {emit_reg_loc(A_MOV,opsize, + p^.right^.location.register, + p^.left^.location); } + + end; + LOC_FPU : begin + if (p^.left^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.left^.resulttype)^.typ + else + if (p^.right^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.right^.resulttype)^.typ + else + if (p^.right^.treetype=typeconvn) and + (p^.right^.left^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ + else + fputyp:=s32real; + case loc of + LOC_CFPUREGISTER: + begin + emit_reg(A_FSTP,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset)); + dec(fpuvaroffset); + end; + LOC_REFERENCE: + floatstore(fputyp,p^.left^.location.reference); + else + internalerror(48991); + end; + end; + LOC_CFPUREGISTER: begin + if (p^.left^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.left^.resulttype)^.typ + else + if (p^.right^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.right^.resulttype)^.typ + else + if (p^.right^.treetype=typeconvn) and + (p^.right^.left^.resulttype^.deftype=floatdef) then + fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ + else + fputyp:=s32real; + emit_reg(A_FLD,S_NO, + correct_fpuregister(p^.right^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + case loc of + LOC_CFPUREGISTER: + begin + emit_reg(A_FSTP,S_NO, + correct_fpuregister(p^.right^.location.register,fpuvaroffset)); + dec(fpuvaroffset); + end; + LOC_REFERENCE: + floatstore(fputyp,p^.left^.location.reference); + else + internalerror(48992); + end; + end; + LOC_JUMP : begin + getlabel(hlabel); + emitlab(truelabel); + if pushed then + restore(p^.left,false); + if loc=LOC_CREGISTER then + emit_const_reg(A_MOV,S_B, + 1,p^.left^.location.register) + else + emit_const_ref(A_MOV,S_B, + 1,newreference(p^.left^.location.reference)); + {emit_const_loc(A_MOV,S_B, + 1,p^.left^.location);} + emitjmp(C_None,hlabel); + emitlab(falselabel); + if pushed then + restore(p^.left,false); + if loc=LOC_CREGISTER then + emit_reg_reg(A_XOR,S_B, + p^.left^.location.register, + p^.left^.location.register) + else + begin + emit_const_ref(A_MOV,S_B, + 0,newreference(p^.left^.location.reference)); +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + emitlab(hlabel); + end; + LOC_FLAGS : begin + if loc=LOC_CREGISTER then + emit_flag2reg(p^.right^.location.resflags,p^.left^.location.register) + else + begin + ai:=new(paicpu,op_ref(A_Setcc,S_B,newreference(p^.left^.location.reference))); + ai^.SetCondition(flag_2_cond[p^.right^.location.resflags]); + exprasmlist^.concat(ai); + end; +{$IfDef regallocfix} + del_reference(p^.left^.location.reference); +{$EndIf regallocfix} + end; + end; + truelabel:=otlabel; + falselabel:=oflabel; + end; + + +{***************************************************************************** + SecondFuncRet +*****************************************************************************} + + procedure secondfuncret(var p : ptree); + var + hr : tregister; + hp : preference; + pp : pprocinfo; + hr_valid : boolean; + begin + reset_reference(p^.location.reference); + hr_valid:=false; + if (not inlining_procedure) and + (procinfo<>pprocinfo(p^.funcretprocinfo)) then + begin + hr:=getregister32; + hr_valid:=true; + hp:=new_reference(procinfo^.framepointer, + procinfo^.framepointer_offset); + emit_ref_reg(A_MOV,S_L,hp,hr); + pp:=procinfo^.parent; + { walk up the stack frame } + while pp<>pprocinfo(p^.funcretprocinfo) do + begin + hp:=new_reference(hr, + pp^.framepointer_offset); + emit_ref_reg(A_MOV,S_L,hp,hr); + pp:=pp^.parent; + end; + p^.location.reference.base:=hr; + p^.location.reference.offset:=pp^.return_offset; + end + else + begin + p^.location.reference.base:=procinfo^.framepointer; + p^.location.reference.offset:=procinfo^.return_offset; + end; + if ret_in_param(p^.rettype.def) then + begin + if not hr_valid then + hr:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr); + p^.location.reference.base:=hr; + p^.location.reference.offset:=0; + end; + end; + + +{***************************************************************************** + SecondArrayConstruct +*****************************************************************************} + + const + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + vtQWord = 17; + + procedure secondarrayconstruct(var p : ptree); + var + hp : ptree; + href : treference; + lt : pdef; + vaddr : boolean; + vtype : longint; + freetemp, + dovariant : boolean; + elesize : longint; + begin + dovariant:=p^.forcevaria or parraydef(p^.resulttype)^.isvariant; + if dovariant then + elesize:=8 + else + begin + elesize:=parraydef(p^.resulttype)^.elesize; + if elesize>4 then + internalerror(8765678); + end; + if not p^.cargs then + begin + reset_reference(p^.location.reference); + { Allocate always a temp, also if no elements are required, to + be sure that location is valid (PFV) } + if parraydef(p^.resulttype)^.highrange=-1 then + gettempofsizereference(elesize,p^.location.reference) + else + gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*elesize,p^.location.reference); + href:=p^.location.reference; + end; + hp:=p; + while assigned(hp) do + begin + if assigned(hp^.left) then + begin + freetemp:=true; + secondpass(hp^.left); + if codegenerror then + exit; + if dovariant then + begin + { find the correct vtype value } + vtype:=$ff; + vaddr:=false; + lt:=hp^.left^.resulttype; + case lt^.deftype of + enumdef, + orddef : + begin + if is_64bitint(lt) then + begin + case porddef(lt)^.typ of + s64bit: + vtype:=vtInt64; + u64bit: + vtype:=vtQWord; + end; + freetemp:=false; + vaddr:=true; + end + else if (lt^.deftype=enumdef) or + is_integer(lt) then + vtype:=vtInteger + else + if is_boolean(lt) then + vtype:=vtBoolean + else + if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then + vtype:=vtChar; + end; + floatdef : + begin + vtype:=vtExtended; + vaddr:=true; + freetemp:=false; + end; + procvardef, + pointerdef : + begin + if is_pchar(lt) then + vtype:=vtPChar + else + vtype:=vtPointer; + end; + classrefdef : + vtype:=vtClass; + objectdef : + begin + vtype:=vtObject; + end; + stringdef : + begin + if is_shortstring(lt) then + begin + vtype:=vtString; + vaddr:=true; + freetemp:=false; + end + else + if is_ansistring(lt) then + begin + vtype:=vtAnsiString; + freetemp:=false; + end; + end; + end; + if vtype=$ff then + internalerror(14357); + { write C style pushes or an pascal array } + if p^.cargs then + begin + if vaddr then + begin + emit_to_mem(hp^.left); + emit_push_lea_loc(hp^.left^.location,freetemp); + del_reference(hp^.left^.location.reference); + end + else + emit_push_loc(hp^.left^.location); + inc(pushedparasize); + end + else + begin + { write changing field update href to the next element } + inc(href.offset,4); + if vaddr then + begin + emit_to_mem(hp^.left); + emit_lea_loc_ref(hp^.left^.location,href,freetemp); + end + else + begin + emit_mov_loc_ref(hp^.left^.location,href,S_L,freetemp); + end; + { update href to the vtype field and write it } + dec(href.offset,4); + emit_const_ref(A_MOV,S_L,vtype,newreference(href)); + { goto next array element } + inc(href.offset,8); + end; + end + else + { normal array constructor of the same type } + begin + case elesize of + 1 : + emit_mov_loc_ref(hp^.left^.location,href,S_B,freetemp); + 2 : + emit_mov_loc_ref(hp^.left^.location,href,S_W,freetemp); + 4 : + emit_mov_loc_ref(hp^.left^.location,href,S_L,freetemp); + else + internalerror(87656781); + end; + inc(href.offset,elesize); + end; + end; + { load next entry } + hp:=hp^.right; + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.109 2000/06/30 22:12:26 peter + * fix for bug 988 + + Revision 1.108 2000/05/18 17:05:15 peter + * fixed size of const parameters in asm readers + + Revision 1.107 2000/05/14 18:50:35 florian + + Int64/QWord stuff for array of const added + + Revision 1.106 2000/04/03 12:23:02 pierre + * fix for bug 909 + + Revision 1.105 2000/03/19 11:55:08 peter + * fixed temp ansi handling within array constructor + + Revision 1.104 2000/03/19 08:14:17 peter + * small order change for array of const which allows better optimization + + Revision 1.103 2000/03/01 15:36:11 florian + * some new stuff for the new cg + + Revision 1.102 2000/03/01 13:20:33 pierre + * fix for bug 859 + + Revision 1.101 2000/03/01 00:03:11 pierre + * fixes for locals in inlined procedures + fix for bug797 + + stabs generation for inlined paras and locals + + Revision 1.100 2000/02/09 18:08:33 jonas + * added regallocs for esi + + Revision 1.99 2000/02/09 13:22:47 peter + * log truncated + + Revision 1.98 2000/02/01 12:54:20 peter + * cargs must also increase pushedparasize else it won't be 'popped' + + Revision 1.97 2000/01/21 12:17:42 jonas + * regallocation fixes + + Revision 1.96 2000/01/09 12:35:01 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.95 2000/01/09 01:44:20 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.94 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.93 1999/12/30 15:04:31 peter + * fixed funcret within inlined procedure + + Revision 1.92 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.91 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.90 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.89 1999/10/12 22:35:48 florian + * compiler didn't complain about l1+l2:=l1+l2; it gave only an assembler + error, fixed + + Revision 1.88 1999/09/27 23:44:47 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.87 1999/09/26 13:26:06 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + + Revision 1.86 1999/09/16 07:56:46 pierre + * double del_reference removed + + Revision 1.85 1999/09/12 08:48:03 florian + * bugs 593 and 607 fixed + * some other potential bugs with array constructors fixed + * for classes compiled in $M+ and it's childs, the default access method + is now published + * fixed copyright message (it is now 1998-2000) + + Revision 1.84 1999/09/11 09:08:31 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.83 1999/09/01 09:37:14 peter + * removed warning + + Revision 1.82 1999/09/01 09:26:21 peter + * fixed temp allocation for arrayconstructor + + Revision 1.81 1999/08/28 15:34:17 florian + * bug 519 fixed + + Revision 1.80 1999/08/26 20:24:37 michael + + Hopefuly last fixes for resourcestrings + + Revision 1.79 1999/08/25 16:41:05 peter + * resources are working again + +} \ No newline at end of file diff --git a/befpc/compiler/cg386mat.pas b/befpc/compiler/cg386mat.pas new file mode 100644 index 0000000..e5cdfb4 --- /dev/null +++ b/befpc/compiler/cg386mat.pas @@ -0,0 +1,1057 @@ +{ + $Id: cg386mat.pas,v 1.1.1.1 2001-07-23 17:15:37 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for math nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386mat; +interface + + uses + tree; + + procedure secondmoddiv(var p : ptree); + procedure secondshlshr(var p : ptree); + procedure secondunaryminus(var p : ptree); + procedure secondnot(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, +{$ifdef dummy} + end { this overcomes the annoying highlighting problem in my TP IDE, + the IDE assumes i386asm start a asm block (FK) } +{$endif} + cgai386,tgeni386; + +{***************************************************************************** + SecondModDiv +*****************************************************************************} + + procedure secondmoddiv(var p : ptree); + var + hreg1 : tregister; +{$ifdef newOptimizations} + hreg2 : tregister; +{$endif} + shrdiv, andmod, pushed,popeax,popedx : boolean; + + power : longint; + hl : pasmlabel; + hloc : tlocation; + pushedreg : tpushed; + typename,opname : string[6]; + + begin + shrdiv := false; + andmod := false; + secondpass(p^.left); + pushed:=maybe_push(p^.right^.registers32,p^.left,is_64bitint(p^.left^.resulttype)); + secondpass(p^.right); + if pushed then + restore(p^.left,is_64bitint(p^.left^.resulttype)); + set_location(p^.location,p^.left^.location); + + if is_64bitint(p^.resulttype) then + begin + { save p^.lcoation, because we change it now } + set_location(hloc,p^.location); + release_qword_loc(p^.location); + release_qword_loc(p^.right^.location); + p^.location.registerlow:=getexplicitregister32(R_EAX); + p^.location.registerhigh:=getexplicitregister32(R_EDX); + pushusedregisters(pushedreg,$ff + and not($80 shr byte(p^.location.registerlow)) + and not($80 shr byte(p^.location.registerhigh))); + { the left operand is in hloc, because the + location of left is p^.location but p^.location + is already destroyed + } + emit_pushq_loc(hloc); + clear_location(hloc); + emit_pushq_loc(p^.right^.location); + + if porddef(p^.resulttype)^.typ=u64bit then + typename:='QWORD' + else + typename:='INT64'; + if p^.treetype=divn then + opname:='DIV_' + else + opname:='MOD_'; + emitcall('FPC_'+opname+typename); + + emit_reg_reg(A_MOV,S_L,R_EAX,p^.location.registerlow); + emit_reg_reg(A_MOV,S_L,R_EDX,p^.location.registerhigh); + popusedregisters(pushedreg); + p^.location.loc:=LOC_REGISTER; + end + else + begin + { put numerator in register } + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + hreg1:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hreg1); + end + else + begin + del_reference(p^.left^.location.reference); + hreg1:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + hreg1); + end; + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hreg1; + end + else hreg1:=p^.left^.location.register; + + if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and + ispowerof2(p^.right^.value,power) then + Begin + shrdiv := true; + {for signed numbers, the numerator must be adjusted before the + shift instruction, but not wih unsigned numbers! Otherwise, + "Cardinal($ffffffff) div 16" overflows! (JM)} + If is_signed(p^.left^.resulttype) Then + Begin +{$ifdef newOptimizations} + If (aktOptProcessor <> class386) and + not(CS_LittleSize in aktglobalswitches) then + { use a sequence without jumps, saw this in + comp.compilers (JM) } + begin + { no jumps, but more operations } + if (hreg1 = R_EAX) and + (R_EDX in unused) then + begin + hreg2 := getexplicitregister32(R_EDX); + emit_none(A_CDQ,S_NO); + end + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + hreg2 := R_EDI; + emit_reg_reg(A_MOV,S_L,hreg1,R_EDI); + { if the left value is signed, R_EDI := $ffffffff, + otherwise 0 } + emit_const_reg(A_SAR,S_L,31,R_EDI); + { if signed, R_EDI := right value-1, otherwise 0 } + end; + emit_const_reg(A_AND,S_L,p^.right^.value-1,hreg2); + { add to the left value } + emit_reg_reg(A_ADD,S_L,hreg2,hreg1); + { release EDX if we used it } +{$ifndef noAllocEdi} + { also releas EDI } + ungetregister32(hreg2); +{$else noAllocEdi} + if (hreg2 = R_EDX) then + ungetregister32(hreg2); +{$endif noAllocEdi} + { do the shift } + emit_const_reg(A_SAR,S_L,power,hreg1); + end + else +{$endif newOptimizations} + begin + { a jump, but less operations } + emit_reg_reg(A_TEST,S_L,hreg1,hreg1); + getlabel(hl); + emitjmp(C_NS,hl); + if power=1 then + emit_reg(A_INC,S_L,hreg1) + else + emit_const_reg(A_ADD,S_L,p^.right^.value-1,hreg1); + emitlab(hl); + emit_const_reg(A_SAR,S_L,power,hreg1); + end + End + Else + emit_const_reg(A_SHR,S_L,power,hreg1); + End + else + if (p^.treetype=modn) and (p^.right^.treetype=ordconstn) and + ispowerof2(p^.right^.value,power) and Not(is_signed(p^.left^.resulttype)) Then + {is there a similar trick for MOD'ing signed numbers? (JM)} + Begin + emit_const_reg(A_AND,S_L,p^.right^.value-1,hreg1); + andmod := true; + End + else + begin + { bring denominator to EDI } + { EDI is always free, it's } + { only used for temporary } + { purposes } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + if (p^.right^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_CREGISTER) then + begin + del_reference(p^.right^.location.reference); + p^.left^.location.loc:=LOC_REGISTER; + emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI); + end + else + begin + emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI); + ungetregister32(p^.right^.location.register); + end; + popedx:=false; + popeax:=false; + if hreg1=R_EDX then + begin + if not(R_EAX in unused) then + begin + emit_reg(A_PUSH,S_L,R_EAX); + popeax:=true; + end; + emit_reg_reg(A_MOV,S_L,R_EDX,R_EAX); + end + else + begin + if not(R_EDX in unused) then + begin + emit_reg(A_PUSH,S_L,R_EDX); + popedx:=true; + end; + if hreg1<>R_EAX then + begin + if not(R_EAX in unused) then + begin + emit_reg(A_PUSH,S_L,R_EAX); + popeax:=true; + end; + emit_reg_reg(A_MOV,S_L,hreg1,R_EAX); + end; + end; + { sign extension depends on the left type } + if porddef(p^.left^.resulttype)^.typ=u32bit then + emit_reg_reg(A_XOR,S_L,R_EDX,R_EDX) + else + emit_none(A_CDQ,S_NO); + + { division depends on the right type } + if porddef(p^.right^.resulttype)^.typ=u32bit then + emit_reg(A_DIV,S_L,R_EDI) + else + emit_reg(A_IDIV,S_L,R_EDI); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + if p^.treetype=divn then + begin + { if result register is busy then copy } + if popeax then + begin + if hreg1=R_EAX then + internalerror(112); + emit_reg_reg(A_MOV,S_L,R_EAX,hreg1) + end + else + if hreg1<>R_EAX then + Begin + ungetregister32(hreg1); + hreg1 := getexplicitregister32(R_EAX); + { I don't think it's possible that now hreg1 <> R_EAX + since popeax is false, but for all certainty I do + support that situation (JM)} + if hreg1 <> R_EAX then + emit_reg_reg(A_MOV,S_L,R_EAX,hreg1); + end; + end + else + {if we did the mod by an "and", the result is in hreg1 and + EDX certainly hasn't been pushed (JM)} + if not(andmod) Then + if popedx then + {the mod was done by an (i)div (so the result is now in + edx), but edx was occupied prior to the division, so + move the result into a safe place (JM)} + emit_reg_reg(A_MOV,S_L,R_EDX,hreg1) + else + Begin + {Get rid of the unnecessary hreg1 if possible (same as with + EAX in divn) (JM)} + ungetregister32(hreg1); + hreg1 := getexplicitregister32(R_EDX); + if hreg1 <> R_EDX then + emit_reg_reg(A_MOV,S_L,R_EDX,hreg1);; + End; + if popeax then + emit_reg(A_POP,S_L,R_EAX); + if popedx then + emit_reg(A_POP,S_L,R_EDX); + end; + If not(andmod or shrdiv) then + {andmod and shrdiv only use hreg1 (which is already in usedinproc, + since it was acquired with getregister), the others also use both + EAX and EDX (JM)} + Begin + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + usedinproc:=usedinproc or ($80 shr byte(R_EDX)); + End; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hreg1; + end; + end; + + +{***************************************************************************** + SecondShlShr +*****************************************************************************} + + procedure secondshlshr(var p : ptree); + var + hregister1,hregister2,hregister3, + hregisterhigh,hregisterlow : tregister; + pushed,popecx : boolean; + op : tasmop; + l1,l2,l3 : pasmlabel; + + begin + popecx:=false; + + secondpass(p^.left); + pushed:=maybe_push(p^.right^.registers32,p^.left,is_64bitint(p^.left^.resulttype)); + secondpass(p^.right); + if pushed then + restore(p^.left,is_64bitint(p^.left^.resulttype)); + + if is_64bitint(p^.left^.resulttype) then + begin + { load left operator in a register } + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + hregisterlow:=getregister32; + hregisterhigh:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, + hregisterlow); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh, + hregisterlow); + end + else + begin + del_reference(p^.left^.location.reference); + hregisterlow:=getregister32; + hregisterhigh:=getregister32; + emit_mov_ref_reg64(p^.left^.location.reference, + hregisterlow, + hregisterhigh); + end; + end + else + begin + hregisterlow:=p^.left^.location.registerlow; + hregisterhigh:=p^.left^.location.registerhigh; + end; + + { shifting by a constant directly coded: } + if (p^.right^.treetype=ordconstn) then + begin + { shrd/shl works only for values <=31 !! } + if p^.right^.value>31 then + begin + if p^.treetype=shln then + begin + emit_reg_reg(A_XOR,S_L,hregisterhigh, + hregisterhigh); + emit_const_reg(A_SHL,S_L,p^.right^.value and 31, + hregisterlow); + end + else + begin + emit_reg_reg(A_XOR,S_L,hregisterlow, + hregisterlow); + emit_const_reg(A_SHR,S_L,p^.right^.value and 31, + hregisterhigh); + end; + p^.location.registerhigh:=hregisterlow; + p^.location.registerlow:=hregisterhigh; + end + else + begin + if p^.treetype=shln then + begin + emit_const_reg_reg(A_SHLD,S_L,p^.right^.value and 31, + hregisterlow,hregisterhigh); + emit_const_reg(A_SHL,S_L,p^.right^.value and 31, + hregisterlow); + end + else + begin + emit_const_reg_reg(A_SHRD,S_L,p^.right^.value and 31, + hregisterhigh,hregisterlow); + emit_const_reg(A_SHR,S_L,p^.right^.value and 31, + hregisterhigh); + end; + p^.location.registerlow:=hregisterlow; + p^.location.registerhigh:=hregisterhigh; + end; + p^.location.loc:=LOC_REGISTER; + end + else + begin + { load right operators in a register } + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + hregister2:=getexplicitregister32(R_ECX); + emit_reg_reg(A_MOV,S_L,p^.right^.location.register, + hregister2); + end + else + begin + del_reference(p^.right^.location.reference); + hregister2:=getexplicitregister32(R_ECX); + emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference), + hregister2); + end; + end + else + hregister2:=p^.right^.location.register; + + { left operator is already in a register } + { hence are both in a register } + { is it in the case ECX ? } + if (hregisterlow=R_ECX) then + begin + { then only swap } + emit_reg_reg(A_XCHG,S_L,hregisterlow,hregister2); + hregister3:=hregisterlow; + hregisterlow:=hregister2; + hregister2:=hregister3; + end + else if (hregisterhigh=R_ECX) then + begin + { then only swap } + emit_reg_reg(A_XCHG,S_L,hregisterhigh,hregister2); + hregister3:=hregisterhigh; + hregisterhigh:=hregister2; + hregister2:=hregister3; + end + + { if second operator not in ECX ? } + else if (hregister2<>R_ECX) then + begin + { ECX occupied then push it } + if not (R_ECX in unused) then + begin + popecx:=true; + emit_reg(A_PUSH,S_L,R_ECX); + end; + emit_reg_reg(A_MOV,S_L,hregister2,R_ECX); + end; + + ungetregister32(hregister2); + + { the damned shift instructions work only til a count of 32 } + { so we've to do some tricks here } + if p^.treetype=shln then + begin + getlabel(l1); + getlabel(l2); + getlabel(l3); + emit_const_reg(A_CMP,S_L,64,R_ECX); + emitjmp(C_L,l1); + emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow); + emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh); + emitjmp(C_None,l3); + emitlab(l1); + emit_const_reg(A_CMP,S_L,32,R_ECX); + emitjmp(C_L,l2); + emit_const_reg(A_SUB,S_L,32,R_ECX); + emit_reg_reg(A_SHL,S_L,R_CL, + hregisterlow); + emit_reg_reg(A_MOV,S_L,hregisterlow,hregisterhigh); + emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow); + emitjmp(C_None,l3); + emitlab(l2); + emit_reg_reg_reg(A_SHLD,S_L,R_CL, + hregisterlow,hregisterhigh); + emit_reg_reg(A_SHL,S_L,R_CL, + hregisterlow); + emitlab(l3); + end + else + begin + getlabel(l1); + getlabel(l2); + getlabel(l3); + emit_const_reg(A_CMP,S_L,64,R_ECX); + emitjmp(C_L,l1); + emit_reg_reg(A_XOR,S_L,hregisterlow,hregisterlow); + emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh); + emitjmp(C_None,l3); + emitlab(l1); + emit_const_reg(A_CMP,S_L,32,R_ECX); + emitjmp(C_L,l2); + emit_const_reg(A_SUB,S_L,32,R_ECX); + emit_reg_reg(A_SHR,S_L,R_CL, + hregisterhigh); + emit_reg_reg(A_MOV,S_L,hregisterhigh,hregisterlow); + emit_reg_reg(A_XOR,S_L,hregisterhigh,hregisterhigh); + emitjmp(C_None,l3); + emitlab(l2); + emit_reg_reg_reg(A_SHRD,S_L,R_CL, + hregisterhigh,hregisterlow); + emit_reg_reg(A_SHR,S_L,R_CL, + hregisterhigh); + emitlab(l3); + + end; + + { maybe put ECX back } + if popecx then + emit_reg(A_POP,S_L,R_ECX); + + p^.location.registerlow:=hregisterlow; + p^.location.registerhigh:=hregisterhigh; + end; + end + else + begin + { load left operators in a register } + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + hregister1:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register, + hregister1); + end + else + begin + del_reference(p^.left^.location.reference); + hregister1:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + hregister1); + end; + end + else + hregister1:=p^.left^.location.register; + + { determine operator } + if p^.treetype=shln then + op:=A_SHL + else + op:=A_SHR; + + { shifting by a constant directly coded: } + if (p^.right^.treetype=ordconstn) then + begin + { l shl 32 should 0 imho, but neither TP nor Delphi do it in this way (FK) + if p^.right^.value<=31 then + } + emit_const_reg(op,S_L,p^.right^.value and 31, + hregister1); + { + else + emit_reg_reg(A_XOR,S_L,hregister1, + hregister1); + } + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister1; + end + else + begin + { load right operators in a register } + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + hregister2:=getexplicitregister32(R_ECX); + emit_reg_reg(A_MOV,S_L,p^.right^.location.register, + hregister2); + end + else + begin + del_reference(p^.right^.location.reference); + hregister2:=getexplicitregister32(R_ECX); + emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference), + hregister2); + end; + end + else + hregister2:=p^.right^.location.register; + + { left operator is already in a register } + { hence are both in a register } + { is it in the case ECX ? } + if (hregister1=R_ECX) then + begin + { then only swap } + emit_reg_reg(A_XCHG,S_L,hregister1,hregister2); + hregister3:=hregister1; + hregister1:=hregister2; + hregister2:=hregister3; + end + { if second operator not in ECX ? } + else if (hregister2<>R_ECX) then + begin + { ECX occupied then push it } + if not (R_ECX in unused) then + begin + popecx:=true; + emit_reg(A_PUSH,S_L,R_ECX); + end; + emit_reg_reg(A_MOV,S_L,hregister2,R_ECX); + end; + ungetregister32(hregister2); + { right operand is in ECX } + emit_reg_reg(op,S_L,R_CL,hregister1); + { maybe ECX back } + if popecx then + emit_reg(A_POP,S_L,R_ECX); + p^.location.register:=hregister1; + end; + end; + end; + + +{***************************************************************************** + SecondUnaryMinus +*****************************************************************************} + + procedure secondunaryminus(var p : ptree); + +{$ifdef SUPPORT_MMX} + procedure do_mmx_neg; + var + op : tasmop; + begin + p^.location.loc:=LOC_MMXREGISTER; + if cs_mmx_saturation in aktlocalswitches then + case mmx_type(p^.resulttype) of + mmxs8bit: + op:=A_PSUBSB; + mmxu8bit: + op:=A_PSUBUSB; + mmxs16bit,mmxfixed16: + op:=A_PSUBSW; + mmxu16bit: + op:=A_PSUBUSW; + end + else + case mmx_type(p^.resulttype) of + mmxs8bit,mmxu8bit: + op:=A_PSUBB; + mmxs16bit,mmxu16bit,mmxfixed16: + op:=A_PSUBW; + mmxs32bit,mmxu32bit: + op:=A_PSUBD; + end; + emit_reg_reg(op,S_NO,p^.location.register,R_MM7); + emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register); + end; +{$endif} + + begin + if is_64bitint(p^.left^.resulttype) then + begin + secondpass(p^.left); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_REGISTER : + begin + p^.location.registerlow:=p^.left^.location.registerlow; + p^.location.registerhigh:=p^.left^.location.registerhigh; + end; + LOC_CREGISTER : + begin + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,p^.location.registerlow); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,p^.location.registerhigh); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.left^.location.reference); + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_mov_ref_reg64(p^.left^.location.reference, + p^.location.registerlow, + p^.location.registerhigh); + end; + end; + { + emit_reg(A_NEG,S_L,p^.location.registerlow); + emit_const_reg(A_ADC,S_L,0,p^.location.registerhigh); + emit_reg(A_NEG,S_L,p^.location.registerhigh); + } + emit_reg(A_NOT,S_L,p^.location.registerhigh); + emit_reg(A_NEG,S_L,p^.location.registerlow); + emit_const_reg(A_SBB,S_L,-1,p^.location.registerhigh); + end + else + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_REGISTER: + begin + p^.location.register:=p^.left^.location.register; + emit_reg(A_NEG,S_L,p^.location.register); + end; + LOC_CREGISTER: + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.location.register, + p^.location.register); + emit_reg(A_NEG,S_L,p^.location.register); + end; +{$ifdef SUPPORT_MMX} + LOC_MMXREGISTER: + begin + set_location(p^.location,p^.left^.location); + emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); + do_mmx_neg; + end; + LOC_CMMXREGISTER: + begin + p^.location.register:=getregistermmx; + emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); + emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, + p^.location.register); + do_mmx_neg; + end; +{$endif SUPPORT_MMX} + LOC_REFERENCE,LOC_MEM: + begin + del_reference(p^.left^.location.reference); + if (p^.left^.resulttype^.deftype=floatdef) and + (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then + begin + p^.location.loc:=LOC_FPU; + floatload(pfloatdef(p^.left^.resulttype)^.typ, + p^.left^.location.reference); + emit_none(A_FCHS,S_NO); + end +{$ifdef SUPPORT_MMX} + else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(p^.left^.resulttype) then + begin + p^.location.register:=getregistermmx; + emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); + emit_ref_reg(A_MOVQ,S_NO, + newreference(p^.left^.location.reference), + p^.location.register); + do_mmx_neg; + end +{$endif SUPPORT_MMX} + else + begin + p^.location.register:=getregister32; + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.register); + emit_reg(A_NEG,S_L,p^.location.register); + end; + end; + LOC_FPU: + begin + p^.location.loc:=LOC_FPU; + emit_none(A_FCHS,S_NO); + end; + LOC_CFPUREGISTER: + begin + emit_reg(A_FLD,S_NO, + correct_fpuregister(p^.left^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + p^.location.loc:=LOC_FPU; + emit_none(A_FCHS,S_NO); + end; + end; + end; +{ Here was a problem... } +{ Operand to be negated always } +{ seems to be converted to signed } +{ 32-bit before doing neg!! } +{ So this is useless... } +{ that's not true: -2^31 gives an overflow error if it is negaded (FK) } +{ emitoverflowcheck(p);} + end; + + +{***************************************************************************** + SecondNot +*****************************************************************************} + + procedure secondnot(var p : ptree); + const + flagsinvers : array[F_E..F_BE] of tresflags = + (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C, + F_A,F_AE,F_B,F_BE); + var + hl : pasmlabel; + opsize : topsize; + begin + if is_boolean(p^.resulttype) then + begin + opsize:=def_opsize(p^.resulttype); + { the second pass could change the location of left } + { if it is a register variable, so we've to do } + { this before the case statement } + if p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM, + LOC_FLAGS,LOC_REGISTER,LOC_CREGISTER] then + secondpass(p^.left); + case p^.left^.location.loc of + LOC_JUMP : + begin + hl:=truelabel; + truelabel:=falselabel; + falselabel:=hl; + secondpass(p^.left); + maketojumpbool(p^.left); + hl:=truelabel; + truelabel:=falselabel; + falselabel:=hl; + end; + LOC_FLAGS : + p^.location.resflags:=flagsinvers[p^.left^.location.resflags]; + LOC_REGISTER : + begin + {p^.location.register:=p^.left^.location.register; + emit_const_reg(A_XOR,opsize,1,p^.location.register);} + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_E; + emit_reg_reg(A_TEST,opsize, + p^.left^.location.register,p^.left^.location.register); + ungetregister(p^.left^.location.register); + end; + LOC_CREGISTER : + begin + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=def_getreg(p^.resulttype); + emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register); + emit_reg_reg(A_TEST,opsize,p^.location.register,p^.location.register); + ungetregister(p^.location.register); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_E; + end; + LOC_REFERENCE, + LOC_MEM : + begin + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + { this was placed before del_ref => internaalerror(10) } + p^.location.register:=def_getreg(p^.resulttype); + emit_ref_reg(A_MOV,opsize, + newreference(p^.left^.location.reference),p^.location.register); + emit_reg_reg(A_TEST,opsize,p^.location.register,p^.location.register); + ungetregister(p^.location.register); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_E; + end; + end; + end +{$ifdef SUPPORT_MMX} + else + if (cs_mmx in aktlocalswitches) and is_mmx_able_array(p^.left^.resulttype) then + begin + secondpass(p^.left); + p^.location.loc:=LOC_MMXREGISTER; + { prepare EDI } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_const_reg(A_MOV,S_L,$ffffffff,R_EDI); + { load operand } + case p^.left^.location.loc of + LOC_MMXREGISTER: + set_location(p^.location,p^.left^.location); + LOC_CMMXREGISTER: + begin + p^.location.register:=getregistermmx; + emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,p^.location.register); + end; + LOC_REFERENCE,LOC_MEM: + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregistermmx; + emit_ref_reg(A_MOVQ,S_NO, + newreference(p^.left^.location.reference),p^.location.register); + end; + end; + { load mask } + emit_reg_reg(A_MOVD,S_NO,R_EDI,R_MM7); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + { lower 32 bit } + emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); + { shift mask } + emit_const_reg(A_PSLLQ,S_NO,32,R_MM7); + { higher 32 bit } + emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); + end +{$endif SUPPORT_MMX} + else if is_64bitint(p^.left^.resulttype) then + begin + secondpass(p^.left); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_REGISTER : + begin + p^.location.registerlow:=p^.left^.location.registerlow; + p^.location.registerhigh:=p^.left^.location.registerhigh; + emit_reg(A_NOT,S_L,p^.location.registerlow); + emit_reg(A_NOT,S_L,p^.location.registerhigh); + end; + LOC_CREGISTER : + begin + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow,p^.location.registerlow); + emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh,p^.location.registerhigh); + emit_reg(A_NOT,S_L,p^.location.registerlow); + emit_reg(A_NOT,S_L,p^.location.registerhigh); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.left^.location.reference); + p^.location.registerlow:=getregister32; + p^.location.registerhigh:=getregister32; + emit_mov_ref_reg64(p^.left^.location.reference, + p^.location.registerlow, + p^.location.registerhigh); + emit_reg(A_NOT,S_L,p^.location.registerlow); + emit_reg(A_NOT,S_L,p^.location.registerhigh); + end; + end; + end + else + begin + secondpass(p^.left); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_REGISTER : + begin + p^.location.register:=p^.left^.location.register; + emit_reg(A_NOT,S_L,p^.location.register); + end; + LOC_CREGISTER : + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,p^.location.register); + emit_reg(A_NOT,S_L,p^.location.register); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),p^.location.register); + emit_reg(A_NOT,S_L,p^.location.register); + end; + end; + end; + end; + + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.45 2000/03/19 15:20:22 florian + * not(b) if b is a register variable, didn't work, fixed + + Revision 1.44 2000/02/24 18:41:38 peter + * removed warnings/notes + + Revision 1.43 2000/02/18 21:25:48 florian + * fixed a bug in int64/qword handling was a quite ugly one + + Revision 1.42 2000/02/09 13:22:47 peter + * log truncated + + Revision 1.41 2000/01/27 15:46:00 florian + * slighly improved code for - and - + + Revision 1.40 2000/01/09 12:35:01 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.39 2000/01/09 01:44:20 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.38 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.37 2000/01/07 00:12:10 peter + * fixed movd isntruction to be A_MOVD instead of A_MOV S_D + + Revision 1.36 1999/11/18 15:34:44 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.35 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.34 1999/09/28 19:43:47 florian + * the maybe_push fix of Pierre wasn't 100%, the tree parameter + must contain a valid location (which is saved if necessary) + + Revision 1.33 1999/09/27 23:37:26 peter + * fixed push/restore bug in div/mod + + Revision 1.32 1999/09/02 17:07:38 florian + * problems with -Or fixed: tdef.isfpuregable was wrong! + + Revision 1.31 1999/08/19 13:08:50 pierre + * emit_??? used + + Revision 1.30 1999/08/04 13:45:23 florian + + floating point register variables !! + * pairegalloc is now generated for register variables + + Revision 1.29 1999/08/04 00:22:51 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.28 1999/08/03 22:02:45 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/cg386mem.pas b/befpc/compiler/cg386mem.pas new file mode 100644 index 0000000..9a40247 --- /dev/null +++ b/befpc/compiler/cg386mem.pas @@ -0,0 +1,1050 @@ +{ + $Id: cg386mem.pas,v 1.1.1.1 2001-07-23 17:15:37 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for in memory related nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386mem; +interface + + uses + tree; + + procedure secondloadvmt(var p : ptree); + procedure secondhnewn(var p : ptree); + procedure secondnewn(var p : ptree); + procedure secondhdisposen(var p : ptree); + procedure secondsimplenewdispose(var p : ptree); + procedure secondaddr(var p : ptree); + procedure seconddoubleaddr(var p : ptree); + procedure secondderef(var p : ptree); + procedure secondsubscriptn(var p : ptree); + procedure secondvecn(var p : ptree); + procedure secondselfn(var p : ptree); + procedure secondwith(var p : ptree); + + +implementation + + uses +{$ifdef GDB} + strings,gdb, +{$endif GDB} + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2,pass_1, + cpubase,cpuasm, + cgai386,tgeni386; + +{***************************************************************************** + SecondLoadVMT +*****************************************************************************} + + procedure secondloadvmt(var p : ptree); + begin + p^.location.register:=getregister32; + emit_sym_ofs_reg(A_MOV, + S_L,newasmsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.pointertype.def)^.vmt_mangledname),0, + p^.location.register); + end; + + +{***************************************************************************** + SecondHNewN +*****************************************************************************} + + procedure secondhnewn(var p : ptree); + begin + end; + + +{***************************************************************************** + SecondNewN +*****************************************************************************} + + procedure secondnewn(var p : ptree); + var + pushed : tpushed; + r : preference; + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + p^.location.register:=p^.left^.location.register; + end + else + begin + pushusedregisters(pushed,$ff); + + gettempofsizereference(target_os.size_of_pointer,p^.location.reference); + + { determines the size of the mem block } + push_int(ppointerdef(p^.resulttype)^.pointertype.def^.size); + emit_push_lea_loc(p^.location,false); + emitcall('FPC_GETMEM'); + + if ppointerdef(p^.resulttype)^.pointertype.def^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label; + emitpushreferenceaddr(r^); + dispose(r); + { push pointer we just allocated, we need to initialize the + data located at that pointer not the pointer self (PFV) } + emit_push_loc(p^.location); + emitcall('FPC_INITIALIZE'); + end; + popusedregisters(pushed); + { may be load ESI } + maybe_loadesi; + end; + if codegenerror then + exit; + end; + + +{***************************************************************************** + SecondDisposeN +*****************************************************************************} + + procedure secondhdisposen(var p : ptree); + begin + secondpass(p^.left); + if codegenerror then + exit; + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + p^.location.reference.index:=p^.left^.location.register; + LOC_CREGISTER: + begin + p^.location.reference.index:=getregister32; + emit_reg_reg(A_MOV,S_L, + p^.left^.location.register, + p^.location.reference.index); + end; + LOC_MEM,LOC_REFERENCE : + begin + del_reference(p^.left^.location.reference); + p^.location.reference.index:=getregister32; + emit_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + p^.location.reference.index); + end; + end; + end; + + +{***************************************************************************** + SecondNewDispose +*****************************************************************************} + + procedure secondsimplenewdispose(var p : ptree); + + var + pushed : tpushed; + r : preference; + + begin + secondpass(p^.left); + if codegenerror then + exit; + + pushusedregisters(pushed,$ff); + + { call the mem handling procedures } + case p^.treetype of + simpledisposen: + begin + if ppointerdef(p^.left^.resulttype)^.pointertype.def^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label; + emitpushreferenceaddr(r^); + dispose(r); + { push pointer adress } + emit_push_loc(p^.left^.location); + emitcall('FPC_FINALIZE'); + end; + emit_push_lea_loc(p^.left^.location,true); + emitcall('FPC_FREEMEM'); + end; + simplenewn: + begin + { determines the size of the mem block } + push_int(ppointerdef(p^.left^.resulttype)^.pointertype.def^.size); + emit_push_lea_loc(p^.left^.location,true); + emitcall('FPC_GETMEM'); + if ppointerdef(p^.left^.resulttype)^.pointertype.def^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=ppointerdef(p^.left^.resulttype)^.pointertype.def^.get_inittable_label; + emitpushreferenceaddr(r^); + dispose(r); + emit_push_loc(p^.left^.location); + emitcall('FPC_INITIALIZE'); + end; + end; + end; + popusedregisters(pushed); + { may be load ESI } + maybe_loadesi; + end; + + +{***************************************************************************** + SecondAddr +*****************************************************************************} + + procedure secondaddr(var p : ptree); + begin + secondpass(p^.left); + + { when loading procvar we do nothing with this node, so load the + location of left } + if p^.procvarload then + begin + set_location(p^.location,p^.left^.location); + exit; + end; + + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + {@ on a procvar means returning an address to the procedure that + is stored in it.} + { yes but p^.left^.symtableentry can be nil + for example on @self !! } + { symtableentry can be also invalid, if left is no tree node } + if (m_tp_procvar in aktmodeswitches) and + (p^.left^.treetype=loadn) and + assigned(p^.left^.symtableentry) and + (p^.left^.symtableentry^.typ=varsym) and + (pvarsym(p^.left^.symtableentry)^.vartype.def^.deftype=procvardef) then + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.register) + else + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference), + p^.location.register); + { for use of other segments } + if p^.left^.location.reference.segment<>R_NO then + p^.location.segment:=p^.left^.location.reference.segment; + end; + + +{***************************************************************************** + SecondDoubleAddr +*****************************************************************************} + + procedure seconddoubleaddr(var p : ptree); + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + emit_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference), + p^.location.register); + end; + + +{***************************************************************************** + SecondDeRef +*****************************************************************************} + + procedure secondderef(var p : ptree); + var + hr : tregister; + begin + secondpass(p^.left); + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + p^.location.reference.base:=p^.left^.location.register; + LOC_CREGISTER: + begin + { ... and reserve one for the pointer } + hr:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ...and reserve one for the pointer } + hr:=getregister32; + emit_ref_reg( + A_MOV,S_L,newreference(p^.left^.location.reference), + hr); + p^.location.reference.base:=hr; + end; + end; + if ppointerdef(p^.left^.resulttype)^.is_far then + p^.location.reference.segment:=R_FS; + if not ppointerdef(p^.left^.resulttype)^.is_far and + (cs_gdb_heaptrc in aktglobalswitches) and + (cs_checkpointer in aktglobalswitches) then + begin + emit_reg( + A_PUSH,S_L,p^.location.reference.base); + emitcall('FPC_CHECKPOINTER'); + end; + end; + + +{***************************************************************************** + SecondSubScriptN +*****************************************************************************} + + procedure secondsubscriptn(var p : ptree); + var + hr : tregister; + begin + secondpass(p^.left); + if codegenerror then + exit; + { classes must be dereferenced implicit } + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class then + begin + reset_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + p^.location.reference.base:=p^.left^.location.register; + LOC_CREGISTER: + begin + { ... and reserve one for the pointer } + hr:=getregister32; + emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ... and reserve one for the pointer } + hr:=getregister32; + emit_ref_reg( + A_MOV,S_L,newreference(p^.left^.location.reference), + hr); + p^.location.reference.base:=hr; + end; + end; + end + else + set_location(p^.location,p^.left^.location); + + inc(p^.location.reference.offset,p^.vs^.address); + end; + + +{***************************************************************************** + SecondVecN +*****************************************************************************} + + procedure secondvecn(var p : ptree); + var + is_pushed : boolean; + ind,hr : tregister; + _p : ptree; + + function get_mul_size:longint; + begin + if p^.memindex then + get_mul_size:=1 + else + begin + if (p^.left^.resulttype^.deftype=arraydef) then + get_mul_size:=parraydef(p^.left^.resulttype)^.elesize + else + get_mul_size:=p^.resulttype^.size; + end + end; + + procedure calc_emit_mul; + var + l1,l2 : longint; + begin + l1:=get_mul_size; + case l1 of + 1,2,4,8 : p^.location.reference.scalefactor:=l1; + else + begin + if ispowerof2(l1,l2) then + emit_const_reg(A_SHL,S_L,l2,ind) + else + emit_const_reg(A_IMUL,S_L,l1,ind); + end; + end; + end; + + var + extraoffset : longint; + { rl stores the resulttype of the left node, this is necessary } + { to detect if it is an ansistring } + { because in constant nodes which constant index } + { the left tree is removed } + t : ptree; + hp : preference; + href : treference; + tai : Paicpu; + pushed : tpushed; + hightree : ptree; + hl,otl,ofl : pasmlabel; + begin + secondpass(p^.left); + { we load the array reference to p^.location } + + { an ansistring needs to be dereferenced } + if is_ansistring(p^.left^.resulttype) or + is_widestring(p^.left^.resulttype) then + begin + reset_reference(p^.location.reference); + if p^.callunique then + begin + if p^.left^.location.loc<>LOC_REFERENCE then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; + pushusedregisters(pushed,$ff); + emitpushreferenceaddr(p^.left^.location.reference); + if is_ansistring(p^.left^.resulttype) then + emitcall('FPC_ANSISTR_UNIQUE') + else + emitcall('FPC_WIDESTR_UNIQUE'); + maybe_loadesi; + popusedregisters(pushed); + end; + + if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + begin + p^.location.reference.base:=p^.left^.location.register; + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.reference.base:=getregister32; + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference), + p^.location.reference.base); + end; + + { check for a zero length string, + we can use the ansistring routine here } + if (cs_check_range in aktlocalswitches) then + begin + pushusedregisters(pushed,$ff); + emit_reg(A_PUSH,S_L,p^.location.reference.base); + emitcall('FPC_ANSISTR_CHECKZERO'); + maybe_loadesi; + popusedregisters(pushed); + end; + + if is_ansistring(p^.left^.resulttype) then + { in ansistrings S[1] is pchar(S)[0] !! } + dec(p^.location.reference.offset) + else + begin + { in widestrings S[1] is pwchar(S)[0] !! } + dec(p^.location.reference.offset,2); + emit_const_reg(A_SHL,S_L, + 1,p^.location.reference.base); + end; + + { we've also to keep left up-to-date, because it is used } + { if a constant array index occurs, subject to change (FK) } + set_location(p^.left^.location,p^.location); + end + else + set_location(p^.location,p^.left^.location); + + { offset can only differ from 0 if arraydef } + if p^.left^.resulttype^.deftype=arraydef then + dec(p^.location.reference.offset, + get_mul_size*parraydef(p^.left^.resulttype)^.lowrange); + if p^.right^.treetype=ordconstn then + begin + { offset can only differ from 0 if arraydef } + if (p^.left^.resulttype^.deftype=arraydef) then + begin + if not(is_open_array(p^.left^.resulttype)) and + not(is_array_of_const(p^.left^.resulttype)) then + begin + if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or + (p^.right^.valueLOC_REFERENCE) and + (p^.location.loc<>LOC_MEM) then + CGMessage(cg_e_illegal_expression); + if (p^.right^.location.loc=LOC_JUMP) then + begin + otl:=truelabel; + getlabel(truelabel); + ofl:=falselabel; + getlabel(falselabel); + end; + is_pushed:=maybe_push(p^.right^.registers32,p,false); + secondpass(p^.right); + if is_pushed then + restore(p,false); + { here we change the location of p^.right + and the update was forgotten so it + led to wrong code in emitrangecheck later PM + so make range check before } + + if cs_check_range in aktlocalswitches then + begin + if p^.left^.resulttype^.deftype=arraydef then + begin + if is_open_array(p^.left^.resulttype) or + is_array_of_const(p^.left^.resulttype) then + begin + reset_reference(href); + parraydef(p^.left^.resulttype)^.genrangecheck; + href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring); + href.offset:=4; + getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); + hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable); + firstpass(hightree); + secondpass(hightree); + emit_mov_loc_ref(hightree^.location,href,S_L,true); + disposetree(hightree); + end; + emitrangecheck(p^.right,p^.left^.resulttype); + end; + end; + + case p^.right^.location.loc of + LOC_REGISTER: + begin + ind:=p^.right^.location.register; + case p^.right^.resulttype^.size of + 1: + begin + hr:=reg8toreg32(ind); + emit_reg_reg(A_MOVZX,S_BL,ind,hr); + ind:=hr; + end; + 2: + begin + hr:=reg16toreg32(ind); + emit_reg_reg(A_MOVZX,S_WL,ind,hr); + ind:=hr; + end; + end; + end; + LOC_CREGISTER: + begin + ind:=getregister32; + case p^.right^.resulttype^.size of + 1: + emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind); + 2: + emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind); + 4: + emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind); + end; + end; + LOC_FLAGS: + begin + ind:=getregister32; + emit_flag2reg(p^.right^.location.resflags,reg32toreg8(ind)); + emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind); + end; + LOC_JUMP : + begin + ind:=getregister32; + emitlab(truelabel); + truelabel:=otl; + emit_const_reg(A_MOV,S_L,1,ind); + getlabel(hl); + emitjmp(C_None,hl); + emitlab(falselabel); + falselabel:=ofl; + emit_reg_reg(A_XOR,S_L,ind,ind); + emitlab(hl); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.right^.location.reference); + ind:=getregister32; + { Booleans are stored in an 8 bit memory location, so + the use of MOVL is not correct } + case p^.right^.resulttype^.size of + 1 : tai:=new(paicpu,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind)); + 2 : tai:=new(Paicpu,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind)); + 4 : tai:=new(Paicpu,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind)); + end; + exprasmlist^.concat(tai); + end; + else + internalerror(5913428); + end; + + { produce possible range check code: } + if cs_check_range in aktlocalswitches then + begin + if p^.left^.resulttype^.deftype=arraydef then + begin + { done defore (PM) } + end + else if (p^.left^.resulttype^.deftype=stringdef) then + begin + case pstringdef(p^.left^.resulttype)^.string_typ of + { it's the same for ansi- and wide strings } + st_widestring, + st_ansistring: + begin + pushusedregisters(pushed,$ff); + emit_reg(A_PUSH,S_L,ind); + hp:=newreference(p^.location.reference); + dec(hp^.offset,7); + emit_ref(A_PUSH,S_L,hp); + emitcall('FPC_ANSISTR_RANGECHECK'); + popusedregisters(pushed); + maybe_loadesi; + end; + st_shortstring: + begin + {!!!!!!!!!!!!!!!!!} + end; + st_longstring: + begin + {!!!!!!!!!!!!!!!!!} + end; + end; + end; + end; + + if p^.location.reference.index=R_NO then + begin + p^.location.reference.index:=ind; + calc_emit_mul; + end + else + begin + if p^.location.reference.base=R_NO then + begin + case p^.location.reference.scalefactor of + 2 : emit_const_reg(A_SHL,S_L,1,p^.location.reference.index); + 4 : emit_const_reg(A_SHL,S_L,2,p^.location.reference.index); + 8 : emit_const_reg(A_SHL,S_L,3,p^.location.reference.index); + end; + calc_emit_mul; + p^.location.reference.base:=p^.location.reference.index; + p^.location.reference.index:=ind; + end + else + begin + emit_ref_reg( + A_LEA,S_L,newreference(p^.location.reference), + p^.location.reference.index); + ungetregister32(p^.location.reference.base); + { the symbol offset is loaded, } + { so release the symbol name and set symbol } + { to nil } + p^.location.reference.symbol:=nil; + p^.location.reference.offset:=0; + calc_emit_mul; + p^.location.reference.base:=p^.location.reference.index; + p^.location.reference.index:=ind; + end; + end; + + if p^.memseg then + p^.location.reference.segment:=R_FS; + end; + end; + +{***************************************************************************** + SecondSelfN +*****************************************************************************} + + procedure secondselfn(var p : ptree); + begin + reset_reference(p^.location.reference); + getexplicitregister32(R_ESI); + if (p^.resulttype^.deftype=classrefdef) or + ((p^.resulttype^.deftype=objectdef) + and pobjectdef(p^.resulttype)^.is_class + ) then + p^.location.register:=R_ESI + else + p^.location.reference.base:=R_ESI; + end; + + +{***************************************************************************** + SecondWithN +*****************************************************************************} + + procedure secondwith(var p : ptree); + var + usetemp,with_expr_in_temp : boolean; +{$ifdef GDB} + withstartlabel,withendlabel : pasmlabel; + pp : pchar; + mangled_length : longint; + + const + withlevel : longint = 0; +{$endif GDB} + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + if p^.left^.location.reference.segment<>R_NO then + message(parser_e_no_with_for_variable_in_other_segments); + + new(p^.withreference); + + usetemp:=false; + if (p^.left^.treetype=loadn) and + (p^.left^.symtable=aktprocsym^.definition^.localst) then + begin + { for locals use the local storage } + p^.withreference^:=p^.left^.location.reference; + p^.islocal:=true; + end + else + { call can have happend with a property } + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_mov_loc_reg(p^.left^.location,R_EDI); + usetemp:=true; + end + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_lea_loc_reg(p^.left^.location,R_EDI,false); + usetemp:=true; + end; + + release_loc(p^.left^.location); + + { if the with expression is stored in a temp } + { area we must make it persistent and shouldn't } + { release it (FK) } + if (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and + istemp(p^.left^.location.reference) then + begin + normaltemptopersistant(p^.left^.location.reference.offset); + with_expr_in_temp:=true; + end + else + with_expr_in_temp:=false; + + { if usetemp is set the value must be in %edi } + if usetemp then + begin + gettempofsizereference(4,p^.withreference^); + normaltemptopersistant(p^.withreference^.offset); + { move to temp reference } + emit_reg_ref(A_MOV,S_L,R_EDI,newreference(p^.withreference^)); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + inc(withlevel); + getlabel(withstartlabel); + getlabel(withendlabel); + emitlab(withstartlabel); + withdebuglist^.concat(new(pai_stabs,init(strpnew( + '"with'+tostr(withlevel)+':'+tostr(symtablestack^.getnewtypecount)+ + '=*'+p^.left^.resulttype^.numberstring+'",'+ + tostr(N_LSYM)+',0,0,'+tostr(p^.withreference^.offset))))); + mangled_length:=length(aktprocsym^.definition^.mangledname); + getmem(pp,mangled_length+50); + strpcopy(pp,'192,0,0,'+withstartlabel^.name); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(pp),'-'); + strpcopy(strend(pp),aktprocsym^.definition^.mangledname); + end; + withdebuglist^.concat(new(pai_stabn,init(strnew(pp)))); + end; +{$endif GDB} + del_reference(p^.left^.location.reference); + end; + + { p^.right can be optimize out !!! } + if assigned(p^.right) then + secondpass(p^.right); + + if usetemp then + begin + ungetpersistanttemp(p^.withreference^.offset); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + emitlab(withendlabel); + strpcopy(pp,'224,0,0,'+withendlabel^.name); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(pp),'-'); + strpcopy(strend(pp),aktprocsym^.definition^.mangledname); + end; + withdebuglist^.concat(new(pai_stabn,init(strnew(pp)))); + freemem(pp,mangled_length+50); + dec(withlevel); + end; +{$endif GDB} + end; + + if with_expr_in_temp then + ungetpersistanttemp(p^.left^.location.reference.offset); + + dispose(p^.withreference); + p^.withreference:=nil; + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.75 2000/04/11 20:36:39 florian + * sometimes wrong range checking code for arrays was generated when + using register variables + + Revision 1.74 2000/04/01 14:18:44 peter + * use arraydef.elesize instead of elementtype.def.size + + Revision 1.73 2000/03/19 11:55:08 peter + * fixed temp ansi handling within array constructor + + Revision 1.72 2000/02/18 20:53:14 pierre + * fixes a stabs problem for functions + + includes a stabs local var for with statements + the name is with in lowercase followed by an index + for nested with. + + Withdebuglist added because the stabs declarations of local + var are postponed to end of function. + + Revision 1.71 2000/02/09 18:08:33 jonas + * added regallocs for esi + + Revision 1.70 2000/02/09 13:22:47 peter + * log truncated + + Revision 1.69 2000/01/09 15:19:23 peter + * fixed misplaced getexplicitreg(r_edi) which broke make cycle + + Revision 1.68 2000/01/09 12:35:02 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.67 2000/01/09 01:44:20 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.66 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.65 2000/01/04 15:15:50 florian + + added compiler switch $maxfpuregisters + + fixed a small problem in secondvecn + + Revision 1.64 2000/01/03 17:10:39 jonas + * fixed "quick hack, to overcome Delphi 2" :) + + Revision 1.63 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.62 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.61 1999/11/15 21:54:38 peter + * LOC_JUMP support for vecn + + Revision 1.60 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.59 1999/10/30 17:35:26 peter + * fpc_freemem fpc_getmem new callings updated + + Revision 1.58 1999/09/17 17:14:02 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.57 1999/09/14 07:59:46 florian + * finally!? fixed + with do + My last and also Peter's fix before were wrong :( + + Revision 1.56 1999/09/13 20:49:41 florian + * hopefully an error in Peter's previous commit fixed + + Revision 1.55 1999/09/10 15:42:50 peter + * fixed with do + * fixed finalize/initialize call for new/dispose + + Revision 1.54 1999/08/25 11:59:46 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.53 1999/08/23 23:49:21 pierre + * hnewn location corrected + + Revision 1.52 1999/08/19 13:08:52 pierre + * emit_??? used + + Revision 1.51 1999/08/16 23:20:28 peter + * range check for array of const + + Revision 1.50 1999/08/14 00:36:05 peter + * array constructor support + +} \ No newline at end of file diff --git a/befpc/compiler/cg386set.pas b/befpc/compiler/cg386set.pas new file mode 100644 index 0000000..0f622d8 --- /dev/null +++ b/befpc/compiler/cg386set.pas @@ -0,0 +1,1026 @@ +{ + $Id: cg386set.pas,v 1.1.1.1 2001-07-23 17:15:38 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate i386 assembler for in set/case nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg386set; +interface + + uses + tree; + + procedure secondsetelement(var p : ptree); + procedure secondin(var p : ptree); + procedure secondcase(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cpuasm, + cgai386,tgeni386; + + const + bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L); + +{***************************************************************************** + SecondSetElement +*****************************************************************************} + + procedure secondsetelement(var p : ptree); + begin + { load first value in 32bit register } + secondpass(p^.left); + if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + emit_to_reg32(p^.left^.location.register); + + { also a second value ? } + if assigned(p^.right) then + begin + secondpass(p^.right); + if p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + emit_to_reg32(p^.right^.location.register); + end; + + { we doesn't modify the left side, we check only the type } + set_location(p^.location,p^.left^.location); + end; + + +{***************************************************************************** + SecondIn +*****************************************************************************} + + procedure secondin(var p : ptree); + type + Tsetpart=record + range : boolean; {Part is a range.} + start,stop : byte; {Start/stop when range; Stop=element when an element.} + end; + var + genjumps, + use_small, + pushed, + ranges : boolean; + hr,hr2, + pleftreg : tregister; + opsize : topsize; + setparts : array[1..8] of Tsetpart; + i,numparts : byte; + {href,href2 : Treference;} + l,l2 : pasmlabel; +{$ifdef CORRECT_SET_IN_FPC} + AM : tasmop; +{$endif CORRECT_SET_IN_FPC} + + function analizeset(Aset:pconstset;is_small:boolean):boolean; + type + byteset=set of byte; + var + compares,maxcompares:word; + i:byte; + begin + analizeset:=false; + ranges:=false; + numparts:=0; + compares:=0; + { Lots of comparisions take a lot of time, so do not allow + too much comparisions. 8 comparisions are, however, still + smalller than emitting the set } + if cs_littlesize in aktglobalswitches then + maxcompares:=8 + else + maxcompares:=5; + { when smallset is possible allow only 3 compares the smallset + code is for littlesize also smaller when more compares are used } + if is_small then + maxcompares:=3; + for i:=0 to 255 do + if i in byteset(Aset^) then + begin + if (numparts=0) or (i<>setparts[numparts].stop+1) then + begin + {Set element is a separate element.} + inc(compares); + if compares>maxcompares then + exit; + inc(numparts); + setparts[numparts].range:=false; + setparts[numparts].stop:=i; + end + else + {Set element is part of a range.} + if not setparts[numparts].range then + begin + {Transform an element into a range.} + setparts[numparts].range:=true; + setparts[numparts].start:=setparts[numparts].stop; + setparts[numparts].stop:=i; + inc(compares); + if compares>maxcompares then + exit; + end + else + begin + {Extend a range.} + setparts[numparts].stop:=i; + {A range of two elements can better + be checked as two separate ones. + When extending a range, our range + becomes larger than two elements.} + ranges:=true; + end; + end; + analizeset:=true; + end; + + begin + { We check first if we can generate jumps, this can be done + because the resulttype is already set in firstpass } + + { check if we can use smallset operation using btl which is limited + to 32 bits, the left side may also not contain higher values !! } + use_small:=(psetdef(p^.right^.resulttype)^.settype=smallset) and + ((p^.left^.resulttype^.deftype=orddef) and (porddef(p^.left^.resulttype)^.high<=32) or + (p^.left^.resulttype^.deftype=enumdef) and (penumdef(p^.left^.resulttype)^.max<=32)); + + { Can we generate jumps? Possible for all types of sets } + genjumps:=(p^.right^.treetype=setconstn) and + analizeset(p^.right^.value_set,use_small); + { calculate both operators } + { the complex one first } + firstcomplex(p); + secondpass(p^.left); + { Only process the right if we are not generating jumps } + if not genjumps then + begin + pushed:=maybe_push(p^.right^.registers32,p^.left,false); + secondpass(p^.right); + if pushed then + restore(p^.left,false); + end; + if codegenerror then + exit; + + { ofcourse not commutative } + if p^.swaped then + swaptree(p); + + if genjumps then + begin + { It gives us advantage to check for the set elements + separately instead of using the SET_IN_BYTE procedure. + To do: Build in support for LOC_JUMP } + + { If register is used, use only lower 8 bits } + if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + begin + pleftreg:=p^.left^.location.register; + if pleftreg in [R_AX..R_DX] then + begin + emit_const_reg(A_AND,S_W,255,pleftreg); + opsize:=S_W; + end + else + if pleftreg in [R_EAX..R_EDI] then + begin + emit_const_reg(A_AND,S_L,255,pleftreg); + opsize:=S_L; + end + else + opsize:=S_B; + end; + + { Get a label to jump to the end } + p^.location.loc:=LOC_FLAGS; + + { It's better to use the zero flag when there are + no ranges } + if ranges then + p^.location.resflags:=F_C + else + p^.location.resflags:=F_E; + + getlabel(l); + + for i:=1 to numparts do + if setparts[i].range then + begin + { Check if left is in a range } + { Get a label to jump over the check } + getlabel(l2); + if setparts[i].start=setparts[i].stop-1 then + begin + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : emit_const_reg(A_CMP,opsize, + setparts[i].start,pleftreg); + else + emit_const_ref(A_CMP,S_B, + setparts[i].start,newreference(p^.left^.location.reference)); + end; + { Result should be in carry flag when ranges are used } + if ranges then + emit_none(A_STC,S_NO); + { If found, jump to end } + emitjmp(C_E,l); + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : emit_const_reg(A_CMP,opsize, + setparts[i].stop,pleftreg); + else + emit_const_ref(A_CMP,S_B, + setparts[i].stop,newreference(p^.left^.location.reference)); + end; + { Result should be in carry flag when ranges are used } + if ranges then + emit_none(A_STC,S_NO); + { If found, jump to end } + emitjmp(C_E,l); + end + else + begin + if setparts[i].start<>0 then + begin + { We only check for the lower bound if it is > 0, because + set elements lower than 0 dont exist } + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + emit_const_reg(A_CMP,opsize, + setparts[i].start,pleftreg); + else + emit_const_ref(A_CMP,S_B, + setparts[i].start,newreference(p^.left^.location.reference)); + end; + { If lower, jump to next check } + emitjmp(C_B,l2); + end; + { We only check for the high bound if it is < 255, because + set elements higher than 255 do nt exist, the its always true, + so only a JMP is generated } + if setparts[i].stop<>255 then + begin + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : emit_const_reg(A_CMP,opsize, + setparts[i].stop+1,pleftreg); + else + emit_const_ref(A_CMP,S_B, + setparts[i].stop+1,newreference(p^.left^.location.reference)); + end; + { If higher, element is in set } + emitjmp(C_B,l); + end + else + begin + emit_none(A_STC,S_NO); + emitjmp(C_None,l); + end; + end; + { Emit the jump over label } + emitlab(l2); + end + else + begin + { Emit code to check if left is an element } + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : emit_const_reg(A_CMP,opsize, + setparts[i].stop,pleftreg); + else + emit_const_ref(A_CMP,S_B, + setparts[i].stop,newreference(p^.left^.location.reference)); + end; + { Result should be in carry flag when ranges are used } + if ranges then + emit_none(A_STC,S_NO); + { If found, jump to end } + emitjmp(C_E,l); + end; + if ranges then + emit_none(A_CLC,S_NO); + { To compensate for not doing a second pass } + p^.right^.location.reference.symbol:=nil; + { Now place the end label } + emitlab(l); + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : ungetregister32(pleftreg); + else + del_reference(p^.left^.location.reference); + end; + end + else + begin + { We will now generated code to check the set itself, no jmps, + handle smallsets separate, because it allows faster checks } + if use_small then + begin + if p^.left^.treetype=ordconstn then + begin + p^.location.resflags:=F_NE; + case p^.right^.location.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + emit_const_reg(A_TEST,S_L, + 1 shl (p^.left^.value and 31),p^.right^.location.register); + ungetregister32(p^.right^.location.register); + end + else + begin + emit_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31), + newreference(p^.right^.location.reference)); + del_reference(p^.right^.location.reference); + end; + end; + end + else + begin + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + hr:=p^.left^.location.register; + emit_to_reg32(hr); + end; + else + begin + { the set element isn't never samller than a byte } + { and because it's a small set we need only 5 bits } + { but 8 bits are easier to load } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOVZX,S_BL, + newreference(p^.left^.location.reference),R_EDI); + hr:=R_EDI; + del_reference(p^.left^.location.reference); + end; + end; + + case p^.right^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : emit_reg_reg(A_BT,S_L,hr, + p^.right^.location.register); + else + begin + del_reference(p^.right^.location.reference); + if p^.right^.location.reference.is_immediate then + begin + { We have to load the value into a register because + btl does not accept values only refs or regs (PFV) } + hr2:=getregister32; + emit_const_reg(A_MOV,S_L, + p^.right^.location.reference.offset,hr2); + emit_reg_reg(A_BT,S_L,hr,hr2); + ungetregister32(hr2); + end + else + emit_reg_ref(A_BT,S_L,hr, + newreference(p^.right^.location.reference)); + end; + end; +{$ifndef noAllocEdi} + { simply to indicate EDI is deallocated here too (JM) } + ungetregister32(hr); +{$else noAllocEdi} + ungetregister32(hr); +{$endif noAllocEdi} + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_C; + end; + end + else + begin + if p^.right^.location.reference.is_immediate then + begin + p^.location.resflags:=F_C; + getlabel(l); + getlabel(l2); + + { Is this treated in firstpass ?? } + if p^.left^.treetype=ordconstn then + begin + hr:=getregister32; + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hr; + emit_const_reg(A_MOV,S_L, + p^.left^.value,hr); + end; + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + hr:=p^.left^.location.register; + emit_to_reg32(hr); + emit_const_reg(A_CMP,S_L,31,hr); + emitjmp(C_NA,l); + { reset carry flag } + emit_none(A_CLC,S_NO); + emitjmp(C_NONE,l2); + emitlab(l); + { We have to load the value into a register because + btl does not accept values only refs or regs (PFV) } + hr2:=getregister32; + emit_const_reg(A_MOV,S_L,p^.right^.location.reference.offset,hr2); + emit_reg_reg(A_BT,S_L,hr,hr2); + ungetregister32(hr2); + end; + else + begin +{$ifdef CORRECT_SET_IN_FPC} + if m_tp in aktmodeswitches then + begin + {***WARNING only correct if + reference is 32 bits (PM) *****} + emit_const_ref(A_CMP,S_L, + 31,newreference(p^.left^.location.reference)); + end + else +{$endif CORRECT_SET_IN_FPC} + begin + emit_const_ref(A_CMP,S_B, + 31,newreference(p^.left^.location.reference)); + end; + emitjmp(C_NA,l); + { reset carry flag } + emit_none(A_CLC,S_NO); + emitjmp(C_NONE,l2); + emitlab(l); + del_reference(p^.left^.location.reference); + hr:=getregister32; + emit_ref_reg(A_MOV,S_L, + newreference(p^.left^.location.reference),hr); + { We have to load the value into a register because + btl does not accept values only refs or regs (PFV) } + hr2:=getregister32; + emit_const_reg(A_MOV,S_L, + p^.right^.location.reference.offset,hr2); + emit_reg_reg(A_BT,S_L,hr,hr2); + ungetregister32(hr2); + end; + end; + emitlab(l2); + end { of p^.right^.location.reference.is_immediate } + { do search in a normal set which could have >32 elementsm + but also used if the left side contains higher values > 32 } + else if p^.left^.treetype=ordconstn then + begin + p^.location.resflags:=F_NE; + inc(p^.right^.location.reference.offset,p^.left^.value shr 3); + emit_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7), + newreference(p^.right^.location.reference)); + del_reference(p^.right^.location.reference); + end + else + begin + pushsetelement(p^.left); + emitpushreferenceaddr(p^.right^.location.reference); + del_reference(p^.right^.location.reference); + { registers need not be save. that happens in SET_IN_BYTE } + { (EDI is changed) } + emitcall('FPC_SET_IN_BYTE'); + { ungetiftemp(p^.right^.location.reference); } + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_C; + end; + end; + end; + if (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(p^.right^.location.reference); + end; + + +{***************************************************************************** + SecondCase +*****************************************************************************} + + procedure secondcase(var p : ptree); + var + with_sign : boolean; + opsize : topsize; + jmp_gt,jmp_le,jmp_lee : tasmcond; + hp : ptree; + { register with case expression } + hregister : tregister; + endlabel,elselabel : pasmlabel; + + { true, if we can omit the range check of the jump table } + jumptable_no_range : boolean; + { where to put the jump table } + jumpsegment : paasmoutput; + min_label : longint; + + procedure gentreejmp(p : pcaserecord); + + var + lesslabel,greaterlabel : pasmlabel; + + begin + emitlab(p^._at); + { calculate labels for left and right } + if (p^.less=nil) then + lesslabel:=elselabel + else + lesslabel:=p^.less^._at; + if (p^.greater=nil) then + greaterlabel:=elselabel + else + greaterlabel:=p^.greater^._at; + { calculate labels for left and right } + { no range label: } + if p^._low=p^._high then + begin + emit_const_reg(A_CMP,opsize,p^._low,hregister); + if greaterlabel=lesslabel then + emitjmp(C_NE,lesslabel) + else + begin + emitjmp(jmp_le,lesslabel); + emitjmp(jmp_gt,greaterlabel); + end; + emitjmp(C_None,p^.statement); + end + else + begin + emit_const_reg(A_CMP,opsize,p^._low,hregister); + emitjmp(jmp_le,lesslabel); + emit_const_reg(A_CMP,opsize,p^._high,hregister); + emitjmp(jmp_gt,greaterlabel); + emitjmp(C_None,p^.statement); + end; + if assigned(p^.less) then + gentreejmp(p^.less); + if assigned(p^.greater) then + gentreejmp(p^.greater); + end; + + procedure genlinearcmplist(hp : pcaserecord); + + var + first : boolean; + last : longint; + + procedure genitem(t : pcaserecord); + + begin + if assigned(t^.less) then + genitem(t^.less); + if t^._low=t^._high then + begin + emit_const_reg(A_CMP,opsize,t^._low,hregister); + emitjmp(C_Z,t^.statement); + last:=t^._low; + end + else + begin + { if there is no unused label between the last and the } + { present label then the lower limit can be checked } + { immediately. else check the range in between: } + if first or (t^._low-last>1) then + begin + emit_const_reg(A_CMP,opsize,t^._low,hregister); + emitjmp(jmp_le,elselabel); + end; + + emit_const_reg(A_CMP,opsize,t^._high,hregister); + emitjmp(jmp_lee,t^.statement); + + last:=t^._high; + end; + first:=false; + if assigned(t^.greater) then + genitem(t^.greater); + end; + + begin + last:=0; + first:=true; + genitem(hp); + emitjmp(C_None,elselabel); + end; + + procedure genlinearlist(hp : pcaserecord); + + var + first : boolean; + last : longint; + {helplabel : longint;} + + procedure genitem(t : pcaserecord); + + begin + if assigned(t^.less) then + genitem(t^.less); + { need we to test the first value } + if first and (t^._low>get_min_value(p^.left^.resulttype)) then + begin + emit_const_reg(A_CMP,opsize,t^._low,hregister); + emitjmp(jmp_le,elselabel); + end; + if t^._low=t^._high then + begin + if t^._low-last=1 then + emit_reg(A_DEC,opsize,hregister) + else if t^._low-last=0 then + emit_reg_reg(A_OR,opsize,hregister,hregister) + else + emit_const_reg(A_SUB,opsize,t^._low-last,hregister); + last:=t^._low; + emitjmp(C_Z,t^.statement); + end + else + begin + { it begins with the smallest label, if the value } + { is even smaller then jump immediately to the } + { ELSE-label } + if first then + begin + { have we to ajust the first value ? } + if t^._low>get_min_value(p^.left^.resulttype) then + begin + if t^._low=1 then + emit_reg(A_DEC,opsize, + hregister) + else + emit_const_reg(A_SUB,opsize, + t^._low,hregister); + end; + end + else + { if there is no unused label between the last and the } + { present label then the lower limit can be checked } + { immediately. else check the range in between: } + if (t^._low-last>1) then + begin + emit_const_reg(A_SUB,opsize,t^._low-last,hregister); + emitjmp(jmp_le,elselabel); + end + else + emit_reg(A_DEC,opsize,hregister); + emit_const_reg(A_SUB,opsize,t^._high-t^._low,hregister); + emitjmp(jmp_lee,t^.statement); + + last:=t^._high; + end; + first:=false; + if assigned(t^.greater) then + genitem(t^.greater); + end; + + begin + { do we need to generate cmps? } + if with_sign and (min_label<0) then + genlinearcmplist(hp) + else + begin + last:=0; + first:=true; + genitem(hp); + emitjmp(C_None,elselabel); + end; + end; + + procedure genjumptable(hp : pcaserecord;min_,max_ : longint); + + var + table : pasmlabel; + last : longint; + hr : preference; + + procedure genitem(t : pcaserecord); + + var + i : longint; + + begin + if assigned(t^.less) then + genitem(t^.less); + { fill possible hole } + for i:=last+1 to t^._low-1 do + jumpsegment^.concat(new(pai_const_symbol,init(elselabel))); + for i:=t^._low to t^._high do + jumpsegment^.concat(new(pai_const_symbol,init(t^.statement))); + last:=t^._high; + if assigned(t^.greater) then + genitem(t^.greater); + end; + + begin + if not(jumptable_no_range) then + begin + emit_const_reg(A_CMP,opsize,min_,hregister); + { case expr less than min_ => goto elselabel } + emitjmp(jmp_le,elselabel); + emit_const_reg(A_CMP,opsize,max_,hregister); + emitjmp(jmp_gt,elselabel); + end; + getlabel(table); + { extend with sign } + if opsize=S_W then + begin + if with_sign then + emit_reg_reg(A_MOVSX,S_WL,hregister, + reg16toreg32(hregister)) + else + emit_reg_reg(A_MOVZX,S_WL,hregister, + reg16toreg32(hregister)); + hregister:=reg16toreg32(hregister); + end + else if opsize=S_B then + begin + if with_sign then + emit_reg_reg(A_MOVSX,S_BL,hregister, + reg8toreg32(hregister)) + else + emit_reg_reg(A_MOVZX,S_BL,hregister, + reg8toreg32(hregister)); + hregister:=reg8toreg32(hregister); + end; + new(hr); + reset_reference(hr^); + hr^.symbol:=table; + hr^.offset:=(-min_)*4; + hr^.index:=hregister; + hr^.scalefactor:=4; + emit_ref(A_JMP,S_NO,hr); + { !!!!! generate tables + if not(cs_littlesize in aktlocalswitches) then + jumpsegment^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4))); + } + jumpsegment^.concat(new(pai_label,init(table))); + last:=min_; + genitem(hp); + { !!!!!!! + if not(cs_littlesize in aktlocalswitches) then + emit_const(A_ALIGN,S_NO,4); + } + end; + + var + lv,hv,max_label,labels : longint; + max_linear_list : longint; +{$ifdef Delphi} + dist : cardinal; +{$else Delphi} + dist : dword; +{$endif Delphi} + begin + getlabel(endlabel); + getlabel(elselabel); + if (cs_create_smart in aktmoduleswitches) then + jumpsegment:=procinfo^.aktlocaldata + else + jumpsegment:=datasegment; + with_sign:=is_signed(p^.left^.resulttype); + if with_sign then + begin + jmp_gt:=C_G; + jmp_le:=C_L; + jmp_lee:=C_LE; + end + else + begin + jmp_gt:=C_A; + jmp_le:=C_B; + jmp_lee:=C_BE; + end; + cleartempgen; + secondpass(p^.left); + { determines the size of the operand } + opsize:=bytes2Sxx[p^.left^.resulttype^.size]; + { copy the case expression to a register } + case p^.left^.location.loc of + LOC_REGISTER: + hregister:=p^.left^.location.register; + LOC_FLAGS : + begin + hregister:=getregister32; + case opsize of + S_B : hregister:=reg32toreg8(hregister); + S_W : hregister:=reg32toreg16(hregister); + end; + emit_flag2reg(p^.left^.location.resflags,hregister); + end; + LOC_CREGISTER: + begin + hregister:=getregister32; + case opsize of + S_B : hregister:=reg32toreg8(hregister); + S_W : hregister:=reg32toreg16(hregister); + end; + emit_reg_reg(A_MOV,opsize, + p^.left^.location.register,hregister); + end; + LOC_MEM,LOC_REFERENCE : begin + del_reference(p^.left^.location.reference); + hregister:=getregister32; + case opsize of + S_B : hregister:=reg32toreg8(hregister); + S_W : hregister:=reg32toreg16(hregister); + end; + emit_ref_reg(A_MOV,opsize,newreference( + p^.left^.location.reference),hregister); + end; + else internalerror(2002); + end; + { we need the min_label always to choose between } + { cmps and subs/decs } + min_label:=case_get_min(p^.nodes); + { now generate the jumps } + if cs_optimize in aktglobalswitches then + begin + { procedures are empirically passed on } + { consumption can also be calculated } + { but does it pay on the different } + { processors? } + { moreover can the size only be appro- } + { ximated as it is not known if rel8, } + { rel16 or rel32 jumps are used } + max_label:=case_get_max(p^.nodes); + labels:=case_count_labels(p^.nodes); + { can we omit the range check of the jump table ? } + getrange(p^.left^.resulttype,lv,hv); + jumptable_no_range:=(lv=min_label) and (hv=max_label); + { hack a little bit, because the range can be greater } + { than the positive range of a longint } + + if (min_label<0) and (max_label>0) then + begin +{$ifdef Delphi} + if min_label=longint($80000000) then + dist:=Cardinal(max_label)+Cardinal($80000000) + else + dist:=Cardinal(max_label)+Cardinal(-min_label) +{$else Delphi} + if min_label=$80000000 then + dist:=dword(max_label)+dword($80000000) + else + dist:=dword(max_label)+dword(-min_label) +{$endif Delphi} + end + else + dist:=max_label-min_label; + + { optimize for size ? } + if cs_littlesize in aktglobalswitches then + begin + if (labels<=2) or + ((max_label-min_label)<0) or + ((max_label-min_label)>3*labels) then + { a linear list is always smaller than a jump tree } + genlinearlist(p^.nodes) + else + { if the labels less or more a continuum then } + genjumptable(p^.nodes,min_label,max_label); + end + else + begin + if jumptable_no_range then + max_linear_list:=4 + else + max_linear_list:=2; + { a jump table crashes the pipeline! } + if aktoptprocessor=Class386 then + inc(max_linear_list,3); + if aktoptprocessor=ClassP5 then + inc(max_linear_list,6); + if aktoptprocessor>=ClassP6 then + inc(max_linear_list,9); + + if (labels<=max_linear_list) then + genlinearlist(p^.nodes) + else + begin + if (dist>4*labels) then + begin + if labels>16 then + gentreejmp(p^.nodes) + else + genlinearlist(p^.nodes); + end + else + genjumptable(p^.nodes,min_label,max_label); + end; + end; + end + else + { it's always not bad } + genlinearlist(p^.nodes); + ungetregister(hregister); + + + { now generate the instructions } + hp:=p^.right; + while assigned(hp) do + begin + cleartempgen; + secondpass(hp^.right); + { don't come back to case line } + aktfilepos:=exprasmlist^.getlasttaifilepos^; + emitjmp(C_None,endlabel); + hp:=hp^.left; + end; + emitlab(elselabel); + { ...and the else block } + if assigned(p^.elseblock) then + begin + cleartempgen; + secondpass(p^.elseblock); + end; + emitlab(endlabel); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.52 2000/05/17 11:42:27 florian + * fixed my previous commit + + Revision 1.51 2000/05/16 18:56:04 florian + * fixed a problem with case and negative labels if a linear list + was generated (fixes tests\test\testcase) + + Revision 1.50 2000/05/11 09:56:20 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.49 2000/03/26 11:33:49 jonas + * release the register used to hold the value of the case variable + at the end of the case + + Revision 1.48 2000/02/09 13:22:48 peter + * log truncated + + Revision 1.47 2000/01/09 12:35:02 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.46 2000/01/09 01:44:21 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.45 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.44 1999/12/01 22:45:54 peter + * fixed wrong assembler with in-node + + Revision 1.43 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.42 1999/09/27 23:44:48 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.41 1999/09/20 16:38:52 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.40 1999/08/25 11:59:47 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.39 1999/08/23 23:46:42 pierre + * del_reference moved to respect registers32 in secondin + + Revision 1.38 1999/08/19 13:08:53 pierre + * emit_??? used + + Revision 1.37 1999/08/04 00:22:54 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.36 1999/08/03 22:02:48 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/cg68kadd.pas b/befpc/compiler/cg68kadd.pas new file mode 100644 index 0000000..76442ff --- /dev/null +++ b/befpc/compiler/cg68kadd.pas @@ -0,0 +1,1302 @@ +{ + $Id: cg68kadd.pas,v 1.1.1.1 2001-07-23 17:15:39 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for add node + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg68kadd; +interface + + uses + tree; + + procedure secondadd(var p : ptree); + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + symtable,aasm,types, + temp_gen,hcodegen,pass_2,cpubase, + cga68k,tgen68k; + +{***************************************************************************** + Helpers +*****************************************************************************} + + procedure processcc(p: ptree); + const + { process condition codes bit definitions } + CARRY_FLAG = $01; + OVFL_FLAG = $02; + ZERO_FLAG = $04; + NEG_FLAG = $08; + var + label1,label2: pasmlabel; + (*************************************************************************) + (* Description: This routine handles the conversion of Floating point *) + (* condition codes to normal cpu condition codes. *) + (*************************************************************************) + begin + getlabel(label1); + getlabel(label2); + case p^.treetype of + equaln,unequaln: begin + { not equal clear zero flag } + emitl(A_FBEQ,label1); + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_B, NOT ZERO_FLAG, R_CCR))); + emitl(A_BRA,label2); + emitl(A_LABEL,label1); + { equal - set zero flag } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR,S_B, ZERO_FLAG, R_CCR))); + emitl(A_LABEL,label2); + end; + ltn: begin + emitl(A_FBLT,label1); + { not less than } + { clear N and V flags } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_B, NOT (NEG_FLAG OR OVFL_FLAG), R_CCR))); + emitl(A_BRA,label2); + emitl(A_LABEL,label1); + { less than } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR,S_B, NEG_FLAG, R_CCR))); + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND,S_B, NOT OVFL_FLAG, R_CCR))); + emitl(A_LABEL,label2); + end; + gtn: begin + emitl(A_FBGT,label1); + { not greater than } + { set Z flag } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR, S_B, ZERO_FLAG, R_CCR))); + emitl(A_BRA,label2); + emitl(A_LABEL,label1); + { greater than } + { set N and V flags } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR,S_B, NEG_FLAG OR OVFL_FLAG , R_CCR))); + emitl(A_LABEL,label2); + end; + gten: begin + emitl(A_FBGE,label1); + { not greater or equal } + { set N and clear V } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_B, NOT OVFL_FLAG, R_CCR))); + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR,S_B, NEG_FLAG, R_CCR))); + emitl(A_BRA,label2); + emitl(A_LABEL,label1); + { greater or equal } + { clear V and N flags } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_B, NOT (OVFL_FLAG OR NEG_FLAG), R_CCR))); + emitl(A_LABEL,label2); + end; + lten: begin + emitl(A_FBLE,label1); + { not less or equal } + { clear Z, N and V } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_B, NOT (ZERO_FLAG OR NEG_FLAG OR OVFL_FLAG), R_CCR))); + emitl(A_BRA,label2); + emitl(A_LABEL,label1); + { less or equal } + { set Z and N } + { and clear V } + exprasmlist^.concat(new(paicpu, op_const_reg( + A_OR,S_B, ZERO_FLAG OR NEG_FLAG, R_CCR))); + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND,S_B, NOT OVFL_FLAG, R_CCR))); + emitl(A_LABEL,label2); + end; + else + begin + InternalError(34); + end; + end; { end case } + end; + + + procedure SetResultLocation(cmpop,unsigned:boolean;var p :ptree); + var + flags : tresflags; + begin + { remove temporary location if not a set or string } + { that's a hack (FK) } + if (p^.left^.resulttype^.deftype<>stringdef) and + ((p^.left^.resulttype^.deftype<>setdef) or (psetdef(p^.left^.resulttype)^.settype=smallset)) and + (p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(p^.left^.location.reference); + if (p^.right^.resulttype^.deftype<>stringdef) and + ((p^.right^.resulttype^.deftype<>setdef) or (psetdef(p^.right^.resulttype)^.settype=smallset)) and + (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(p^.right^.location.reference); + { in case of comparison operation the put result in the flags } + if cmpop then + begin + if not(unsigned) then + begin + if p^.swaped then + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_G; + lten : flags:=F_GE; + gtn : flags:=F_L; + gten : flags:=F_LE; + end + else + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_L; + lten : flags:=F_LE; + gtn : flags:=F_G; + gten : flags:=F_GE; + end; + end + else + begin + if p^.swaped then + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_A; + lten : flags:=F_AE; + gtn : flags:=F_B; + gten : flags:=F_BE; + end + else + case p^.treetype of + equaln : flags:=F_E; + unequaln : flags:=F_NE; + ltn : flags:=F_B; + lten : flags:=F_BE; + gtn : flags:=F_A; + gten : flags:=F_AE; + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=flags; + end; + end; + + +{***************************************************************************** + Addstring +*****************************************************************************} + + procedure addstring(var p : ptree); + var + pushedregs : tpushed; + href : treference; + pushed, + cmpop : boolean; + begin + { string operations are not commutative } + if p^.swaped then + swaptree(p); + case pstringdef(p^.left^.resulttype)^.string_typ of + st_ansistring: + begin + case p^.treetype of + addn : + begin + { we do not need destination anymore } + del_reference(p^.left^.location.reference); + del_reference(p^.right^.location.reference); + { concatansistring(p); } + end; + ltn,lten,gtn,gten, + equaln,unequaln : + begin + pushusedregisters(pushedregs,$ff); + secondpass(p^.left); + del_reference(p^.left^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + secondpass(p^.right); + del_reference(p^.right^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + emitcall('FPC_ANSISTRCMP',true); + maybe_loada5; + popusedregisters(pushedregs); + end; + end; + end; + st_shortstring: + begin + case p^.treetype of + addn : begin + cmpop:=false; + secondpass(p^.left); + if (p^.left^.treetype<>addn) then + begin + { can only reference be } + { string in register would be funny } + { therefore produce a temporary string } + + { release the registers } + del_reference(p^.left^.location.reference); + gettempofsizereference(256,href); + copystring(href,p^.left^.location.reference,255); + ungetiftemp(p^.left^.location.reference); + + { does not hurt: } + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_MEM; + p^.left^.location.reference:=href; + end; + + secondpass(p^.right); + + { on the right we do not need the register anymore too } + del_reference(p^.right^.location.reference); + pushusedregisters(pushedregs,$ffff); + { WE INVERSE THE PARAMETERS!!! } + { Because parameters are inversed in the rtl } + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + emitcall('FPC_STRCONCAT',true); + maybe_loadA5; + popusedregisters(pushedregs); + set_location(p^.location,p^.left^.location); + ungetiftemp(p^.right^.location.reference); + end; { this case } + ltn,lten,gtn,gten, + equaln,unequaln : + begin + secondpass(p^.left); + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + cmpop:=true; + del_reference(p^.right^.location.reference); + del_reference(p^.left^.location.reference); + { generates better code } + { s='' and s<>'' } + if (p^.treetype in [equaln,unequaln]) and + ( + ((p^.left^.treetype=stringconstn) and + (str_length(p^.left)=0)) or + ((p^.right^.treetype=stringconstn) and + (str_length(p^.right)=0)) + ) then + begin + { only one node can be stringconstn } + { else pass 1 would have evaluted } + { this node } + if p^.left^.treetype=stringconstn then + exprasmlist^.concat(new(paicpu,op_ref( + A_TST,S_B,newreference(p^.right^.location.reference)))) + else + exprasmlist^.concat(new(paicpu,op_ref( + A_TST,S_B,newreference(p^.left^.location.reference)))); + end + else + begin + pushusedregisters(pushedregs,$ffff); + + { parameters are directly passed via registers } + { this has several advantages, no loss of the flags } + { on exit ,and MUCH faster on m68k machines } + { speed difference (68000) } + { normal routine: entry, exit code + push = 124 } + { (best case) } + { assembler routine: param setup (worst case) = 48 } + + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_LEA,S_L,newreference(p^.left^.location.reference),R_A0))); + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_LEA,S_L,newreference(p^.right^.location.reference),R_A1))); + { + emitpushreferenceaddr(p^.left^.location.reference); + emitpushreferenceaddr(p^.right^.location.reference); } + emitcall('FPC_STRCMP',true); + maybe_loada5; + popusedregisters(pushedregs); + end; + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + end; { end this case } + + else CGMessage(type_e_mismatch); + end; + end; { end case } + end; + SetResultLocation(cmpop,true,p); + end; + + +{***************************************************************************** + Addset +*****************************************************************************} + + procedure addset(var p : ptree); + var + cmpop, + pushed : boolean; + href : treference; + pushedregs : tpushed; + begin + cmpop:=false; + + { not commutative } + if p^.swaped then + swaptree(p); + + secondpass(p^.left); + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if codegenerror then + exit; + if pushed then + restore(p); + + set_location(p^.location,p^.left^.location); + + { handle operations } + case p^.treetype of + equaln, + unequaln : begin + cmpop:=true; + del_reference(p^.left^.location.reference); + del_reference(p^.right^.location.reference); + pushusedregisters(pushedregs,$ff); + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + emitcall('FPC_SET_COMP_SETS',true); + maybe_loada5; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + end; + addn : begin + { add can be an other SET or Range or Element ! } + del_reference(p^.left^.location.reference); + del_reference(p^.right^.location.reference); + pushusedregisters(pushedregs,$ff); + href.symbol:=nil; + gettempofsizereference(32,href); + { add a range or a single element? } + if p^.right^.treetype=setelementn then + begin + concatcopy(p^.left^.location.reference,href,32,false); + if assigned(p^.right^.right) then + begin + loadsetelement(p^.right^.right); + loadsetelement(p^.right^.left); + emitpushreferenceaddr(exprasmlist,href); + emitcall('FPC_SET_SET_RANGE',true); + end + else + begin + loadsetelement(p^.right^.left); + emitpushreferenceaddr(exprasmlist,href); + emitcall('FPC_SET_SET_BYTE',true); + end; + end + else + begin + { must be an other set } + emitpushreferenceaddr(exprasmlist,href); + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + emitcall('FPC_SET_ADD_SETS',true); + end; + maybe_loada5; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=href; + end; + subn, + symdifn, + muln : begin + del_reference(p^.left^.location.reference); + del_reference(p^.right^.location.reference); + href.symbol:=nil; + pushusedregisters(pushedregs,$ff); + gettempofsizereference(32,href); + emitpushreferenceaddr(exprasmlist,href); + emitpushreferenceaddr(exprasmlist,p^.right^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + case p^.treetype of + subn : emitcall('FPC_SET_SUB_SETS',true); + symdifn : emitcall('FPC_SET_SYMDIF_SETS',true); + muln : emitcall('FPC_SET_MUL_SETS',true); + end; + maybe_loada5; + popusedregisters(pushedregs); + ungetiftemp(p^.left^.location.reference); + ungetiftemp(p^.right^.location.reference); + p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=href; + end; + else + CGMessage(type_e_mismatch); + end; + SetResultLocation(cmpop,true,p); + end; + + +{***************************************************************************** + SecondAdd +*****************************************************************************} + + procedure secondadd(var p : ptree); + { is also being used for xor, and "mul", "sub, or and comparative } + { operators } + + label do_normal; + + var + hregister : tregister; + noswap, + pushed,mboverflow,cmpop : boolean; + op : tasmop; + flags : tresflags; + otl,ofl : pasmlabel; + power : longint; + opsize : topsize; + hl4: pasmlabel; + tmpref : treference; + + + { true, if unsigned types are compared } + unsigned : boolean; + { true, if a small set is handled with the longint code } + is_set : boolean; + { is_in_dest if the result is put directly into } + { the resulting refernce or varregister } + is_in_dest : boolean; + { true, if for sets subtractions the extra not should generated } + extra_not : boolean; + + begin + { to make it more readable, string and set (not smallset!) have their + own procedures } + case p^.left^.resulttype^.deftype of + stringdef : begin + addstring(p); + exit; + end; + setdef : begin + { normalsets are handled separate } + if not(psetdef(p^.left^.resulttype)^.settype=smallset) then + begin + addset(p); + exit; + end; + end; + end; + + { defaults } + unsigned:=false; + is_in_dest:=false; + extra_not:=false; + noswap:=false; + opsize:=S_L; + + { are we a (small)set, must be set here because the side can be + swapped ! (PFV) } + is_set:=(p^.left^.resulttype^.deftype=setdef); + + { calculate the operator which is more difficult } + firstcomplex(p); + + { handling boolean expressions extra: } + if ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit])) then + begin + if (porddef(p^.left^.resulttype)^.typ=bool8bit) or + (porddef(p^.right^.resulttype)^.typ=bool8bit) then + opsize:=S_B + else + if (porddef(p^.left^.resulttype)^.typ=bool16bit) or + (porddef(p^.right^.resulttype)^.typ=bool16bit) then + opsize:=S_W + else + opsize:=S_L; + case p^.treetype of + andn, + orn : begin + clear_location(p^.location); + p^.location.loc:=LOC_JUMP; + cmpop:=false; + case p^.treetype of + andn : begin + otl:=truelabel; + getlabel(truelabel); + secondpass(p^.left); + maketojumpbool(p^.left); + emitl(A_LABEL,truelabel); + truelabel:=otl; + end; + orn : begin + ofl:=falselabel; + getlabel(falselabel); + secondpass(p^.left); + maketojumpbool(p^.left); + emitl(A_LABEL,falselabel); + falselabel:=ofl; + end; + else + CGMessage(type_e_mismatch); + end; + secondpass(p^.right); + maketojumpbool(p^.right); + end; + unequaln, + equaln,xorn : begin + if p^.left^.treetype=ordconstn then + swaptree(p); + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + { are enough registers free ? } + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + goto do_normal; + end + else + CGMessage(type_e_mismatch); + end + end + else + begin + { in case of constant put it to the left } + if (p^.left^.treetype=ordconstn) then + swaptree(p); + secondpass(p^.left); + { this will be complicated as + a lot of code below assumes that + p^.location and p^.left^.location are the same } + +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) and + ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then + begin + set_location(p^.location,dest_loc); + in_dest_loc:=true; + is_in_dest:=true; + end + else +{$endif test_dest_loc} + set_location(p^.location,p^.left^.location); + + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then + restore(p); + + if (p^.left^.resulttype^.deftype=pointerdef) or + + (p^.right^.resulttype^.deftype=pointerdef) or + + ((p^.right^.resulttype^.deftype=objectdef) and + pobjectdef(p^.right^.resulttype)^.is_class and + (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class + ) or + + (p^.left^.resulttype^.deftype=classrefdef) or + + (p^.left^.resulttype^.deftype=procvardef) or + + (p^.left^.resulttype^.deftype=enumdef) or + + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=s32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=s32bit)) or + + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=u32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=u32bit)) or + + { as well as small sets } + is_set then + begin + do_normal: + mboverflow:=false; + cmpop:=false; + if (p^.left^.resulttype^.deftype=pointerdef) or + (p^.right^.resulttype^.deftype=pointerdef) or + ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=u32bit)) or + ((p^.right^.resulttype^.deftype=orddef) and + (porddef(p^.right^.resulttype)^.typ=u32bit)) then + unsigned:=true; + case p^.treetype of + addn : begin + if is_set then + begin + { adding elements is not commutative } + if p^.swaped and (p^.left^.treetype=setelementn) then + swaptree(p); + { are we adding set elements ? } + if p^.right^.treetype=setelementn then + begin + { no range support for smallsets! } + if assigned(p^.right^.right) then + internalerror(43244); + { Not supported for m68k} + Comment(V_Fatal,'No smallsets for m68k'); + end + else + op:=A_OR; + mboverflow:=false; + unsigned:=false; + end + else + begin + op:=A_ADD; + mboverflow:=true; + end; + end; + symdifn : begin + { the symetric diff is only for sets } + if is_set then + begin + op:=A_EOR; + mboverflow:=false; + unsigned:=false; + end + else + CGMessage(type_e_mismatch); + end; + muln : begin + if is_set then + begin + op:=A_AND; + mboverflow:=false; + unsigned:=false; + end + else + begin + if unsigned then + op:=A_MULU + else + op:=A_MULS; + mboverflow:=true; + end; + end; + subn : begin + if is_set then + begin + op:=A_AND; + mboverflow:=false; + unsigned:=false; + extra_not:=true; + end + else + begin + op:=A_SUB; + mboverflow:=true; + end; + end; + ltn,lten, + gtn,gten, + equaln,unequaln : begin + op:=A_CMP; + cmpop:=true; + end; + xorn : op:=A_EOR; + orn : op:=A_OR; + andn : op:=A_AND; + else + CGMessage(type_e_mismatch); + end; + + { left and right no register? } + { then one must be demanded } + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + { register variable ? } + if (p^.left^.location.loc=LOC_CREGISTER) then + begin + { it is OK if this is the destination } + if is_in_dest then + begin + hregister:=p^.location.register; + emit_reg_reg(A_MOVE,opsize,p^.left^.location.register, + hregister); + end + else + if cmpop then + begin + { do not disturb the register } + hregister:=p^.location.register; + end + else + begin + hregister:=getregister32; + emit_reg_reg(A_MOVE,opsize,p^.left^.location.register, + hregister); + end + end + else + begin + del_reference(p^.left^.location.reference); + if is_in_dest then + begin + hregister:=p^.location.register; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.left^.location.reference),hregister))); + end + else + begin + hregister:=getregister32; + { first give free, then demand new register } + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.left^.location.reference),hregister))); + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end + else + { if on the right the register then swap } + if not(noswap) and (p^.right^.location.loc=LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + { at this point, p^.location.loc should be LOC_REGISTER } + { and p^.location.register should be a valid register } + { containing the left result } + if p^.right^.location.loc<>LOC_REGISTER then + begin + if (p^.treetype=subn) and p^.swaped then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + if extra_not then + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,opsize,p^.location.register))); + + emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,R_D6); + emit_reg_reg(op,opsize,p^.location.register,R_D6); + emit_reg_reg(A_MOVE,opsize,R_D6,p^.location.register); + end + else + begin + if extra_not then + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,opsize,p^.location.register))); + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.right^.location.reference),R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,p^.location.register,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,opsize,R_D6,p^.location.register))); + del_reference(p^.right^.location.reference); + end; + end + else + begin + if (p^.right^.treetype=ordconstn) and (op=A_CMP) and + (p^.right^.value=0) then + exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,p^.location.register))) + else + if (p^.right^.treetype=ordconstn) and (op=A_MULS) and + (ispowerof2(p^.right^.value,power)) then + begin + if (power <= 8) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_ASL,opsize,power, + p^.location.register))) + else + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,power, + R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_ASL,opsize,R_D6, + p^.location.register))) + end; + end + else + begin + if (p^.right^.location.loc=LOC_CREGISTER) then + begin + if extra_not then + begin + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D6); + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,R_D6))); + emit_reg_reg(A_AND,S_L,R_D6, + p^.location.register); + end + else + begin + if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then + { Emulation for MC68000 } + begin + emit_reg_reg(A_MOVE,opsize,p^.right^.location.register, + R_D0); + emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1); + emitcall('FPC_LONGMUL',true); + emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register); + end + else + if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then + CGMessage(cg_f_32bit_not_supported_in_68000) + else + emit_reg_reg(op,opsize,p^.right^.location.register, + p^.location.register); + end; + end + else + begin + if extra_not then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference( + p^.right^.location.reference),R_D6))); + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,R_D6))); + emit_reg_reg(A_AND,S_L,R_D6, + p^.location.register); + end + else + begin + if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then + { Emulation for MC68000 } + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE, opsize, + newreference(p^.right^.location.reference),R_D1))); + emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D0); + emitcall('FPC_LONGMUL',true); + emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register); + end + else + if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then + CGMessage(cg_f_32bit_not_supported_in_68000) + else + { When one of the source/destination is a memory reference } + { and the operator is EOR, the we must load it into the } + { value into a register first since only EOR reg,reg exists } + { on the m68k } + if (op=A_EOR) then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference( + p^.right^.location.reference),R_D0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,R_D0, + p^.location.register))); + end + else + exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,newreference( + p^.right^.location.reference),p^.location.register))); + end; + del_reference(p^.right^.location.reference); + end; + end; + end; + end + else + begin + { when swapped another result register } + if (p^.treetype=subn) and p^.swaped then + begin + if extra_not then + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register))); + + exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize, + p^.location.register,p^.right^.location.register))); + swap_location(p^.location,p^.right^.location); + + { newly swapped also set swapped flag } + { just to maintain ordering } + p^.swaped:=not(p^.swaped); + end + else + begin + if extra_not then + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.right^.location.register))); + + if (op=A_MULS) and (opsize = S_L) and (aktoptprocessor=MC68000) then + { Emulation for MC68000 } + begin + emit_reg_reg(A_MOVE,opsize,p^.right^.location.register, + R_D0); + emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1); + emitcall('FPC_LONGMUL',true); + emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register); + end + else + if (op=A_MULU) and (opsize = S_L) and (aktoptprocessor=MC68000) then + CGMessage(cg_f_32bit_not_supported_in_68000) + else + + exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize, + p^.right^.location.register, + p^.location.register))); + end; + ungetregister32(p^.right^.location.register); + end; + + if cmpop then + ungetregister32(p^.location.register); + + { only in case of overflow operations } + { produce overflow code } + if mboverflow then + emitoverflowcheck(p); + { only in case of overflow operations } + { produce overflow code } + { we must put it here directly, because sign of operation } + { is in unsigned VAR!! } + end + else + + { Char type } + if ((p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=uchar)) then + begin + case p^.treetype of + ltn,lten,gtn,gten, + equaln,unequaln : + cmpop:=true; + else CGMessage(type_e_mismatch); + end; + unsigned:=true; + { left and right no register? } + { the one must be demanded } + if (p^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_REGISTER) then + begin + if p^.location.loc=LOC_CREGISTER then + begin + if cmpop then + { do not disturb register } + hregister:=p^.location.register + else + begin + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_B,p^.location.register, + hregister); + end; + end + else + begin + del_reference(p^.location.reference); + + { first give free then demand new register } + hregister:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference), + hregister))); + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end; + + { now p always a register } + + if (p^.right^.location.loc=LOC_REGISTER) and + (p^.location.loc<>LOC_REGISTER) then + begin + swap_location(p^.location,p^.right^.location); + + { newly swapped also set swapped flag } + p^.swaped:=not(p^.swaped); + end; + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + emit_reg_reg(A_CMP,S_B, + p^.right^.location.register,p^.location.register); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,S_B,newreference( + p^.right^.location.reference),p^.location.register))); + del_reference(p^.right^.location.reference); + end; + end + else + begin + emit_reg_reg(A_CMP,S_B,p^.right^.location.register, + p^.location.register); + ungetregister32(p^.right^.location.register); + end; + ungetregister32(p^.location.register); + end + else + + { Floating point } + if (p^.left^.resulttype^.deftype=floatdef) and + (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then + begin + { real constants to the left } + if p^.left^.treetype=realconstn then + swaptree(p); + cmpop:=false; + case p^.treetype of + addn : op:=A_FADD; + muln : op:=A_FMUL; + subn : op:=A_FSUB; + slashn : op:=A_FDIV; + ltn,lten,gtn,gten, + equaln,unequaln : begin + op:=A_FCMP; + cmpop:=true; + end; + else CGMessage(type_e_mismatch); + end; + + if (p^.left^.location.loc <> LOC_FPU) and + (p^.right^.location.loc <> LOC_FPU) then + begin + { we suppose left in reference } + del_reference(p^.left^.location.reference); + { get a copy, since we don't want to modify the same } + { node at the same time. } + tmpref:=p^.left^.location.reference; + if assigned(p^.left^.location.reference.symbol) then + tmpref.symbol:=stringdup(p^.left^.location.reference.symbol^); + + floatload(pfloatdef(p^.left^.resulttype)^.typ, tmpref, + p^.left^.location); + clear_reference(tmpref); + end + else + begin + if (p^.right^.location.loc = LOC_FPU) + and(p^.left^.location.loc <> LOC_FPU) then + begin + swap_location(p^.left^.location, p^.right^.location); + p^.swaped := not(p^.swaped); + end + end; + + { ---------------- LEFT = LOC_FPUREG -------------------- } + if ((p^.treetype =subn) or (p^.treetype = slashn)) and (p^.swaped) then + { fpu_reg = right(FP1) / fpu_reg } + { fpu_reg = right(FP1) - fpu_reg } + begin + if (cs_fp_emulation in aktmoduleswitches) then + begin + { fpu_reg = right / D1 } + { fpu_reg = right - D1 } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0))); + + + { load value into D1 } + if p^.right^.location.loc <> LOC_FPU then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.right^.location.reference),R_D1))) + else + emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D1); + + { probably a faster way to do this but... } + case op of + A_FADD: emitcall('FPC_SINGLE_ADD',true); + A_FMUL: emitcall('FPC_SINGLE_MUL',true); + A_FSUB: emitcall('FPC_SINGLE_SUB',true); + A_FDIV: emitcall('FPC_SINGLE_DIV',true); + A_FCMP: emitcall('FPC_SINGLE_CMP',true); + end; + if not cmpop then { only flags are affected with cmpop } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0, + p^.left^.location.fpureg))); + + { if this was a reference, then delete as it } + { it no longer required. } + if p^.right^.location.loc <> LOC_FPU then + del_reference(p^.right^.location.reference); + end + else + begin + + if p^.right^.location.loc <> LOC_FPU then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE, + getfloatsize(pfloatdef(p^.left^.resulttype)^.typ), + newreference(p^.right^.location.reference), + R_FP1))) + else + { FPm --> FPn must use extended precision } + emit_reg_reg(A_FMOVE,S_FX,p^.right^.location.fpureg,R_FP1); + + { arithmetic expression performed in extended mode } + exprasmlist^.concat(new(paicpu,op_reg_reg(op,S_FX, + p^.left^.location.fpureg,R_FP1))); + + { cmpop does not change any floating point register!! } + if not cmpop then + emit_reg_reg(A_FMOVE,S_FX,R_FP1,p^.left^.location.fpureg) +{ exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE, + getfloatsize(pfloatdef(p^.left^.resulttype)^.typ), + R_FP1,p^.left^.location.fpureg)))} + else + { process comparison, to make it compatible with the rest of the code } + processcc(p); + + { if this was a reference, then delete as it } + { it no longer required. } + if p^.right^.location.loc <> LOC_FPU then + del_reference(p^.right^.location.reference); + end; + end + else { everything is in the right order } + begin + { fpu_reg = fpu_reg / right } + { fpu_reg = fpu_reg - right } + { + commutative ops } + if cs_fp_emulation in aktmoduleswitches then + begin + + { load value into D7 } + if p^.right^.location.loc <> LOC_FPU then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.right^.location.reference),R_D0))) + else + emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D0); + + emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D1); + { probably a faster way to do this but... } + case op of + A_FADD: emitcall('FPC_SINGLE_ADD',true); + A_FMUL: emitcall('FPC_SINGLE_MUL',true); + A_FSUB: emitcall('FPC_SINGLE_SUB',true); + A_FDIV: emitcall('FPC_SINGLE_DIV',true); + A_FCMP: emitcall('FPC_SINGLE_CMP',true); + end; + if not cmpop then { only flags are affected with cmpop } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0, + p^.left^.location.fpureg))); + { if this was a reference, then delete as it } + { it no longer required. } + if p^.right^.location.loc <> LOC_FPU then + del_reference(p^.right^.location.reference); + end + else + begin + if p^.right^.location.loc <> LOC_FPU then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE, + getfloatsize(pfloatdef(p^.left^.resulttype)^.typ), + newreference(p^.right^.location.reference),R_FP1))) + else + emit_reg_reg(A_FMOVE,getfloatsize(pfloatdef(p^.left^.resulttype)^.typ), + p^.right^.location.fpureg,R_FP1); + + emit_reg_reg(op,S_FX,R_FP1,p^.left^.location.fpureg); + + if cmpop then + processcc(p); + + { if this was a reference, then delete as it } + { it no longer required. } + if p^.right^.location.loc <> LOC_FPU then + del_reference(p^.right^.location.reference); + + end + end; { endif treetype = .. } + + + if cmpop then + begin + { the register is now longer required } + if p^.left^.location.loc = LOC_FPU then + begin + ungetregister(p^.left^.location.fpureg); + end; + + + if p^.swaped then + case p^.treetype of + equaln: flags := F_E; + unequaln: flags := F_NE; + ltn : flags := F_G; + lten : flags := F_GE; + gtn : flags := F_L; + gten: flags := F_LE; + end + else + case p^.treetype of + equaln: flags := F_E; + unequaln : flags := F_NE; + ltn: flags := F_L; + lten : flags := F_LE; + gtn : flags := F_G; + gten: flags := F_GE; + end; + clear_location(p^.location); + p^.location.loc := LOC_FLAGS; + p^.location.resflags := flags; + cmpop := false; + end + else + begin + clear_location(p^.location); + p^.location.loc := LOC_FPU; + if p^.left^.location.loc = LOC_FPU then + { copy fpu register result . } + { HERE ON EXIT FPU REGISTER IS IN EXTENDED MODE! } + p^.location.fpureg := p^.left^.location.fpureg + else + begin + InternalError(34); + end; + end; + end + + + else CGMessage(type_e_mismatch); + end; + SetResultLocation(cmpop,unsigned,p); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/03/01 00:04:31 pierre + Use $GOTO ON + + Revision 1.19 2000/02/09 13:22:48 peter + * log truncated + + Revision 1.18 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.17 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.16 1999/09/16 11:34:52 pierre + * typo correction + +} \ No newline at end of file diff --git a/befpc/compiler/cg68kcal.pas b/befpc/compiler/cg68kcal.pas new file mode 100644 index 0000000..cbeb99a --- /dev/null +++ b/befpc/compiler/cg68kcal.pas @@ -0,0 +1,1102 @@ +{ + $Id: cg68kcal.pas,v 1.1.1.1 2001-07-23 17:15:39 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for in call nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg68kcal; +interface + + uses + symtable,tree; + + { save the size of pushed parameter } + var + pushedparasize : longint; + + procedure secondcallparan(var p : ptree;defcoll : pdefcoll; + push_from_left_to_right : boolean); + procedure secondcalln(var p : ptree); + procedure secondprocinline(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k,cg68kld; + +{***************************************************************************** + SecondCallParaN +*****************************************************************************} + + + procedure secondcallparan(var p : ptree;defcoll : pdefcoll; + push_from_left_to_right : boolean); + + procedure maybe_push_open_array_high; + var + r : preference; + begin + { open array ? } + { defcoll^.data can be nil for read/write } + if assigned(defcoll^.data) and + is_open_array(defcoll^.data) then + begin + inc(pushedparasize,4); + { push high } + if is_open_array(p^.left^.resulttype) then + begin + new(r); + reset_reference(r^); + r^.base:=highframepointer; + r^.offset:=highoffset+4; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH))); + end + else + push_int(parraydef(p^.left^.resulttype)^.highrange-parraydef(p^.left^.resulttype)^.lowrange); + end; + end; + + var + size : longint; + stackref : treference; + otlabel,hlabel,oflabel : pasmlabel; + { temporary variables: } + reg : tregister; + tempdeftype : tdeftype; + tempreference : treference; + r : preference; + s : topsize; + op : tasmop; + + begin + { push from left to right if specified } + if push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left); + { in codegen.handleread.. defcoll^.data is set to nil } + if assigned(defcoll^.data) and + (defcoll^.data^.deftype=formaldef) then + begin + { allow @var } + if p^.left^.treetype=addrn then + begin + { allways a register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH))); + ungetregister32(p^.left^.location.register); + end + else + begin + if (p^.left^.location.loc<>LOC_REFERENCE) and + (p^.left^.location.loc<>LOC_MEM) then + CGMessage(type_e_mismatch) + else + begin + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end; + end; + inc(pushedparasize,4); + end + { handle call by reference parameter } + else if (defcoll^.paratyp=vs_var) then + begin + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_var_must_be_reference); + maybe_push_open_array_high; + inc(pushedparasize,4); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + begin + tempdeftype:=p^.resulttype^.deftype; + if tempdeftype=filedef then + CGMessage(cg_e_file_must_call_by_reference); + if (assigned(defcoll^.data) and + is_open_array(defcoll^.data)) or + push_addr_param(p^.resulttype) then + begin + maybe_push_open_array_high; + inc(pushedparasize,4); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end + else + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + { HERE IS A BIG PROBLEM } + { --> We *MUST* know the data size to push } + { for the moment, we can say that the savesize } + { indicates the parameter size to push, but } + { that is CERTAINLY NOT TRUE! } + { CAN WE USE LIKE LOC_MEM OR LOC_REFERENCE?? } + case integer(p^.left^.resulttype^.size) of + 1 : Begin + { A byte sized value normally increments } + { the SP by 2, BUT because how memory has } + { been setup OR because of GAS, a byte sized } + { push CRASHES the Amiga, therefore, we do it } + { by hand instead. } + { PUSH A WORD SHIFTED LEFT 8 } + reg := getregister32; + emit_reg_reg(A_MOVE, S_B, p^.left^.location.register, reg); + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W, + 8, reg))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W, + reg,R_SPPUSH))); + { offset will be TWO greater } + inc(pushedparasize,2); + ungetregister32(reg); + ungetregister32(p^.left^.location.register); + end; + 2 : + Begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W, + p^.left^.location.register,R_SPPUSH))); + inc(pushedparasize,2); + ungetregister32(p^.left^.location.register); + end; + 4 : Begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.left^.location.register,R_SPPUSH))); + inc(pushedparasize,4); + ungetregister32(p^.left^.location.register); + end; + else + Begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.left^.location.register,R_SPPUSH))); + inc(pushedparasize,4); + ungetregister32(p^.left^.location.register); + end; + end; { end case } + end; + LOC_FPU : begin + size:=pfloatdef(p^.left^.resulttype)^.size; + inc(pushedparasize,size); + { how now how long a FPU is !! } + if (size > 0) and (size < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_L,size,R_SP))) + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBA, + S_L,size,R_SP))); + new(r); + reset_reference(r^); + r^.base:=R_SP; + s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ); + if (cs_fp_emulation in aktmoduleswitches) or (s=S_FS) then + begin + { when in emulation mode... } + { only single supported!!! } + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L, + p^.left^.location.fpureg,r))); + end + else + { convert back from extended to normal type } + exprasmlist^.concat(new(paicpu,op_reg_ref(A_FMOVE,s, + p^.left^.location.fpureg,r))); + end; + LOC_REFERENCE,LOC_MEM : + begin + tempreference:=p^.left^.location.reference; + del_reference(p^.left^.location.reference); + case p^.resulttype^.deftype of + enumdef, + orddef : begin + case p^.resulttype^.size of + 4 : begin + emit_push_mem(tempreference); + inc(pushedparasize,4); + end; + 1 : Begin + { We push a BUT, the SP is incremented by 2 } + { as specified in the Motorola Prog's Ref Manual } + { Therefore offet increments BY 2!!! } + { BUG??? ... } + { SWAP OPERANDS: } + if tempreference.isintvalue then + Begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W, + tempreference.offset shl 8,R_SPPUSH))); + end + else + Begin + { A byte sized value normally increments } + { the SP by 2, BUT because how memory has } + { been setup OR because of GAS, a byte sized } + { push CRASHES the Amiga, therefore, we do it } + { by hand instead. } + { PUSH A WORD SHIFTED LEFT 8 } + reg:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B, + newreference(tempreference),reg))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W, + 8, reg))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W, + reg,R_SPPUSH))); + ungetregister32(reg); +{ exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W, + newreference(tempreference),R_SPPUSH))); } + end; + inc(pushedparasize,2); + end; + 2 : begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W, + newreference(tempreference),R_SPPUSH))); + inc(pushedparasize,2); + end; + end; + end; + floatdef : begin + case pfloatdef(p^.resulttype)^.typ of + f32bit, + s32real : + begin + emit_push_mem(tempreference); + inc(pushedparasize,4); + end; + s64real: + {s64bit } + begin + inc(tempreference.offset,4); + emit_push_mem(tempreference); + dec(tempreference.offset,4); + emit_push_mem(tempreference); + inc(pushedparasize,8); + end; +{$ifdef use48} + s48real : begin + end; +{$endif} + s80real : begin + CGMessage(cg_f_extended_cg68k_not_supported); +{ inc(tempreference.offset,6); + emit_push_mem(tempreference); + dec(tempreference.offset,4); + emit_push_mem(tempreference); + dec(tempreference.offset,2); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W, + newreference(tempreference),R_SPPUSH))); + inc(pushedparasize,extended_size);} + end; + end; + end; + pointerdef,procvardef, + classrefdef: begin + emit_push_mem(tempreference); + inc(pushedparasize,4); + end; + arraydef,recorddef,stringdef,setdef,objectdef : + begin + if ((p^.resulttype^.deftype=setdef) and + (psetdef(p^.resulttype)^.settype=smallset)) then + begin + emit_push_mem(tempreference); + inc(pushedparasize,4); + end + else + begin + size:=p^.resulttype^.size; + + { Alignment } + { + if (size>=4) and ((size and 3)<>0) then + inc(size,4-(size and 3)) + else if (size>=2) and ((size and 1)<>0) then + inc(size,2-(size and 1)) + else + if size=1 then size:=2; + } + { create stack space } + if (size > 0) and (size < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_L,size,R_SP))) + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBA, + S_L,size,R_SP))); + inc(pushedparasize,size); + { create stack reference } + stackref.symbol := nil; + clear_reference(stackref); + stackref.base:=R_SP; + { produce copy } + if p^.resulttype^.deftype=stringdef then + begin + copystring(stackref,p^.left^.location.reference, + pstringdef(p^.resulttype)^.len); + end + else + begin + concatcopy(p^.left^.location.reference, + stackref,p^.resulttype^.size,true); + end; + end; + end; + else CGMessage(cg_e_illegal_expression); + end; + end; + LOC_JUMP : begin + getlabel(hlabel); + inc(pushedparasize,2); + emitl(A_LABEL,truelabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,1 shl 8,R_SPPUSH))); + emitl(A_JMP,hlabel); + emitl(A_LABEL,falselabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,0,R_SPPUSH))); + emitl(A_LABEL,hlabel); + end; + LOC_FLAGS : begin + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.left^.location.resflags],S_B, + R_D0))); + exprasmlist^.concat(new(paicpu,op_reg(A_NEG, S_B, R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_W,$ff, R_D0))); + inc(pushedparasize,2); + { ----------------- HACK ----------------------- } + { HERE IS THE BYTE SIZED PUSH HACK ONCE AGAIN } + { SHIFT LEFT THE BYTE TO MAKE IT WORK! } + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_W,8, R_D0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH))); + end; + end; + end; + truelabel:=otlabel; + falselabel:=oflabel; + { push from right to left } + if not push_from_left_to_right and assigned(p^.right) then + secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); + end; + + +{***************************************************************************** + SecondCallN +*****************************************************************************} + + procedure secondcalln(var p : ptree); + + var + unusedregisters : tregisterset; + pushed : tpushed; + funcretref : treference; + hregister : tregister; + oldpushedparasize : longint; + { true if a5 must be loaded again after the subroutine } + loada5 : boolean; + { true if a virtual method must be called directly } + no_virtual_call : boolean; + { true if we produce a con- or destrutor in a call } + is_con_or_destructor : boolean; + { true if a constructor is called again } + extended_new : boolean; + { adress returned from an I/O-error } + iolabel : pasmlabel; + { lexlevel count } + i : longint; + { help reference pointer } + r : preference; + pp,params : ptree; + { temp register allocation } + reg: tregister; + { help reference pointer } + ref: preference; + + label + dont_call; + + begin + extended_new:=false; + iolabel:=nil; + loada5:=true; + no_virtual_call:=false; + unusedregisters:=unused; + if not assigned(p^.procdefinition) then + exit; + { only if no proc var } + if not(assigned(p^.right)) then + is_con_or_destructor:=(potype_constructor=p^.procdefinition^.proctypeoption) + or (potype_destructor=p^.procdefinition^.proctypeoption); + { proc variables destroy all registers } + if (p^.right=nil) and + { virtual methods too } + (po_virtualmethod in p^.procdefinition^.procoptions) then + begin + if (po_iocheck in p^.procdefinition^.procoptions) and + not(po_iocheck in aktprocsym^.definition^.procoptions) and + (cs_check_io in aktlocalswitches) then + begin + getlabel(iolabel); + emitl(A_LABEL,iolabel); + end + else iolabel:=nil; + + { save all used registers } + pushusedregisters(pushed,pprocdef(p^.procdefinition)^.usedregisters); + + { give used registers through } + usedinproc:=usedinproc or pprocdef(p^.procdefinition)^.usedregisters; + end + else + begin + pushusedregisters(pushed,$ffff); + usedinproc:=$ffff; + + { no IO check for methods and procedure variables } + iolabel:=nil; + end; + + { generate the code for the parameter and push them } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + if (p^.resulttype<>pdef(voiddef)) and + ret_in_param(p^.resulttype) then + begin + funcretref.symbol:=nil; +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) and + (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then + begin + funcretref:=dest_loc.reference; + if assigned(dest_loc.reference.symbol) then + funcretref.symbol:=stringdup(dest_loc.reference.symbol^); + in_dest_loc:=true; + end + else +{$endif test_dest_loc} + gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); + end; + if assigned(p^.left) then + begin + pushedparasize:=0; + { be found elsewhere } + if assigned(p^.right) then + secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1, + (pocall_leftright in p^.procdefinition^.proccalloptions)) + else + secondcallparan(p^.left,p^.procdefinition^.para1, + (pocall_leftright in p^.procdefinition^.proccalloptions)); + end; + params:=p^.left; + p^.left:=nil; + if ret_in_param(p^.resulttype) then + begin + emitpushreferenceaddr(exprasmlist,funcretref); + inc(pushedparasize,4); + end; + { overloaded operator have no symtable } + if (p^.right=nil) then + begin + { push self } + if assigned(p^.symtable) and + (p^.symtable^.symtabletype=withsymtable) then + begin + { dirty trick to avoid the secondcall below } + p^.methodpointer:=genzeronode(callparan); + p^.methodpointer^.location.loc:=LOC_REGISTER; + p^.methodpointer^.location.register:=R_A5; + { change dispose type !! } + p^.disposetyp:=dt_mbleft_and_method; + { make a reference } + new(r); + reset_reference(r^); + r^.offset:=p^.symtable^.datasize; + r^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5))); + end; + + { push self } + if assigned(p^.symtable) and + ((p^.symtable^.symtabletype=objectsymtable) or + (p^.symtable^.symtabletype=withsymtable)) then + begin + if assigned(p^.methodpointer) then + begin + case p^.methodpointer^.treetype of + typen : + begin + { direct call to inherited method } + if po_abstractmethod in p^.procdefinition^.procoptions then + begin + CGMessage(cg_e_cant_call_abstract_method); + goto dont_call; + end; + { generate no virtual call } + no_virtual_call:=true; + if (sp_static in p^.symtableprocentry^.symoptions) then + begin + { well lets put the VMT address directly into a5 } + { it is kind of dirty but that is the simplest } + { way to accept virtual static functions (PM) } + loada5:=true; + exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE,S_L, + newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + end + else + + { this is a member call, so A5 isn't modfied } + loada5:=false; + + { a class destructor needs a flag } + if pobjectdef(p^.methodpointer^.resulttype)^.is_class and + assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption=potype_destructor) then + begin + push_int(0); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + end; + + if not(is_con_or_destructor and + pobjectdef(p^.methodpointer^.resulttype)^.is_class and + assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor]) + ) then + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + { if an inherited con- or destructor should be } + { called in a con- or destructor then a warning } + { will be made } + { con- and destructors need a pointer to the vmt } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and + assigned(aktprocsym) then + begin + if not(aktprocsym^.definition^.proctypeoption in + [potype_constructor,potype_destructor]) then + CGMessage(cg_w_member_cd_call_from_method); + end; + { class destructors get there flag below } + if is_con_or_destructor and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and + assigned(aktprocsym) and + (aktprocsym^.definition^.proctypeoption=potype_destructor)) then + push_int(0); + end; + hnewn : begin + { extended syntax of new } + { A5 must be zero } + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,0,R_A5))); + emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH); + { insert the vmt } + exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L, + newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); + extended_new:=true; + end; + hdisposen : begin + secondpass(p^.methodpointer); + + { destructor with extended syntax called from dispose } + { hdisposen always deliver LOC_REFRENZ } + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_A5))); + del_reference(p^.methodpointer^.location.reference); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L, + newcsymbol(pobjectdef + (p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); + end; + else + begin + { call to a instance member } + if (p^.symtable^.symtabletype<>withsymtable) then + begin + secondpass(p^.methodpointer); + + + case p^.methodpointer^.location.loc of + LOC_REGISTER : + begin + ungetregister32(p^.methodpointer^.location.register); + emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5); + end; + else + begin + if (p^.methodpointer^.resulttype^.deftype=objectdef) and + pobjectdef(p^.methodpointer^.resulttype)^.is_class then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.methodpointer^.location.reference),R_A5))) + else + Begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.methodpointer^.location.reference),R_A5))); + end; + + del_reference(p^.methodpointer^.location.reference); + end; + end; + end; + { when calling a class method, we have to load ESI with the VMT ! + But, not for a class method via self } + if not(po_containsself in p^.procdefinition^.procoptions) then + begin + if (po_classmethod in p^.procdefinition^.procoptions) and + not(p^.methodpointer^.resulttype^.deftype=classrefdef) then + begin + { class method needs current VMT } + new(r); + reset_reference(r^); + r^.base:=R_A5; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5))); + end; + { direct call to destructor: don't remove data! } + if (p^.procdefinition^.proctypeoption=potype_destructor) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + push_int(1); + + { direct call to class constructor, don't allocate memory } + if (p^.procdefinition^.proctypeoption=potype_constructor) and + (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + push_int(0) + else + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + if is_con_or_destructor then + begin + { classes don't get a VMT pointer pushed } + if (p^.methodpointer^.resulttype^.deftype=objectdef) and + not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then + begin + + if (p^.procdefinition^.proctypeoption=potype_constructor) then + begin + { it's no bad idea, to insert the VMT } + exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L, + newcsymbol(pobjectdef( + p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); + end + { destructors haven't to dispose the instance, if this is } + { a direct call } + else + push_int(0); + end; + end; + end; + end; + end; + end + else + begin + if (po_classmethod in p^.procdefinition^.procoptions) and + not( + assigned(aktprocsym) and + (po_classmethod in aktprocsym^.definition^.procoptions) + ) then + begin + { class method needs current VMT } + new(r); + reset_reference(r^); + r^.base:=R_A5; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_A5))); + end + else + begin + { member call, A5 isn't modified } + loada5:=false; + end; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH))); + { but a con- or destructor here would probably almost } + { always be placed wrong } + if is_con_or_destructor then + begin + CGMessage(cg_w_member_cd_call_from_method); + { not insert VMT pointer } { VMT-Zeiger nicht eintragen } + push_int(0); + end; + end; + end; + + { push base pointer ?} + if (lexlevel>=normal_function_level) and assigned(pprocdef(p^.procdefinition)^.parast) and + ((pprocdef(p^.procdefinition)^.parast^.symtablelevel)>normal_function_level) then + begin + { if we call a nested function in a method, we must } + { push also SELF! } + { THAT'S NOT TRUE, we have to load ESI via frame pointer } + { access } + { + begin + loadesi:=false; + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ESI))); + end; + } + if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + new(r); + reset_reference(r^); + r^.offset:=procinfo^.framepointer_offset; + r^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH))) + end + { this is only true if the difference is one !! + but it cannot be more !! } + else if lexlevel=(pprocdef(p^.procdefinition)^.parast^.symtablelevel)-1 then + begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,procinfo^.framepointer,R_SPPUSH))) + end + else if lexlevel>(pprocdef(p^.procdefinition)^.parast^.symtablelevel) then + begin + hregister:=getaddressreg; + new(r); + reset_reference(r^); + r^.offset:=procinfo^.framepointer_offset; + r^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,hregister))); + for i:=(pprocdef(p^.procdefinition)^.parast^.symtablelevel) to lexlevel-1 do + begin + new(r); + reset_reference(r^); + {we should get the correct frame_pointer_offset at each level + how can we do this !!! } + r^.offset:=procinfo^.framepointer_offset; + r^.base:=hregister; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,hregister))); + end; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH))); + ungetregister32(hregister); + end + else + internalerror(25000); + end; + + if (po_virtualmethod in p^.procdefinition^.procoptions) and + not(no_virtual_call) then + begin + { static functions contain the vmt_address in ESI } + { also class methods } + if assigned(aktprocsym) then + begin + if (((sp_static in aktprocsym^.symoptions) or + (po_classmethod in aktprocsym^.definition^.procoptions)) and + ((p^.methodpointer=nil) or (p^.methodpointer^.treetype=typen))) + or + (po_staticmethod in p^.procdefinition^.procoptions) or + (p^.procdefinition^.proctypeoption=potype_constructor) or + { A5 is loaded earlier } + (po_classmethod in p^.procdefinition^.procoptions) then + begin + new(r); + reset_reference(r^); + r^.base:=R_a5; + end + else + begin + new(r); + reset_reference(r^); + r^.base:=R_a5; + r^.offset:= pprocdef(p^.procdefinition)^._class^.vmt_offset; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_a0))); + new(r); + reset_reference(r^); + r^.base:=R_a0; + end; + end + else + begin + new(r); + reset_reference(r^); + r^.base:=R_a5; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,R_a0))); + new(r); + reset_reference(r^); + r^.base:=R_a0; + end; + if pprocdef(p^.procdefinition)^.extnumber=-1 then + internalerror(1609991); + r^.offset:=pprocdef(p^.procdefinition)^.extnumber*4+12; + if (cs_check_range in aktlocalswitches) then + begin + { If the base is already A0, the no instruction will } + { be emitted! } + emit_reg_reg(A_MOVE,S_L,r^.base,R_A0); + emitcall('FPC_CHECK_OBJECT',true); + end; + { This was wrong we must then load the address into the } + { register a0 and/or a5 } + { Because doing an indirect call with offset is NOT } + { allowed on the m68k! } + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(r^),R_A0))); + { clear the reference } + reset_reference(r^); + r^.base := R_A0; + exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,r))); + end + else if pocall_palmossyscall in p^.procdefinition^.proccalloptions then + begin + exprasmlist^.concat(new(paicpu,op_const(A_TRAP,S_NO,15))); + exprasmlist^.concat(new(pai_const,init_16bit(pprocdef(p^.procdefinition)^.extnumber))); + end + else + emitcall(pprocdef(p^.procdefinition)^.mangledname, + (p^.symtableproc^.symtabletype=unitsymtable) or + ((p^.symtableproc^.symtabletype=objectsymtable) and + (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))or + ((p^.symtableproc^.symtabletype=withsymtable) and + (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))); + if (pocall_clearstack in p^.procdefinition^.proccalloptions) then + begin + if (pushedparasize > 0) and (pushedparasize < 9) then + { restore the stack, to its initial value } + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP))) + else + { restore the stack, to its initial value } + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP))); + end; + end + else + begin + secondpass(p^.right); + case p^.right^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + if p^.right^.location.register in [R_D0..R_D7] then + begin + reg := getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg); + new(ref); + reset_reference(ref^); + ref^.base := reg; + exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref))); + ungetregister(reg); + end + else + begin + new(ref); + reset_reference(ref^); + ref^.base := p^.right^.location.register; + exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref))); + end; + ungetregister32(p^.right^.location.register); + end + else + begin + if assigned(p^.right^.location.reference.symbol) then + { Here we have a symbolic name to the routine, so solve } + { problem by loading the address first, and then emitting } + { the call. } + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.right^.location.reference),R_A1))); + new(ref); + reset_reference(ref^); + ref^.base := R_A1; + exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref))); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.right^.location.reference),R_A1))); + new(ref); + reset_reference(ref^); + ref^.base := R_A1; + exprasmlist^.concat(new(paicpu,op_ref(A_JSR,S_NO,ref))); + end; + del_reference(p^.right^.location.reference); + end; + end; + end; + dont_call: + pushedparasize:=oldpushedparasize; + unused:=unusedregisters; + + { handle function results } + if p^.resulttype<>pdef(voiddef) then + begin + + { a contructor could be a function with boolean result } + if (p^.right=nil) and + (p^.procdefinition^.proctypeoption=potype_constructor) and + { quick'n'dirty check if it is a class or an object } + (p^.resulttype^.deftype=orddef) then + begin + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_NE; + if extended_new then + begin +{$ifdef test_dest_loc} + if dest_loc_known and (dest_loc_tree=p) then + mov_reg_to_dest(p,S_L,R_EAX) + else +{$endif test_dest_loc} + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.register:=hregister; + end; + end + { structed results are easy to handle.... } + else if ret_in_param(p^.resulttype) then + begin + p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=funcretref; + end + else + begin + if (p^.resulttype^.deftype in [orddef,enumdef]) then + begin + p^.location.loc:=LOC_REGISTER; + case p^.resulttype^.size of + 4 : + begin + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.register:=hregister; + end; + 1 : + begin + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_B,R_D0,hregister); + p^.location.register:=hregister; + end; + 2: + begin + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.register:=hregister; + end; + else internalerror(7); + end + end + else if (p^.resulttype^.deftype=floatdef) then + case pfloatdef(p^.resulttype)^.typ of + f32bit : + begin + p^.location.loc:=LOC_REGISTER; + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.register:=hregister; + end; + s32real : Begin + p^.location.loc:=LOC_FPU; + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.fpureg:=hregister; + end; + s64comp,s64real,s80real: begin + if cs_fp_emulation in aktmoduleswitches then + begin + p^.location.loc:=LOC_FPU; + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.fpureg:=hregister; + end + else + begin + { TRUE FPU mode } + p^.location.loc:=LOC_FPU; + { on exit of function result in R_FP0 } + p^.location.fpureg:=R_FP0; + end; + end; + else + begin + p^.location.loc:=LOC_FPU; + p^.location.fpureg:=R_FP0; + end; + end {end case } + else + begin + p^.location.loc:=LOC_REGISTER; + hregister:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_D0,hregister); + p^.location.register:=hregister; + end; + end; + end; + { perhaps i/o check ? } + if iolabel<>nil then + begin + exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,newcsymbol(iolabel^.name,0)))); + emitcall('FPC_IOCHECK',true); + end; + + { restore registers } + popusedregisters(pushed); + + { at last, restore instance pointer (SELF) } + if loada5 then + maybe_loada5; + pp:=params; + while assigned(pp) do + begin + if assigned(pp^.left) then + if (pp^.left^.location.loc=LOC_REFERENCE) or + (pp^.left^.location.loc=LOC_MEM) then + ungetiftemp(pp^.left^.location.reference); + pp:=pp^.right; + end; + disposetree(params); + end; + + +{***************************************************************************** + SecondProcInlineN +*****************************************************************************} + + procedure secondprocinline(var p : ptree); + begin + InternalError(132421); + end; + + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.25 2000/03/01 00:04:31 pierre + Use $GOTO ON + + Revision 1.24 2000/02/09 13:22:48 peter + * log truncated + + Revision 1.23 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.22 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.21 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.20 1999/09/27 23:44:48 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.19 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.18 1999/09/16 11:34:52 pierre + * typo correction + +} diff --git a/befpc/compiler/cg68kcnv.pas b/befpc/compiler/cg68kcnv.pas new file mode 100644 index 0000000..53cedae --- /dev/null +++ b/befpc/compiler/cg68kcnv.pas @@ -0,0 +1,1381 @@ +{ + $Id: cg68kcnv.pas,v 1.1.1.1 2001-07-23 17:15:40 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for type converting nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$E+,F+,N+} +{$endif} +unit cg68kcnv; +interface + + uses + tree; + + procedure secondtypeconv(var p : ptree); + procedure secondas(var p : ptree); + procedure secondis(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k; + +{***************************************************************************** + SecondTypeConv +*****************************************************************************} + + procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); + + var + hp : preference; + hregister : tregister; + neglabel,poslabel : pasmlabel; + + begin + { convert from p2 to p1 } + { range check from enums is not made yet !!} + { and its probably not easy } + if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then + exit; + { range checking is different for u32bit } + { lets try to generate it allways } + if (cs_check_range in aktlocalswitches) and + { with $R+ explicit type conversations in TP aren't range checked! } + (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and + ((porddef(p1)^.low>porddef(p2)^.low) or + (porddef(p1)^.highporddef(p1)^.high then + begin + getlabel(neglabel); + getlabel(poslabel); + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,hregister))); + emitl(A_BLT,neglabel); + end; + emit_bounds_check(hp^,hregister); + if porddef(p1)^.low>porddef(p1)^.high then + begin + new(hp); + reset_reference(hp^); + hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1)); + emitl(A_JMP,poslabel); + emitl(A_LABEL,neglabel); + emit_bounds_check(hp^,hregister); + emitl(A_LABEL,poslabel); + end; + end; + end; + + + type + tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype); + + procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype); + + begin + maybe_rangechecking(p,hp^.resulttype,p^.resulttype); + end; + + + procedure second_smaller(p,hp : ptree;convtyp : tconverttype); + + var + hregister,destregister : tregister; + {opsize : topsize;} + ref : boolean; + hpp : preference; + + begin + { !!!!!!!! Rangechecking } + ref:=false; + { problems with enums !! } + { with $R+ explicit type conversations in TP aren't range checked! } + if (p^.resulttype^.deftype=orddef) and + (hp^.resulttype^.deftype=orddef) and + ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or + (porddef(p^.resulttype)^.highLOC_CREGISTER) then + begin + del_reference(p^.left^.location.reference); + { we can do this here as we need no temp inside second_bigger } + ungetiftemp(p^.left^.location.reference); + end; + { this is wrong !!! + gives me movl (%eax),%eax + for the length(string !!! + use only for constant values } + {Constanst cannot be loaded into registers using MOVZX!} + if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then + case convtyp of + tc_int_2_int: + begin + if is_register then + hregister := p^.left^.location.register + else + hregister := getregister32; + if is_register then + emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister) + else + begin + if p^.left^.location.loc = LOC_CREGISTER then + emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister) + else + exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B, + newreference(P^.left^.location.reference), hregister))); + end; + case convtyp of + tc_u8bit_2_s32bit, + tc_u8bit_2_u32bit: + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND,S_L,$FF,hregister))); + tc_s8bit_2_u32bit, + tc_s8bit_2_s32bit: + begin + if aktoptprocessor = MC68020 then + exprasmlist^.concat(new(paicpu,op_reg + (A_EXTB,S_L,hregister))) + else { else if aktoptprocessor } + begin + { byte to word } + exprasmlist^.concat(new(paicpu,op_reg + (A_EXT,S_W,hregister))); + { word to long } + exprasmlist^.concat(new(paicpu,op_reg + (A_EXT,S_L,hregister))); + end; + end; + tc_s8bit_2_u16bit, + tc_u8bit_2_s16bit, + tc_u8bit_2_u16bit: + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND,S_W,$FF,hregister))); + + tc_s8bit_2_s16bit: + exprasmlist^.concat(new(paicpu, op_reg( + A_EXT, S_W, hregister))); + + end; { inner case } + end; + tc_u16bit_2_u32bit, + tc_u16bit_2_s32bit, + tc_s16bit_2_u32bit, + tc_s16bit_2_s32bit: begin + if is_register then + hregister := p^.left^.location.register + else + hregister := getregister32; + if is_register then + emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister) + else + begin + if p^.left^.location.loc = LOC_CREGISTER then + emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister) + else + exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_W, + newreference(P^.left^.location.reference), hregister))); + end; + if (convtyp = tc_u16bit_2_s32bit) or + (convtyp = tc_u16bit_2_u32bit) then + exprasmlist^.concat(new(paicpu, op_const_reg( + A_AND, S_L, $ffff, hregister))) + else { tc_s16bit_2_s32bit } + { tc_s16bit_2_u32bit } + exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L, + hregister))); + end; + end { end case } + else + begin + case convtyp of + tc_u8bit_2_s32bit, + tc_s8bit_2_s32bit, + tc_u16bit_2_s32bit, + tc_s16bit_2_s32bit, + tc_u8bit_2_u32bit, + tc_s8bit_2_u32bit, + tc_u16bit_2_u32bit, + tc_s16bit_2_u32bit: + + begin + hregister:=getregister32; + op:=A_MOVE; + opsize:=S_L; + end; + tc_s8bit_2_u16bit, + tc_s8bit_2_s16bit, + tc_u8bit_2_s16bit, + tc_u8bit_2_u16bit: + begin + hregister:=getregister32; + op:=A_MOVE; + opsize:=S_W; + end; + end; + if is_register then + begin + emit_reg_reg(op,opsize,p^.left^.location.register,hregister); + end + else + begin + if p^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(op,opsize,p^.left^.location.register,hregister) + else exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize, + newreference(p^.left^.location.reference),hregister))); + end; + end; { end elseif } + + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype); +{$endif dummy} + end; + + + procedure second_string_string(p,hp : ptree;convtyp : tconverttype); + + var + pushed : tpushed; + + begin + { does anybody know a better solution than this big case statement ? } + { ok, a proc table would do the job } + case pstringdef(p)^.string_typ of + + st_shortstring: + case pstringdef(p^.left)^.string_typ of + st_shortstring: + begin + stringdispose(p^.location.reference.symbol); + gettempofsizereference(p^.resulttype^.size,p^.location.reference); + del_reference(p^.left^.location.reference); + copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len); + ungetiftemp(p^.left^.location.reference); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_longstring: + case pstringdef(p^.left)^.string_typ of + st_shortstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_ansistring: + case pstringdef(p^.left)^.string_typ of + st_shortstring: + begin + pushusedregisters(pushed,$ff); + push_int(p^.resulttype^.size-1); + gettempofsizereference(p^.resulttype^.size,p^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.location.reference); + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + { !!!!! exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register))); } + ungetregister32(p^.left^.location.register); + end; + LOC_REFERENCE,LOC_MEM: + begin + emit_push_mem(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + end; + end; + emitcall('FPC_ANSI_TO_SHORTSTRING',true); + maybe_loada5; + popusedregisters(pushed); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + + st_widestring: + case pstringdef(p^.left)^.string_typ of + st_shortstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_ansistring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + {!!!!!!!} + internalerror(8888); + end; + end; + end; + end; + + procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype); + + begin + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + inc(p^.left^.location.reference.offset); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), + R_A0))); + emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register); + end; + + procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype); + + begin + inc(p^.location.reference.offset); + end; + + procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype); + + begin + del_reference(p^.left^.location.reference); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), + R_A0))); + emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register); + end; + + procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype); + var + reg: tregister; + begin + clear_location(p^.location); + p^.location.loc:=LOC_REFERENCE; + clear_reference(p^.location.reference); + { here, after doing some arithmetic on the pointer } + { we put it back in an address register } + if p^.left^.location.loc=LOC_REGISTER then + begin + reg := getaddressreg; + { move the pointer in a data register back into } + { an address register. } + emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg); + + p^.location.reference.base:=reg; + ungetregister32(p^.left^.location.register); + end + else + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.reference.base:=getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, + p^.location.reference.base); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.reference.base:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), + p^.location.reference.base))); + end; + end; + end; + + { generates the code for the type conversion from an array of char } + { to a string } + procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype); + + var + l : longint; + + begin + { this is a type conversion which copies the data, so we can't } + { return a reference } + clear_location(p^.location); + p^.location.loc:=LOC_MEM; + + { first get the memory for the string } + stringdispose(p^.location.reference.symbol); + gettempofsizereference(256,p^.location.reference); + + { calc the length of the array } + l:=parraydef(p^.left^.resulttype)^.highrange- + parraydef(p^.left^.resulttype)^.lowrange+1; + + if l>255 then + CGMessage(type_e_mismatch); + + { write the length } + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,l, + newreference(p^.location.reference)))); + + { copy to first char of string } + inc(p^.location.reference.offset); + + { generates the copy code } + { and we need the source never } + concatcopy(p^.left^.location.reference,p^.location.reference,l,true); + + { correct the string location } + dec(p^.location.reference.offset); + end; + + procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype); + + begin + stringdispose(p^.location.reference.symbol); + gettempofsizereference(256,p^.location.reference); + { call loadstring with correct left and right } + p^.right:=p^.left; + p^.left:=p; + loadstring(p); + p^.left:=nil; { reset left tree, which is empty } + { p^.right is not disposed for typeconv !! PM } + disposetree(p^.right); + p^.right:=nil; + end; + + procedure second_int_real(p,hp : ptree;convtyp : tconverttype); + + var + r : preference; + + begin + emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true); + ungetiftemp(p^.left^.location.reference); + if porddef(p^.left^.resulttype)^.typ=u32bit then + push_int(0); + + emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH); + new(r); + reset_reference(r^); + r^.base := R_SP; + { no emulation } +{ for u32bit a solution would be to push $0 and to load a ++ comp ++ if porddef(p^.left^.resulttype)^.typ=u32bit then ++ exprasmlist^.concat(new(paicpu,op_ref(A_FILD,S_IQ,r))) ++ else} + clear_location(p^.location); + p^.location.loc := LOC_FPU; + { get floating point register. } + if (cs_fp_emulation in aktmoduleswitches) then + begin + p^.location.fpureg := getregister32; + exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE, S_L, r, R_D0))); + emitcall('FPC_LONG2SINGLE',true); + emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg); + end + else + begin + p^.location.fpureg := getfloatreg; + exprasmlist^.concat(new(paicpu, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg))) + end; + if porddef(p^.left^.resulttype)^.typ=u32bit then + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,8,R_SP))) + else + { restore the stack to the previous address } + exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L, 4, R_SP))); + end; + + procedure second_real_fix(p,hp : ptree;convtyp : tconverttype); + var + rreg : tregister; + ref : treference; + begin + rreg:=getregister32; + { Are we in a LOC_FPU, if not then use scratch registers } + { instead of allocating reserved registers. } + if (p^.left^.location.loc<>LOC_FPU) then + begin + if (cs_fp_emulation in aktmoduleswitches) then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1))); + emitcall('FPC_LONGMUL',true); + emit_reg_reg(A_MOVE,S_L,R_D0,rreg); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,R_FP0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg))); + end; + end + else + begin + if (cs_fp_emulation in aktmoduleswitches) then + begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1))); + emitcall('FPC_LONGMUL',true); + emit_reg_reg(A_MOVE,S_L,R_D0,rreg); + end + else + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg))); + end; + end; + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=rreg; + end; + + + procedure second_float_float(p,hp : ptree;convtyp : tconverttype); + + begin + case p^.left^.location.loc of + LOC_FPU : begin + { reload } + clear_location(p^.location); + p^.location.loc := LOC_FPU; + p^.location.fpureg := p^.left^.location.fpureg; + end; + LOC_MEM, + LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ, + p^.left^.location.reference,p^.location); + end; +{ ALREADY HANDLED BY FLOATLOAD } +{ p^.location.loc:=LOC_FPU; } + end; + + procedure second_fix_real(p,hp : ptree;convtyp : tconverttype); + var + startreg : tregister; + hl : pasmlabel; + r : treference; + reg1: tregister; + hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: pasmlabel; + begin + if (p^.left^.location.loc=LOC_REGISTER) or + (p^.left^.location.loc=LOC_CREGISTER) then + begin + startreg:=p^.left^.location.register; + ungetregister(startreg); + { move d0,d0 is removed by emit_reg_reg } + emit_reg_reg(A_MOVE,S_L,startreg,R_D0); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference( + p^.left^.location.reference),R_D0))); + del_reference(p^.left^.location.reference); + startreg:=R_NO; + end; + + reg1 := getregister32; + + { Motorola 68000 equivalent of CDQ } + { we choose d1:d0 pair for quad word } + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,R_D0))); + getlabel(hl1); + emitl(A_BPL,hl1); + { we copy all bits (-ve number) } + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1))); + getlabel(hl2); + emitl(A_BRA,hl2); + emitl(A_LABEL,hl1); + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_D0))); + emitl(A_LABEL,hl2); + { end CDQ } + + exprasmlist^.concat(new(paicpu,op_reg_reg(A_EOR,S_L,R_D1,R_D0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,reg1))); + getlabel(hl3); + emitl(A_BEQ,hl3); + + { Motorola 68000 equivalent of RCL } + getlabel(hl4); + emitl(A_BCC,hl4); + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_L,1,reg1))); + getlabel(hl5); + emitl(A_BRA,hl5); + emitl(A_LABEL,hl4); + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1))); + emitl(A_LABEL,hl5); + { end RCL } + + { Motorola 68000 equivalent of BSR } + { save register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_D6))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,31,R_D0))); + getlabel(hl6); + emitl(A_LABEL,hl6); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_BTST,S_L,R_D0,R_D1))); + getlabel(hl7); + emitl(A_BNE,hl7); + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D0))); + emitl(A_BPL,hl6); + { restore register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D6,R_D0))); + emitl(A_LABEL,hl7); + { end BSR } + + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,32,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_B,R_D1,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D6,R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_W,1007,R_D1))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,5,R_D1))); + + { Motorola 68000 equivalent of SHLD } + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,11,R_D6))); + { save register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D1,R_A0))); + getlabel(hl8); + emitl(A_LABEL,hl8); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D1))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6))); + emitl(A_BNE,hl8); + { restore register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D1))); + { end Motorola equivalent of SHLD } + + { Motorola 68000 equivalent of SHLD } + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,20,R_D6))); + { save register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_A0))); + getlabel(hl9); + emitl(A_LABEL,hl9); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6))); + emitl(A_BNE,hl9); + { restore register } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D0))); + { end Motorola equivalent of SHLD } + + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,20,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_L,R_D6,R_D0))); + emitl(A_LABEL, hl3); + + { create temp values and put on stack } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH))); + + + reset_reference(r); + r.base:=R_SP; + + if (cs_fp_emulation in aktmoduleswitches) then + begin + clear_location(p^.location); + p^.location.loc:=LOC_FPU; + p^.location.fpureg := getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(r), + p^.left^.location.fpureg))) + end + else + begin + clear_location(p^.location); + p^.location.loc:=LOC_FPU; + p^.location.fpureg := getfloatreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(r), + p^.left^.location.fpureg))) + end; + { clear temporary space } + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDQ,S_L,8,R_SP))); + ungetregister32(reg1); +{ Alreadu handled above... } +{ p^.location.loc:=LOC_FPU; } + end; + + procedure second_int_fix(p,hp : ptree;convtyp : tconverttype); + + var + {hs : string;} + hregister : tregister; + + begin + if (p^.left^.location.loc=LOC_REGISTER) then + hregister:=p^.left^.location.register + else if (p^.left^.location.loc=LOC_CREGISTER) then + hregister:=getregister32 + else + begin + del_reference(p^.left^.location.reference); + hregister:=getregister32; + case porddef(p^.left^.resulttype)^.typ of + s8bit : begin + exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B, + newreference(p^.left^.location.reference),hregister))); + if aktoptprocessor = MC68020 then + exprasmlist^.concat(new(paicpu, op_reg(A_EXTB,S_L,hregister))) + else + begin + exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_W,hregister))); + exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L,hregister))); + end; + end; + u8bit : begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference), + hregister))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hregister))); + end; + s16bit :begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference), + hregister))); + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,hregister))); + end; + u16bit : begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference), + hregister))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hregister))); + end; + s32bit,u32bit : exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), + hregister))); + {!!!! u32bit } + end; + end; + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ,S_L,16,R_D1))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D1,hregister))); + + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister; + end; + + + procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype); + + begin + { secondpass(hp); already done in secondtypeconv PM } + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + del_reference(hp^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(hp^.location.reference),R_A0))); + + emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register); + end; + + procedure second_bool_to_int(p,hp : ptree;convtyp : tconverttype); + + var + oldtruelabel,oldfalselabel,hlabel : pasmlabel; + hregister : tregister; + newsize, + opsize : topsize; + op : tasmop; + begin + oldtruelabel:=truelabel; + oldfalselabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(hp); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + del_reference(hp^.location.reference); + hregister:=getregister32; + case porddef(hp^.resulttype)^.typ of + bool8bit : begin + case porddef(p^.resulttype)^.typ of + u8bit,s8bit, + bool8bit : opsize:=S_B; + u16bit,s16bit, + bool16bit : opsize:=S_BW; + u32bit,s32bit, + bool32bit : opsize:=S_BL; + end; + end; + bool16bit : begin + case porddef(p^.resulttype)^.typ of + u8bit,s8bit, + bool8bit : opsize:=S_B; + u16bit,s16bit, + bool16bit : opsize:=S_W; + u32bit,s32bit, + bool32bit : opsize:=S_WL; + end; + end; + bool32bit : begin + case porddef(p^.resulttype)^.typ of + u8bit,s8bit, + bool8bit : opsize:=S_B; + u16bit,s16bit, + bool16bit : opsize:=S_W; + u32bit,s32bit, + bool32bit : opsize:=S_L; + end; + end; + end; + op:=A_MOVE; +{ if opsize in [S_B,S_W,S_L] then + op:=A_MOVE + else + if (porddef(p^.resulttype)^.typ in [s8bit,s16bit,s32bit]) then + op:=A_MOVSX + else + op:=A_MOVZX; } + case porddef(p^.resulttype)^.typ of + bool8bit,u8bit,s8bit : begin + p^.location.register:=hregister; + newsize:=S_B; + end; + bool16bit,u16bit,s16bit : begin + p^.location.register:=hregister; + newsize:=S_W; + end; + bool32bit,u32bit,s32bit : begin + p^.location.register:=hregister; + newsize:=S_L; + end; + else + internalerror(10060); + end; + + case hp^.location.loc of + LOC_MEM, + LOC_REFERENCE : exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize, + newreference(hp^.location.reference),p^.location.register))); + LOC_REGISTER, + LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize, + hp^.location.register,p^.location.register))); + LOC_FLAGS : begin +{ hregister:=reg32toreg8(hregister); } + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister))); +{ !!!!!!!! + case porddef(p^.resulttype)^.typ of + bool16bit, + u16bit,s16bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register))); + bool32bit, + u32bit,s32bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register))); + end; } + end; + LOC_JUMP : begin + getlabel(hlabel); + emitl(A_LABEL,truelabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,newsize,1,hregister))); + emitl(A_JMP,hlabel); + emitl(A_LABEL,falselabel); + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,newsize,hregister))); + emitl(A_LABEL,hlabel); + end; + else + internalerror(10061); + end; + truelabel:=oldtruelabel; + falselabel:=oldfalselabel; + end; + + + procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype); + var + hregister : tregister; + begin + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + del_reference(hp^.location.reference); + case hp^.location.loc of + LOC_MEM,LOC_REFERENCE : + begin + hregister:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(hp^.location.reference),hregister))); + end; + LOC_REGISTER,LOC_CREGISTER : + begin + hregister:=hp^.location.register; + end; + else + internalerror(10062); + end; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_OR,S_L,hregister,hregister))); +{ hregister:=reg32toreg8(hregister); } + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister))); + case porddef(p^.resulttype)^.typ of + bool8bit : p^.location.register:=hregister; +{ !!!!!!!!!!! + + bool16bit : begin + p^.location.register:=reg8toreg16(hregister); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register))); + end; + bool32bit : begin + p^.location.register:=reg16toreg32(hregister); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register))); + end; } + else + internalerror(10064); + end; + end; + + procedure second_load_smallset(p,hp : ptree;convtyp : tconverttype); + var + href : treference; + pushedregs : tpushed; + begin + href.symbol:=nil; + pushusedregisters(pushedregs,$ff); + gettempofsizereference(32,href); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + emitpushreferenceaddr(exprasmlist,href); + emitcall('FPC_SET_LOAD_SMALL',true); + maybe_loada5; + popusedregisters(pushedregs); + clear_location(p^.location); + p^.location.loc:=LOC_MEM; + stringdispose(p^.location.reference.symbol); + p^.location.reference:=href; + end; + + procedure second_ansistring_to_pchar(p,hp : ptree;convtyp : tconverttype); + + var + l1,l2 : pasmlabel; + hr : preference; + + begin + InternalError(342132); +{!!!!!!!!!!! + + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + getlabel(l1); + getlabel(l2); + case hp^.location.loc of + LOC_CREGISTER,LOC_REGISTER: + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_L,0, + hp^.location.register))); + LOC_MEM,LOC_REFERENCE: + begin + exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_L,0, + newreference(hp^.location.reference)))); + del_reference(hp^.location.reference); + p^.location.register:=getregister32; + end; + end; + emitl(A_JZ,l1); + if hp^.location.loc in [LOC_MEM,LOC_REFERENCE] then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,newreference( + hp^.location.reference), + p^.location.register))); + emitl(A_JMP,l2); + emitl(A_LABEL,l1); + new(hr); + reset_reference(hr^); + hr^.symbol:=stringdup('FPC_EMPTYCHAR'); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,hr, + p^.location.register))); + emitl(A_LABEL,l2); } + end; + + procedure second_pchar_to_string(p,hp : ptree;convtyp : tconverttype); + begin + internalerror(12121); + end; + + procedure second_nothing(p,hp : ptree;convtyp : tconverttype); + begin + end; + +{**************************************************************************** + SecondTypeConv +****************************************************************************} + + procedure secondtypeconv(var p : ptree); + const + secondconvert : array[tconverttype] of + tsecondconvproc = (second_nothing,second_nothing, + second_bigger,second_only_rangecheck, + second_bigger,second_bigger,second_bigger, + second_smaller,second_smaller, + second_smaller,second_string_string, + second_cstring_charpointer,second_string_chararray, + second_array_to_pointer,second_pointer_to_array, + second_char_to_string,second_bigger, + second_bigger,second_bigger, + second_smaller,second_smaller, + second_smaller,second_smaller, + second_bigger); + +{$ifdef dummy} + ,second_smaller, + second_only_rangecheck,second_bigger, + second_bigger,second_bigger, + second_bigger,second_only_rangecheck, + second_smaller,second_smaller, + second_smaller,second_smaller, + second_bool_to_int,second_int_to_bool, + second_int_real,second_real_fix, + second_fix_real,second_int_fix,second_float_float, + second_chararray_to_string, + second_proc_to_procvar, + { is constant char to pchar, is done by firstpass } + second_nothing, + second_load_smallset, + second_ansistring_to_pchar, + second_pchar_to_string, + second_nothing); +{$endif dummy} + + begin + { this isn't good coding, I think tc_bool_2_int, shouldn't be } + { type conversion (FK) } + + { this is necessary, because second_bool_byte, have to change } + { true- and false label before calling secondpass } + if p^.convtyp<>tc_bool_2_int then + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + if codegenerror then + exit; + end; + + if not(p^.convtyp in [tc_equal,tc_not_possible]) then + {the second argument only is for maybe_range_checking !} + secondconvert[p^.convtyp](p,p^.left,p^.convtyp) + end; + + +{***************************************************************************** + SecondIs +*****************************************************************************} + + procedure secondis(var p : ptree); + + var + pushed : tpushed; + + begin + { save all used registers } + pushusedregisters(pushed,$ffff); + secondpass(p^.left); + clear_location(p^.location); + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_NE; + + { push instance to check: } + case p^.left^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE, + S_L,p^.left^.location.register,R_SPPUSH))); + ungetregister32(p^.left^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE, + S_L,newreference(p^.left^.location.reference),R_SPPUSH))); + del_reference(p^.left^.location.reference); + end; + else internalerror(100); + end; + + { generate type checking } + secondpass(p^.right); + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE, + S_L,p^.right^.location.register,R_SPPUSH))); + ungetregister32(p^.right^.location.register); + end; + LOC_MEM,LOC_REFERENCE: + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE, + S_L,newreference(p^.right^.location.reference),R_SPPUSH))); + del_reference(p^.right^.location.reference); + end; + else internalerror(100); + end; + emitcall('FPC_DO_IS',true); + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_B,R_D0))); + popusedregisters(pushed); + end; + + +{***************************************************************************** + SecondAs +*****************************************************************************} + + procedure secondas(var p : ptree); + + var + pushed : tpushed; + + begin + set_location(p^.location,p^.left^.location); + { save all used registers } + pushusedregisters(pushed,$ffff); + { push the vmt of the class } + exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE, + S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH))); + emitpushreferenceaddr(exprasmlist,p^.location.reference); + emitcall('FPC_DO_AS',true); + popusedregisters(pushed); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.17 2000/02/09 13:22:48 peter + * log truncated + + Revision 1.16 2000/01/07 01:14:21 peter + * updated copyright to 2000 + + Revision 1.15 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.14 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.13 1999/08/25 11:59:48 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/cg68kcon.pas b/befpc/compiler/cg68kcon.pas new file mode 100644 index 0000000..f2f2510 --- /dev/null +++ b/befpc/compiler/cg68kcon.pas @@ -0,0 +1,389 @@ +{ + $Id: cg68kcon.pas,v 1.1.1.1 2001-07-23 17:15:41 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kcon; +interface + + uses + tree; + +{.$define SMALLSETORD} + + + procedure secondrealconst(var p : ptree); + procedure secondfixconst(var p : ptree); + procedure secondordconst(var p : ptree); + procedure secondstringconst(var p : ptree); + procedure secondsetconst(var p : ptree); + procedure secondniln(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k,symconst; + +{***************************************************************************** + SecondRealConst +*****************************************************************************} + + procedure secondrealconst(var p : ptree); + const + floattype2ait:array[tfloattype] of tait= + (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_none,ait_none); + var + hp1 : pai; + lastlabel : pasmlabel; + realait : tait; + begin + lastlabel:=nil; + realait:=floattype2ait[pfloatdef(p^.resulttype)^.typ]; + { const already used ? } + if not assigned(p^.lab_real) then + begin + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + if (hp1^.typ=realait) and (lastlabel<>nil) then + begin + if( + ((realait=ait_real_32bit) and (pai_real_32bit(hp1)^.value=p^.value_real)) or + ((realait=ait_real_64bit) and (pai_real_64bit(hp1)^.value=p^.value_real)) or + ((realait=ait_real_80bit) and (pai_real_80bit(hp1)^.value=p^.value_real)) or + ((realait=ait_comp_64bit) and (pai_comp_64bit(hp1)^.value=p^.value_real)) + ) then + begin + { found! } + p^.lab_real:=lastlabel; + break; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_real) then + begin + getdatalabel(lastlabel); + p^.lab_real:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + case realait of + ait_real_64bit : consts^.concat(new(pai_real_32bit,init(p^.value_real))); + ait_real_32bit : consts^.concat(new(pai_real_32bit,init(p^.value_real))); + ait_real_80bit : consts^.concat(new(pai_real_32bit,init(p^.value_real))); + else + internalerror(10120); + end; + end; + end; + clear_reference(p^.location.reference); + p^.location.reference.symbol:=stringdup(p^.lab_real^.name); + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + SecondFixConst +*****************************************************************************} + + procedure secondfixconst(var p : ptree); + begin + { an fix comma const. behaves as a memory reference } + p^.location.loc:=LOC_MEM; + p^.location.reference.isintvalue:=true; + p^.location.reference.offset:=p^.value_fix; + end; + + +{***************************************************************************** + SecondOrdConst +*****************************************************************************} + + procedure secondordconst(var p : ptree); + begin + { an integer const. behaves as a memory reference } + p^.location.loc:=LOC_MEM; + p^.location.reference.isintvalue:=true; + p^.location.reference.offset:=p^.value; + end; + + +{***************************************************************************** + SecondStringConst +*****************************************************************************} + + procedure secondstringconst(var p : ptree); + var + hp1 : pai; + l1,l2, + lastlabel : pasmlabel; + pc : pchar; + same_string : boolean; + i,mylength : longint; + begin + lastlabel:=nil; + { const already used ? } + if not assigned(p^.lab_str) then + begin + if is_shortstring(p^.resulttype) then + mylength:=p^.length+2 + else + mylength:=p^.length+1; + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + { when changing that code, be careful that } + { you don't use typed consts, which are } + { are also written to consts } + { currently, this is no problem, because } + { typed consts have no leading length or } + { they have no trailing zero } + if (hp1^.typ=ait_string) and (lastlabel<>nil) and + (pai_string(hp1)^.len=mylength) then + begin + same_string:=true; + for i:=0 to p^.length do + if pai_string(hp1)^.str[i]<>p^.value_str[i] then + begin + same_string:=false; + break; + end; + if same_string then + begin + { found! } + p^.lab_str:=lastlabel; + break; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_str) then + begin + getdatalabel(lastlabel); + p^.lab_str:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + { generate an ansi string ? } + case p^.stringtype of + st_ansistring: + begin + { an empty ansi string is nil! } + if p^.length=0 then + consts^.concat(new(pai_const,init_32bit(0))) + else + begin + getdatalabel(l1); + getdatalabel(l2); + consts^.concat(new(pai_label,init(l2))); + consts^.concat(new(pai_const_symbol,init(l1))); + consts^.concat(new(pai_const,init_32bit(p^.length))); + consts^.concat(new(pai_const,init_32bit(p^.length))); + consts^.concat(new(pai_const,init_32bit(-1))); + consts^.concat(new(pai_label,init(l1))); + getmem(pc,p^.length+2); + move(p^.value_str^,pc^,p^.length); + pc[p^.length]:=#0; + { to overcome this problem we set the length explicitly } + { with the ending null char } + consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1))); + { return the offset of the real string } + p^.lab_str:=l2; + end; + end; + st_shortstring: + begin + { empty strings } + if p^.length=0 then + consts^.concat(new(pai_const,init_16bit(0))) + else + begin + { also length and terminating zero } + getmem(pc,p^.length+3); + move(p^.value_str^,pc[1],p^.length+1); + pc[0]:=chr(p^.length); + { to overcome this problem we set the length explicitly } + { with the ending null char } + pc[p^.length+1]:=#0; + consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+2))); + end; + end; + end; + end; + end; + clear_reference(p^.location.reference); + p^.location.reference.symbol:=stringdup(p^.lab_str^.name); + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + SecondSetCons +*****************************************************************************} + + procedure secondsetconst(var p : ptree); + var + hp1 : pai; + lastlabel : pasmlabel; + i : longint; + neededtyp : tait; + begin +{$ifdef SMALLSETORD} + { small sets are loaded as constants } + if psetdef(p^.resulttype)^.settype=smallset then + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.isintvalue:=true; + p^.location.reference.offset:=plongint(p^.value_set)^; + exit; + end; +{$endif} + if psetdef(p^.resulttype)^.settype=smallset then + neededtyp:=ait_const_32bit + else + neededtyp:=ait_const_8bit; + lastlabel:=nil; + { const already used ? } + if not assigned(p^.lab_set) then + begin + { tries to found an old entry } + hp1:=pai(consts^.first); + while assigned(hp1) do + begin + if hp1^.typ=ait_label then + lastlabel:=pai_label(hp1)^.l + else + begin + if (lastlabel<>nil) and (hp1^.typ=neededtyp) then + begin + if (hp1^.typ=ait_const_8bit) then + begin + { compare normal set } + i:=0; + while assigned(hp1) and (i<32) do + begin + if pai_const(hp1)^.value<>p^.value_set^[i] then + break; + inc(i); + hp1:=pai(hp1^.next); + end; + if i=32 then + begin + { found! } + p^.lab_set:=lastlabel; + break; + end; + { leave when the end of consts is reached, so no + hp1^.next is done } + if not assigned(hp1) then + break; + end + else + begin + { compare small set } + if plongint(p^.value_set)^=pai_const(hp1)^.value then + begin + { found! } + p^.lab_set:=lastlabel; + break; + end; + end; + end; + lastlabel:=nil; + end; + hp1:=pai(hp1^.next); + end; + { :-(, we must generate a new entry } + if not assigned(p^.lab_set) then + begin + getdatalabel(lastlabel); + p^.lab_set:=lastlabel; + if (cs_create_smart in aktmoduleswitches) then + consts^.concat(new(pai_cut,init)); + consts^.concat(new(pai_label,init(lastlabel))); + if psetdef(p^.resulttype)^.settype=smallset then + begin + move(p^.value_set^,i,sizeof(longint)); + consts^.concat(new(pai_const,init_32bit(i))); + end + else + begin + for i:=0 to 31 do + consts^.concat(new(pai_const,init_8bit(p^.value_set^[i]))); + end; + end; + end; + clear_reference(p^.location.reference); + p^.location.reference.symbol:=stringdup(p^.lab_set^.name); + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + SecondNilN +*****************************************************************************} + + procedure secondniln(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + p^.location.reference.isintvalue:=true; + p^.location.reference.offset:=0; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.8 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.7 1999/09/20 16:38:52 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.6 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} diff --git a/befpc/compiler/cg68kflw.pas b/befpc/compiler/cg68kflw.pas new file mode 100644 index 0000000..6fdff92 --- /dev/null +++ b/befpc/compiler/cg68kflw.pas @@ -0,0 +1,806 @@ +{ + $Id: cg68kflw.pas,v 1.1.1.1 2001-07-23 17:15:41 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for nodes that influence the flow + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +unit cg68kflw; +interface + + uses + tree; + + procedure second_while_repeatn(var p : ptree); + procedure secondifn(var p : ptree); + procedure secondfor(var p : ptree); + procedure secondexitn(var p : ptree); + procedure secondbreakn(var p : ptree); + procedure secondcontinuen(var p : ptree); + procedure secondgoto(var p : ptree); + procedure secondlabel(var p : ptree); + procedure secondraise(var p : ptree); + procedure secondtryexcept(var p : ptree); + procedure secondtryfinally(var p : ptree); + procedure secondon(var p : ptree); + procedure secondfail(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k; + +{***************************************************************************** + Second_While_RepeatN +*****************************************************************************} + + procedure second_while_repeatn(var p : ptree); + + var + l1,l2,l3,oldclabel,oldblabel : pasmlabel; + otlabel,oflabel : pasmlabel; + begin + getlabel(l1); + getlabel(l2); + { arrange continue and breaklabels: } + oldclabel:=aktcontinuelabel; + oldblabel:=aktbreaklabel; + if p^.treetype=repeatn then + begin + emitl(A_LABEL,l1); + aktcontinuelabel:=l1; + aktbreaklabel:=l2; + cleartempgen; + if assigned(p^.right) then + secondpass(p^.right); + + otlabel:=truelabel; + oflabel:=falselabel; + truelabel:=l2; + falselabel:=l1; + cleartempgen; + secondpass(p^.left); + maketojumpbool(p^.left); + emitl(A_LABEL,l2); + truelabel:=otlabel; + falselabel:=oflabel; + end + else { //// NOT a small set //// } + begin + { handling code at the end as it is much more efficient } + emitl(A_JMP,l2); + + emitl(A_LABEL,l1); + cleartempgen; + + getlabel(l3); + aktcontinuelabel:=l2; + aktbreaklabel:=l3; + + if assigned(p^.right) then + secondpass(p^.right); + + emitl(A_LABEL,l2); + otlabel:=truelabel; + oflabel:=falselabel; + truelabel:=l1; + falselabel:=l3; + cleartempgen; + secondpass(p^.left); + maketojumpbool(p^.left); + + emitl(A_LABEL,l3); + truelabel:=otlabel; + falselabel:=oflabel; + end; + aktcontinuelabel:=oldclabel; + aktbreaklabel:=oldblabel; + end; + + +{***************************************************************************** + SecondIfN +*****************************************************************************} + + procedure secondifn(var p : ptree); + + var + hl,otlabel,oflabel : pasmlabel; + + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + cleartempgen; + secondpass(p^.left); + maketojumpbool(p^.left); + if assigned(p^.right) then + begin + emitl(A_LABEL,truelabel); + cleartempgen; + secondpass(p^.right); + end; + if assigned(p^.t1) then + begin + if assigned(p^.right) then + begin + getlabel(hl); + emitl(A_JMP,hl); + end; + emitl(A_LABEL,falselabel); + cleartempgen; + secondpass(p^.t1); + if assigned(p^.right) then + emitl(A_LABEL,hl); + end + else + emitl(A_LABEL,falselabel); + if not(assigned(p^.right)) then + emitl(A_LABEL,truelabel); + truelabel:=otlabel; + falselabel:=oflabel; + end; + +{***************************************************************************** + SecondFor +*****************************************************************************} + + procedure secondfor(var p : ptree); + + var + l1,l3,oldclabel,oldblabel : pasmlabel; + omitfirstcomp,temptovalue : boolean; + hs : byte; + temp1 : treference; + hop : tasmop; + cmpreg,cmp32 : tregister; + opsize : topsize; + count_var_is_signed : boolean; + + begin + oldclabel:=aktcontinuelabel; + oldblabel:=aktbreaklabel; + getlabel(aktcontinuelabel); + getlabel(aktbreaklabel); + getlabel(l3); + + { could we spare the first comparison ? } + omitfirstcomp:=false; + if p^.right^.treetype=ordconstn then + if p^.left^.right^.treetype=ordconstn then + omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value)) + or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value)); + + { only calculate reference } + cleartempgen; + secondpass(p^.t2); + if not(simple_loadn) then + CGMessage(cg_e_illegal_count_var); + + { produce start assignment } + cleartempgen; + secondpass(p^.left); + count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype)); + hs:=p^.t2^.resulttype^.size; + cmp32:=getregister32; + cmpreg:=cmp32; + case hs of + 1 : begin + opsize:=S_B; + end; + 2 : begin + opsize:=S_W; + end; + 4 : begin + opsize:=S_L; + end; + end; + cleartempgen; + secondpass(p^.right); + { calculate pointer value and check if changeable and if so } + { load into temporary variable } + if p^.right^.treetype<>ordconstn then + begin + temp1.symbol:=nil; + gettempofsizereference(hs,temp1); + temptovalue:=true; + if (p^.right^.location.loc=LOC_REGISTER) or + (p^.right^.location.loc=LOC_CREGISTER) then + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,opsize,p^.right^.location.register, + newreference(temp1)))); + end + else + concatcopy(p^.right^.location.reference,temp1,hs,false); + end + else temptovalue:=false; + + if temptovalue then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1), + p^.t2^.location.register))); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference), + cmpreg))); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1), + cmpreg))); + end; + end + else + begin + if not(omitfirstcomp) then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^.right^.value, + p^.t2^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,opsize,p^.right^.value, + newreference(p^.t2^.location.reference)))); + end; + end; + if p^.backward then + begin + if count_var_is_signed then + hop:=A_BLT + else + hop:=A_BCS; + end + else + if count_var_is_signed then + hop:=A_BGT + else hop:=A_BHI; + + if not(omitfirstcomp) or temptovalue then + emitl(hop,aktbreaklabel); + + emitl(A_LABEL,l3); + + { help register must not be in instruction block } + cleartempgen; + if assigned(p^.t1) then + secondpass(p^.t1); + + emitl(A_LABEL,aktcontinuelabel); + + { makes no problems there } + cleartempgen; + + { demand help register again } + cmp32:=getregister32; + case hs of + 1 : begin + opsize:=S_B; + end; + 2 : begin + opsize:=S_W; + end; + 4 : opsize:=S_L; + end; + + { produce comparison and the corresponding } + { jump } + if temptovalue then + begin + if p^.t2^.location.loc=LOC_CREGISTER then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1), + p^.t2^.location.register))); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference), + cmpreg))); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_CMP,opsize,newreference(temp1), + cmpreg))); + end; + end + else + begin + if p^.t2^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^.right^.value, + p^.t2^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,opsize,p^.right^.value, + newreference(p^.t2^.location.reference)))); + end; + if p^.backward then + if count_var_is_signed then + hop:=A_BLE + else + hop :=A_BLS + else + if count_var_is_signed then + hop:=A_BGE + else + hop:=A_BCC; + emitl(hop,aktbreaklabel); + { according to count direction DEC or INC... } + { must be after the test because of 0to 255 for bytes !! } + if p^.backward then + hop:=A_SUB + else hop:=A_ADD; + + if p^.t2^.location.loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_const_reg(hop,opsize,1,p^.t2^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(hop,opsize,1,newreference(p^.t2^.location.reference)))); + emitl(A_JMP,l3); + + { this is the break label: } + emitl(A_LABEL,aktbreaklabel); + ungetregister32(cmp32); + + if temptovalue then + ungetiftemp(temp1); + + aktcontinuelabel:=oldclabel; + aktbreaklabel:=oldblabel; + end; + + +{***************************************************************************** + SecondExitN +*****************************************************************************} + + procedure secondexitn(var p : ptree); + + var + is_mem : boolean; + {op : tasmop; + s : topsize;} + otlabel,oflabel : pasmlabel; + + label + do_jmp; + + begin + if assigned(p^.left) then + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + secondpass(p^.left); + case p^.left^.location.loc of + LOC_FPU : goto do_jmp; + LOC_MEM,LOC_REFERENCE : is_mem:=true; + LOC_CREGISTER, + LOC_REGISTER : is_mem:=false; + LOC_FLAGS : begin + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0))); + exprasmlist^.concat(new(paicpu,op_reg(A_NEG, S_B, R_D0))); + goto do_jmp; + end; + LOC_JUMP : begin + emitl(A_LABEL,truelabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,1,R_D0))); + emitl(A_JMP,aktexit2label); + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_B,R_D0))); + goto do_jmp; + end; + else internalerror(2001); + end; + case procinfo^.retdef^.deftype of + orddef, + enumdef : begin + case procinfo^.retdef^.size of + 4 : if is_mem then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference),R_D0))) + else + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0); + 2 : if is_mem then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W, + newreference(p^.left^.location.reference),R_D0))) + else + emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,R_D0); + 1 : if is_mem then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B, + newreference(p^.left^.location.reference),R_D0))) + else + emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D0); + end; + end; + pointerdef, + procvardef : begin + if is_mem then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference),R_D0))) + else + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0))); + end; + floatdef : begin + { floating point return values .... } + { single are returned in d0 } + if (pfloatdef(procinfo^.retdef)^.typ=f32bit) or + (pfloatdef(procinfo^.retdef)^.typ=s32real) then + begin + if is_mem then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference),R_D0))) + else + begin + if pfloatdef(procinfo^.retdef)^.typ=f32bit then + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0) + else + begin + { single values are in the floating point registers } + if cs_fp_emulation in aktmoduleswitches then + emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0) + else + exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_FS, + p^.left^.location.fpureg,R_D0))); + end; + end; + end + else + Begin + { this is only possible in real non emulation mode } + { LOC_MEM,LOC_REFERENCE } + if is_mem then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE, + getfloatsize(pfloatdef(procinfo^.retdef)^.typ), + newreference(p^.left^.location.reference),R_FP0))); + end + else + { LOC_FPU } + begin + { convert from extended to correct type } + { when storing } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE, + getfloatsize(pfloatdef(procinfo^.retdef)^.typ),p^.left^.location.fpureg,R_FP0))); + end; + end; + end; + end; +do_jmp: + truelabel:=otlabel; + falselabel:=oflabel; + emitl(A_JMP,aktexit2label); + end + else + begin + emitl(A_JMP,aktexitlabel); + end; + end; + + +{***************************************************************************** + SecondBreakN +*****************************************************************************} + + procedure secondbreakn(var p : ptree); + begin + if aktbreaklabel<>nil then + emitl(A_JMP,aktbreaklabel) + else + CGMessage(cg_e_break_not_allowed); + end; + + +{***************************************************************************** + SecondContinueN +*****************************************************************************} + + procedure secondcontinuen(var p : ptree); + begin + if aktcontinuelabel<>nil then + emitl(A_JMP,aktcontinuelabel) + else + CGMessage(cg_e_continue_not_allowed); + end; + + +{***************************************************************************** + SecondGoto +*****************************************************************************} + + procedure secondgoto(var p : ptree); + + begin + emitl(A_JMP,p^.labelnr); + end; + + +{***************************************************************************** + SecondLabel +*****************************************************************************} + + procedure secondlabel(var p : ptree); + begin + emitl(A_LABEL,p^.labelnr); + cleartempgen; + secondpass(p^.left); + end; + + +{***************************************************************************** + SecondRaise +*****************************************************************************} + + { generates the code for a raise statement } + procedure secondraise(var p : ptree); + + var + a : pasmlabel; + + begin + if assigned(p^.left) then + begin + { generate the address } + if assigned(p^.right) then + begin + secondpass(p^.right); + if codegenerror then + exit; + end + else + begin + getlabel(a); + emitl(A_LABEL,a); + exprasmlist^.concat(new(paicpu, + op_csymbol_reg(A_MOVE,S_L,newcsymbol(a^.name,0),R_SPPUSH))); + end; + secondpass(p^.left); + if codegenerror then + exit; + + case p^.left^.location.loc of + LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.left^.location.register,R_SPPUSH))); + else CGMessage(type_e_mismatch); + end; + emitcall('FPC_RAISEEXCEPTION',true); + end + else + emitcall('FPC_RERAISE',true); + end; + + +{***************************************************************************** + SecondTryExcept +*****************************************************************************} + + var + endexceptlabel : pasmlabel; + + procedure secondtryexcept(var p : ptree); + + var + exceptlabel,doexceptlabel,oldendexceptlabel, + lastonlabel : pasmlabel; + + begin + InternalError(3431243); +(* + { this can be called recursivly } + oldendexceptlabel:=endexceptlabel; + { we modify EAX } + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + + getlabel(exceptlabel); + getlabel(doexceptlabel); + getlabel(endexceptlabel); + getlabel(lastonlabel); + push_int (1); { push type of exceptionframe } + emitcall('FPC_PUSHEXCEPTADDR',true); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + emitcall('FPC_SETJMP',true); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitl(A_JNE,exceptlabel); + + { try code } + secondpass(p^.left); + if codegenerror then + exit; + + emitl(A_LABEL,exceptlabel); + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitl(A_JNE,doexceptlabel); + emitcall('FPC_POPADDRSTACK',true); + emitl(A_JMP,endexceptlabel); + emitl(A_LABEL,doexceptlabel); + + if assigned(p^.right) then + secondpass(p^.right); + + emitl(A_LABEL,lastonlabel); + { default handling } + if assigned(p^.t1) then + begin + { FPC_CATCHES must be called with + 'default handler' flag (=-1) + } + push_int (-1); + emitcall('FPC_CATCHES',true); + secondpass(p^.t1); + end + else + emitcall('FPC_RERAISE',true); + emitl(A_LABEL,endexceptlabel); + endexceptlabel:=oldendexceptlabel; *) + end; + + +{***************************************************************************** + SecondOn +*****************************************************************************} + + procedure secondon(var p : ptree); + var + nextonlabel,myendexceptlabel : pasmlabel; + ref : treference; + + begin +{ !!!!!!!!!!!!!!! } +(* getlabel(nextonlabel); + { push the vmt } + exprasmlist^.concat(new(paicpu,op_csymbol(A_PUSH,S_L, + newcsymbol(p^.excepttype^.vmt_mangledname,0)))); + maybe_concat_external(p^.excepttype^.owner, + p^.excepttype^.vmt_mangledname); + + emitcall('FPC_CATCHES',true); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitl(A_JE,nextonlabel); + ref.symbol:=nil; + gettempofsizereference(4,ref); + + { what a hack ! } + if assigned(p^.exceptsymtable) then + pvarsym(p^.exceptsymtable^.root)^.address:=ref.offset; + + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + R_EAX,newreference(ref)))); + + if assigned(p^.right) then + secondpass(p^.right); + { clear some stuff } + ungetiftemp(ref); + emitl(A_JMP,endexceptlabel); + emitl(A_LABEL,nextonlabel); + { next on node } + if assigned(p^.left) then + secondpass(p^.left); *) + end; + +{***************************************************************************** + SecondTryFinally +*****************************************************************************} + + procedure secondtryfinally(var p : ptree); + + var + finallylabel,noreraiselabel,endfinallylabel : pasmlabel; + + begin +(* { we modify EAX } + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + + getlabel(finallylabel); + getlabel(noreraiselabel); + getlabel(endfinallylabel); + push_int(1); { Type of stack-frame must be pushed} + emitcall('FPC_PUSHEXCEPTADDR',true); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + emitcall('FPC_SETJMP',true); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitl(A_JNE,finallylabel); + + { try code } + secondpass(p^.left); + if codegenerror then + exit; + + emitl(A_LABEL,finallylabel); + + { finally code } + secondpass(p^.right); + if codegenerror then + exit; + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitl(A_JE,noreraiselabel); + emitcall('FPC_RERAISE',true); + emitl(A_LABEL,noreraiselabel); + emitcall('FPC_POPADDRSTACK',true); + emitl(A_LABEL,endfinallylabel); *) + end; + + +{***************************************************************************** + SecondFail +*****************************************************************************} + + procedure secondfail(var p : ptree); + var + hp : preference; + begin + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_A5))); + { also reset to zero in the stack } + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.selfpointer_offset; + hp^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A5,hp))); + exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel))); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.16 2000/03/01 00:04:31 pierre + Use $GOTO ON + + Revision 1.15 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.14 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.13 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.12 1999/11/09 23:06:44 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.11 1999/09/27 23:44:48 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.10 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.9 1999/08/25 11:59:49 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/cg68kinl.pas b/befpc/compiler/cg68kinl.pas new file mode 100644 index 0000000..7ac3ba4 --- /dev/null +++ b/befpc/compiler/cg68kinl.pas @@ -0,0 +1,926 @@ +{ + $Id: cg68kinl.pas,v 1.1.1.1 2001-07-23 17:15:41 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k inline nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kinl; +interface + + uses + tree; + + procedure secondinline(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + aasm,types,symtable, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k,cg68kld,cg68kcal; + + +{***************************************************************************** + Helpers +*****************************************************************************} + + { reverts the parameter list } + var nb_para : integer; + + function reversparameter(p : ptree) : ptree; + + var + hp1,hp2 : ptree; + + begin + hp1:=nil; + nb_para := 0; + while assigned(p) do + begin + { pull out } + hp2:=p; + p:=p^.right; + inc(nb_para); + { pull in } + hp2^.right:=hp1; + hp1:=hp2; + end; + reversparameter:=hp1; + end; + + +{***************************************************************************** + SecondInLine +*****************************************************************************} + + procedure secondinline(var p : ptree); + const + { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); } + float_name: array[tfloattype] of string[8]= + ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16'); + addqconstsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADDQ,A_SUBQ); + addconstsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); + addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); + var + aktfile : treference; + ft : tfiletype; + opsize : topsize; + asmop : tasmop; + pushed : tpushed; + {inc/dec} + addconstant : boolean; + addvalue : longint; + + + procedure handlereadwrite(doread,doln : boolean); + { produces code for READ(LN) and WRITE(LN) } + + procedure loadstream; + const + io:array[0..1] of string[7]=('_OUTPUT','_INPUT'); + var + r : preference; + begin + new(r); + reset_reference(r^); + r^.symbol:=stringdup( + 'U_'+upper(target_info.system_unit)+io[byte(doread)]); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,r,R_A0))) + end; + + var + node,hp : ptree; + typedtyp, + pararesult : pdef; + has_length : boolean; + dummycoll : tdefcoll; + iolabel : pasmlabel; + npara : longint; + + begin + { I/O check } + if (cs_check_io in aktlocalswitches) and + not(po_iocheck in aktprocsym^.definition^.procoptions) then + begin + getlabel(iolabel); + emitl(A_LABEL,iolabel); + end + else + iolabel:=nil; + { for write of real with the length specified } + has_length:=false; + hp:=nil; + { reserve temporary pointer to data variable } + aktfile.symbol:=nil; + gettempofsizereference(4,aktfile); + { first state text data } + ft:=ft_text; + { and state a parameter ? } + if p^.left=nil then + begin + { the following instructions are for "writeln;" } + loadstream; + { save @aktfile in temporary variable } + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile)))); + end + else + begin + { revers paramters } + node:=reversparameter(p^.left); + + p^.left := node; + npara := nb_para; + { calculate data variable } + { is first parameter a file type ? } + if node^.left^.resulttype^.deftype=filedef then + begin + ft:=pfiledef(node^.left^.resulttype)^.filetype; + if ft=ft_typed then + typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as; + secondpass(node^.left); + if codegenerror then + exit; + + { save reference in temporary variables } + if node^.left^.location.loc<>LOC_REFERENCE then + begin + CGMessage(cg_e_illegal_expression); + exit; + end; + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0))); + + { skip to the next parameter } + node:=node^.right; + end + else + begin + { load stdin/stdout stream } + loadstream; + end; + + { save @aktfile in temporary variable } + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile)))); + if doread then + { parameter by READ gives call by reference } + dummycoll.paratyp:=vs_var + { an WRITE Call by "Const" } + else + dummycoll.paratyp:=vs_const; + + { because of secondcallparan, which otherwise attaches } + if ft=ft_typed then + { this is to avoid copy of simple const parameters } + {dummycoll.data:=new(pformaldef,init)} + dummycoll.data:=cformaldef + else + { I think, this isn't a good solution (FK) } + dummycoll.data:=nil; + + while assigned(node) do + begin + pushusedregisters(pushed,$ff); + hp:=node; + node:=node^.right; + hp^.right:=nil; + if hp^.is_colon_para then + CGMessage(parser_e_illegal_colon_qualifier); + if ft=ft_typed then + never_copy_const_param:=true; + secondcallparan(hp,@dummycoll,false); + if ft=ft_typed then + never_copy_const_param:=false; + hp^.right:=node; + if codegenerror then + exit; + + emit_push_mem(aktfile); + if (ft=ft_typed) then + begin + { OK let's try this } + { first we must only allow the right type } + { we have to call blockread or blockwrite } + { but the real problem is that } + { reset and rewrite should have set } + { the type size } + { as recordsize for that file !!!! } + { how can we make that } + { I think that is only possible by adding } + { reset and rewrite to the inline list a call } + { allways read only one record by element } + push_int(typedtyp^.size); + if doread then + emitcall('FPC_TYPED_READ',true) + else + emitcall('FPC_TYPED_WRITE',true); + end + else + begin + { save current position } + pararesult:=hp^.left^.resulttype; + { handle possible field width } + { of course only for write(ln) } + if not doread then + begin + { handle total width parameter } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + secondcallparan(hp,@dummycoll,false); + hp^.right:=node; + if codegenerror then + exit; + has_length:=true; + end + else + if pararesult^.deftype<>floatdef then + push_int(0) + else + push_int(-32767); + { a second colon para for a float ? } + if assigned(node) and node^.is_colon_para then + begin + hp:=node; + node:=node^.right; + hp^.right:=nil; + secondcallparan(hp,@dummycoll,false); + hp^.right:=node; + if pararesult^.deftype<>floatdef then + CGMessage(parser_e_illegal_colon_qualifier); + if codegenerror then + exit; + end + else + begin + if pararesult^.deftype=floatdef then + push_int(-1); + end + end; + case pararesult^.deftype of + stringdef : begin + if doread then + begin + { push maximum string length } + push_int(pstringdef(pararesult)^.len); + case pstringdef(pararesult)^.string_typ of + st_shortstring: + emitcall ('FPC_READ_TEXT_STRING',true); + st_ansistring: + emitcall ('FPC_READ_TEXT_ANSISTRING',true); + st_longstring: + emitcall ('FPC_READ_TEXT_LONGSTRING',true); + st_widestring: + emitcall ('FPC_READ_TEXT_ANSISTRING',true); + end + end + else + Case pstringdef(Pararesult)^.string_typ of + st_shortstring: + emitcall ('FPC_WRITE_TEXT_STRING',true); + st_ansistring: + emitcall ('FPC_WRITE_TEXT_ANSISTRING',true); + st_longstring: + emitcall ('FPC_WRITE_TEXT_LONGSTRING',true); + st_widestring: + emitcall ('FPC_WRITE_TEXT_ANSISTRING',true); + end; + end; + pointerdef : begin + if is_equal(ppointerdef(pararesult)^.definition,cchardef) then + begin + if doread then + emitcall('FPC_READ_TEXT_PCHAR_AS_POINTER',true) + else + emitcall('FPC_WRITE_TEXT_PCHAR_AS_POINTER',true); + end; + end; + arraydef : begin + if (parraydef(pararesult)^.lowrange=0) and + is_equal(parraydef(pararesult)^.definition,cchardef) then + begin + if doread then + emitcall('FPC_READ_TEXT_PCHAR_AS_ARRAY',true) + else + emitcall('FPC_WRITE_TEXT_PCHAR_AS_ARRAY',true); + end; + end; + floatdef : begin + if doread then + emitcall('FPC_READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true) + else + emitcall('FPC_WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true); + end; + orddef : begin + case porddef(pararesult)^.typ of + u8bit : if doread then + emitcall('FPC_READ_TEXT_BYTE',true); + s8bit : if doread then + emitcall('FPC_READ_TEXT_SHORTINT',true); + u16bit : if doread then + emitcall('FPC_READ_TEXT_WORD',true); + s16bit : if doread then + emitcall('FPC_READ_TEXT_INTEGER',true); + s32bit : if doread then + emitcall('FPC_READ_TEXT_LONGINT',true) + else + emitcall('FPC_WRITE_TEXT_LONGINT',true); + u32bit : if doread then + emitcall('FPC_READ_TEXT_CARDINAL',true) + else + emitcall('FPC_WRITE_TEXT_CARDINAL',true); + uchar : if doread then + emitcall('FPC_READ_TEXT_CHAR',true) + else + emitcall('FPC_WRITE_TEXT_CHAR',true); + bool8bit, + bool16bit, + bool32bit : if doread then + CGMessage(parser_e_illegal_parameter_list) + else + emitcall('FPC_WRITE_TEXT_BOOLEAN',true); + end; + end; + end; + end; + { load ESI in methods again } + popusedregisters(pushed); + maybe_loada5; + end; + end; + { Insert end of writing for textfiles } + if ft=ft_text then + begin + pushusedregisters(pushed,$ff); + emit_push_mem(aktfile); + if doread then + begin + if doln then + emitcall('FPC_READLN_END',true) + else + emitcall('FPC_READ_END',true); + end + else + begin + if doln then + emitcall('FPC_WRITELN_END',true) + else + emitcall('FPC_WRITE_END',true); + end; + popusedregisters(pushed); + maybe_loada5; + end; + { Insert IOCheck if set } + if assigned(iolabel) then + begin + { registers are saved in the procedure } + exprasmlist^.concat(new(paicpu,op_csymbol(A_PEA,S_L,newcsymbol(iolabel^.name,0)))); + emitcall('FPC_IOCHECK',true); + end; + { Freeup all used temps } + ungetiftemp(aktfile); + if assigned(p^.left) then + begin + p^.left:=reversparameter(p^.left); + if npara<>nb_para then + CGMessage(cg_f_internal_error_in_secondinline); + hp:=p^.left; + while assigned(hp) do + begin + if assigned(hp^.left) then + if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + ungetiftemp(hp^.left^.location.reference); + hp:=hp^.right; + end; + end; + end; + + procedure handle_str; + + var + hp,node : ptree; + dummycoll : tdefcoll; + is_real,has_length : boolean; + + begin + pushusedregisters(pushed,$ff); + node:=p^.left; + is_real:=false; + has_length:=false; + while assigned(node^.right) do node:=node^.right; + { if a real parameter somewhere then call REALSTR } + if (node^.left^.resulttype^.deftype=floatdef) then + is_real:=true; + + node:=p^.left; + { we have at least two args } + { with at max 2 colon_para in between } + + { first arg longint or float } + hp:=node; + node:=node^.right; + hp^.right:=nil; + dummycoll.data:=hp^.resulttype; + { string arg } + + dummycoll.paratyp:=vs_var; + secondcallparan(hp,@dummycoll,false); + if codegenerror then + exit; + + dummycoll.paratyp:=vs_const; + disposetree(hp); + p^.left:=nil; + + { second arg } + hp:=node; + node:=node^.right; + hp^.right:=nil; + { frac para } + if hp^.is_colon_para and assigned(node) and + node^.is_colon_para then + begin + dummycoll.data:=hp^.resulttype; + secondcallparan(hp,@dummycoll,false); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + has_length:=true; + end + else + if is_real then + push_int(-1); + + { third arg, length only if is_real } + if hp^.is_colon_para then + begin + dummycoll.data:=hp^.resulttype; + secondcallparan(hp,@dummycoll,false); + if codegenerror then + exit; + disposetree(hp); + hp:=node; + node:=node^.right; + hp^.right:=nil; + end + else + if is_real then + push_int(-32767) + else + push_int(-1); + + { last arg longint or real } + secondcallparan(hp,@dummycoll,false); + if codegenerror then + exit; + + disposetree(hp); + + if is_real then + emitcall('FPC_STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true) + else if porddef(hp^.resulttype)^.typ=u32bit then + emitcall('FPC_STR_CARDINAL',true) + else + emitcall('FPC_STR_LONGINT',true); + popusedregisters(pushed); + end; + + var + r : preference; + l : longint; + ispushed : boolean; + hregister : tregister; + otlabel,oflabel,filenamestring : pasmlabel; + oldpushedparasize : longint; + begin + { save & reset pushedparasize } + oldpushedparasize:=pushedparasize; + pushedparasize:=0; + case p^.inlinenumber of + in_assert_x_y: + begin + { !!!!!!!!! } + end; + in_lo_word, + in_hi_word : + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W, + newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_word then + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSR,S_W,8,p^.location.register))); + p^.location.register:=p^.location.register; + end; + in_high_x : + begin + if is_open_array(p^.left^.resulttype) then + begin + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + new(r); + reset_reference(r^); + r^.base:=highframepointer; + r^.offset:=highoffset+4; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + r,p^.location.register))); + end + end; + in_sizeof_x, + in_typeof_x : + begin + { sizeof(openarray) handling } + if (p^.inlinenumber=in_sizeof_x) and + is_open_array(p^.left^.resulttype) then + begin + { sizeof(openarray)=high(openarray)+1 } + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + new(r); + reset_reference(r^); + r^.base:=highframepointer; + r^.offset:=highoffset+4; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + r,p^.location.register))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L, + 1,p^.location.register))); + if parraydef(p^.left^.resulttype)^.elesize<>1 then + exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_L, + parraydef(p^.left^.resulttype)^.elesize,p^.location.register))); + end + else + begin + { for both cases load vmt } + if p^.left^.treetype=typen then + begin + exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_LEA, + S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0), + R_A0))); + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_L,R_A0,p^.location.register); + end + else + begin + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + { load VMT pointer } + inc(p^.left^.location.reference.offset, + pobjectdef(p^.left^.resulttype)^.vmt_offset); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + end; + { in sizeof load size } + if p^.inlinenumber=in_sizeof_x then + begin + new(r); + reset_reference(r^); + { load the address in A0 } + { because now supposedly p^.location.register is an } + { address. } + emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0); + r^.base:=R_A0; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r, + p^.location.register))); + end; + end; + end; + in_lo_long, + in_hi_long : begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, + p^.location.register); + end + else + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + if p^.inlinenumber=in_hi_long then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ, S_L, 16, R_D1))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register))); + end; + p^.location.register:=p^.location.register; + end; + in_length_string : + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + { length in ansi strings is at offset -8 } + if is_ansistring(p^.left^.resulttype) then + dec(p^.location.reference.offset,8); + end; + in_pred_x, + in_succ_x: + begin + secondpass(p^.left); + if p^.inlinenumber=in_pred_x then + asmop:=A_SUB + else + asmop:=A_ADD; + case p^.resulttype^.size of + 4 : opsize:=S_L; + 2 : opsize:=S_W; + 1 : opsize:=S_B; + else + internalerror(10080); + end; + p^.location.loc:=LOC_REGISTER; + if p^.left^.location.loc<>LOC_REGISTER then + begin + p^.location.register:=getregister32; + if p^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(A_MOVE,opsize,p^.left^.location.register, + p^.location.register) + else + if p^.left^.location.loc=LOC_FLAGS then + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.left^.location.resflags],S_NO, + p^.location.register))) + else + begin + del_reference(p^.left^.location.reference); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference), + p^.location.register))); + end; + end + else p^.location.register:=p^.left^.location.register; + exprasmlist^.concat(new(paicpu,op_const_reg(asmop,opsize,1, + p^.location.register))) + { here we should insert bounds check ? } + { and direct call to bounds will crash the program } + { if we are at the limit } + { we could also simply say that pred(first)=first and succ(last)=last } + { could this be usefull I don't think so (PM) + emitoverflowcheck;} + end; + in_dec_x, + in_inc_x : + begin + { set defaults } + addvalue:=1; + addconstant:=true; + { load first parameter, must be a reference } + secondpass(p^.left^.left); + case p^.left^.left^.resulttype^.deftype of + orddef, + enumdef : begin + case p^.left^.left^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + end; + end; + pointerdef : begin + opsize:=S_L; + addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.size; + end; + else + internalerror(10081); + end; + { second argument specified?, must be a s32bit in register } + if assigned(p^.left^.right) then + begin + secondpass(p^.left^.right^.left); + { when constant, just multiply the addvalue } + if is_constintnode(p^.left^.right^.left) then + addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left) + else + begin + case p^.left^.right^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register; + LOC_MEM, + LOC_REFERENCE : begin + hregister:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.right^.left^.location.reference),hregister))); + end; + else + internalerror(10082); + end; + { insert multiply with addvalue if its >1 } + if addvalue>1 then + exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,opsize, + addvalue,hregister))); + addconstant:=false; + end; + end; + { write the add instruction } + if addconstant then + begin + if (addvalue > 0) and (addvalue < 9) then + exprasmlist^.concat(new(paicpu,op_const_ref(addqconstsubop[p^.inlinenumber],opsize, + addvalue,newreference(p^.left^.left^.location.reference)))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(addconstsubop[p^.inlinenumber],opsize, + addvalue,newreference(p^.left^.left^.location.reference)))); + end + else + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(addsubop[p^.inlinenumber],opsize, + hregister,newreference(p^.left^.left^.location.reference)))); + ungetregister32(hregister); + end; + emitoverflowcheck(p^.left^.left); + end; + in_assigned_x : + begin + secondpass(p^.left^.left); + p^.location.loc:=LOC_FLAGS; + if (p^.left^.left^.location.loc=LOC_REGISTER) or + (p^.left^.left^.location.loc=LOC_CREGISTER) then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L, + p^.left^.left^.location.register))); + ungetregister32(p^.left^.left^.location.register); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref(A_TST,S_L, + newreference(p^.left^.left^.location.reference)))); + del_reference(p^.left^.left^.location.reference); + end; + p^.location.resflags:=F_NE; + end; + in_reset_typedfile,in_rewrite_typedfile : + begin + pushusedregisters(pushed,$ffff); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L, + pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH))); + secondload(p^.left); + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + if p^.inlinenumber=in_reset_typedfile then + emitcall('FPC_RESET_TYPED',true) + else + emitcall('FPC_REWRITE_TYPED',true); + popusedregisters(pushed); + end; + in_write_x : + handlereadwrite(false,false); + in_writeln_x : + handlereadwrite(false,true); + in_read_x : + handlereadwrite(true,false); + in_readln_x : + handlereadwrite(true,true); + in_str_x_string : + begin + handle_str; + maybe_loada5; + end; + in_include_x_y, + in_exclude_x_y: + begin + CGMessage(cg_e_include_not_implemented); +{ !!!!!!! } +(* secondpass(p^.left^.left); + if p^.left^.right^.left^.treetype=ordconstn then + begin + { calculate bit position } + l:=1 shl (p^.left^.right^.left^.value mod 32); + + { determine operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_OR + else + begin + asmop:=A_AND; + l:=not(l); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + begin + inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4); + exprasmlist^.concat(new(paicpu,op_const_ref(asmop,S_L, + l,newreference(p^.left^.left^.location.reference)))); + del_reference(p^.left^.left^.location.reference); + end + else + { LOC_CREGISTER } + exprasmlist^.concat(new(paicpu,op_const_reg(asmop,S_L, + l,p^.left^.left^.location.register))); + end + else + begin + { generate code for the element to set } + ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left); + secondpass(p^.left^.right^.left); + if ispushed then + restore(p^.left^.left); + { determine asm operator } + if p^.inlinenumber=in_include_x_y then + asmop:=A_BTS + else + asmop:=A_BTR; + if psetdef(p^.left^.resulttype)^.settype=smallset then + begin + if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then + hregister:=p^.left^.right^.left^.location.register + else + begin + hregister:=R_EDI; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L, + newreference(p^.left^.right^.left^.location.reference),R_EDI))); + end; + if (p^.left^.left^.location.loc=LOC_REFERENCE) then + exprasmlist^.concat(new(paicpu,op_reg_ref(asmop,S_L,R_EDI, + newreference(p^.left^.right^.left^.location.reference)))) + else + exprasmlist^.concat(new(paicpu,op_reg_reg(asmop,S_L,R_EDI, + p^.left^.right^.left^.location.register))); + end + else + begin + internalerror(10083); + end; + end; + *) + end; + + else + internalerror(9); + end; + pushedparasize:=oldpushedparasize; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.22 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.21 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.20 1999/12/20 21:42:35 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.19 1999/11/20 01:22:18 pierre + + cond FPC_USE_CPREFIX (needs also some RTL changes) + this allows to use unit global vars as DLL exports + (the underline prefix seems needed by dlltool) + + Revision 1.18 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.17 1999/08/25 11:59:50 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} + diff --git a/befpc/compiler/cg68kld.pas b/befpc/compiler/cg68kld.pas new file mode 100644 index 0000000..c92499e --- /dev/null +++ b/befpc/compiler/cg68kld.pas @@ -0,0 +1,496 @@ +{ + $Id: cg68kld.pas,v 1.1.1.1 2001-07-23 17:15:42 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for load/assignment nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kld; +interface + + uses + tree,cpubase; + + var + { this is for open arrays and strings } + { but be careful, this data is in the } + { generated code destroyed quick, and also } + { the next call of secondload destroys this } + { data } + { So be careful using the informations } + { provided by this variables } + highframepointer : tregister; + highoffset : longint; + + procedure secondload(var p : ptree); + procedure secondassignment(var p : ptree); + procedure secondfuncret(var p : ptree); + procedure secondarrayconstruct(var p : ptree); + + +implementation + + uses + cobjects,verbose,globals,symconst, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cga68k,tgen68k; + + +{***************************************************************************** + SecondLoad +*****************************************************************************} + + procedure secondload(var p : ptree); + + var + hregister : tregister; + i : longint; + symtabletype: tsymtabletype; + hp : preference; + + begin + simple_loadn:=true; + reset_reference(p^.location.reference); + case p^.symtableentry^.typ of + { this is only for toasm and toaddr } + absolutesym : + begin + stringdispose(p^.location.reference.symbol); + p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); + end; + varsym : + begin + hregister:=R_NO; + symtabletype:=p^.symtable^.symtabletype; + { in case it is a register variable: } + { we simply set the location to the } + { correct register. } + if pvarsym(p^.symtableentry)^.reg<>R_NO then + begin + p^.location.loc:=LOC_CREGISTER; + p^.location.register:=pvarsym(p^.symtableentry)^.reg; + unused:=unused-[pvarsym(p^.symtableentry)^.reg]; + end + else + begin + { --------------------- LOCAL AND TEMP VARIABLES ------------- } + if (symtabletype=parasymtable) or (symtabletype=localsymtable) then + begin + + p^.location.reference.base:=procinfo^.framepointer; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + + if (symtabletype=localsymtable) then + p^.location.reference.offset:=-p^.location.reference.offset; + + if (symtabletype in [localsymtable,inlinelocalsymtable]) then + p^.location.reference.offset:=-p^.location.reference.offset; + + if (lexlevel>(p^.symtable^.symtablelevel)) then + begin + hregister:=getaddressreg; + + { make a reference } + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.framepointer_offset; + hp^.base:=procinfo^.framepointer; + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister))); + + simple_loadn:=false; + i:=lexlevel-1; + while i>(p^.symtable^.symtablelevel) do + begin + { make a reference } + new(hp); + reset_reference(hp^); + hp^.offset:=8; + hp^.base:=hregister; + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister))); + dec(i); + end; + p^.location.reference.base:=hregister; + end; + end + { --------------------- END OF LOCAL AND TEMP VARS ---------------- } + else + case symtabletype of + unitsymtable,globalsymtable, + staticsymtable : begin + stringdispose(p^.location.reference.symbol); + p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); + end; + objectsymtable : begin + if sp_static in pvarsym(p^.symtableentry)^.symoptions then + begin + stringdispose(p^.location.reference.symbol); + p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); + end + else + begin + p^.location.reference.base:=R_A5; + p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; + end; + end; + withsymtable : begin + hregister:=getaddressreg; + p^.location.reference.base:=hregister; + { make a reference } + new(hp); + reset_reference(hp^); + hp^.offset:=p^.symtable^.datasize; + hp^.base:=procinfo^.framepointer; + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hregister))); + + p^.location.reference.offset:= + pvarsym(p^.symtableentry)^.address; + end; + end; + + { in case call by reference, then calculate: } + if (pvarsym(p^.symtableentry)^.varspez=vs_var) or + is_open_array(pvarsym(p^.symtableentry)^.definition) or + is_array_of_const(pvarsym(p^.symtableentry)^.definition) or + ((pvarsym(p^.symtableentry)^.varspez=vs_const) and + push_addr_param(pvarsym(p^.symtableentry)^.definition)) then + begin + simple_loadn:=false; + if hregister=R_NO then + hregister:=getaddressreg; + { ADDED FOR OPEN ARRAY SUPPORT. } + if (p^.location.reference.base=procinfo^.framepointer) then + begin + highframepointer:=p^.location.reference.base; + highoffset:=p^.location.reference.offset; + end + else + begin + highframepointer:=R_A1; + highoffset:=p^.location.reference.offset; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.location.reference.base,R_A1))); + end; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference), + hregister))); + { END ADDITION } + clear_reference(p^.location.reference); + p^.location.reference.base:=hregister; + end; + { should be dereferenced later (FK) + if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and + ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oo_is_class)<>0) then + begin + simple_loadn:=false; + if hregister=R_NO then + hregister:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference), + hregister))); + clear_reference(p^.location.reference); + p^.location.reference.base:=hregister; + end; + } + end; + end; + procsym: + begin + {!!!!! Be aware, work on virtual methods too } + stringdispose(p^.location.reference.symbol); + p^.location.reference.symbol:= + stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname); + end; + typedconstsym : + begin + stringdispose(p^.location.reference.symbol); + p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); + end; + else internalerror(4); + end; + end; + + +{***************************************************************************** + SecondAssignment +*****************************************************************************} + + procedure secondassignment(var p : ptree); + + var + opsize : topsize; + withresult : boolean; + otlabel,hlabel,oflabel : pasmlabel; + hregister : tregister; + loc : tloc; + pushed : boolean; + + begin + otlabel:=truelabel; + oflabel:=falselabel; + getlabel(truelabel); + getlabel(falselabel); + withresult:=false; + { calculate left sides } + secondpass(p^.left); + if codegenerror then + exit; + loc:=p^.left^.location.loc; + { lets try to optimize this (PM) } + { define a dest_loc that is the location } + { and a ptree to verify that it is the right } + { place to insert it } +{$ifdef test_dest_loc} + if (aktexprlevel<4) then + begin + dest_loc_known:=true; + dest_loc:=p^.left^.location; + dest_loc_tree:=p^.right; + end; +{$endif test_dest_loc} + + pushed:=maybe_push(p^.right^.registers32,p^.left); + secondpass(p^.right); + if pushed then restore(p^.left); + + if codegenerror then + exit; +{$ifdef test_dest_loc} + dest_loc_known:=false; + if in_dest_loc then + begin + truelabel:=otlabel; + falselabel:=oflabel; + in_dest_loc:=false; + exit; + end; +{$endif test_dest_loc} + if p^.left^.resulttype^.deftype=stringdef then + begin + { we do not need destination anymore } + del_reference(p^.left^.location.reference); + { only source if withresult is set } + if not(withresult) then + del_reference(p^.right^.location.reference); + loadstring(p); + ungetiftemp(p^.right^.location.reference); + end + else case p^.right^.location.loc of + LOC_REFERENCE, + LOC_MEM : begin + { handle ordinal constants trimmed } + if (p^.right^.treetype in [ordconstn,fixconstn]) or + (loc=LOC_CREGISTER) then + begin + case p^.left^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + end; + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.right^.location.reference), + p^.left^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,opsize, + p^.right^.location.reference.offset, + newreference(p^.left^.location.reference)))); + {exprasmlist^.concat(new(paicpu,op_const_loc(A_MOV,opsize, + p^.right^.location.reference.offset, + p^.left^.location)));} + end + else + begin + concatcopy(p^.right^.location.reference, + p^.left^.location.reference,p^.left^.resulttype^.size, + withresult); + ungetiftemp(p^.right^.location.reference); + end; + end; + LOC_REGISTER, + LOC_CREGISTER : begin + case p^.right^.resulttype^.size of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + end; + { simplified with op_reg_loc } + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,opsize, + p^.right^.location.register, + p^.left^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,opsize, + p^.right^.location.register, + newreference(p^.left^.location.reference)))); + {exprasmlist^.concat(new(paicpu,op_reg_loc(A_MOV,opsize, + p^.right^.location.register, + p^.left^.location))); } + + end; + LOC_FPU : begin + if loc<>LOC_REFERENCE then + internalerror(10010) + else + floatstore(pfloatdef(p^.left^.resulttype)^.typ, + p^.right^.location,p^.left^.location.reference); + end; + LOC_JUMP : begin + getlabel(hlabel); + emitl(A_LABEL,truelabel); + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B, + 1,p^.left^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B, + 1,newreference(p^.left^.location.reference)))); + {exprasmlist^.concat(new(paicpu,op_const_loc(A_MOV,S_B, + 1,p^.left^.location)));} + emitl(A_JMP,hlabel); + emitl(A_LABEL,falselabel); + if loc=LOC_CREGISTER then + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_B, + p^.left^.location.register))) + else + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B, + 0,newreference(p^.left^.location.reference)))); + emitl(A_LABEL,hlabel); + end; + LOC_FLAGS : begin + if loc=LOC_CREGISTER then + begin + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B, + p^.left^.location.register))); + exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_B,p^.left^.location.register))); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref(flag_2_set[p^.right^.location.resflags],S_B, + newreference(p^.left^.location.reference)))); + exprasmlist^.concat(new(paicpu,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference)))); + end; + + end; + end; + truelabel:=otlabel; + falselabel:=oflabel; + end; + + +{***************************************************************************** + SecondFuncRetN +*****************************************************************************} + + procedure secondfuncret(var p : ptree); + var + hr : tregister; + hp : preference; + pp : pprocinfo; + hr_valid : boolean; + begin + clear_reference(p^.location.reference); + hr_valid:=false; +{ !!!!!!! } + + if @procinfo<>pprocinfo(p^.funcretprocinfo) then + begin + hr:=getaddressreg; + hr_valid:=true; + hp:=new_reference(procinfo^.framepointer, + procinfo^.framepointer_offset); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hr))); + + pp:=procinfo^.parent; + { walk up the stack frame } + while pp<>pprocinfo(p^.funcretprocinfo) do + begin + hp:=new_reference(hr, + pp^.framepointer_offset); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,hr))); + pp:=pp^.parent; + end; + p^.location.reference.base:=hr; + end + else + p^.location.reference.base:=procinfo^.framepointer; + p^.location.reference.offset:=procinfo^.retoffset; + if ret_in_param(p^.retdef) then + begin + if not hr_valid then + { this was wrong !! PM } + hr:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hr))); + p^.location.reference.base:=hr; + p^.location.reference.offset:=0; + end; + end; + +{***************************************************************************** + SecondArrayConstruct +*****************************************************************************} + + const + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + + procedure secondarrayconstruct(var p : ptree); + begin + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.12 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.11 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.10 1999/11/10 00:06:08 pierre + * adapted to procinfo as pointer + + Revision 1.9 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.8 1999/09/16 11:34:54 pierre + * typo correction + +} diff --git a/befpc/compiler/cg68kmat.pas b/befpc/compiler/cg68kmat.pas new file mode 100644 index 0000000..205a98a --- /dev/null +++ b/befpc/compiler/cg68kmat.pas @@ -0,0 +1,465 @@ +{ + $Id: cg68kmat.pas,v 1.1.1.1 2001-07-23 17:15:42 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for math nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kmat; +interface + + uses + tree; + + procedure secondmoddiv(var p : ptree); + procedure secondshlshr(var p : ptree); + procedure secondunaryminus(var p : ptree); + procedure secondnot(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k; + +{***************************************************************************** + SecondModDiv +*****************************************************************************} + + { D0 and D1 used as temp (ok) } + procedure secondmoddiv(var p : ptree); + + var + hreg1 : tregister; + power : longint; + hl : pasmlabel; + reg: tregister; + pushed: boolean; + hl1: pasmlabel; + begin + secondpass(p^.left); + set_location(p^.location,p^.left^.location); + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + + { put numerator in register } + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + hreg1:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1); + end + else + begin + del_reference(p^.left^.location.reference); + hreg1:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), + hreg1))); + end; + clear_location(p^.left^.location); + p^.left^.location.loc:=LOC_REGISTER; + p^.left^.location.register:=hreg1; + end + else hreg1:=p^.left^.location.register; + + if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and + ispowerof2(p^.right^.value,power) then + begin + exprasmlist^.concat(new(paicpu, op_reg(A_TST, S_L, hreg1))); + getlabel(hl); + emitl(A_BPL,hl); + if (power = 1) then + exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L,1, hreg1))) + else + Begin + { optimize using ADDQ if possible! } + if (p^.right^.value-1) < 9 then + exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1))) + else + exprasmlist^.concat(new(paicpu, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1))); + end; + emitl(A_LABEL, hl); + if (power > 0) and (power < 9) then + exprasmlist^.concat(new(paicpu, op_const_reg(A_ASR, S_L,power, hreg1))) + else + begin + exprasmlist^.concat(new(paicpu, op_const_reg(A_MOVE,S_L,power, R_D0))); + exprasmlist^.concat(new(paicpu, op_reg_reg(A_ASR,S_L,R_D0, hreg1))); + end; + end + else + begin + { bring denominator to D1 } + { D1 is always free, it's } + { only used for temporary } + { purposes } + if (p^.right^.location.loc<>LOC_REGISTER) and + (p^.right^.location.loc<>LOC_CREGISTER) then + begin + del_reference(p^.right^.location.reference); + p^.left^.location.loc:=LOC_REGISTER; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1))); + end + else + begin + ungetregister32(p^.right^.location.register); + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1); + end; + + { on entering this section D1 should contain the divisor } + + if (aktoptprocessor = MC68020) then + begin + { Check if divisor is ZERO - if so call HALT_ERROR } + { with d0 = 200 (Division by zero!) } + getlabel(hl1); + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,R_D1))); + { if not zero then simply continue on } + emitl(A_BNE,hl1); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,200,R_D0))); + emitcall('FPC_HALT_ERROR',true); + emitl(A_LABEL,hl1); + if (p^.treetype = modn) then + Begin + reg := getregister32; + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,reg))); + getlabel(hl); + { here what we do is prepare the high register with the } + { correct sign. i.e we clear it, check if the low dword reg } + { which will participate in the division is signed, if so we} + { we extend the sign to the high doword register by inverting } + { all the bits. } + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,hreg1))); + emitl(A_BPL,hl); + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,reg))); + emitl(A_LABEL,hl); + { reg:hreg1 / d1 } + exprasmlist^.concat(new(paicpu,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1))); + { hreg1 already contains quotient } + { looking for remainder } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,reg,hreg1))); + ungetregister32(reg); + end + else + { simple division... } + Begin + { reg:hreg1 / d1 } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_DIVS,S_L,R_D1,hreg1))); + end; + end + else { MC68000 operations } + begin + { put numerator in d0 } + emit_reg_reg(A_MOVE,S_L,hreg1,R_D0); + { operation to perform on entry to both } + { routines... d0/d1 } + { return result in d0 } + if p^.treetype = divn then + emitcall('FPC_LONGDIV',true) + else + emitcall('FPC_LONGMOD',true); + emit_reg_reg(A_MOVE,S_L,R_D0,hreg1); + end; { endif } + end; + { this registers are always used when div/mod are present } + usedinproc:=usedinproc or ($800 shr word(R_D1)); + usedinproc:=usedinproc or ($800 shr word(R_D0)); + clear_location(p^.location); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hreg1; + end; + + +{***************************************************************************** + SecondShlShr +*****************************************************************************} + + { D6 used as scratch (ok) } + procedure secondshlshr(var p : ptree); + + var + hregister1,hregister2,hregister3 : tregister; + op : tasmop; + pushed : boolean; + begin + + secondpass(p^.left); + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + + { load left operators in a register } + if p^.left^.location.loc<>LOC_REGISTER then + begin + if p^.left^.location.loc=LOC_CREGISTER then + begin + hregister1:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, + hregister1); + end + else + begin + del_reference(p^.left^.location.reference); + hregister1:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), + hregister1))); + end; + end + else hregister1:=p^.left^.location.register; + + { determine operator } + if p^.treetype=shln then + op:=A_LSL + else + op:=A_LSR; + + { shifting by a constant directly decode: } + if (p^.right^.treetype=ordconstn) then + begin + if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31, + hregister1))) + else + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31, + R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(op,S_L,R_D6,hregister1))); + end; + p^.location.loc:=LOC_REGISTER; + p^.location.register:=hregister1; + end + else + begin + { load right operators in a register } + if p^.right^.location.loc<>LOC_REGISTER then + begin + if p^.right^.location.loc=LOC_CREGISTER then + begin + hregister2:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register, + hregister2); + end + else + begin + del_reference(p^.right^.location.reference); + hregister2:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference), + hregister2))); + end; + end + else hregister2:=p^.right^.location.register; + + + emit_reg_reg(op,S_L,hregister2,hregister1); + p^.location.register:=hregister1; + end; + { this register is always used when shl/shr are present } + usedinproc:=usedinproc or ($800 shr byte(R_D6)); + end; + +{***************************************************************************** + Secondunaryminus +*****************************************************************************} + + procedure secondunaryminus(var p : ptree); + + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + case p^.left^.location.loc of + LOC_REGISTER : begin + p^.location.register:=p^.left^.location.register; + exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register))); + end; + LOC_CREGISTER : begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.location.register, + p^.location.register); + exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register))); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.left^.location.reference); + { change sign of a floating point } + { in the case of emulation, get } + { a free register, and change sign } + { manually. } + { otherwise simply load into an FPU} + { register. } + if (p^.left^.resulttype^.deftype=floatdef) and + (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then + begin + { move to FPU } + floatload(pfloatdef(p^.left^.resulttype)^.typ, + p^.left^.location.reference,p^.location); + if (cs_fp_emulation) in aktmoduleswitches then + { if in emulation mode change sign manually } + exprasmlist^.concat(new(paicpu,op_const_reg(A_BCHG,S_L,31, + p^.location.fpureg))) + else + exprasmlist^.concat(new(paicpu,op_reg(A_FNEG,S_FX, + p^.location.fpureg))); + end + else + begin + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + exprasmlist^.concat(new(paicpu,op_reg(A_NEG,S_L,p^.location.register))); + end; + end; + LOC_FPU : begin + p^.location.loc:=LOC_FPU; + p^.location.fpureg := p^.left^.location.fpureg; + if (cs_fp_emulation) in aktmoduleswitches then + exprasmlist^.concat(new(paicpu,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg))) + else + exprasmlist^.concat(new(paicpu,op_reg(A_FNEG,S_FX,p^.location.fpureg))); + end; + end; +{ emitoverflowcheck;} + end; + + +{***************************************************************************** + SecondNot +*****************************************************************************} + + procedure secondnot(var p : ptree); + + const + flagsinvers : array[F_E..F_BE] of tresflags = + (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C, + F_A,F_AE,F_B,F_BE); + + var + hl : pasmlabel; + + begin + if (p^.resulttype^.deftype=orddef) and + (porddef(p^.resulttype)^.typ=bool8bit) then + begin + case p^.location.loc of + LOC_JUMP : begin + hl:=truelabel; + truelabel:=falselabel; + falselabel:=hl; + secondpass(p^.left); + maketojumpbool(p^.left); + hl:=truelabel; + truelabel:=falselabel; + falselabel:=hl; + end; + LOC_FLAGS : begin + secondpass(p^.left); + p^.location.resflags:=flagsinvers[p^.left^.location.resflags]; + end; + LOC_REGISTER : begin + secondpass(p^.left); + p^.location.register:=p^.left^.location.register; + exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register))); + end; + LOC_CREGISTER : begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, + p^.location.register); + exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register))); + end; + LOC_REFERENCE,LOC_MEM : begin + secondpass(p^.left); + del_reference(p^.left^.location.reference); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + if p^.left^.location.loc=LOC_CREGISTER then + emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, + p^.location.register) + else + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B, + newreference(p^.left^.location.reference), + p^.location.register))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_EOR,S_B,1,p^.location.register))); + end; + end; + end + else + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + + case p^.left^.location.loc of + LOC_REGISTER : begin + p^.location.register:=p^.left^.location.register; + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register))); + end; + LOC_CREGISTER : begin + p^.location.register:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register, + p^.location.register); + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register))); + end; + LOC_REFERENCE,LOC_MEM : + begin + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference), + p^.location.register))); + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register))); + end; + end; + {if p^.left^.location.loc=loc_register then + p^.location.register:=p^.left^.location.register + else + begin + del_locref(p^.left^.location); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_loc_reg(A_MOV,S_L, + p^.left^.location, + p^.location.register))); + end; + exprasmlist^.concat(new(paicpu,op_reg(A_NOT,S_L,p^.location.register)));} + + end; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.8 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.7 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.6 1999/11/18 15:34:44 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.5 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} diff --git a/befpc/compiler/cg68kmem.pas b/befpc/compiler/cg68kmem.pas new file mode 100644 index 0000000..355b827 --- /dev/null +++ b/befpc/compiler/cg68kmem.pas @@ -0,0 +1,740 @@ +{ + $Id: cg68kmem.pas,v 1.1.1.1 2001-07-23 17:15:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for in memory related nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kmem; +interface + + uses + tree; + + procedure secondloadvmt(var p : ptree); + procedure secondhnewn(var p : ptree); + procedure secondnewn(var p : ptree); + procedure secondhdisposen(var p : ptree); + procedure secondsimplenewdispose(var p : ptree); + procedure secondaddr(var p : ptree); + procedure seconddoubleaddr(var p : ptree); + procedure secondderef(var p : ptree); + procedure secondsubscriptn(var p : ptree); + procedure secondvecn(var p : ptree); + procedure secondselfn(var p : ptree); + procedure secondwith(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k; + + +{***************************************************************************** + SecondLoadVMT +*****************************************************************************} + + procedure secondloadvmt(var p : ptree); + begin + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE, + S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0), + p^.location.register))); + end; + + +{***************************************************************************** + SecondHNewN +*****************************************************************************} + + procedure secondhnewn(var p : ptree); + begin + end; + + +{***************************************************************************** + SecondNewN +*****************************************************************************} + + procedure secondnewn(var p : ptree); + var + pushed : tpushed; + r : preference; + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + p^.location.register:=p^.left^.location.register; + end + else + begin + pushusedregisters(pushed,$ff); + + { code copied from simplenewdispose PM } + { determines the size of the mem block } + push_int(ppointerdef(p^.resulttype)^.definition^.size); + + gettempofsizereference(target_os.size_of_pointer,p^.location.reference); + emitpushreferenceaddr(exprasmlist,p^.location.reference); + + emitcall('FPC_GETMEM',true); +{!!!!!!!} +(* if ppointerdef(p^.resulttype)^.definition^.needs_inittable then + begin + new(r); + reset_reference(r^); + r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_inittable_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + emitpushreferenceaddr(exprasmlist,p^.location.reference); + stringdispose(r^.symbol); + dispose(r); + emitcall('FPC_INITIALIZE',true); + end; *) + popusedregisters(pushed); + { may be load ESI } + maybe_loada5; + end; + if codegenerror then + exit; + end; + + +{***************************************************************************** + SecondDisposeN +*****************************************************************************} + + procedure secondhdisposen(var p : ptree); + begin + secondpass(p^.left); + if codegenerror then + exit; + clear_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + p^.location.reference.base:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.left^.location.register, + p^.location.reference.base))); + end; + LOC_MEM,LOC_REFERENCE : + begin + del_reference(p^.left^.location.reference); + p^.location.reference.base:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference), + p^.location.reference.base))); + end; + end; + end; + + +{***************************************************************************** + SecondNewDispose +*****************************************************************************} + + procedure secondsimplenewdispose(var p : ptree); + + + var + pushed : tpushed; + r : preference; + + begin + secondpass(p^.left); + if codegenerror then + exit; + + pushusedregisters(pushed,$ffff); + { determines the size of the mem block } + push_int(ppointerdef(p^.left^.resulttype)^.definition^.size); + + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + p^.left^.location.register,R_SPPUSH))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + + end; + + { call the mem handling procedures } + case p^.treetype of + simpledisposen: + begin + if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then + begin +{!!!!!!!} + +(* new(r); + reset_reference(r^); + r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L, + p^.left^.location.register))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + end; + emitcall('FPC_FINALIZE',true); *) + end; + emitcall('FPC_FREEMEM',true); + end; + simplenewn: + begin + emitcall('FPC_GETMEM',true); + if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then + begin +{!!!!!!!} + +(* new(r); + reset_reference(r^); + r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label)); + emitpushreferenceaddr(exprasmlist,r^); + { push pointer adress } + case p^.left^.location.loc of + LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L, + p^.left^.location.register))); + LOC_REFERENCE: + emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + end; + emitcall('FPC_INITIALIZE',true); *) + end; + end; + end; + popusedregisters(pushed); + { may be load ESI } + maybe_loada5; + end; + + +{***************************************************************************** + SecondAddr +*****************************************************************************} + + procedure secondaddr(var p : ptree); + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + p^.location.register:=getregister32; + {@ on a procvar means returning an address to the procedure that + is stored in it.} + { yes but p^.left^.symtableentry can be nil + for example on @self !! } + { symtableentry can be also invalid, if left is no tree node } + if (p^.left^.treetype=loadn) and + assigned(p^.left^.symtableentry) and + (p^.left^.symtableentry^.typ=varsym) and + (Pvarsym(p^.left^.symtableentry)^.definition^.deftype= + procvardef) then + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference), + p^.location.register))) + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_A0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + R_A0,p^.location.register))); + end; + { for use of other segments } + { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then + p^.location.segment:=p^.left^.location.reference.segment; + } + del_reference(p^.left^.location.reference); + end; + + +{***************************************************************************** + SecondDoubleAddr +*****************************************************************************} + + procedure seconddoubleaddr(var p : ptree); + begin + secondpass(p^.left); + p^.location.loc:=LOC_REGISTER; + del_reference(p^.left^.location.reference); + p^.location.register:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_A0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + R_A0,p^.location.register))); + end; + + +{***************************************************************************** + SecondDeRef +*****************************************************************************} + + procedure secondderef(var p : ptree); + var + hr : tregister; + + begin + secondpass(p^.left); + clear_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER : Begin + hr := getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + ungetregister(p^.left^.location.register); + end; + LOC_CREGISTER : begin + { ... and reserve one for the pointer } + hr:=getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + { LOC_REGISTER indicates that this is a + variable register which should not be freed. } +{ ungetregister(p^.left^.location.register); } + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ...and reserve one for the pointer } + hr:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_MOVE,S_L,newreference(p^.left^.location.reference), + hr))); + p^.location.reference.base:=hr; + end; + end; + end; + + +{***************************************************************************** + SecondSubScriptN +*****************************************************************************} + + procedure secondsubscriptn(var p : ptree); + var + hr: tregister; + + begin + + secondpass(p^.left); + + if codegenerror then + exit; + { classes must be dereferenced implicit } + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class then + begin + clear_reference(p^.location.reference); + case p^.left^.location.loc of + LOC_REGISTER: + begin + { move it to an address register...} + hr:=getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + { free register } + ungetregister(p^.left^.location.register); + end; + LOC_CREGISTER: + begin + { ... and reserve one for the pointer } + hr:=getaddressreg; + emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr); + p^.location.reference.base:=hr; + end; + else + begin + { free register } + del_reference(p^.left^.location.reference); + + { ... and reserve one for the pointer } + hr:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_MOVE,S_L,newreference(p^.left^.location.reference), + hr))); + p^.location.reference.base:=hr; + end; + end; + end + else + set_location(p^.location,p^.left^.location); + + inc(p^.location.reference.offset,p^.vs^.address); + end; + + +{***************************************************************************** + SecondVecN +*****************************************************************************} + + { used D0, D1 as scratch (ok) } + { arrays ... } + { Sets up the array and string } + { references . } + procedure secondvecn(var p : ptree); + + var + pushed : boolean; + ind : tregister; + _p : ptree; + + procedure calc_emit_mul; + + var + l1,l2 : longint; + + begin + l1:=p^.resulttype^.size; + case l1 of + 1 : p^.location.reference.scalefactor:=l1; + 2 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,ind))); + 4 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,ind))); + 8 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,3,ind))); + else + begin + if ispowerof2(l1,l2) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,l2,ind))) + else + begin + { use normal MC68000 signed multiply } + if (l1 >= -32768) and (l1 <= 32767) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_W,l1,ind))) + else + { use long MC68020 long multiply } + if (aktoptprocessor = MC68020) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_MULS,S_L,l1,ind))) + else + { MC68000 long multiply } + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,l1,R_D0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,ind,R_D1))); + emitcall('FPC_LONGMUL',true); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,ind))); + end; + end; + end; { else case } + end; { end case } + end; { calc_emit_mul } + + var + extraoffset : longint; + t : ptree; + hp : preference; + tai:paicpu; + reg: tregister; + + begin + secondpass(p^.left); + { RESULT IS IN p^.location.reference } + set_location(p^.location,p^.left^.location); + + { offset can only differ from 0 if arraydef } + if p^.left^.resulttype^.deftype=arraydef then + dec(p^.location.reference.offset, + p^.resulttype^.size* + parraydef(p^.left^.resulttype)^.lowrange); + + if p^.right^.treetype=ordconstn then + begin + { offset can only differ from 0 if arraydef } + if (p^.left^.resulttype^.deftype=arraydef) then + begin + if not(is_open_array(p^.left^.resulttype)) then + begin + if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or + (p^.right^.valueLOC_REFERENCE) and + (p^.location.loc<>LOC_MEM) then + CGMessage(cg_e_illegal_expression); + + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + case p^.right^.location.loc of + LOC_REGISTER : begin + ind:=p^.right^.location.register; + case p^.right^.resulttype^.size of + 1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ff,ind))); + 2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ffff,ind))); + end; + end; + + LOC_CREGISTER : begin + ind:=getregister32; + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind); + case p^.right^.resulttype^.size of + 1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ff,ind))); + 2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ffff,ind))); + end; + end; + LOC_FLAGS: + begin + ind:=getregister32; + exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,ind))); + end + else { else outer case } + begin + del_reference(p^.right^.location.reference); + ind:=getregister32; + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.right^.location.reference),ind))); + + {Booleans are stored in an 8 bit memory location, so + the use of MOVL is not correct.} + case p^.right^.resulttype^.size of + 1: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ff,ind))); + 2: exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ffff,ind))); + end; { end case } + end; { end else begin } + end; + + { produce possible range check code: } + if cs_check_range in aktlocalswitches then + begin + if p^.left^.resulttype^.deftype=arraydef then + begin + new(hp); + reset_reference(hp^); + parraydef(p^.left^.resulttype)^.genrangecheck; + hp^.symbol:=stringdup(parraydef(p^.left^.resulttype)^.getrangecheckstring); + emit_bounds_check(hp^,ind); + end; + end; + + { ------------------------ HANDLE INDEXING ----------------------- } + { In Motorola 680x0 mode, displacement can only be of 64K max. } + { Therefore instead of doing a direct displacement, we must first } + { load the new address into an address register. Therefore the } + { symbol is not used. } + if assigned(p^.location.reference.symbol) then + begin + if p^.location.reference.base <> R_NO then + CGMessage(cg_f_secondvecn_base_defined_twice); + p^.location.reference.base:=getaddressreg; + exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0), + p^.location.reference.base))); + stringdispose(p^.location.reference.symbol); + end; + + if (p^.location.reference.index=R_NO) then + begin + p^.location.reference.index:=ind; + calc_emit_mul; + { here we must check for the offset } + { and if out of bounds for the motorola } + { eg: out of signed d8 then reload index } + { with correct value. } + if p^.location.reference.offset > 127 then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind))); + p^.location.reference.offset := 0; + end + else if p^.location.reference.offset < -128 then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind))); + p^.location.reference.offset := 0; + end; + end + { if no index then allways get an address register !! PM } + else if p^.location.reference.base=R_NO then + begin + case p^.location.reference.scalefactor of + 2 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,p^.location.reference.index))); + 4 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,p^.location.reference.index))); + 8 : exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,3,p^.location.reference.index))); + end; + calc_emit_mul; + + { we must use address register to put index in base } + { compare with cgi386.pas } + + reg := getaddressreg; + p^.location.reference.base := reg; + + emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg); + ungetregister(p^.location.reference.index); + + p^.location.reference.index:=ind; + end + else + begin + reg := getaddressreg; + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_LEA,S_L,newreference(p^.location.reference), + reg))); + + ungetregister(p^.location.reference.base); + { the symbol offset is loaded, } + { so release the symbol name and set symbol } + { to nil } + stringdispose(p^.location.reference.symbol); + p^.location.reference.offset:=0; + calc_emit_mul; + p^.location.reference.base:=reg; + ungetregister32(p^.location.reference.index); + p^.location.reference.index:=ind; + end; + end; + end; + + +{***************************************************************************** + SecondSelfN +*****************************************************************************} + + procedure secondselfn(var p : ptree); + begin + clear_reference(p^.location.reference); + p^.location.reference.base:=R_A5; + end; + + +{***************************************************************************** + SecondWithN +*****************************************************************************} + + procedure secondwith(var p : ptree); + var + ref : treference; + symtable : psymtable; + i : longint; + + begin + if assigned(p^.left) then + begin + secondpass(p^.left); + ref.symbol:=nil; + gettempofsizereference(4,ref); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.left^.location.reference),R_A0))); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L, + R_A0,newreference(ref)))); + del_reference(p^.left^.location.reference); + { the offset relative to (%ebp) is only needed here! } + symtable:=p^.withsymtable; + for i:=1 to p^.tablecount do + begin + symtable^.datasize:=ref.offset; + symtable:=symtable^.next; + end; + + { p^.right can be optimize out !!! } + if p^.right<>nil then + secondpass(p^.right); + { clear some stuff } + ungetiftemp(ref); + end; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.15 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.14 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.13 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.12 1999/08/25 11:59:52 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/cg68kset.pas b/befpc/compiler/cg68kset.pas new file mode 100644 index 0000000..ecba68f --- /dev/null +++ b/befpc/compiler/cg68kset.pas @@ -0,0 +1,826 @@ +{ + $Id: cg68kset.pas,v 1.1.1.1 2001-07-23 17:15:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generate m68k assembler for in set/case nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cg68kset; +interface + + uses + tree; + + procedure secondsetelement(var p : ptree); + procedure secondin(var p : ptree); + procedure secondcase(var p : ptree); + + +implementation + + uses + globtype,systems,symconst, + cobjects,verbose,globals, + symtable,aasm,types, + hcodegen,temp_gen,pass_2, + cpubase,cga68k,tgen68k; + + const + bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L); + +{***************************************************************************** + SecondSetElement +*****************************************************************************} + + procedure secondsetelement(var p : ptree); + begin + { load first value in 32bit register } + secondpass(p^.left); + if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + emit_to_reg32(p^.left^.location.register); + + { also a second value ? } + if assigned(p^.right) then + begin + secondpass(p^.right); + if p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + emit_to_reg32(p^.right^.location.register); + end; + + { we doesn't modify the left side, we check only the type } + set_location(p^.location,p^.left^.location); + end; + + +{***************************************************************************** + SecondIn +*****************************************************************************} + + { could be built into secondadd but it } + { should be easy to read } + procedure secondin(var p : ptree); + + + type Tsetpart=record + range:boolean; {Part is a range.} + start,stop:byte; {Start/stop when range; Stop=element + when an element.} + end; + + var + pushed,ranges : boolean; + hr : tregister; + setparts:array[1..8] of Tsetpart; + i,numparts:byte; + {href,href2:Treference;} + l,l2 : pasmlabel; + hl,hl1 : pasmlabel; + hl2, hl3: pasmlabel; + opsize : topsize; + + + function swaplongint(l : longint): longint; + var + w1: word; + w2: word; + begin + w1:=l and $ffff; + w2:=l shr 16; + l:=swap(w2)+(longint(swap(w1)) shl 16); + swaplongint:=l; + end; + + function analizeset(Aset:Pconstset):boolean; + + type byteset=set of byte; + tlongset = array[0..7] of longint; + var compares,maxcompares:word; + someset : tlongset; + i:byte; + + begin + analizeset:=false; + ranges:=false; + numparts:=0; + compares:=0; + {Lots of comparisions take a lot of time, so do not allow + too much comparisions. 8 comparisions are, however, still + smalller than emitting the set.} + maxcompares:=5; + if cs_littlesize in aktglobalswitches then + maxcompares:=8; + move(ASet^,someset,32); + { On Big endian machines sets are stored } + { as INTEL Little-endian format, therefore } + { we must convert it to the correct format } +{$IFDEF BIG_ENDIAN} + for I:=0 to 7 do + someset[i]:=swaplongint(someset[i]); +{$ENDIF} + for i:=0 to 255 do + if i in byteset(someset) then + begin + if (numparts=0) or + (i<>setparts[numparts].stop+1) then + begin + {Set element is a separate element.} + inc(compares); + if compares>maxcompares then + exit; + inc(numparts); + setparts[numparts].range:=false; + setparts[numparts].stop:=i; + end + else + {Set element is part of a range.} + if not setparts[numparts].range then + begin + {Transform an element into a range.} + setparts[numparts].range:=true; + setparts[numparts].start:= + setparts[numparts].stop; + setparts[numparts].stop:=i; + inc(compares); + if compares>maxcompares then + exit; + end + else + begin + {Extend a range.} + setparts[numparts].stop:=i; + {A range of two elements can better + be checked as two separate ones. + When extending a range, our range + becomes larger than two elements.} + ranges:=true; + end; + end; + analizeset:=true; + end; { end analizeset } + + begin + if psetdef(p^.right^.resulttype)^.settype=smallset then + begin + if p^.left^.treetype=ordconstn then + begin + { only compulsory } + secondpass(p^.left); + secondpass(p^.right); + if codegenerror then + exit; + p^.location.resflags:=F_NE; + { Because of the Endian of the m68k, we have to consider this as a } + { normal set and load it byte per byte, otherwise we will never get } + { the correct result. } + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER : + begin + emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1); + exprasmlist^.concat(new(paicpu, + op_const_reg(A_AND,S_L, 1 shl (p^.left^.value and 31),R_D1))); + end; + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference( + p^.right^.location.reference),R_D1))); + exprasmlist^.concat(new(paicpu,op_const_reg( + A_AND,S_L,1 shl (p^.left^.value and 31) ,R_D1))); + end; + end; + del_reference(p^.right^.location.reference); + end + else + begin + { calculate both operators } + { the complex one first } + firstcomplex(p); + secondpass(p^.left); + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p^.left); + secondpass(p^.right); + if pushed then + restore(p^.left); + { of course not commutative } + if p^.swaped then + swaptree(p); + { load index into register } + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + hr:=p^.left^.location.register; + else + begin + { Small sets are always 32 bit values, there is no } + { way they can be anything else, so no problems here} + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.left^.location.reference),R_D1))); + hr:=R_D1; + del_reference(p^.left^.location.reference); + end; + end; + case p^.right^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : exprasmlist^.concat(new(paicpu, op_reg_reg(A_BTST,S_L,hr,p^.right^.location.register))); + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference), + R_D0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_BTST,S_L,hr,R_D0))); + del_reference(p^.right^.location.reference); + end; + end; + { support carry routines } + { sets the carry flags according to the result of BTST } + { i.e the Z flag. } + getlabel(hl); + emitl(A_BNE,hl); + { leave all bits unchanged except Carry = 0 } + exprasmlist^.concat(new(paicpu, op_const_reg(A_AND, S_B, $FE, R_CCR))); + getlabel(hl1); + emitl(A_BRA,hl1); + emitl(A_LABEL, hl); + { set carry to 1 } + exprasmlist^.concat(new(paicpu, op_const_reg(A_OR, S_B, $01, R_CCR))); + emitl(A_LABEL, hl1); + { end support carry routines } + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_C; + end; + end + else { //// NOT a small set //// } + begin + if p^.left^.treetype=ordconstn then + begin + { only compulsory } + secondpass(p^.left); + secondpass(p^.right); + if codegenerror then + exit; + p^.location.resflags:=F_NE; + inc(p^.right^.location.reference.offset,(p^.left^.value div 32)*4); + exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE, S_L, + newreference(p^.right^.location.reference), R_D1))); + exprasmlist^.concat(new(paicpu, op_const_reg(A_AND, S_L, + 1 shl (p^.left^.value mod 32),R_D1))); + del_reference(p^.right^.location.reference); + end + else + begin + if (p^.right^.treetype=setconstn) and + analizeset(p^.right^.value_set) then + begin + {It gives us advantage to check for the set elements + separately instead of using the SET_IN_BYTE procedure. + To do: Build in support for LOC_JUMP.} + secondpass(p^.left); + {We won't do a second pass on p^.right, because + this will emit the constant set.} + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + 255,p^.left^.location.register))); + else + Begin + { Because of the m68k endian, then we must LOAD normally the } + { value into a register first, all depending on the source } + { size! } + opsize:=S_NO; + case integer(p^.left^.resulttype^.size) of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + else + internalerror(19); + end; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.left^.location.reference),R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + 255,R_D0))); + end; + end; + {Get a label to jump to the end.} + p^.location.loc:=LOC_FLAGS; + {It's better to use the zero flag when there are no ranges.} + if ranges then + p^.location.resflags:=F_C + else + p^.location.resflags:=F_E; + {href.symbol := nil; + clear_reference(href);} + getlabel(l); + {href.symbol:=stringdup(lab2str(l));} + for i:=1 to numparts do + if setparts[i].range then + begin + {Check if left is in a range.} + {Get a label to jump over the check.} + {href2.symbol := nil; + clear_reference(href2);} + getlabel(l2); + {href.symbol:=stringdup(lab2str(l2));} + if setparts[i].start=setparts[i].stop-1 then + begin + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].start,p^.left^.location.register))); + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].start,R_D0))); +{ exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B, + setparts[i].start,newreference(p^.left^.location.reference))));} + end; + {Result should be in carry flag when ranges are used.} + { Here the m68k does not affect any flag except the } + { flag which is OR'ed } + if ranges then + exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR))); + {If found, jump to end.} + emitl(A_BEQ,l); + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop,p^.left^.location.register))); + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop,R_D0))); +{ exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B, + setparts[i].stop,newreference(p^.left^.location.reference))));} + end; + {Result should be in carry flag when ranges are used.} + { Here the m68k does not affect any flag except the } + { flag which is OR'ed } + if ranges then + exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR))); + {If found, jump to end.} + emitl(A_BEQ,l); + end + else + begin + if setparts[i].start<>0 then + begin + {We only check for the lower bound if it is > 0, because + set elements lower than 0 do nt exist.} + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].start,p^.left^.location.register))); + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].start,R_D0))); +{ exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B, + setparts[i].start,newreference(p^.left^.location.reference)))); } + end; + {If lower, jump to next check.} + emitl(A_BCS,l2); + end; + if setparts[i].stop<>255 then + begin + {We only check for the high bound if it is < 255, because + set elements higher than 255 do nt exist.} + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop+1,p^.left^.location.register))); + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop+1,R_D0))); +{ exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B, + setparts[i].stop+1,newreference(p^.left^.location.reference))));} + end; { end case } + {If higher, element is in set.} + emitl(A_BCS,l); + end + else + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_B,$01,R_CCR))); + emitl(A_JMP,l); + end; + end; + {Emit the jump over label.} + exprasmlist^.concat(new(pai_label,init(l2))); + end + else + begin + {Emit code to check if left is an element.} + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop,p^.left^.location.register))); + else +{ exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_B, + setparts[i].stop,newreference(p^.left^.location.reference))));} + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_W, + setparts[i].stop,R_D0))); + end; + {Result should be in carry flag when ranges are used.} + if ranges then + exprasmlist^.concat(new(paicpu, op_const_reg(A_OR,S_B,$01,R_CCR))); + {If found, jump to end.} + emitl(A_BEQ,l); + end; + if ranges then + { clear carry flag } + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_B,$FE,R_CCR))); + {To compensate for not doing a second pass.} + stringdispose(p^.right^.location.reference.symbol); + {Now place the end label.} + exprasmlist^.concat(new(pai_label,init(l))); + end + else + begin + { calculate both operators } + { the complex one first } + firstcomplex(p); + secondpass(p^.left); + { + unnecessary !! PM + set_location(p^.location,p^.left^.location);} + { are too few registers free? } + pushed:=maybe_push(p^.right^.registers32,p); + secondpass(p^.right); + if pushed then restore(p); + { of course not commutative } + if p^.swaped then + swaptree(p); + { SET_IN_BYTE is an inline assembler procedure instead } + { of a normal procedure, which is *MUCH* faster } + { Parameters are passed by registers, and FLAGS are set } + { according to the result. } + { a0 = address of set } + { d0.b = value to compare with } + { CARRY SET IF FOUND ON EXIT } + loadsetelement(p^.left); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L, + newreference(p^.right^.location.reference),R_A0)));; +{ emitpushreferenceaddr(p^.right^.location.reference);} + del_reference(p^.right^.location.reference); + emitcall('FPC_SET_IN_BYTE',true); + { ungetiftemp(p^.right^.location.reference); } + p^.location.loc:=LOC_FLAGS; + p^.location.resflags:=F_C; + end; + end; + end; + end; + + +{***************************************************************************** + SecondCase +*****************************************************************************} + + procedure secondcase(var p : ptree); + + var + with_sign : boolean; + opsize : topsize; + jmp_gt,jmp_le,jmp_lee : tasmop; + hp : ptree; + { register with case expression } + hregister : tregister; + endlabel,elselabel : pasmlabel; + + { true, if we can omit the range check of the jump table } + jumptable_no_range : boolean; + + procedure gentreejmp(p : pcaserecord); + + var + lesslabel,greaterlabel : pasmlabel; + + begin + emitl(A_LABEL,p^._at); + { calculate labels for left and right } + if (p^.less=nil) then + lesslabel:=elselabel + else + lesslabel:=p^.less^._at; + if (p^.greater=nil) then + greaterlabel:=elselabel + else + greaterlabel:=p^.greater^._at; + { calculate labels for left and right } + { no range label: } + if p^._low=p^._high then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._low,hregister))); + if greaterlabel=lesslabel then + begin + emitl(A_BNE,lesslabel); + end + else + begin + emitl(jmp_le,lesslabel); + emitl(jmp_gt,greaterlabel); + end; + emitl(A_JMP,p^.statement); + end + else + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._low,hregister))); + emitl(jmp_le,lesslabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,p^._high,hregister))); + emitl(jmp_gt,greaterlabel); + emitl(A_JMP,p^.statement); + end; + if assigned(p^.less) then + gentreejmp(p^.less); + if assigned(p^.greater) then + gentreejmp(p^.greater); + end; + + procedure genlinearlist(hp : pcaserecord); + + var + first : boolean; + last : longint; + + procedure genitem(t : pcaserecord); + + begin + if assigned(t^.less) then + genitem(t^.less); + if t^._low=t^._high then + begin + if (t^._low-last > 0) and (t^._low-last < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister))) + else + if (t^._low-last = 0) then + exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,hregister))) + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-last,hregister))); + last:=t^._low; + + emitl(A_BEQ,t^.statement); + end + else + begin + { it begins with the smallest label, if the value } + { is even smaller then jump immediately to the } + { ELSE-label } + if first then + begin + if (t^._low-1 > 0) and (t^._low < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister))) + else + if t^._low-1=0 then + exprasmlist^.concat(new(paicpu,op_reg(A_TST,opsize,hregister))) + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-1,hregister))); + if t^._low = 0 then + emitl(A_BLE,elselabel) + else + emitl(jmp_lee,elselabel); + end + { if there is no unused label between the last and the } + { present label then the lower limit can be checked } + { immediately. else check the range in between: } + else if (t^._low-last>1)then + + begin + if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister))) + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister))); + emitl(jmp_lee,elselabel); + end; + exprasmlist^.concat(new(paicpu,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister))); + emitl(jmp_lee,t^.statement); + + last:=t^._high; + end; + first:=false; + if assigned(t^.greater) then + genitem(t^.greater); + end; + + var + hr : tregister; + + begin + { case register is modified by the list evalution } + if (p^.left^.location.loc=LOC_CREGISTER) then + begin + hr:=getregister32; + end; + last:=0; + first:=true; + genitem(hp); + emitl(A_JMP,elselabel); + end; + + procedure genjumptable(hp : pcaserecord;min_,max_ : longint); + + var + table : pasmlabel; + last : longint; + hr : preference; + + procedure genitem(t : pcaserecord); + + var + i : longint; + + begin + if assigned(t^.less) then + genitem(t^.less); + { fill possible hole } + for i:=last+1 to t^._low-1 do + datasegment^.concat(new(pai_const_symbol,init(elselabel))); + for i:=t^._low to t^._high do + datasegment^.concat(new(pai_const_symbol,init(t^.statement))); + last:=t^._high; + if assigned(t^.greater) then + genitem(t^.greater); + end; + + begin + if not(jumptable_no_range) then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,min_,hregister))); + { case expr less than min_ => goto elselabel } + emitl(jmp_le,elselabel); + exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,opsize,max_,hregister))); + emitl(jmp_gt,elselabel); + end; + getlabel(table); + { extend with sign } + if opsize=S_W then + begin + { word to long - unsigned } + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hregister))); + end + else if opsize=S_B then + begin + { byte to long - unsigned } + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hregister))); + end; + new(hr); + reset_reference(hr^); + hr^.symbol:=stringdup(table^.name); + hr^.offset:=(-min_)*4; + + { add scalefactor *4 to index } + exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,2,hregister))); +{ hr^.scalefactor:=4; } + hr^.base:=getaddressreg; + emit_reg_reg(A_MOVE,S_L,hregister,hr^.base); + exprasmlist^.concat(new(paicpu,op_ref(A_JMP,S_NO,hr))); +{ if not(cs_littlesize in aktglobalswitches^ ) then + datasegment^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4))); } + datasegment^.concat(new(pai_label,init(table))); + last:=min_; + genitem(hp); + if hr^.base <> R_NO then ungetregister(hr^.base); + { !!!!!!! + if not(cs_littlesize in aktglobalswitches^ ) then + exprasmlist^.concat(new(paicpu,op_const(A_ALIGN,S_NO,4))); + } + end; + + var + lv,hv,min_label,max_label,labels : longint; + max_linear_list : longint; + + begin + getlabel(endlabel); + getlabel(elselabel); + with_sign:=is_signed(p^.left^.resulttype); + if with_sign then + begin + jmp_gt:=A_BGT; + jmp_le:=A_BLT; + jmp_lee:=A_BLE; + end + else + begin + jmp_gt:=A_BHI; + jmp_le:=A_BCS; + jmp_lee:=A_BLS; + end; + cleartempgen; + secondpass(p^.left); + { determines the size of the operand } + { determines the size of the operand } + opsize:=bytes2Sxx[p^.left^.resulttype^.size]; + { copy the case expression to a register } + { copy the case expression to a register } + case p^.left^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : hregister:=p^.left^.location.register; + LOC_MEM,LOC_REFERENCE : begin + del_reference(p^.left^.location.reference); + hregister:=getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize,newreference( + p^.left^.location.reference),hregister))); + end; + else internalerror(2002); + end; + { now generate the jumps } + if cs_optimize in aktglobalswitches then + begin + { procedures are empirically passed on } + { consumption can also be calculated } + { but does it pay on the different } + { processors? } + { moreover can the size only be appro- } + { ximated as it is not known if rel8, } + { rel16 or rel32 jumps are used } + min_label:=case_get_min(p^.nodes); + max_label:=case_get_max(p^.nodes); + labels:=case_count_labels(p^.nodes); + { can we omit the range check of the jump table } + getrange(p^.left^.resulttype,lv,hv); + jumptable_no_range:=(lv=min_label) and (hv=max_label); + + { optimize for size ? } + if cs_littlesize in aktglobalswitches then + begin + if (labels<=2) or ((max_label-min_label)>3*labels) then + { a linear list is always smaller than a jump tree } + genlinearlist(p^.nodes) + else + { if the labels less or more a continuum then } + genjumptable(p^.nodes,min_label,max_label); + end + else + begin + if jumptable_no_range then + max_linear_list:=4 + else + max_linear_list:=2; + + if (labels<=max_linear_list) then + genlinearlist(p^.nodes) + else + begin + if ((max_label-min_label)>4*labels) then + begin + if labels>16 then + gentreejmp(p^.nodes) + else + genlinearlist(p^.nodes); + end + else + genjumptable(p^.nodes,min_label,max_label); + end; + end; + end + else + { it's always not bad } + genlinearlist(p^.nodes); + + { now generate the instructions } + hp:=p^.right; + while assigned(hp) do + begin + cleartempgen; + secondpass(hp^.right); + emitl(A_JMP,endlabel); + hp:=hp^.left; + end; + emitl(A_LABEL,elselabel); + { ... and the else block } + if assigned(p^.elseblock) then + begin + cleartempgen; + secondpass(p^.elseblock); + end; + emitl(A_LABEL,endlabel); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.11 2000/02/09 13:22:49 peter + * log truncated + + Revision 1.10 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.9 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} + diff --git a/befpc/compiler/cga68k.pas b/befpc/compiler/cga68k.pas new file mode 100644 index 0000000..0fa31f6 --- /dev/null +++ b/befpc/compiler/cga68k.pas @@ -0,0 +1,1423 @@ +{ + $Id: cga68k.pas,v 1.1.1.1 2001-07-23 17:15:45 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Carl Eric Codere + + This unit generates 68000 (or better) assembler from the parse tree + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cga68k; + + interface + + uses + globtype,cobjects,tree,cpubase,aasm,symtable,symconst; + + procedure emitl(op : tasmop;var l : pasmlabel); + procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); + procedure emitcall(const routine:string;add_to_externals : boolean); + procedure emitloadord2reg(location:Tlocation;orddef:Porddef; + destreg:Tregister;delloc:boolean); + procedure emit_to_reg32(var hr:tregister); + procedure loadsetelement(var p : ptree); + { produces jumps to true respectively false labels using boolean expressions } + procedure maketojumpbool(p : ptree); + procedure emitoverflowcheck(p: ptree); + procedure push_int(l : longint); + function maybe_push(needed : byte;p : ptree) : boolean; + procedure restore(p : ptree); + procedure emit_push_mem(const ref : treference); + procedure emitpushreferenceaddr(list : paasmoutput;const ref : treference); + procedure copystring(const dref,sref : treference;len : byte); + procedure concatcopy(source,dest : treference;size : longint;delsource : boolean); + { see implementation } + procedure maybe_loada5; + procedure emit_bounds_check(hp: treference; index: tregister); + procedure loadstring(p:ptree); + procedure decransiref(const ref : treference); + + procedure floatload(t : tfloattype;const ref : treference; var location:tlocation); + { return a float op_size from a floatb type } + { also does some error checking for problems } + function getfloatsize(t: tfloattype): topsize; + procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference); +{ procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize); + procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); } + + procedure firstcomplex(p : ptree); + + { generate stackframe for interrupt procedures } + procedure generate_interrupt_stackframe_entry; + procedure generate_interrupt_stackframe_exit; + { generate entry code for a procedure.} + procedure genentrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; + stackframe:longint; + var parasize:longint;var nostackframe:boolean; + inlined : boolean); + { generate the exit code for a procedure. } + procedure genexitcode(list : paasmoutput;parasize:longint; + nostackframe,inlined:boolean); + + procedure removetemps(list : paasmoutput;p : plinkedlist); + procedure releasedata(p : plinkedlist); + +{$ifdef test_dest_loc} +const { used to avoid temporary assignments } + dest_loc_known : boolean = false; + in_dest_loc : boolean = false; + dest_loc_tree : ptree = nil; + +var dest_loc : tlocation; + +procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); + +{$endif test_dest_loc} + + + implementation + + uses + systems,globals,verbose,files,types,pbase, + tgen68k,hcodegen,temp_gen,ppu +{$ifdef GDB} + ,gdb +{$endif} + ; + + + { + procedure genconstadd(size : topsize;l : longint;const str : string); + + begin + if l=0 then + else if l=1 then + exprasmlist^.concat(new(pai68k,op_A_INC,size,str) + else if l=-1 then + exprasmlist^.concat(new(pai68k,op_A_INC,size,str) + else + exprasmlist^.concat(new(pai68k,op_ADD,size,'$'+tostr(l)+','+str); + end; + } + procedure copystring(const dref,sref : treference;len : byte); + + var + pushed : tpushed; + + begin + pushusedregisters(pushed,$ffff); +{ emitpushreferenceaddr(dref); } +{ emitpushreferenceaddr(sref); } +{ push_int(len); } + { This speeds up from 116 cycles to 24 cycles on the 68000 } + { when passing register parameters! } + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(dref),R_A1))); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(sref),R_A0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,len,R_D0))); + emitcall('FPC_STRCOPY',true); + maybe_loada5; + popusedregisters(pushed); + end; + + + procedure decransiref(const ref : treference); + begin + emitpushreferenceaddr(exprasmlist,ref); + emitcall('FPC_ANSISTR_DECR_REF',true); + end; + + procedure loadstring(p:ptree); + begin + case p^.right^.resulttype^.deftype of + stringdef : begin + { load a string ... } + { here two possible choices: } + { if it is a char, then simply } + { load 0 length string } + if (p^.right^.treetype=stringconstn) and + (str_length(p^.right)=0) then + exprasmlist^.concat(new(paicpu,op_const_ref( + A_MOVE,S_B,0,newreference(p^.left^.location.reference)))) + else + copystring(p^.left^.location.reference,p^.right^.location.reference, + min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len)); + end; + orddef : begin + if p^.right^.treetype=ordconstn then + begin + { offset 0: length of string } + { offset 1: character } + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_W,1*256+p^.right^.value, + newreference(p^.left^.location.reference)))) + end + else + begin + { not so elegant (goes better with extra register } + if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + exprasmlist^.concat(new(paicpu,op_reg_reg( + A_MOVE,S_B,p^.right^.location.register,R_D0))); + ungetregister32(p^.right^.location.register); + end + else + begin + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_MOVE,S_B,newreference(p^.right^.location.reference),R_D0))); + del_reference(p^.right^.location.reference); + end; + { alignment can cause problems } + { add length of string to ref } + exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,1, + newreference(p^.left^.location.reference)))); +(* if abs(p^.left^.location.reference.offset) >= 1 then + Begin *) + { temporarily decrease offset } + Inc(p^.left^.location.reference.offset); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_B,R_D0, + newreference(p^.left^.location.reference)))); + Dec(p^.left^.location.reference.offset); + { restore offset } +(* end + else + Begin + Comment(V_Debug,'SecondChar2String() internal error.'); + internalerror(34); + end; *) + end; + end; + else + CGMessage(type_e_mismatch); + end; + end; + + + + + + procedure restore(p : ptree); + + var + hregister : tregister; + + begin + if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then + hregister:=getregister32 + else + hregister:=getaddressreg; + + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_SPPULL,hregister))); + if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then + begin + p^.location.register:=hregister; + end + else + begin + reset_reference(p^.location.reference); + p^.location.reference.base:=hregister; + set_location(p^.left^.location,p^.location); + end; + end; + + function maybe_push(needed : byte;p : ptree) : boolean; + + var + pushed : boolean; + begin + if (needed>usablereg32) or (needed > usableaddress) then + begin + if (p^.location.loc=LOC_REGISTER) or + (p^.location.loc=LOC_CREGISTER) then + begin + pushed:=true; + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.location.register,R_SPPUSH))); + ungetregister32(p^.location.register); + end + else + if ((p^.location.loc=LOC_MEM) or(p^.location.loc=LOC_REFERENCE)) and + ((p^.location.reference.base<>R_NO) or + (p^.location.reference.index<>R_NO)) then + begin + del_reference(p^.location.reference); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.location.reference), + R_A0))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_SPPUSH))); + pushed:=true; + end + else pushed:=false; + end + else pushed:=false; + maybe_push:=pushed; + end; + + + { emit out of range check for arrays and sets} + procedure emit_bounds_check(hp: treference; index: tregister); + { index = index of array to check } + { memory of range check information for array } + var + hl : pasmlabel; + begin + if (aktoptprocessor = MC68020) then + begin + exprasmlist^.concat(new(paicpu, op_ref_reg(A_CMP2,S_L,newreference(hp),index))); + getlabel(hl); + emitl(A_BCC, hl); + exprasmlist^.concat(new(paicpu, op_const_reg(A_MOVE,S_L,201,R_D0))); + emitcall('FPC_HALT_ERROR',true); + emitl(A_LABEL, hl); + end + else + begin + exprasmlist^.concat(new(paicpu, op_ref_reg(A_LEA,S_L,newreference(hp), R_A1))); + exprasmlist^.concat(new(paicpu, op_reg_reg(A_MOVE, S_L, index, R_D0))); + emitcall('FPC_RE_BOUNDS_CHECK',true); + end; + end; + + + procedure emit_to_reg32(var hr:tregister); + begin +(* case hr of + R_AX..R_DI : begin + hr:=reg16toreg32(hr); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hr))); + end; + R_AL..R_DL : begin + hr:=reg8toreg32(hr); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hr))); + end; + R_AH..R_DH : begin + hr:=reg8toreg32(hr); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff00,hr))); + end; + end; *) + end; + + function getfloatsize(t: tfloattype): topsize; + begin + case t of + s32real: getfloatsize := S_FS; + s64real: getfloatsize := S_FL; + s80real: getfloatsize := S_FX; +{$ifdef extdebug} + else {else case } + begin + Comment(V_Debug,' getfloatsize() trying to get unknown size.'); + internalerror(12); + end; +{$endif} + end; + end; + + procedure emitl(op : tasmop;var l : pasmlabel); + + begin + if op=A_LABEL then + exprasmlist^.concat(new(pai_label,init(l))) + else + exprasmlist^.concat(new(pai_labeled,init(op,l))) + end; + + procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); + + begin + if (reg1 <> reg2) or (i <> A_MOVE) then + exprasmlist^.concat(new(paicpu,op_reg_reg(i,s,reg1,reg2))); + end; + + + procedure emitcall(const routine:string;add_to_externals : boolean); + + begin + exprasmlist^.concat(new(paicpu,op_csymbol(A_JSR,S_NO,newcsymbol(routine,0)))); + {!!!!! + if add_to_externals and + not (cs_compilesystem in aktmoduleswitches) then + concat_external(routine,EXT_NEAR); + } + end; + + + procedure maketojumpbool(p : ptree); + + begin + if p^.error then + exit; + if (p^.resulttype^.deftype=orddef) and + (porddef(p^.resulttype)^.typ=bool8bit) then + begin + if is_constboolnode(p) then + begin + if p^.value<>0 then + emitl(A_JMP,truelabel) + else emitl(A_JMP,falselabel); + end + else + begin + case p^.location.loc of + LOC_CREGISTER,LOC_REGISTER : begin + exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_B,p^.location.register))); + ungetregister32(p^.location.register); + emitl(A_BNE,truelabel); + emitl(A_JMP,falselabel); + end; + LOC_MEM,LOC_REFERENCE : begin + exprasmlist^.concat(new(paicpu,op_ref( + A_TST,S_B,newreference(p^.location.reference)))); + del_reference(p^.location.reference); + emitl(A_BNE,truelabel); + emitl(A_JMP,falselabel); + end; + LOC_FLAGS : begin + emitl(flag_2_jmp[p^.location.resflags],truelabel); + emitl(A_JMP,falselabel); + end; + end; + end; + end + else + CGMessage(type_e_mismatch); + end; + + procedure emitoverflowcheck(p: ptree); + + var + hl : pasmlabel; + + begin + if cs_check_overflow in aktlocalswitches then + begin + getlabel(hl); + if not ((p^.resulttype^.deftype=pointerdef) or + ((p^.resulttype^.deftype=orddef) and + (porddef(p^.resulttype)^.typ in [u16bit,u32bit,u8bit,uchar,bool8bit]))) then + emitl(A_BVC,hl) + else + emitl(A_BCC,hl); + emitcall('FPC_OVERFLOW',true); + emitl(A_LABEL,hl); + end; + end; + + + procedure push_int(l : longint); + + begin + if (l = 0) and (aktoptprocessor = MC68020) then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + R_D6, R_SPPUSH))); + end + else + if not(cs_littlesize in aktglobalswitches) and (l >= -128) and (l <= 127) then + begin + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ,S_L,l,R_D6))); + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D6,R_SPPUSH))); + end + else + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,l,R_SPPUSH))); + end; + + procedure emit_push_mem(const ref : treference); + { Push a value on to the stack } + begin + if ref.isintvalue then + push_int(ref.offset) + else + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(ref),R_SPPUSH))); + end; + + + { USES REGISTER R_A1 } + procedure emitpushreferenceaddr(list : paasmoutput;const ref : treference); + { Push a pointer to a value on the stack } + begin + if ref.isintvalue then + push_int(ref.offset) + else + begin + if (ref.base=R_NO) and (ref.index=R_NO) then + list^.concat(new(paicpu,op_ref(A_PEA,S_L, + newreference(ref)))) + else if (ref.base=R_NO) and (ref.index<>R_NO) and + (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then + list^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L, + ref.index,R_SPPUSH))) + else if (ref.base<>R_NO) and (ref.index=R_NO) and + (ref.offset=0) and (ref.symbol=nil) then + list^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,ref.base,R_SPPUSH))) + else + begin + list^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(ref),R_A1))); + list^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A1,R_SPPUSH))); + end; + end; + end; + + { This routine needs to be further checked to see if it works correctly } + { because contrary to the intel version, all large set elements are read } + { as 32-bit value_str, and then decomposed to find the correct byte. } + + { CHECKED : Depending on the result size, if reference, a load may be } + { required on word, long or byte. } + procedure loadsetelement(var p : ptree); + + var + hr : tregister; + opsize : topsize; + + begin + { copy the element in the d0.b register, slightly complicated } + case p^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + hr:=p^.location.register; + emit_reg_reg(A_MOVE,S_L,hr,R_D0); + ungetregister32(hr); + end; + else + begin + { This is quite complicated, because of the endian on } + { the m68k! } + opsize:=S_NO; + case integer(p^.resulttype^.size) of + 1 : opsize:=S_B; + 2 : opsize:=S_W; + 4 : opsize:=S_L; + else + internalerror(19); + end; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,opsize, + newreference(p^.location.reference),R_D0))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + 255,R_D0))); +{ + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L, + newreference(p^.location.reference),R_D0))); } +{ exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, + $ff,R_D0))); } + del_reference(p^.location.reference); + end; + end; + end; + + + procedure generate_interrupt_stackframe_entry; + begin + { save the registers of an interrupt procedure } + + { .... also the segment registers } + end; + + procedure generate_interrupt_stackframe_exit; + + begin + { restore the registers of an interrupt procedure } + end; + + + procedure genentrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; + stackframe:longint; + var parasize:longint;var nostackframe:boolean; + inlined : boolean); +{Generates the entry code for a procedure.} + +var hs:string; + hp:Pused_unit; + unitinits:taasmoutput; +{$ifdef GDB} + stab_function_name:Pai_stab_function_name; +{$endif GDB} +begin + if potype_proginit=aktprocsym^.definition^.proctypeoption then + begin + {Init the stack checking.} + if (cs_check_stack in aktlocalswitches) and + (target_info.target=target_m68k_linux) then + begin + procinfo^.aktentrycode^.insert(new(paicpu, + op_csymbol(A_JSR,S_NO,newcsymbol('FPC_INIT_STACK_CHECK',0)))); + end + else + { The main program has already allocated its stack - so we simply compare } + { with a value of ZERO, and the comparison will directly check! } + if (cs_check_stack in aktlocalswitches) then + begin + procinfo^.aktentrycode^.insert(new(paicpu,op_csymbol(A_JSR,S_NO, + newcsymbol('FPC_STACKCHECK',0)))); + procinfo^.aktentrycode^.insert(new(paicpu,op_const_reg(A_MOVE,S_L, + 0,R_D0))); + end; + + + unitinits.init; + + {Call the unit init procedures.} + hp:=pused_unit(usedunits.first); + while assigned(hp) do + begin + { call the unit init code and make it external } + if (hp^.u^.flags and uf_init)<>0 then + begin + unitinits.concat(new(paicpu,op_csymbol(A_JSR,S_NO,newcsymbol('INIT$$'+hp^.u^.modulename^,0)))); + end; + hp:=pused_unit(hp^.next); + end; + procinfo^.aktentrycode^.insertlist(@unitinits); + unitinits.done; + end; + + { a constructor needs a help procedure } + if potype_constructor=aktprocsym^.definition^.proctypeoption then + begin + if procinfo^._class^.is_class then + begin + procinfo^.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel))); + procinfo^.aktentrycode^.insert(new(paicpu,op_csymbol(A_JSR,S_NO, + newcsymbol('FPC_NEW_CLASS',0)))); + end + else + begin + procinfo^.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel))); + procinfo^.aktentrycode^.insert(new(paicpu,op_csymbol(A_JSR,S_NO, + newcsymbol('FPC_HELP_CONSTRUCTOR',0)))); + procinfo^.aktentrycode^.insert(new(paicpu,op_const_reg(A_MOVE,S_L,procinfo^._class^.vmt_offset,R_D0))); + end; + end; + { don't load ESI, does the caller } + +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + list^.insert(new(pai_force_line,init)); +{$endif GDB} + + { omit stack frame ? } + if procinfo^.framepointer=stack_pointer then + begin + CGMessage(cg_d_stackframe_omited); + nostackframe:=true; + if (aktprocsym^.definition^.proctypeoption=potype_unitinit) or + (aktprocsym^.definition^.proctypeoption=potype_proginit) or + (aktprocsym^.definition^.proctypeoption=potype_unitfinalize) then + parasize:=0 + else + parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.call_offset; + end + else + begin + if (aktprocsym^.definition^.proctypeoption=potype_unitinit) or + (aktprocsym^.definition^.proctypeoption=potype_proginit) or + (aktprocsym^.definition^.proctypeoption=potype_unitfinalize) then + parasize:=0 + else + parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.call_offset-8; + nostackframe:=false; + if stackframe<>0 then + begin + if cs_littlesize in aktglobalswitches then + begin + if (cs_check_stack in aktlocalswitches) and + (target_info.target<>target_m68k_linux) then + begin + { If only not in main program, do we setup stack checking } + if (aktprocsym^.definition^.proctypeoption<>potype_proginit) then + Begin + procinfo^.aktentrycode^.insert(new(paicpu, + op_csymbol(A_JSR,S_NO,newcsymbol('FPC_STACKCHECK',0)))); + procinfo^.aktentrycode^.insert(new(paicpu,op_const_reg(A_MOVE,S_L,stackframe,R_D0))); + end; + end; + { to allocate stack space } + { here we allocate space using link signed 16-bit version } + { -ve offset to allocate stack space! } + if (stackframe > -32767) and (stackframe < 32769) then + procinfo^.aktentrycode^.insert(new(paicpu,op_reg_const(A_LINK,S_W,R_A6,-stackframe))) + else + CGMessage(cg_e_stacklimit_in_local_routine); + end + else + begin + { Not to complicate the code generator too much, and since some } + { of the systems only support this format, the stackframe cannot } + { exceed 32K in size. } + if (stackframe > -32767) and (stackframe < 32769) then + begin + procinfo^.aktentrycode^.insert(new(paicpu,op_const_reg(A_SUB,S_L,stackframe,R_SP))); + { IF only NOT in main program do we check the stack normally } + if (cs_check_stack in aktlocalswitches) and + (aktprocsym^.definition^.proctypeoption<>potype_proginit) then + begin + procinfo^.aktentrycode^.insert(new(paicpu, + op_csymbol(A_JSR,S_NO,newcsymbol('FPC_STACKCHECK',0)))); + procinfo^.aktentrycode^.insert(new(paicpu,op_const_reg(A_MOVE,S_L, + stackframe,R_D0))); + end; + procinfo^.aktentrycode^.insert(new(paicpu,op_reg_reg(A_MOVE,S_L,R_SP,R_A6))); + procinfo^.aktentrycode^.insert(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH))); + end + else + CGMessage(cg_e_stacklimit_in_local_routine); + end; + end {endif stackframe<>0 } + else + begin + procinfo^.aktentrycode^.insert(new(paicpu,op_reg_reg(A_MOVE,S_L,R_SP,R_A6))); + procinfo^.aktentrycode^.insert(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH))); + end; + end; + + + if po_interrupt in aktprocsym^.definition^.procoptions then + generate_interrupt_stackframe_entry; + + {proc_names.insert(aktprocsym^.definition^.mangledname);} + + if (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or + ((procinfo^._class<>nil) and (procinfo^._class^.owner^. + symtabletype=globalsymtable)) then + make_global:=true; + hs:=proc_names.get; + +{$IfDef GDB} + if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then + stab_function_name := new(pai_stab_function_name,init(strpnew(hs))); +{$EndIf GDB} + + + while hs<>'' do + begin + if make_global then + procinfo^.aktentrycode^.insert(new(pai_symbol,initname_global(hs,0))) + else + procinfo^.aktentrycode^.insert(new(pai_symbol,initname(hs,0))); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + if target_os.use_function_relative_addresses then + list^.insert(new(pai_stab_function_name,init(strpnew(hs)))); + + { This is not a nice solution to save the name, change it and restore when done } + { not only not nice but also completely wrong !!! (PM) } + { aktprocsym^.setname(hs); + list^.insert(new(pai_stabs,init(aktprocsym^.stabstring))); } + end; +{$endif GDB} + hs:=proc_names.get; + end; +{$ifdef GDB} + + if (cs_debuginfo in aktmoduleswitches) then + begin + if target_os.use_function_relative_addresses then + procinfo^.aktentrycode^.insert(stab_function_name); + if make_global or ((procinfo^.flags and pi_is_global) <> 0) then + aktprocsym^.is_global := True; + aktprocsym^.isstabwritten:=true; + end; +{$endif GDB} + { Alignment required for Motorola } + procinfo^.aktentrycode^.insert(new(pai_align,init(2))); +end; + +{Generate the exit code for a procedure.} +procedure genexitcode(list : paasmoutput;parasize:longint; nostackframe,inlined:boolean); +var hr:Preference; {This is for function results.} + op:Tasmop; + s:Topsize; + +begin + { !!!! insert there automatic destructors } + + procinfo^.aktexitcode^.insert(new(pai_label,init(aktexitlabel))); + + { call the destructor help procedure } + if potype_destructor=aktprocsym^.definition^.proctypeoption then + begin + if procinfo^._class^.is_class then + begin + procinfo^.aktexitcode^.insert(new(paicpu,op_csymbol(A_JSR,S_NO, + newcsymbol('FPC_DISPOSE_CLASS',0)))); + end + else + begin + procinfo^.aktexitcode^.insert(new(paicpu,op_csymbol(A_JSR,S_NO, + newcsymbol('FPC_HELP_DESTRUCTOR',0)))); + procinfo^.aktexitcode^.insert(new(paicpu,op_const_reg(A_MOVE,S_L,procinfo^._class^.vmt_offset,R_D0))); + end; + end; + + { call __EXIT for main program } + { ????????? } + if (potype_proginit=aktprocsym^.definition^.proctypeoption) and + (target_info.target<>target_m68k_PalmOS) then + begin + procinfo^.aktexitcode^.concat(new(paicpu,op_csymbol(A_JSR,S_NO,newcsymbol('FPC_DO_EXIT',0)))); + end; + + { handle return value } + if po_assembler in aktprocsym^.definition^.procoptions then + if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then + begin + if procinfo^.retdef<>pdef(voiddef) then + begin + if procinfo^.funcret_state<>vs_assigned then + CGMessage(sym_w_function_result_not_set); + new(hr); + reset_reference(hr^); + hr^.offset:=procinfo^.retoffset; + hr^.base:=procinfo^.framepointer; + if (procinfo^.retdef^.deftype in [orddef,enumdef]) then + begin + case procinfo^.retdef^.size of + 4 : procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hr,R_D0))); + 2 : procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,hr,R_D0))); + 1 : procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,hr,R_D0))); + end; + end + else + if (procinfo^.retdef^.deftype in [pointerdef,enumdef,procvardef]) or + ((procinfo^.retdef^.deftype=setdef) and + (psetdef(procinfo^.retdef)^.settype=smallset)) then + procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hr,R_D0))) + else + if (procinfo^.retdef^.deftype=floatdef) then + begin + if pfloatdef(procinfo^.retdef)^.typ=f32bit then + begin + { Isnt this missing ? } + procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hr,R_D0))); + end + else + begin + { how the return value is handled } + { if single value, then return in d0, otherwise return in } + { TRUE FPU register (does not apply in emulation mode) } + if (pfloatdef(procinfo^.retdef)^.typ = s32real) then + begin + procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE, + S_L,hr,R_D0))) + end + else + begin + if cs_fp_emulation in aktmoduleswitches then + procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_MOVE, + S_L,hr,R_D0))) + else + procinfo^.aktexitcode^.concat(new(paicpu,op_ref_reg(A_FMOVE, + getfloatsize(pfloatdef(procinfo^.retdef)^.typ),hr,R_FP0))); + end; + end; + end + else + dispose(hr); + end + end + else + begin + { successful constructor deletes the zero flag } + { and returns self in accumulator } + procinfo^.aktexitcode^.concat(new(pai_label,init(quickexitlabel))); + { eax must be set to zero if the allocation failed !!! } + procinfo^.aktexitcode^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A5,R_D0))); + { faster then OR on mc68000/mc68020 } + procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_TST,S_L,R_D0))); + end; + procinfo^.aktexitcode^.concat(new(pai_label,init(aktexit2label))); + if not(nostackframe) then + procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_UNLK,S_NO,R_A6))); + + { at last, the return is generated } + + if po_interrupt in aktprocsym^.definition^.procoptions then + generate_interrupt_stackframe_exit + else + if (parasize=0) or (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then + {Routines with the poclearstack flag set use only a ret.} + { also routines with parasize=0 } + procinfo^.aktexitcode^.concat(new(paicpu,op_none(A_RTS,S_NO))) + else + { return with immediate size possible here } + { signed! } + if (aktoptprocessor = MC68020) and (parasize < $7FFF) then + procinfo^.aktexitcode^.concat(new(paicpu,op_const( + A_RTD,S_NO,parasize))) + { manually restore the stack } + else + begin + { We must pull the PC Counter from the stack, before } + { restoring the stack pointer, otherwise the PC would } + { point to nowhere! } + + { save the PC counter (pop it from the stack) } + procinfo^.aktexitcode^.concat(new(paicpu,op_reg_reg( + A_MOVE,S_L,R_SPPULL,R_A0))); + { can we do a quick addition ... } + if (parasize > 0) and (parasize < 9) then + procinfo^.aktexitcode^.concat(new(paicpu,op_const_reg( + A_ADD,S_L,parasize,R_SP))) + else { nope ... } + procinfo^.aktexitcode^.concat(new(paicpu,op_const_reg( + A_ADD,S_L,parasize,R_SP))); + { endif } + { restore the PC counter (push it on the stack) } + procinfo^.aktexitcode^.concat(new(paicpu,op_reg_reg( + A_MOVE,S_L,R_A0,R_SPPUSH))); + procinfo^.aktexitcode^.concat(new(paicpu,op_none( + A_RTS,S_NO))) + end; +{$ifdef GDB} + if cs_debuginfo in aktmoduleswitches then + begin + aktprocsym^.concatstabto(procinfo^.aktexitcode); + if assigned(procinfo^._class) then + procinfo^.aktexitcode^.concat(new(pai_stabs,init(strpnew( + '"$t:v'+procinfo^._class^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.selfpointer_offset))))); + + if (porddef(aktprocsym^.definition^.retdef) <> voiddef) then + procinfo^.aktexitcode^.concat(new(pai_stabs,init(strpnew( + '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.retoffset))))); + + procinfo^.aktexitcode^.concat(new(pai_stabn,init(strpnew('192,0,0,' + +aktprocsym^.definition^.mangledname)))); + + procinfo^.aktexitcode^.concat(new(pai_stabn,init(strpnew('224,0,0,' + +lab2str(aktexit2label))))); + end; +{$endif GDB} +end; + + + { USES REGISTERS R_A0 AND R_A1 } + { maximum size of copy is 65535 bytes } + procedure concatcopy(source,dest : treference;size : longint;delsource : boolean); + + var + ecxpushed : boolean; + helpsize : longint; + i : byte; + reg8,reg32 : tregister; + swap : boolean; + hregister : tregister; + iregister : tregister; + jregister : tregister; + hp1 : treference; + hp2 : treference; + hl : pasmlabel; + hl2: pasmlabel; + + begin + { this should never occur } + if size > 65535 then + internalerror(0); + hregister := getregister32; + if delsource then + del_reference(source); + + { from 12 bytes movs is being used } + if (size<=8) or (not(cs_littlesize in aktglobalswitches) and (size<=12)) then + begin + helpsize:=size div 4; + { move a dword x times } + for i:=1 to helpsize do + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(source),hregister))); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,hregister,newreference(dest)))); + inc(source.offset,4); + inc(dest.offset,4); + dec(size,4); + end; + { move a word } + if size>1 then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(source),hregister))); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_W,hregister,newreference(dest)))); + inc(source.offset,2); + inc(dest.offset,2); + dec(size,2); + end; + { move a single byte } + if size>0 then + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(source),hregister))); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_B,hregister,newreference(dest)))); + end + + end + else + begin + if (usableaddress > 1) then + begin + iregister := getaddressreg; + jregister := getaddressreg; + end + else + if (usableaddress = 1) then + begin + iregister := getaddressreg; + jregister := R_A1; + end + else + begin + iregister := R_A0; + jregister := R_A1; + end; + { reference for move (An)+,(An)+ } + reset_reference(hp1); + hp1.base := iregister; { source register } + hp1.direction := dir_inc; + reset_reference(hp2); + hp2.base := jregister; + hp2.direction := dir_inc; + { iregister = source } + { jregister = destination } + + + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(source),iregister))); + exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(dest),jregister))); + + { double word move only on 68020+ machines } + { because of possible alignment problems } + { use fast loop mode } + if (aktoptprocessor=MC68020) then + begin + helpsize := size - size mod 4; + size := size mod 4; + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,helpsize div 4,hregister))); + getlabel(hl2); + emitl(A_BRA,hl2); + getlabel(hl); + emitl(A_LABEL,hl); + exprasmlist^.concat(new(paicpu,op_ref_ref(A_MOVE,S_L,newreference(hp1),newreference(hp2)))); + emitl(A_LABEL,hl2); + exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister))); + if size > 1 then + begin + dec(size,2); + exprasmlist^.concat(new(paicpu,op_ref_ref(A_MOVE,S_W,newreference(hp1), newreference(hp2)))); + end; + if size = 1 then + exprasmlist^.concat(new(paicpu,op_ref_ref(A_MOVE,S_B,newreference(hp1), newreference(hp2)))); + end + else + begin + { Fast 68010 loop mode with no possible alignment problems } + helpsize := size; + exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,helpsize,hregister))); + getlabel(hl2); + emitl(A_BRA,hl2); + getlabel(hl); + emitl(A_LABEL,hl); + exprasmlist^.concat(new(paicpu,op_ref_ref(A_MOVE,S_B,newreference(hp1),newreference(hp2)))); + emitl(A_LABEL,hl2); + exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister))); + end; + + { restore the registers that we have just used olny if they are used! } + if jregister = R_A1 then + hp2.base := R_NO; + if iregister = R_A0 then + hp1.base := R_NO; + del_reference(hp1); + del_reference(hp2); + end; + + { loading SELF-reference again } + maybe_loada5; + + if delsource then + ungetiftemp(source); + + ungetregister32(hregister); + end; + + + procedure emitloadord2reg(location:Tlocation;orddef:Porddef; + destreg:Tregister;delloc:boolean); + + {A lot smaller and less bug sensitive than the original unfolded loads.} + + var tai:paicpu; + r:Preference; + + begin + case location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + case orddef^.typ of + u8bit: begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,location.register,destreg))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ANDI,S_L,$FF,destreg))); + end; + s8bit: begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,location.register,destreg))); + if (aktoptprocessor <> MC68020) then + begin + { byte to word } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,destreg))); + { word to long } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,destreg))); + end + else { 68020+ and later only } + exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,destreg))); + end; + u16bit: begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,location.register,destreg))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ANDI,S_L,$FFFF,destreg))); + end; + s16bit: begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,location.register,destreg))); + { word to long } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,destreg))); + end; + u32bit: + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,location.register,destreg))); + s32bit: + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,location.register,destreg))); + end; + if delloc then + ungetregister(location.register); + end; + LOC_REFERENCE: + begin + r:=newreference(location.reference); + case orddef^.typ of + u8bit: begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,r,destreg))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ANDI,S_L,$FF,destreg))); + end; + s8bit: begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,r,destreg))); + if (aktoptprocessor <> MC68020) then + begin + { byte to word } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,destreg))); + { word to long } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,destreg))); + end + else { 68020+ and later only } + exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,destreg))); + end; + u16bit: begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,r,destreg))); + exprasmlist^.concat(new(paicpu,op_const_reg(A_ANDI,S_L,$ffff,destreg))); + end; + s16bit: begin + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,r,destreg))); + { word to long } + exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,destreg))); + end; + u32bit: + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,destreg))); + s32bit: + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,r,destreg))); + end; + if delloc then + del_reference(location.reference); + end + else + internalerror(6); + end; + end; + + + { if necessary A5 is reloaded after a call} + procedure maybe_loada5; + + var + hp : preference; + p : pprocinfo; + i : longint; + + begin + if assigned(procinfo^._class) then + begin + if lexlevel>normal_function_level then + begin + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.framepointer_offset; + hp^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,R_A5))); + p:=procinfo^.parent; + for i:=3 to lexlevel-1 do + begin + new(hp); + reset_reference(hp^); + hp^.offset:=p^.framepointer_offset; + hp^.base:=R_A5; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,R_A5))); + p:=p^.parent; + end; + new(hp); + reset_reference(hp^); + hp^.offset:=p^.selfpointer_offset; + hp^.base:=R_A5; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,R_A5))); + end + else + begin + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.selfpointer_offset; + hp^.base:=procinfo^.framepointer; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,hp,R_A5))); + end; + end; + end; + + + (***********************************************************************) + (* PROCEDURE FLOATLOAD *) + (* Description: This routine is to be called each time a location *) + (* must be set to LOC_FPU and a value loaded into a FPU register. *) + (* *) + (* Remark: The routine sets up the register field of LOC_FPU correctly*) + (***********************************************************************) + + procedure floatload(t : tfloattype;const ref : treference; var location:tlocation); + + var + op : tasmop; + s : topsize; + + begin + { no emulation } + case t of + s32real : s := S_FS; + s64real : s := S_FL; + s80real : s := S_FX; + else + begin + CGMessage(cg_f_unknown_float_type); + end; + end; { end case } + location.loc := LOC_FPU; + if not ((cs_fp_emulation) in aktmoduleswitches) then + begin + location.fpureg := getfloatreg; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,s,newreference(ref),location.fpureg))) + end + else + { handle emulation } + begin + if t = s32real then + begin + location.fpureg := getregister32; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(ref),location.fpureg))) + end + else + { other floating types are not supported in emulation mode } + CGMessage(sym_e_type_id_not_defined); + end; + end; + +{ procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); + + begin + case t of + s32real : begin + op:=A_FSTP; + s:=S_FS; + end; + s64real : begin + op:=A_FSTP; + s:=S_FL; + end; + s80real : begin + op:=A_FSTP; + s:=S_FX; + end; + s64bit : begin + op:=A_FISTP; + s:=S_IQ; + end; + else internalerror(17); + end; + end; } + + + { stores an FPU value to memory } + { location:tlocation used to free up FPU register } + { ref: destination of storage } + procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference); + + var + op : tasmop; + s : topsize; + + begin + if location.loc <> LOC_FPU then + InternalError(34); + { no emulation } + case t of + s32real : s := S_FS; + s64real : s := S_FL; + s80real : s := S_FX; + else + begin + CGMessage(cg_f_unknown_float_type); + end; + end; { end case } + if not ((cs_fp_emulation) in aktmoduleswitches) then + begin + { This permits the mixing of emulation and non-emulation routines } + { only possible for REAL = SINGLE value_str } + if not (location.fpureg in [R_FP0..R_FP7]) then + Begin + if s = S_FS then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref)))) + else + internalerror(255); + end + else + exprasmlist^.concat(new(paicpu,op_reg_ref(A_FMOVE,s,location.fpureg,newreference(ref)))); + ungetregister(location.fpureg); + end + else + { handle emulation } + begin + if t = s32real then + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref)))); + ungetregister32(location.fpureg); + end + else + { other floating types are not supported in emulation mode } + CGMessage(sym_e_type_id_not_defined); + end; + location.fpureg:=R_NO; { no register in LOC_FPU now } + end; + + procedure firstcomplex(p : ptree); + + var + hp : ptree; + + begin + { always calculate boolean AND and OR from left to right } + if ((p^.treetype=orn) or (p^.treetype=andn)) and + (p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ=bool8bit) then + p^.swaped:=false + else if (p^.left^.registers32 selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.36 1999/11/06 14:34:18 peter + * truncated log to 20 revs + + Revision 1.35 1999/09/27 23:44:48 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.34 1999/09/16 23:05:51 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.33 1999/09/16 11:34:54 pierre + * typo correction + + Revision 1.32 1999/08/25 11:59:54 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/cgai386.pas b/befpc/compiler/cgai386.pas new file mode 100644 index 0000000..2527b1d --- /dev/null +++ b/befpc/compiler/cgai386.pas @@ -0,0 +1,4165 @@ +{ + $Id: cgai386.pas,v 1.1.1.1 2001-07-23 17:15:47 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Helper routines for the i386 code generator + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} + +unit cgai386; + + interface + + uses + cobjects,tree, + cpubase,cpuasm, + symconst,symtable,aasm; + +{$define TESTGETTEMP to store const that + are written into temps for later release PM } + + function def_opsize(p1:pdef):topsize; + function def2def_opsize(p1,p2:pdef):topsize; + function def_getreg(p1:pdef):tregister; + function makereg8(r:tregister):tregister; + function makereg16(r:tregister):tregister; + function makereg32(r:tregister):tregister; + + procedure emitlab(var l : pasmlabel); + procedure emitjmp(c : tasmcond;var l : pasmlabel); + procedure emit_flag2reg(flag:tresflags;hregister:tregister); + + procedure emit_none(i : tasmop;s : topsize); + + procedure emit_const(i : tasmop;s : topsize;c : longint); + procedure emit_reg(i : tasmop;s : topsize;reg : tregister); + procedure emit_ref(i : tasmop;s : topsize;ref : preference); + + procedure emit_const_reg(i : tasmop;s : topsize;c : longint;reg : tregister); + procedure emit_const_ref(i : tasmop;s : topsize;c : longint;ref : preference); + procedure emit_ref_reg(i : tasmop;s : topsize;ref : preference;reg : tregister); + procedure emit_reg_ref(i : tasmop;s : topsize;reg : tregister;ref : preference); + procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); + + procedure emit_const_reg_reg(i : tasmop;s : topsize;c : longint;reg1,reg2 : tregister); + procedure emit_reg_reg_reg(i : tasmop;s : topsize;reg1,reg2,reg3 : tregister); + + + procedure emit_sym(i : tasmop;s : topsize;op : pasmsymbol); + procedure emit_sym_ofs(i : tasmop;s : topsize;op : pasmsymbol;ofs : longint); + procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;reg : tregister); + procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;ref : preference); + + procedure emitcall(const routine:string); + + procedure emit_mov_loc_ref(const t:tlocation;const ref:treference;siz:topsize;freetemp:boolean); + procedure emit_mov_loc_reg(const t:tlocation;reg:tregister); + procedure emit_mov_ref_reg64(r : treference;rl,rh : tregister); + procedure emit_lea_loc_ref(const t:tlocation;const ref:treference;freetemp:boolean); + procedure emit_lea_loc_reg(const t:tlocation;reg:tregister;freetemp:boolean); + procedure emit_push_loc(const t:tlocation); + + { pushes qword location to the stack } + procedure emit_pushq_loc(const t : tlocation); + procedure release_qword_loc(const t : tlocation); + + { remove non regvar registers in loc from regs (in the format } + { pushusedregisters uses) } + procedure remove_non_regvars_from_loc(const t: tlocation; var regs: byte); + { releases the registers of a location } + procedure release_loc(const t : tlocation); + + procedure emit_pushw_loc(const t:tlocation); + procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean); + procedure emit_to_mem(var p:ptree); + procedure emit_to_reg16(var hr:tregister); + procedure emit_to_reg32(var hr:tregister); + procedure emit_mov_reg_loc(reg: TRegister; const t:tlocation); + procedure emit_movq_reg_loc(reghigh,reglow: TRegister;t:tlocation); + + procedure copyshortstring(const dref,sref : treference;len : byte; + loadref, del_sref: boolean); + procedure loadansistring(p : ptree); + + procedure finalize(t : pdef;const ref : treference;is_already_ref : boolean); + procedure incrstringref(t : pdef;const ref : treference); + procedure decrstringref(t : pdef;const ref : treference); + + function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean; + procedure push_int(l : longint); + procedure emit_push_mem(const ref : treference); + procedure emitpushreferenceaddr(const ref : treference); + procedure pushsetelement(p : ptree); + procedure restore(p : ptree;isint64 : boolean); + procedure push_value_para(p:ptree;inlined,is_cdecl:boolean; + para_offset:longint;alignment : longint); + +{$ifdef TEMPS_NOT_PUSH} + { does the same as restore/ , but uses temp. space instead of pushing } + function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean; + procedure restorefromtemp(p : ptree;isint64 : boolean); +{$endif TEMPS_NOT_PUSH} + + procedure floatload(t : tfloattype;const ref : treference); + procedure floatstore(t : tfloattype;const ref : treference); + procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize); + procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); + + procedure maybe_loadesi; + procedure maketojumpbool(p : ptree); + procedure emitloadord2reg(const location:Tlocation;orddef:Porddef;destreg:Tregister;delloc:boolean); + procedure emitoverflowcheck(p:ptree); + procedure emitrangecheck(p:ptree;todef:pdef); + procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean); + procedure firstcomplex(p : ptree); + + procedure genentrycode(alist : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; + stackframe:longint; + var parasize:longint;var nostackframe:boolean; + inlined : boolean); + procedure genexitcode(alist : paasmoutput;parasize:longint; + nostackframe,inlined:boolean); + + { if a unit doesn't have a explicit init/final code, } + { we've to generate one, if the units has ansistrings } + { in the interface or implementation } + procedure genimplicitunitfinal(alist : paasmoutput); + procedure genimplicitunitinit(alist : paasmoutput); +{$ifdef test_dest_loc} + +const + { used to avoid temporary assignments } + dest_loc_known : boolean = false; + in_dest_loc : boolean = false; + dest_loc_tree : ptree = nil; + +var + dest_loc : tlocation; + +procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); + +{$endif test_dest_loc} + + + implementation + + uses + strings,globtype,systems,globals,verbose,files,types,pbase, + tgeni386,temp_gen,hcodegen,ppu +{$ifdef GDB} + ,gdb +{$endif} +{$ifndef NOTARGETWIN32} + ,t_win32 +{$endif} + ; + + +{***************************************************************************** + Helpers +*****************************************************************************} + + function def_opsize(p1:pdef):topsize; + begin + case p1^.size of + 1 : def_opsize:=S_B; + 2 : def_opsize:=S_W; + 4 : def_opsize:=S_L; + else + internalerror(78); + end; + end; + + + function def2def_opsize(p1,p2:pdef):topsize; + var + o1 : topsize; + begin + case p1^.size of + 1 : o1:=S_B; + 2 : o1:=S_W; + 4 : o1:=S_L; + { I don't know if we need it (FK) } + 8 : o1:=S_L; + else + internalerror(78); + end; + if assigned(p2) then + begin + case p2^.size of + 1 : o1:=S_B; + 2 : begin + if o1=S_B then + o1:=S_BW + else + o1:=S_W; + end; + 4,8: + begin + case o1 of + S_B : o1:=S_BL; + S_W : o1:=S_WL; + end; + end; + end; + end; + def2def_opsize:=o1; + end; + + + function def_getreg(p1:pdef):tregister; + begin + case p1^.size of + 1 : def_getreg:=reg32toreg8(getregister32); + 2 : def_getreg:=reg32toreg16(getregister32); + 4 : def_getreg:=getregister32; + else + internalerror(78); + end; + end; + + + function makereg8(r:tregister):tregister; + begin + case r of + R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP : + makereg8:=reg32toreg8(r); + R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : + makereg8:=reg16toreg8(r); + R_AL,R_BL,R_CL,R_DL : + makereg8:=r; + end; + end; + + + function makereg16(r:tregister):tregister; + begin + case r of + R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP : + makereg16:=reg32toreg16(r); + R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : + makereg16:=r; + R_AL,R_BL,R_CL,R_DL : + makereg16:=reg8toreg16(r); + end; + end; + + + function makereg32(r:tregister):tregister; + begin + case r of + R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP : + makereg32:=r; + R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : + makereg32:=reg16toreg32(r); + R_AL,R_BL,R_CL,R_DL : + makereg32:=reg8toreg32(r); + end; + end; + + +{***************************************************************************** + Emit Assembler +*****************************************************************************} + + procedure emitlab(var l : pasmlabel); + begin + if not l^.is_set then + exprasmlist^.concat(new(pai_label,init(l))) + else + internalerror(7453984); + end; + +{$ifdef nojmpfix} + procedure emitjmp(c : tasmcond;var l : pasmlabel); + var + ai : Paicpu; + begin + if c=C_None then + exprasmlist^.concat(new(paicpu,op_sym(A_JMP,S_NO,l))) + else + begin + ai:=new(paicpu,op_sym(A_Jcc,S_NO,l)); + ai^.SetCondition(c); + ai^.is_jmp:=true; + exprasmlist^.concat(ai); + end; + end; +{$else nojmpfix} + procedure emitjmp(c : tasmcond;var l : pasmlabel); + var + ai : Paicpu; + begin + if c=C_None then + ai := new(paicpu,op_sym(A_JMP,S_NO,l)) + else + begin + ai:=new(paicpu,op_sym(A_Jcc,S_NO,l)); + ai^.SetCondition(c); + end; + ai^.is_jmp:=true; + exprasmlist^.concat(ai); + end; +{$endif nojmpfix} + + procedure emit_flag2reg(flag:tresflags;hregister:tregister); + var + ai : paicpu; + hreg : tregister; + begin + hreg:=makereg8(hregister); + ai:=new(paicpu,op_reg(A_Setcc,S_B,hreg)); + ai^.SetCondition(flag_2_cond[flag]); + exprasmlist^.concat(ai); + if hreg<>hregister then + begin + if hregister in regset16bit then + emit_to_reg16(hreg) + else + emit_to_reg32(hreg); + end; + end; + + + procedure emit_none(i : tasmop;s : topsize); + begin + exprasmlist^.concat(new(paicpu,op_none(i,s))); + end; + + procedure emit_reg(i : tasmop;s : topsize;reg : tregister); + begin + exprasmlist^.concat(new(paicpu,op_reg(i,s,reg))); + end; + + procedure emit_ref(i : tasmop;s : topsize;ref : preference); + begin + exprasmlist^.concat(new(paicpu,op_ref(i,s,ref))); + end; + + procedure emit_const(i : tasmop;s : topsize;c : longint); + begin + exprasmlist^.concat(new(paicpu,op_const(i,s,c))); + end; + + procedure emit_const_reg(i : tasmop;s : topsize;c : longint;reg : tregister); + begin + exprasmlist^.concat(new(paicpu,op_const_reg(i,s,c,reg))); + end; + + procedure emit_const_ref(i : tasmop;s : topsize;c : longint;ref : preference); + begin + exprasmlist^.concat(new(paicpu,op_const_ref(i,s,c,ref))); + end; + + procedure emit_ref_reg(i : tasmop;s : topsize;ref : preference;reg : tregister); + begin + exprasmlist^.concat(new(paicpu,op_ref_reg(i,s,ref,reg))); + end; + + procedure emit_reg_ref(i : tasmop;s : topsize;reg : tregister;ref : preference); + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(i,s,reg,ref))); + end; + + procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); + begin + if (reg1<>reg2) or (i<>A_MOV) then + exprasmlist^.concat(new(paicpu,op_reg_reg(i,s,reg1,reg2))); + end; + + procedure emit_const_reg_reg(i : tasmop;s : topsize;c : longint;reg1,reg2 : tregister); + begin + exprasmlist^.concat(new(paicpu,op_const_reg_reg(i,s,c,reg1,reg2))); + end; + + procedure emit_reg_reg_reg(i : tasmop;s : topsize;reg1,reg2,reg3 : tregister); + begin + exprasmlist^.concat(new(paicpu,op_reg_reg_reg(i,s,reg1,reg2,reg3))); + end; + + procedure emit_sym(i : tasmop;s : topsize;op : pasmsymbol); + begin + exprasmlist^.concat(new(paicpu,op_sym(i,s,op))); + end; + + procedure emit_sym_ofs(i : tasmop;s : topsize;op : pasmsymbol;ofs : longint); + begin + exprasmlist^.concat(new(paicpu,op_sym_ofs(i,s,op,ofs))); + end; + + procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;reg : tregister); + begin + exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(i,s,op,ofs,reg))); + end; + + procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;ref : preference); + begin + exprasmlist^.concat(new(paicpu,op_sym_ofs_ref(i,s,op,ofs,ref))); + end; + + procedure emitcall(const routine:string); + begin + exprasmlist^.concat(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol(routine)))); + end; + + { only usefull in startup code } + procedure emitinsertcall(const routine:string); + begin + exprasmlist^.insert(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol(routine)))); + end; + + + procedure emit_mov_loc_ref(const t:tlocation;const ref:treference;siz:topsize;freetemp:boolean); + var + hreg : tregister; + pushedeax : boolean; + + begin + pushedeax:=false; + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,siz, + t.register,newreference(ref)))); + ungetregister32(t.register); { the register is not needed anymore } + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + emit_const_ref(A_MOV,siz, + t.reference.offset,newreference(ref)) + else + begin + case siz of + S_B : begin + { we can't do a getregister in the code generator } + { without problems!!! } + if usablereg32>0 then + hreg:=reg32toreg8(getregister32) + else + begin + emit_reg(A_PUSH,S_L,R_EAX); + pushedeax:=true; + hreg:=R_AL; + end; + end; + S_W : hreg:=R_DI; + S_L : hreg:=R_EDI; + end; +{$ifndef noAllocEdi} + if hreg in [R_DI,R_EDI] then + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,siz, + newreference(t.reference),hreg); + del_reference(t.reference); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,siz, + hreg,newreference(ref)))); + if siz=S_B then + begin + if pushedeax then + emit_reg(A_POP,S_L,R_EAX) + else + ungetregister(hreg); + end; +{$ifndef noAllocEdi} + if hreg in [R_DI,R_EDI] then + ungetregister32(R_EDI); +{$endif noAllocEdi} + { we can release the registers } + { but only AFTER the MOV! Important for the optimizer! + (JM)} + del_reference(ref); + end; + if freetemp then + ungetiftemp(t.reference); + end; + else + internalerror(330); + end; + end; + + + procedure emit_mov_loc_reg(const t:tlocation;reg:tregister); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + emit_reg_reg(A_MOV,S_L,t.register,reg); + ungetregister32(t.register); { the register is not needed anymore } + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + emit_const_reg(A_MOV,S_L, + t.reference.offset,reg) + else + begin + emit_ref_reg(A_MOV,S_L, + newreference(t.reference),reg); + end; + end; + else + internalerror(330); + end; + end; + + procedure emit_mov_reg_loc(reg: TRegister; const t:tlocation); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + emit_reg_reg(A_MOV,RegSize(Reg), + reg,t.register); + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + internalerror(334) + else + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,RegSize(Reg), + Reg,newreference(t.reference)))); + end; + end; + else + internalerror(330); + end; + end; + + + procedure emit_lea_loc_reg(const t:tlocation;reg:tregister;freetemp:boolean); + begin + case t.loc of + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + internalerror(331) + else + begin + emit_ref_reg(A_LEA,S_L, + newreference(t.reference),reg); + end; + if freetemp then + ungetiftemp(t.reference); + end; + else + internalerror(332); + end; + end; + + + procedure emit_movq_reg_loc(reghigh,reglow: TRegister;t:tlocation); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + emit_reg_reg(A_MOV,S_L, + reglow,t.registerlow); + emit_reg_reg(A_MOV,S_L, + reghigh,t.registerhigh); + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + internalerror(334) + else + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + Reglow,newreference(t.reference)))); + inc(t.reference.offset,4); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + Reghigh,newreference(t.reference)))); + end; + end; + else + internalerror(330); + end; + end; + + + procedure emit_pushq_loc(const t : tlocation); + + var + hr : preference; + + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L, + t.registerhigh))); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L, + t.registerlow))); + end; + LOC_MEM, + LOC_REFERENCE: + begin + hr:=newreference(t.reference); + inc(hr^.offset,4); + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L, + hr))); + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L, + newreference(t.reference)))); + ungetiftemp(t.reference); + end; + else internalerror(331); + end; + end; + + procedure remove_non_regvars_from_loc(const t: tlocation; var regs: byte); + begin + case t.loc of + LOC_REGISTER: + { can't be a regvar, since it would be LOC_CREGISTER then } + regs := regs and not($80 shr byte(t.register)); + LOC_MEM,LOC_REFERENCE: + begin + if not(cs_regalloc in aktglobalswitches) or + (t.reference.base in usableregs) then + regs := regs and + not($80 shr byte(t.reference.base)); + if not(cs_regalloc in aktglobalswitches) or + (t.reference.index in usableregs) then + regs := regs and + not($80 shr byte(t.reference.index)); + end; + end; + end; + + + procedure release_loc(const t : tlocation); + + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + ungetregister32(t.register); + end; + LOC_MEM, + LOC_REFERENCE: + del_reference(t.reference); + else internalerror(332); + end; + end; + + procedure release_qword_loc(const t : tlocation); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + ungetregister32(t.registerhigh); + ungetregister32(t.registerlow); + end; + LOC_MEM, + LOC_REFERENCE: + del_reference(t.reference); + else internalerror(331); + end; + end; + + + procedure emit_push_loc(const t:tlocation); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,makereg32(t.register)))); + ungetregister(t.register); { the register is not needed anymore } + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,t.reference.offset))) + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(t.reference)))); + del_reference(t.reference); + ungetiftemp(t.reference); + end; + else + internalerror(330); + end; + end; + + + procedure emit_pushw_loc(const t:tlocation); + var + opsize : topsize; + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + if target_os.stackalignment=4 then + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,makereg32(t.register)))) + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_W,makereg16(t.register)))); + ungetregister(t.register); { the register is not needed anymore } + end; + LOC_MEM, + LOC_REFERENCE : begin + if target_os.stackalignment=4 then + opsize:=S_L + else + opsize:=S_W; + if t.reference.is_immediate then + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,t.reference.offset))) + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize,newreference(t.reference)))); + del_reference(t.reference); + ungetiftemp(t.reference); + end; + else + internalerror(330); + end; + end; + + + procedure emit_lea_loc_ref(const t:tlocation;const ref:treference;freetemp:boolean); + begin + case t.loc of + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + internalerror(331) + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(t.reference),R_EDI); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + R_EDI,newreference(ref)))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + { release the registers } + del_reference(t.reference); + if freetemp then + ungetiftemp(t.reference); + end; + else + internalerror(332); + end; + end; + + + procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean); + begin + case t.loc of + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.is_immediate then + internalerror(331) + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L, + newreference(t.reference),R_EDI); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + if freetemp then + ungetiftemp(t.reference); + end; + else + internalerror(332); + end; + end; + + + procedure emit_to_mem(var p:ptree); + + var + r : treference; + + begin + case p^.location.loc of + LOC_FPU : begin + reset_reference(p^.location.reference); + gettempofsizereference(10,p^.location.reference); + floatstore(pfloatdef(p^.resulttype)^.typ,p^.location.reference); + { This can't be never a l-value! (FK) + p^.location.loc:=LOC_REFERENCE; } + end; + LOC_REGISTER: + begin + if is_64bitint(p^.resulttype) then + begin + gettempofsizereference(8,r); + emit_reg_ref(A_MOV,S_L,p^.location.registerlow, + newreference(r)); + inc(r.offset,4); + emit_reg_ref(A_MOV,S_L,p^.location.registerhigh, + newreference(r)); + dec(r.offset,4); + p^.location.reference:=r; + end + else + internalerror(1405001); + end; + LOC_MEM, + LOC_REFERENCE : ; + LOC_CFPUREGISTER : begin + emit_reg(A_FLD,S_NO,correct_fpuregister(p^.location.register,fpuvaroffset)); + inc(fpuvaroffset); + reset_reference(p^.location.reference); + gettempofsizereference(10,p^.location.reference); + floatstore(pfloatdef(p^.resulttype)^.typ,p^.location.reference); + { This can't be never a l-value! (FK) + p^.location.loc:=LOC_REFERENCE; } + end; + else + internalerror(333); + end; + p^.location.loc:=LOC_MEM; + end; + + + procedure emit_to_reg16(var hr:tregister); + begin + { ranges are a little bit bug sensitive ! } + case hr of + R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP,R_EBP: + begin + hr:=reg32toreg16(hr); + end; + R_AL,R_BL,R_CL,R_DL: + begin + hr:=reg8toreg16(hr); + emit_const_reg(A_AND,S_W,$ff,hr); + end; + R_AH,R_BH,R_CH,R_DH: + begin + hr:=reg8toreg16(hr); + emit_const_reg(A_AND,S_W,$ff00,hr); + end; + end; + end; + + + procedure emit_to_reg32(var hr:tregister); + begin + { ranges are a little bit bug sensitive ! } + case hr of + R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP,R_BP: + begin + hr:=reg16toreg32(hr); + emit_const_reg(A_AND,S_L,$ffff,hr); + end; + R_AL,R_BL,R_CL,R_DL: + begin + hr:=reg8toreg32(hr); + emit_const_reg(A_AND,S_L,$ff,hr); + end; + R_AH,R_BH,R_CH,R_DH: + begin + hr:=reg8toreg32(hr); + emit_const_reg(A_AND,S_L,$ff00,hr); + end; + end; + end; + + procedure emit_mov_ref_reg64(r : treference;rl,rh : tregister); + + var + hr : preference; + + begin + { if we load a 64 bit reference, we must be careful because } + { we could overwrite the registers of the reference by } + { accident } + if r.base=rl then + begin + emit_reg_reg(A_MOV,S_L,r.base, + R_EDI); + r.base:=R_EDI; + end + else if r.index=rl then + begin + emit_reg_reg(A_MOV,S_L,r.index, + R_EDI); + r.index:=R_EDI; + end; + emit_ref_reg(A_MOV,S_L, + newreference(r),rl); + hr:=newreference(r); + inc(hr^.offset,4); + emit_ref_reg(A_MOV,S_L, + hr,rh); + end; + +{***************************************************************************** + Emit String Functions +*****************************************************************************} + + procedure copyshortstring(const dref,sref : treference;len : byte; + loadref, del_sref: boolean); + begin + emitpushreferenceaddr(dref); + { if it's deleted right before it's used, the optimizer can move } + { the reg deallocations to the right places (JM) } + if del_sref then + del_reference(sref); + if loadref then + emit_push_mem(sref) + else + emitpushreferenceaddr(sref); + push_int(len); + emitcall('FPC_SHORTSTR_COPY'); + maybe_loadesi; + end; + + procedure copylongstring(const dref,sref : treference;len : longint;loadref:boolean); + begin + emitpushreferenceaddr(dref); + if loadref then + emit_push_mem(sref) + else + emitpushreferenceaddr(sref); + push_int(len); + emitcall('FPC_LONGSTR_COPY'); + maybe_loadesi; + end; + + + procedure incrstringref(t : pdef;const ref : treference); + + var + pushedregs : tpushed; + + begin + pushusedregisters(pushedregs,$ff); + emitpushreferenceaddr(ref); + if is_ansistring(t) then + begin + emitcall('FPC_ANSISTR_INCR_REF'); + end + else if is_widestring(t) then + begin + emitcall('FPC_WIDESTR_INCR_REF'); + end + else internalerror(1859); + popusedregisters(pushedregs); + end; + + + procedure decrstringref(t : pdef;const ref : treference); + + var + pushedregs : tpushed; + + begin + pushusedregisters(pushedregs,$ff); + emitpushreferenceaddr(ref); + if is_ansistring(t) then + begin + emitcall('FPC_ANSISTR_DECR_REF'); + end + else if is_widestring(t) then + begin + emitcall('FPC_WIDESTR_DECR_REF'); + end + else internalerror(1859); + popusedregisters(pushedregs); + end; + + procedure loadansistring(p : ptree); + { + copies an ansistring from p^.right to p^.left, we + assume, that both sides are ansistring, firstassignement have + to take care of that, an ansistring can't be a register variable + } + var + pushed : tpushed; + regs_to_push: byte; + ungettemp : boolean; + begin + { before pushing any parameter, we have to save all used } + { registers, but before that we have to release the } + { registers of that node to save uneccessary pushed } + { so be careful, if you think you can optimize that code (FK) } + + { nevertheless, this has to be changed, because otherwise the } + { register is released before it's contents are pushed -> } + { problems with the optimizer (JM) } + del_reference(p^.left^.location.reference); + ungettemp:=false; + { Find out which registers have to be pushed (JM) } + regs_to_push := $ff; + remove_non_regvars_from_loc(p^.right^.location,regs_to_push); + { And push them (JM) } + pushusedregisters(pushed,regs_to_push); + case p^.right^.location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register))); + ungetregister32(p^.right^.location.register); + end; + LOC_REFERENCE,LOC_MEM: + begin + { First release the registers because emit_push_mem may } + { load the reference in edi before pushing and then the } + { dealloc is too late (and optimizations are missed (JM) } + del_reference(p^.right^.location.reference); + { This one doesn't need extra registers (JM) } + emit_push_mem(p^.right^.location.reference); + ungettemp:=true; + end; + end; + emitpushreferenceaddr(p^.left^.location.reference); + del_reference(p^.left^.location.reference); + emitcall('FPC_ANSISTR_ASSIGN'); + maybe_loadesi; + popusedregisters(pushed); + if ungettemp then + ungetiftemp(p^.right^.location.reference); + end; + + +{***************************************************************************** + Emit Push Functions +*****************************************************************************} + + function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean; + var + pushed : boolean; + {hregister : tregister; } +{$ifdef TEMPS_NOT_PUSH} + href : treference; +{$endif TEMPS_NOT_PUSH} + begin + if needed>usablereg32 then + begin + if (p^.location.loc=LOC_REGISTER) then + begin + if isint64 then + begin +{$ifdef TEMPS_NOT_PUSH} + gettempofsizereference(href,8); + p^.temp_offset:=href.offset; + href.offset:=href.offset+4; + exprasmlist^.concat(new(paicpu,op_reg(A_MOV,S_L,p^.location.registerhigh,href))); + href.offset:=href.offset-4; +{$else TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerhigh))); +{$endif TEMPS_NOT_PUSH} + ungetregister32(p^.location.registerhigh); + end +{$ifdef TEMPS_NOT_PUSH} + else + begin + gettempofsizereference(href,4); + p^.temp_offset:=href.offset; + end +{$endif TEMPS_NOT_PUSH} + ; + pushed:=true; +{$ifdef TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,p^.location.register,href))); +{$else TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.register))); +{$endif TEMPS_NOT_PUSH} + ungetregister32(p^.location.register); + end + else if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and + ((p^.location.reference.base<>R_NO) or + (p^.location.reference.index<>R_NO) + ) then + begin + del_reference(p^.location.reference); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L,newreference(p^.location.reference), + R_EDI); +{$ifdef TEMPS_NOT_PUSH} + gettempofsizereference(href,4); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,href))); + p^.temp_offset:=href.offset; +{$else TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); +{$endif TEMPS_NOT_PUSH} +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + pushed:=true; + end + else pushed:=false; + end + else pushed:=false; + maybe_push:=pushed; + end; + +{$ifdef TEMPS_NOT_PUSH} + function maybe_savetotemp(needed : byte;p : ptree;isint64 : boolean) : boolean; + + var + pushed : boolean; + href : treference; + + begin + if needed>usablereg32 then + begin + if (p^.location.loc=LOC_REGISTER) then + begin + if isint64(p^.resulttype) then + begin + gettempofsizereference(href,8); + p^.temp_offset:=href.offset; + href.offset:=href.offset+4; + exprasmlist^.concat(new(paicpu,op_reg(A_MOV,S_L,p^.location.registerhigh,href))); + href.offset:=href.offset-4; + ungetregister32(p^.location.registerhigh); + end + else + begin + gettempofsizereference(href,4); + p^.temp_offset:=href.offset; + end; + pushed:=true; + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,p^.location.register,href))); + ungetregister32(p^.location.register); + end + else if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and + ((p^.location.reference.base<>R_NO) or + (p^.location.reference.index<>R_NO) + ) then + begin + del_reference(p^.location.reference); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L,newreference(p^.location.reference), + R_EDI); + gettempofsizereference(href,4); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,href))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + p^.temp_offset:=href.offset; + pushed:=true; + end + else pushed:=false; + end + else pushed:=false; + maybe_push:=pushed; + end; +{$endif TEMPS_NOT_PUSH} + + + procedure push_int(l : longint); + begin + if (l = 0) and + not(aktoptprocessor in [Class386, ClassP6]) and + not(cs_littlesize in aktglobalswitches) + Then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_XOR,S_L,R_EDI,R_EDI); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,l))); + end; + + procedure emit_push_mem(const ref : treference); + + begin + if ref.is_immediate then + push_int(ref.offset) + else + begin + if not(aktoptprocessor in [Class386, ClassP6]) and + not(cs_littlesize in aktglobalswitches) + then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L,newreference(ref),R_EDI); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(ref)))); + end; + end; + + + procedure emitpushreferenceaddr(const ref : treference); + var + href : treference; + begin + { this will fail for references to other segments !!! } + if ref.is_immediate then + { is this right ? } + begin + { push_int(ref.offset)} + gettempofsizereference(4,href); + emit_const_ref(A_MOV,S_L,ref.offset,newreference(href)); + emitpushreferenceaddr(href); + del_reference(href); + end + else + begin + if ref.segment<>R_NO then + CGMessage(cg_e_cant_use_far_pointer_there); + if (ref.base=R_NO) and (ref.index=R_NO) then + exprasmlist^.concat(new(paicpu,op_sym_ofs(A_PUSH,S_L,ref.symbol,ref.offset))) + else if (ref.base=R_NO) and (ref.index<>R_NO) and + (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,ref.index))) + else if (ref.base<>R_NO) and (ref.index=R_NO) and + (ref.offset=0) and (ref.symbol=nil) then + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,ref.base))) + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L,newreference(ref),R_EDI); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; + end; + + + procedure pushsetelement(p : ptree); + { + copies p a set element on the stack + } + var + hr,hr16,hr32 : tregister; + begin + { copy the element on the stack, slightly complicated } + if p^.treetype=ordconstn then + begin + if target_os.stackalignment=4 then + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,p^.value))) + else + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_W,p^.value))); + end + else + begin + case p^.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + begin + hr:=p^.location.register; + case hr of + R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP : + begin + hr16:=reg32toreg16(hr); + hr32:=hr; + end; + R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : + begin + hr16:=hr; + hr32:=reg16toreg32(hr); + end; + R_AL,R_BL,R_CL,R_DL : + begin + hr16:=reg8toreg16(hr); + hr32:=reg8toreg32(hr); + end; + end; + if target_os.stackalignment=4 then + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,hr32))) + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_W,hr16))); + ungetregister32(hr32); + end; + else + begin + if target_os.stackalignment=4 then + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(p^.location.reference)))) + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_W,newreference(p^.location.reference)))); + del_reference(p^.location.reference); + end; + end; + end; + end; + + + procedure restore(p : ptree;isint64 : boolean); + var + hregister : tregister; +{$ifdef TEMPS_NOT_PUSH} + href : treference; +{$endif TEMPS_NOT_PUSH} + begin + hregister:=getregister32; +{$ifdef TEMPS_NOT_PUSH} + reset_reference(href); + href.base:=procinfo^.frame_pointer; + href.offset:=p^.temp_offset; + emit_ref_reg(A_MOV,S_L,href,hregister); +{$else TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,hregister))); +{$endif TEMPS_NOT_PUSH} + if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + p^.location.register:=hregister; + if isint64 then + begin + p^.location.registerhigh:=getregister32; +{$ifdef TEMPS_NOT_PUSH} + href.offset:=p^.temp_offset+4; + emit_ref_reg(A_MOV,S_L,p^.location.registerhigh); + { set correctly for release ! } + href.offset:=p^.temp_offset; +{$else TEMPS_NOT_PUSH} + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,p^.location.registerhigh))); +{$endif TEMPS_NOT_PUSH} + end; + end + else + begin + reset_reference(p^.location.reference); + { any reasons why this was moved into the index register ? } + { normally usage of base register is much better (FK) } + p^.location.reference.base:=hregister; + { Why is this done? We can never be sure about p^.left + because otherwise secondload fails !!! + set_location(p^.left^.location,p^.location);} + end; +{$ifdef TEMPS_NOT_PUSH} + ungetiftemp(href); +{$endif TEMPS_NOT_PUSH} + end; + +{$ifdef TEMPS_NOT_PUSH} + procedure restorefromtemp(p : ptree;isint64 : boolean); + var + hregister : tregister; + href : treference; + + begin + hregister:=getregister32; + reset_reference(href); + href.base:=procinfo^.frame_pointer; + href.offset:=p^.temp_offset; + emit_ref_reg(A_MOV,S_L,href,hregister); + if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + p^.location.register:=hregister; + if isint64 then + begin + p^.location.registerhigh:=getregister32; + href.offset:=p^.temp_offset+4; + emit_ref_reg(A_MOV,S_L,p^.location.registerhigh); + { set correctly for release ! } + href.offset:=p^.temp_offset; + end; + end + else + begin + reset_reference(p^.location.reference); + p^.location.reference.base:=hregister; + { Why is this done? We can never be sure about p^.left + because otherwise secondload fails PM + set_location(p^.left^.location,p^.location);} + end; + ungetiftemp(href); + end; +{$endif TEMPS_NOT_PUSH} + + procedure push_value_para(p:ptree;inlined,is_cdecl:boolean; + para_offset:longint;alignment : longint); + var + tempreference : treference; + r : preference; + opsize : topsize; + op : tasmop; + hreg : tregister; + size : longint; + hlabel : pasmlabel; + begin + case p^.location.loc of + LOC_REGISTER, + LOC_CREGISTER: + begin + case p^.location.register of + R_EAX,R_EBX,R_ECX,R_EDX,R_ESI, + R_EDI,R_ESP,R_EBP : + begin + if p^.resulttype^.size=8 then + begin + inc(pushedparasize,8); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + p^.location.registerlow,r))); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + p^.location.registerhigh,r))); + end + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerhigh))); + ungetregister32(p^.location.registerhigh); + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerlow))); + ungetregister32(p^.location.registerlow); + end + else + begin + inc(pushedparasize,4); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L, + p^.location.register,r))); + end + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.register))); + ungetregister32(p^.location.register); + end; + end; + R_AX,R_BX,R_CX,R_DX,R_SI,R_DI: + begin + if alignment=4 then + begin + opsize:=S_L; + hreg:=reg16toreg32(p^.location.register); + inc(pushedparasize,4); + end + else + begin + opsize:=S_W; + hreg:=p^.location.register; + inc(pushedparasize,2); + end; + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r))); + end + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg))); + ungetregister32(reg16toreg32(p^.location.register)); + end; + R_AL,R_BL,R_CL,R_DL: + begin + if alignment=4 then + begin + opsize:=S_L; + hreg:=reg8toreg32(p^.location.register); + inc(pushedparasize,4); + end + else + begin + opsize:=S_W; + hreg:=reg8toreg16(p^.location.register); + inc(pushedparasize,2); + end; + { we must push always 16 bit } + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r))); + end + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg))); + ungetregister32(reg8toreg32(p^.location.register)); + end; + else internalerror(1899); + end; + end; + LOC_FPU: + begin + size:=align(pfloatdef(p^.resulttype)^.size,alignment); + inc(pushedparasize,size); + if not inlined then + emit_const_reg(A_SUB,S_L,size,R_ESP); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (exprasmlist^.first=exprasmlist^.last) then + exprasmlist^.concat(new(pai_force_line,init)); +{$endif GDB} + r:=new_reference(R_ESP,0); + floatstoreops(pfloatdef(p^.resulttype)^.typ,op,opsize); + { this is the easiest case for inlined !! } + if inlined then + begin + r^.base:=procinfo^.framepointer; + r^.offset:=para_offset-pushedparasize; + end; + exprasmlist^.concat(new(paicpu,op_ref(op,opsize,r))); + dec(fpuvaroffset); + end; + LOC_CFPUREGISTER: + begin + exprasmlist^.concat(new(paicpu,op_reg(A_FLD,S_NO, + correct_fpuregister(p^.location.register,fpuvaroffset)))); + size:=align(pfloatdef(p^.resulttype)^.size,alignment); + inc(pushedparasize,size); + if not inlined then + emit_const_reg(A_SUB,S_L,size,R_ESP); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (exprasmlist^.first=exprasmlist^.last) then + exprasmlist^.concat(new(pai_force_line,init)); +{$endif GDB} + r:=new_reference(R_ESP,0); + floatstoreops(pfloatdef(p^.resulttype)^.typ,op,opsize); + { this is the easiest case for inlined !! } + if inlined then + begin + r^.base:=procinfo^.framepointer; + r^.offset:=para_offset-pushedparasize; + end; + exprasmlist^.concat(new(paicpu,op_ref(op,opsize,r))); + end; + LOC_REFERENCE,LOC_MEM: + begin + tempreference:=p^.location.reference; + del_reference(p^.location.reference); + case p^.resulttype^.deftype of + enumdef, + orddef : + begin + case p^.resulttype^.size of + 8 : begin + inc(pushedparasize,8); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + inc(tempreference.offset,4); + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + begin + inc(tempreference.offset,4); + emit_push_mem(tempreference); + dec(tempreference.offset,4); + emit_push_mem(tempreference); + end; + end; + 4 : begin + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + end; + 1,2 : begin + if alignment=4 then + begin + opsize:=S_L; + hreg:=R_EDI; + inc(pushedparasize,4); + end + else + begin + opsize:=S_W; + hreg:=R_DI; + inc(pushedparasize,2); + end; + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,opsize, + newreference(tempreference),hreg); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize, + newreference(tempreference)))); + end; + else + internalerror(234231); + end; + end; + floatdef : + begin + case pfloatdef(p^.resulttype)^.typ of + f32bit, + s32real : + begin + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + end; + s64real, + s64comp : + begin + inc(pushedparasize,4); + inc(tempreference.offset,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + inc(pushedparasize,4); + dec(tempreference.offset,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + end; + s80real : + begin + inc(pushedparasize,4); + if alignment=4 then + inc(tempreference.offset,8) + else + inc(tempreference.offset,6); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + dec(tempreference.offset,4); + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + if alignment=4 then + begin + opsize:=S_L; + hreg:=R_EDI; + inc(pushedparasize,4); + dec(tempreference.offset,4); + end + else + begin + opsize:=S_W; + hreg:=R_DI; + inc(pushedparasize,2); + dec(tempreference.offset,2); + end; + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,opsize, + newreference(tempreference),hreg); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize, + newreference(tempreference)))); + end; + end; + end; + pointerdef, + procvardef, + classrefdef: + begin + inc(pushedparasize,4); + if inlined then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_MOV,S_L, + newreference(tempreference),R_EDI); + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end + else + emit_push_mem(tempreference); + end; + arraydef, + recorddef, + stringdef, + setdef, + objectdef : + begin + { even some structured types are 32 bit } + if is_widestring(p^.resulttype) or + is_ansistring(p^.resulttype) or + is_smallset(p^.resulttype) or + ((p^.resulttype^.deftype in [recorddef,arraydef]) and (p^.resulttype^.size<=4) + and ((p^.resulttype^.deftype<>arraydef) or not + (parraydef(p^.resulttype)^.IsConstructor or + parraydef(p^.resulttype)^.isArrayOfConst or + is_open_array(p^.resulttype))) + ) or + ((p^.resulttype^.deftype=objectdef) and + pobjectdef(p^.resulttype)^.is_class) then + begin + if (p^.resulttype^.size>2) or + ((alignment=4) and (p^.resulttype^.size>0)) then + begin + inc(pushedparasize,4); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + concatcopy(tempreference,r^,4,false,false); + end + else + emit_push_mem(tempreference); + end + else + begin + if p^.resulttype^.size>0 then + begin + inc(pushedparasize,2); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + concatcopy(tempreference,r^,2,false,false); + end + else + exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_W,newreference(tempreference)))); + end; + end; + end + { call by value open array ? } + else if is_cdecl then + begin + { push on stack } + size:=align(p^.resulttype^.size,alignment); + inc(pushedparasize,size); + emit_const_reg(A_SUB,S_L,size,R_ESP); + r:=new_reference(R_ESP,0); + concatcopy(tempreference,r^,size,false,false); + end + else + internalerror(8954); + end; + else + CGMessage(cg_e_illegal_expression); + end; + end; + LOC_JUMP: + begin + getlabel(hlabel); + if alignment=4 then + begin + opsize:=S_L; + inc(pushedparasize,4); + end + else + begin + opsize:=S_W; + inc(pushedparasize,2); + end; + emitlab(truelabel); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_const_ref(A_MOV,opsize,1,r); + end + else + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,1))); + emitjmp(C_None,hlabel); + emitlab(falselabel); + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + emit_const_ref(A_MOV,opsize,0,r); + end + else + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,0))); + emitlab(hlabel); + end; + LOC_FLAGS: + begin + if not(R_EAX in unused) then + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI); + end; + emit_flag2reg(p^.location.resflags,R_AL); + emit_reg_reg(A_MOVZX,S_BW,R_AL,R_AX); + if alignment=4 then + begin + opsize:=S_L; + hreg:=R_EAX; + inc(pushedparasize,4); + end + else + begin + opsize:=S_W; + hreg:=R_AX; + inc(pushedparasize,2); + end; + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r))); + end + else + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg))); + if not(R_EAX in unused) then + begin + emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; +{$ifdef SUPPORT_MMX} + LOC_MMXREGISTER, + LOC_CMMXREGISTER: + begin + inc(pushedparasize,8); { was missing !!! (PM) } + emit_const_reg( + A_SUB,S_L,8,R_ESP); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (exprasmlist^.first=exprasmlist^.last) then + exprasmlist^.concat(new(pai_force_line,init)); +{$endif GDB} + if inlined then + begin + r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVQ,S_NO, + p^.location.register,r))); + end + else + begin + r:=new_reference(R_ESP,0); + exprasmlist^.concat(new(paicpu,op_reg_ref( + A_MOVQ,S_NO,p^.location.register,r))); + end; + end; +{$endif SUPPORT_MMX} + end; + end; + + + +{***************************************************************************** + Emit Float Functions +*****************************************************************************} + + procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize); + begin + case t of + s32real : begin + op:=A_FLD; + s:=S_FS; + end; + s64real : begin + op:=A_FLD; + { ???? } + s:=S_FL; + end; + s80real : begin + op:=A_FLD; + s:=S_FX; + end; + s64comp : begin + op:=A_FILD; + s:=S_IQ; + end; + else internalerror(17); + end; + end; + + + procedure floatload(t : tfloattype;const ref : treference); + var + op : tasmop; + s : topsize; + begin + floatloadops(t,op,s); + exprasmlist^.concat(new(paicpu,op_ref(op,s, + newreference(ref)))); + inc(fpuvaroffset); + end; + + + procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); + begin + case t of + s32real : begin + op:=A_FSTP; + s:=S_FS; + end; + s64real : begin + op:=A_FSTP; + s:=S_FL; + end; + s80real : begin + op:=A_FSTP; + s:=S_FX; + end; + s64comp : begin + op:=A_FISTP; + s:=S_IQ; + end; + else + internalerror(17); + end; + end; + + + procedure floatstore(t : tfloattype;const ref : treference); + var + op : tasmop; + s : topsize; + begin + floatstoreops(t,op,s); + exprasmlist^.concat(new(paicpu,op_ref(op,s, + newreference(ref)))); + dec(fpuvaroffset); + end; + + +{***************************************************************************** + Emit Functions +*****************************************************************************} + + procedure maketojumpbool(p : ptree); + { + produces jumps to true respectively false labels using boolean expressions + } + var + opsize : topsize; + storepos : tfileposinfo; + begin + if p^.error then + exit; + storepos:=aktfilepos; + aktfilepos:=p^.fileinfo; + if is_boolean(p^.resulttype) then + begin + if is_constboolnode(p) then + begin + if p^.value<>0 then + emitjmp(C_None,truelabel) + else + emitjmp(C_None,falselabel); + end + else + begin + opsize:=def_opsize(p^.resulttype); + case p^.location.loc of + LOC_CREGISTER,LOC_REGISTER : begin + emit_reg_reg(A_OR,opsize,p^.location.register, + p^.location.register); + ungetregister(p^.location.register); + emitjmp(C_NZ,truelabel); + emitjmp(C_None,falselabel); + end; + LOC_MEM,LOC_REFERENCE : begin + emit_const_ref( + A_CMP,opsize,0,newreference(p^.location.reference)); + del_reference(p^.location.reference); + emitjmp(C_NZ,truelabel); + emitjmp(C_None,falselabel); + end; + LOC_FLAGS : begin + emitjmp(flag_2_cond[p^.location.resflags],truelabel); + emitjmp(C_None,falselabel); + end; + end; + end; + end + else + CGMessage(type_e_mismatch); + aktfilepos:=storepos; + end; + + + { produces if necessary overflowcode } + procedure emitoverflowcheck(p:ptree); + var + hl : pasmlabel; + begin + if not(cs_check_overflow in aktlocalswitches) then + exit; + getlabel(hl); + if not ((p^.resulttype^.deftype=pointerdef) or + ((p^.resulttype^.deftype=orddef) and + (porddef(p^.resulttype)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar, + bool8bit,bool16bit,bool32bit]))) then + emitjmp(C_NO,hl) + else + emitjmp(C_NB,hl); + emitcall('FPC_OVERFLOW'); + emitlab(hl); + end; + + { produces range check code, while one of the operands is a 64 bit + integer } + procedure emitrangecheck64(p : ptree;todef : pdef); + + begin + + CGMessage(cg_w_64bit_range_check_not_supported); + {internalerror(28699);} + end; + + { produces if necessary rangecheckcode } + procedure emitrangecheck(p:ptree;todef:pdef); + { + generate range checking code for the value at location t. The + type used is the checked against todefs ranges. fromdef (p.resulttype) + is the original type used at that location, when both defs are + equal the check is also insert (needed for succ,pref,inc,dec) + } + var + neglabel, + poslabel : pasmlabel; + href : treference; + rstr : string; + hreg : tregister; + opsize : topsize; + op : tasmop; + fromdef : pdef; + lto,hto, + lfrom,hfrom : longint; + doublebound, + is_reg, + popecx : boolean; + begin + { range checking on and range checkable value? } + if not(cs_check_range in aktlocalswitches) or + not(todef^.deftype in [orddef,enumdef,arraydef]) then + exit; + { only check when assigning to scalar, subranges are different, + when todef=fromdef then the check is always generated } + fromdef:=p^.resulttype; + if is_64bitint(fromdef) or is_64bitint(todef) then + begin + emitrangecheck64(p,todef); + exit; + end; + {we also need lto and hto when checking if we need to use doublebound! + (JM)} + getrange(todef,lto,hto); + if todef<>fromdef then + begin + getrange(p^.resulttype,lfrom,hfrom); + { first check for not being u32bit, then if the to is bigger than + from } + if (lto=hfrom) then + exit; + end; + { generate the rangecheck code for the def where we are going to + store the result } + doublebound:=false; + case todef^.deftype of + orddef : + begin + porddef(todef)^.genrangecheck; + rstr:=porddef(todef)^.getrangecheckstring; + doublebound:=(porddef(todef)^.typ=u32bit) and (lto>hto); + end; + enumdef : + begin + penumdef(todef)^.genrangecheck; + rstr:=penumdef(todef)^.getrangecheckstring; + end; + arraydef : + begin + parraydef(todef)^.genrangecheck; + rstr:=parraydef(todef)^.getrangecheckstring; + doublebound:=(lto>hto); + end; + end; + { get op and opsize } + opsize:=def2def_opsize(fromdef,u32bitdef); + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + if is_signed(fromdef) then + op:=A_MOVSX + else + op:=A_MOVZX; + is_reg:=(p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]); + if is_reg then + hreg:=p^.location.register; + if not target_os.use_bound_instruction then + begin + { FPC_BOUNDCHECK needs to be called with + %ecx - value + %edi - pointer to the ranges } + popecx:=false; + if not(is_reg) or + (p^.location.register<>R_ECX) then + begin + if not(R_ECX in unused) then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX))); + popecx:=true; + end + else exprasmlist^.concat(new(pairegalloc,alloc(R_ECX))); + if is_reg then + emit_reg_reg(op,opsize,p^.location.register,R_ECX) + else + emit_ref_reg(op,opsize,newreference(p^.location.reference),R_ECX); + end; + if doublebound then + begin + getlabel(neglabel); + getlabel(poslabel); + emit_reg_reg(A_OR,S_L,R_ECX,R_ECX); + emitjmp(C_L,neglabel); + end; + { insert bound instruction only } +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),0,R_EDI))); + emitcall('FPC_BOUNDCHECK'); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + { u32bit needs 2 checks } + if doublebound then + begin + emitjmp(C_None,poslabel); + emitlab(neglabel); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),8,R_EDI))); + emitcall('FPC_BOUNDCHECK'); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + emitlab(poslabel); + end; + if popecx then + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX))) + else exprasmlist^.concat(new(pairegalloc,dealloc(R_ECX))); + end + else + begin + reset_reference(href); + href.symbol:=newasmsymbol(rstr); + { load the value in a register } + if is_reg then + begin + { be sure that hreg is a 32 bit reg, if not load it in %edi } + if p^.location.register in [R_EAX..R_EDI] then + hreg:=p^.location.register + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(op,opsize,p^.location.register,R_EDI); + hreg:=R_EDI; + end; + end + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(op,opsize,newreference(p^.location.reference),R_EDI); + hreg:=R_EDI; + end; + if doublebound then + begin + getlabel(neglabel); + getlabel(poslabel); + emit_reg_reg(A_TEST,S_L,hreg,hreg); + emitjmp(C_L,neglabel); + end; + { insert bound instruction only } + exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href)))); + { u32bit needs 2 checks } + if doublebound then + begin + href.offset:=8; + emitjmp(C_None,poslabel); + emitlab(neglabel); + exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href)))); + emitlab(poslabel); + end; +{$ifndef noAllocEdi} + if hreg = R_EDI then + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; + + + procedure concatcopy(source,dest : treference;size : longint;delsource,loadref : boolean); + + const + isizes : array[0..3] of topsize=(S_L,S_B,S_W,S_B); + ishr : array[0..3] of byte=(2,0,1,0); + + var + ecxpushed : boolean; + helpsize : longint; + i : byte; + reg8,reg32 : tregister; + swap : boolean; + + procedure maybepushecx; + begin + if not(R_ECX in unused) then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX))); + ecxpushed:=true; + end; + end; + + begin +{$IfNDef regallocfix} + If delsource then + del_reference(source); +{$EndIf regallocfix} + if (not loadref) and + ((size<=8) or + (not(cs_littlesize in aktglobalswitches ) and (size<=12))) then + begin + helpsize:=size shr 2; +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + for i:=1 to helpsize do + begin + emit_ref_reg(A_MOV,S_L,newreference(source),R_EDI); +{$ifdef regallocfix} + If (size = 4) and delsource then + del_reference(source); +{$endif regallocfix} + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,newreference(dest)))); + inc(source.offset,4); + inc(dest.offset,4); + dec(size,4); + end; + if size>1 then + begin + emit_ref_reg(A_MOV,S_W,newreference(source),R_DI); +{$ifdef regallocfix} + If (size = 2) and delsource then + del_reference(source); +{$endif regallocfix} + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_W,R_DI,newreference(dest)))); + inc(source.offset,2); + inc(dest.offset,2); + dec(size,2); + end; +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + if size>0 then + begin + { and now look for an 8 bit register } + swap:=false; + if R_EAX in unused then reg8:=R_AL + else if R_EBX in unused then reg8:=R_BL + else if R_ECX in unused then reg8:=R_CL + else if R_EDX in unused then reg8:=R_DL + else + begin + swap:=true; + { we need only to check 3 registers, because } + { one is always not index or base } + if (dest.base<>R_EAX) and (dest.index<>R_EAX) then + begin + reg8:=R_AL; + reg32:=R_EAX; + end + else if (dest.base<>R_EBX) and (dest.index<>R_EBX) then + begin + reg8:=R_BL; + reg32:=R_EBX; + end + else if (dest.base<>R_ECX) and (dest.index<>R_ECX) then + begin + reg8:=R_CL; + reg32:=R_ECX; + end; + end; + if swap then + { was earlier XCHG, of course nonsense } + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_reg_reg(A_MOV,S_L,reg32,R_EDI); + end; + emit_ref_reg(A_MOV,S_B,newreference(source),reg8); +{$ifdef regallocfix} + If delsource then + del_reference(source); +{$endif regallocfix} + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_B,reg8,newreference(dest)))); + if swap then + begin + emit_reg_reg(A_MOV,S_L,R_EDI,reg32); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + end; + end + else + begin +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_ref_reg(A_LEA,S_L,newreference(dest),R_EDI); +{$ifdef regallocfix} + {is this ok?? (JM)} + del_reference(dest); +{$endif regallocfix} +{$ifndef noAllocEdi} + exprasmlist^.concat(new(pairegalloc,alloc(R_ESI))); +{$endif noAllocEdi} + if loadref then + emit_ref_reg(A_MOV,S_L,newreference(source),R_ESI) + else + begin + emit_ref_reg(A_LEA,S_L,newreference(source),R_ESI); +{$ifdef regallocfix} + if delsource then + del_reference(source); +{$endif regallocfix} + end; + + exprasmlist^.concat(new(paicpu,op_none(A_CLD,S_NO))); + ecxpushed:=false; + if cs_littlesize in aktglobalswitches then + begin + maybepushecx; + emit_const_reg(A_MOV,S_L,size,R_ECX); + exprasmlist^.concat(new(paicpu,op_none(A_REP,S_NO))); + exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO))); + end + else + begin + helpsize:=size shr 2; + size:=size and 3; + if helpsize>1 then + begin + maybepushecx; + emit_const_reg(A_MOV,S_L,helpsize,R_ECX); + exprasmlist^.concat(new(paicpu,op_none(A_REP,S_NO))); + end; + if helpsize>0 then + exprasmlist^.concat(new(paicpu,op_none(A_MOVSD,S_NO))); + if size>1 then + begin + dec(size,2); + exprasmlist^.concat(new(paicpu,op_none(A_MOVSW,S_NO))); + end; + if size=1 then + exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO))); + end; +{$ifndef noAllocEdi} + ungetregister32(R_EDI); + exprasmlist^.concat(new(pairegalloc,dealloc(R_ESI))); +{$endif noAllocEdi} + if ecxpushed then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX))); + end; + + { loading SELF-reference again } + maybe_loadesi; + end; + if delsource then + ungetiftemp(source); + end; + + + procedure emitloadord2reg(const location:Tlocation;orddef:Porddef; + destreg:Tregister;delloc:boolean); + + {A lot smaller and less bug sensitive than the original unfolded loads.} + + var tai:Paicpu; + r:Preference; + + begin + tai := nil; + case location.loc of + LOC_REGISTER,LOC_CREGISTER: + begin + case orddef^.typ of + u8bit: + tai:=new(paicpu,op_reg_reg(A_MOVZX,S_BL,location.register,destreg)); + s8bit: + tai:=new(paicpu,op_reg_reg(A_MOVSX,S_BL,location.register,destreg)); + u16bit: + tai:=new(paicpu,op_reg_reg(A_MOVZX,S_WL,location.register,destreg)); + s16bit: + tai:=new(paicpu,op_reg_reg(A_MOVSX,S_WL,location.register,destreg)); + u32bit,s32bit: + if location.register <> destreg then + tai:=new(paicpu,op_reg_reg(A_MOV,S_L,location.register,destreg)); + end; + if delloc then + ungetregister(location.register); + end; + LOC_MEM, + LOC_REFERENCE: + begin + if location.reference.is_immediate then + tai:=new(paicpu,op_const_reg(A_MOV,S_L,location.reference.offset,destreg)) + else + begin + r:=newreference(location.reference); + case orddef^.typ of + u8bit: + tai:=new(paicpu,op_ref_reg(A_MOVZX,S_BL,r,destreg)); + s8bit: + tai:=new(paicpu,op_ref_reg(A_MOVSX,S_BL,r,destreg)); + u16bit: + tai:=new(paicpu,op_ref_reg(A_MOVZX,S_WL,r,destreg)); + s16bit: + tai:=new(paicpu,op_ref_reg(A_MOVSX,S_WL,r,destreg)); + u32bit: + tai:=new(paicpu,op_ref_reg(A_MOV,S_L,r,destreg)); + s32bit: + tai:=new(paicpu,op_ref_reg(A_MOV,S_L,r,destreg)); + end; + end; + if delloc then + del_reference(location.reference); + end + else + internalerror(6); + end; + if assigned(tai) then + exprasmlist^.concat(tai); + end; + + { if necessary ESI is reloaded after a call} + procedure maybe_loadesi; + + var + hp : preference; + p : pprocinfo; + i : longint; + + begin + if assigned(procinfo^._class) then + begin +{$ifndef noAllocEdi} + exprasmlist^.concat(new(pairegalloc,alloc(R_ESI))); +{$endif noAllocEdi} + if lexlevel>normal_function_level then + begin + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.framepointer_offset; + hp^.base:=procinfo^.framepointer; + emit_ref_reg(A_MOV,S_L,hp,R_ESI); + p:=procinfo^.parent; + for i:=3 to lexlevel-1 do + begin + new(hp); + reset_reference(hp^); + hp^.offset:=p^.framepointer_offset; + hp^.base:=R_ESI; + emit_ref_reg(A_MOV,S_L,hp,R_ESI); + p:=p^.parent; + end; + new(hp); + reset_reference(hp^); + hp^.offset:=p^.selfpointer_offset; + hp^.base:=R_ESI; + emit_ref_reg(A_MOV,S_L,hp,R_ESI); + end + else + begin + new(hp); + reset_reference(hp^); + hp^.offset:=procinfo^.selfpointer_offset; + hp^.base:=procinfo^.framepointer; + emit_ref_reg(A_MOV,S_L,hp,R_ESI); + end; + end; + end; + + + { DO NOT RELY on the fact that the ptree is not yet swaped + because of inlining code PM } + procedure firstcomplex(p : ptree); + var + hp : ptree; + begin + { always calculate boolean AND and OR from left to right } + if (p^.treetype in [orn,andn]) and + (p^.left^.resulttype^.deftype=orddef) and + (porddef(p^.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then + begin + { p^.swaped:=false} + if p^.swaped then + internalerror(234234); + end + else + if (p^.left^.registers321) then + begin + if ispowerof2(parraydef(pvarsym(p)^.vartype.def)^.elesize, power) then + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SHL,S_L, + power,R_EDI))) + else + exprasmlist^.concat(new(paicpu, + op_const_reg(A_IMUL,S_L, + parraydef(pvarsym(p)^.vartype.def)^.elesize,R_EDI))); + end; +{$ifndef NOTARGETWIN32} + { windows guards only a few pages for stack growing, } + { so we have to access every page first } + if target_os.id=os_i386_win32 then + begin + getlabel(again); + getlabel(ok); + emitlab(again); + exprasmlist^.concat(new(paicpu, + op_const_reg(A_CMP,S_L,winstackpagesize,R_EDI))); + emitjmp(C_C,ok); + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SUB,S_L,winstackpagesize,R_EDI))); + emitjmp(C_None,again); + + emitlab(ok); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_SUB,S_L,R_EDI,R_ESP))); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + { now reload EDI } + new(r); + reset_reference(r^); + r^.base:=procinfo^.framepointer; + r^.offset:=pvarsym(p)^.address+4+procinfo^.para_offset; +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu, + op_ref_reg(A_MOV,S_L,r,R_EDI))); + + exprasmlist^.concat(new(paicpu, + op_reg(A_INC,S_L,R_EDI))); + + if (parraydef(pvarsym(p)^.vartype.def)^.elesize<>1) then + begin + if ispowerof2(parraydef(pvarsym(p)^.vartype.def)^.elesize, power) then + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SHL,S_L, + power,R_EDI))) + else + exprasmlist^.concat(new(paicpu, + op_const_reg(A_IMUL,S_L, + parraydef(pvarsym(p)^.vartype.def)^.elesize,R_EDI))); + end; + end + else +{$endif NOTARGETWIN32} + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_SUB,S_L,R_EDI,R_ESP))); + { load destination } + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_MOV,S_L,R_ESP,R_EDI))); + + { don't destroy the registers! } + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_ECX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_ESI))); + + { load count } + new(r); + reset_reference(r^); + r^.base:=procinfo^.framepointer; + r^.offset:=pvarsym(p)^.address+4+procinfo^.para_offset; + exprasmlist^.concat(new(paicpu, + op_ref_reg(A_MOV,S_L,r,R_ECX))); + + { load source } + new(r); + reset_reference(r^); + r^.base:=procinfo^.framepointer; + r^.offset:=pvarsym(p)^.address+procinfo^.para_offset; + exprasmlist^.concat(new(paicpu, + op_ref_reg(A_MOV,S_L,r,R_ESI))); + + { scheduled .... } + exprasmlist^.concat(new(paicpu, + op_reg(A_INC,S_L,R_ECX))); + + { calculate size } + len:=parraydef(pvarsym(p)^.vartype.def)^.elesize; + opsize:=S_B; + if (len and 3)=0 then + begin + opsize:=S_L; + len:=len shr 2; + end + else + if (len and 1)=0 then + begin + opsize:=S_W; + len:=len shr 1; + end; + + if ispowerof2(len, power) then + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SHL,S_L, + power,R_ECX))) + else + exprasmlist^.concat(new(paicpu, + op_const_reg(A_IMUL,S_L,len,R_ECX))); + exprasmlist^.concat(new(paicpu, + op_none(A_REP,S_NO))); + case opsize of + S_B : exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO))); + S_W : exprasmlist^.concat(new(paicpu,op_none(A_MOVSW,S_NO))); + S_L : exprasmlist^.concat(new(paicpu,op_none(A_MOVSD,S_NO))); + end; +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_ESI))); + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_ECX))); + + { patch the new address } + new(r); + reset_reference(r^); + r^.base:=procinfo^.framepointer; + r^.offset:=pvarsym(p)^.address+procinfo^.para_offset; + exprasmlist^.concat(new(paicpu, + op_reg_ref(A_MOV,S_L,R_ESP,r))); + end + else + if is_shortstring(pvarsym(p)^.vartype.def) then + begin + reset_reference(href1); + href1.base:=procinfo^.framepointer; + href1.offset:=pvarsym(p)^.address+procinfo^.para_offset; + reset_reference(href2); + href2.base:=procinfo^.framepointer; + href2.offset:=-pvarsym(p)^.localvarsym^.address+pvarsym(p)^.localvarsym^.owner^.address_fixup; + copyshortstring(href2,href1,pstringdef(pvarsym(p)^.vartype.def)^.len,true,false); + end + else + begin + reset_reference(href1); + href1.base:=procinfo^.framepointer; + href1.offset:=pvarsym(p)^.address+procinfo^.para_offset; + reset_reference(href2); + href2.base:=procinfo^.framepointer; + href2.offset:=-pvarsym(p)^.localvarsym^.address+pvarsym(p)^.localvarsym^.owner^.address_fixup; + concatcopy(href1,href2,pvarsym(p)^.vartype.def^.size,true,true); + end; + end; + end; + + procedure inittempansistrings; + + var + hp : ptemprecord; + r : preference; + + begin + hp:=templist; + while assigned(hp) do + begin + if hp^.temptype in [tt_ansistring,tt_freeansistring] then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + new(r); + reset_reference(r^); + r^.base:=procinfo^.framepointer; + r^.offset:=hp^.pos; + emit_const_ref(A_MOV,S_L,0,r); + end; + hp:=hp^.next; + end; + end; + + procedure finalizetempansistrings; + + var + hp : ptemprecord; + hr : treference; + begin + hp:=templist; + while assigned(hp) do + begin + if hp^.temptype in [tt_ansistring,tt_freeansistring] then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + reset_reference(hr); + hr.base:=procinfo^.framepointer; + hr.offset:=hp^.pos; + emitpushreferenceaddr(hr); + emitcall('FPC_ANSISTR_DECR_REF'); + end; + hp:=hp^.next; + end; + end; + + var + ls : longint; + + procedure largest_size(p : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + if (psym(p)^.typ=varsym) and + (pvarsym(p)^.getvaluesize>ls) then + ls:=pvarsym(p)^.getvaluesize; + end; + + procedure alignstack(alist : paasmoutput); + + begin +{$ifdef dummy} + if (cs_optimize in aktglobalswitches) and + (aktoptprocessor in [classp5,classp6]) then + begin + ls:=0; + aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}largest_size); + if ls>=8 then + alist^.insert(new(paicpu,op_const_reg(A_AND,S_L,-8,R_ESP))); + end; +{$endif dummy} + end; + + procedure genentrycode(alist : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; + stackframe:longint; + var parasize:longint;var nostackframe:boolean; + inlined : boolean); + { + Generates the entry code for a procedure + } + var + hs : string; +{$ifdef GDB} + stab_function_name : Pai_stab_function_name; +{$endif GDB} + hr : preference; + p : psymtable; + r : treference; + oldlist, + oldexprasmlist : paasmoutput; + again : pasmlabel; + i : longint; + + begin + oldexprasmlist:=exprasmlist; + exprasmlist:=alist; + if (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then + begin + emitinsertcall('FPC_INITIALIZEUNITS'); + if target_info.target=target_I386_WIN32 then + begin + new(hr); + reset_reference(hr^); + hr^.symbol:=newasmsymbol( + 'U_SYSWIN32_ISCONSOLE'); + if apptype=at_cui then + exprasmlist^.insert(new(paicpu,op_const_ref(A_MOV,S_B, + 1,hr))) + else + exprasmlist^.insert(new(paicpu,op_const_ref(A_MOV,S_B, + 0,hr))); + end; + + oldlist:=exprasmlist; + exprasmlist:=new(paasmoutput,init); + p:=symtablestack; + while assigned(p) do + begin + p^.foreach({$ifndef TP}@{$endif}initialize_threadvar); + p:=p^.next; + end; + oldlist^.insertlist(exprasmlist); + dispose(exprasmlist,done); + exprasmlist:=oldlist; + end; + +{$ifdef GDB} + if (not inlined) and (cs_debuginfo in aktmoduleswitches) then + exprasmlist^.insert(new(pai_force_line,init)); +{$endif GDB} + + { a constructor needs a help procedure } + if (aktprocsym^.definition^.proctypeoption=potype_constructor) then + begin + if procinfo^._class^.is_class then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel))); + emitinsertcall('FPC_NEW_CLASS'); + end + else + begin + exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel))); + emitinsertcall('FPC_HELP_CONSTRUCTOR'); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI))); + end; + end; + + { don't load ESI, does the caller } + { we must do it for local function } + { that can be called from a foreach } + { of another object than self !! PM } + + if assigned(procinfo^._class) and + (lexlevel>normal_function_level) then + maybe_loadesi; + + { When message method contains self as a parameter, + we must load it into ESI } + If (po_containsself in aktprocsym^.definition^.procoptions) then + begin + new(hr); + reset_reference(hr^); + hr^.offset:=procinfo^.selfpointer_offset; + hr^.base:=procinfo^.framepointer; + exprasmlist^.insert(new(paicpu,op_ref_reg(A_MOV,S_L,hr,R_ESI))); +{$ifndef noAllocEdi} + exprasmlist^.insert(new(pairegalloc,alloc(R_ESI))); +{$endif noAllocEdi} + end; + { should we save edi,esi,ebx like C ? } + if (po_savestdregs in aktprocsym^.definition^.procoptions) then + begin + if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBX))); + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ESI))); + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EDI))); + end; + + { for the save all registers we can simply use a pusha,popa which + push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax } + if (po_saveregisters in aktprocsym^.definition^.procoptions) then + begin + exprasmlist^.insert(new(paicpu,op_none(A_PUSHA,S_L))); + end; + + { omit stack frame ? } + if not inlined then + if procinfo^.framepointer=stack_pointer then + begin + CGMessage(cg_d_stackframe_omited); + nostackframe:=true; + if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + parasize:=0 + else + parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-4; + if stackframe<>0 then + exprasmlist^.insert(new(paicpu, + op_const_reg(A_SUB,S_L,stackframe,R_ESP))); + end + else + begin + alignstack(alist); + if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + parasize:=0 + else + parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-8; + nostackframe:=false; + if stackframe<>0 then + begin +{$ifdef unused} + if (cs_littlesize in aktglobalswitches) and (stackframe<=65535) then + begin + if (cs_check_stack in aktlocalswitches) and + not(target_info.target in [target_i386_linux,target_i386_win32]) then + begin + emitinsertcall('FPC_STACKCHECK'); + exprasmlist^.insert(new(paicpu,op_const(A_PUSH,S_L,stackframe))); + end; + if cs_profile in aktmoduleswitches then + genprofilecode; + + { %edi is already saved when pocdecl is used + if (target_info.target=target_linux) and + ((aktprocsym^.definition^.options and poexports)<>0) then + exprasmlist^.insert(new(Paicpu,op_reg(A_PUSH,S_L,R_EDI))); } + { ATTENTION: + never use ENTER in linux !!! + the stack page fault does not support it PM } + exprasmlist^.insert(new(paicpu,op_const_const(A_ENTER,S_NO,stackframe,0))) + end + else +{$endif unused} + begin + { windows guards only a few pages for stack growing, } + { so we have to access every page first } + if (target_os.id=os_i386_win32) and + (stackframe>=winstackpagesize) then + begin + if stackframe div winstackpagesize<=5 then + begin + exprasmlist^.insert(new(paicpu,op_const_reg(A_SUB,S_L,stackframe-4,R_ESP))); + for i:=1 to stackframe div winstackpagesize do + begin + hr:=new_reference(R_ESP,stackframe-i*winstackpagesize); + exprasmlist^.concat(new(paicpu, + op_const_ref(A_MOV,S_L,0,hr))); + end; + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + end + else + begin + getlabel(again); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu, + op_const_reg(A_MOV,S_L,stackframe div winstackpagesize,R_EDI))); + emitlab(again); + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP))); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg(A_DEC,S_L,R_EDI))); + emitjmp(C_NZ,again); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.concat(new(paicpu, + op_const_reg(A_SUB,S_L,stackframe mod winstackpagesize,R_ESP))); + end + end + else + exprasmlist^.insert(new(paicpu,op_const_reg(A_SUB,S_L,stackframe,R_ESP))); + if (cs_check_stack in aktlocalswitches) and + not(target_info.target in [target_i386_linux,target_i386_win32]) then + begin + emitinsertcall('FPC_STACKCHECK'); + exprasmlist^.insert(new(paicpu,op_const(A_PUSH,S_L,stackframe))); + end; + if cs_profile in aktmoduleswitches then + genprofilecode; + exprasmlist^.insert(new(paicpu,op_reg_reg(A_MOV,S_L,R_ESP,R_EBP))); + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBP))); + end; + end { endif stackframe <> 0 } + else + begin + if cs_profile in aktmoduleswitches then + genprofilecode; + exprasmlist^.insert(new(paicpu,op_reg_reg(A_MOV,S_L,R_ESP,R_EBP))); + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBP))); + end; + end; + + if (po_interrupt in aktprocsym^.definition^.procoptions) then + generate_interrupt_stackframe_entry; + + { initialize return value } + if (procinfo^.returntype.def<>pdef(voiddef)) and + (procinfo^.returntype.def^.needs_inittable) and + ((procinfo^.returntype.def^.deftype<>objectdef) or + not(pobjectdef(procinfo^.returntype.def)^.is_class)) then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + reset_reference(r); + r.offset:=procinfo^.return_offset; + r.base:=procinfo^.framepointer; + initialize(procinfo^.returntype.def,r,ret_in_param(procinfo^.returntype.def)); + end; + + { generate copies of call by value parameters } + if not(po_assembler in aktprocsym^.definition^.procoptions) and + not (pocall_cdecl in aktprocsym^.definition^.proccalloptions) then + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}copyvalueparas); + + { initialisize local data like ansistrings } + case aktprocsym^.definition^.proctypeoption of + potype_unitinit: + begin + { using current_module^.globalsymtable is hopefully } + { more robust than symtablestack and symtablestack^.next } + psymtable(current_module^.globalsymtable)^.foreach({$ifndef TP}@{$endif}initialize_data); + psymtable(current_module^.localsymtable)^.foreach({$ifndef TP}@{$endif}initialize_data); + end; + { units have seperate code for initilization and finalization } + potype_unitfinalize: ; + else + aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}initialize_data); + end; + + { add a reference to all call by value/const parameters } + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}incr_data); + + { initialisizes temp. ansi/wide string data } + inittempansistrings; + + { do we need an exception frame because of ansi/widestrings ? } + if not inlined and + ((procinfo^.flags and pi_needs_implicit_finally)<>0) and + { but it's useless in init/final code of units } + not(aktprocsym^.definition^.proctypeoption in [potype_unitfinalize,potype_unitinit]) then + begin + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + + { Type of stack-frame must be pushed} + exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1))); + emitcall('FPC_PUSHEXCEPTADDR'); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + emitcall('FPC_SETJMP'); + exprasmlist^.concat(new(paicpu, + op_reg(A_PUSH,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitjmp(C_NE,aktexitlabel); + { probably we've to reload self here } + maybe_loadesi; + end; + + if not inlined then + begin + if (cs_profile in aktmoduleswitches) or + (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or + (assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then + make_global:=true; + + hs:=proc_names.get; + +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then + stab_function_name := new(pai_stab_function_name,init(strpnew(hs))); +{$EndIf GDB} + + while hs<>'' do + begin + if make_global then + exprasmlist^.insert(new(pai_symbol,initname_global(hs,0))) + else + exprasmlist^.insert(new(pai_symbol,initname(hs,0))); + +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + target_os.use_function_relative_addresses then + exprasmlist^.insert(new(pai_stab_function_name,init(strpnew(hs)))); +{$endif GDB} + + hs:=proc_names.get; + end; + + if make_global or ((procinfo^.flags and pi_is_global) <> 0) then + aktprocsym^.is_global := True; + +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + if target_os.use_function_relative_addresses then + exprasmlist^.insert(stab_function_name); + exprasmlist^.insert(new(pai_stabs,init(aktprocsym^.stabstring))); + aktprocsym^.isstabwritten:=true; + end; +{$endif GDB} + + { Align, gprof uses 16 byte granularity } + if (cs_profile in aktmoduleswitches) then + exprasmlist^.insert(new(pai_align,init_op(16,$90))) + else + if not(cs_littlesize in aktglobalswitches) then + exprasmlist^.insert(new(pai_align,init(16))); + end; + exprasmlist:=oldexprasmlist; + end; + + + procedure handle_return_value(inlined : boolean;var uses_eax,uses_edx : boolean); + var + hr : preference; + op : Tasmop; + s : Topsize; + begin + uses_eax:=false; + uses_edx:=false; + if procinfo^.returntype.def<>pdef(voiddef) then + begin + {if ((procinfo^.flags and pi_operator)<>0) and + assigned(opsym) then + procinfo^.funcret_is_valid:= + procinfo^.funcret_is_valid or (opsym^.refs>0);} + if (procinfo^.funcret_state<>vs_assigned) and not inlined { and + ((procinfo^.flags and pi_uses_asm)=0)} then + CGMessage(sym_w_function_result_not_set); + hr:=new_reference(procinfo^.framepointer,procinfo^.return_offset); + if (procinfo^.returntype.def^.deftype in [orddef,enumdef]) then + begin + uses_eax:=true; + case procinfo^.returntype.def^.size of + 8: + begin + emit_ref_reg(A_MOV,S_L,hr,R_EAX); + hr:=new_reference(procinfo^.framepointer,procinfo^.return_offset+4); + emit_ref_reg(A_MOV,S_L,hr,R_EDX); + uses_edx:=true; + end; + + 4: + emit_ref_reg(A_MOV,S_L,hr,R_EAX); + + 2: + emit_ref_reg(A_MOV,S_W,hr,R_AX); + + 1: + emit_ref_reg(A_MOV,S_B,hr,R_AL); + end; + end + else + if ret_in_acc(procinfo^.returntype.def) then + begin + uses_eax:=true; + emit_ref_reg(A_MOV,S_L,hr,R_EAX); + end + else + if (procinfo^.returntype.def^.deftype=floatdef) then + begin + floatloadops(pfloatdef(procinfo^.returntype.def)^.typ,op,s); + exprasmlist^.concat(new(paicpu,op_ref(op,s,hr))) + end + else + dispose(hr); + end + end; + + + procedure genexitcode(alist : paasmoutput;parasize:longint;nostackframe,inlined:boolean); + + var +{$ifdef GDB} + mangled_length : longint; + p : pchar; +{$endif GDB} + nofinal,okexitlabel,noreraiselabel,nodestroycall : pasmlabel; + hr : treference; + uses_eax,uses_edx,uses_esi : boolean; + oldexprasmlist : paasmoutput; + ai : paicpu; + pd : pprocdef; + + begin + oldexprasmlist:=exprasmlist; + exprasmlist:=alist; + + if aktexitlabel^.is_used then + exprasmlist^.insert(new(pai_label,init(aktexitlabel))); + + { call the destructor help procedure } + if (aktprocsym^.definition^.proctypeoption=potype_destructor) and + assigned(procinfo^._class) then + begin + if procinfo^._class^.is_class then + begin + emitinsertcall('FPC_DISPOSE_CLASS'); + end + else + begin + emitinsertcall('FPC_HELP_DESTRUCTOR'); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI))); + { must the object be finalized ? } + if procinfo^._class^.needs_inittable then + begin + getlabel(nofinal); + exprasmlist^.insert(new(pai_label,init(nofinal))); + emitinsertcall('FPC_FINALIZE'); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ESI))); + exprasmlist^.insert(new(paicpu,op_sym(A_PUSH,S_L,procinfo^._class^.get_inittable_label))); + ai:=new(paicpu,op_sym(A_Jcc,S_NO,nofinal)); + ai^.SetCondition(C_Z); + exprasmlist^.insert(ai); + reset_reference(hr); + hr.base:=R_EBP; + hr.offset:=8; + exprasmlist^.insert(new(paicpu,op_const_ref(A_CMP,S_L,0,newreference(hr)))); + end; + end; + end; + + { finalize temporary data } + finalizetempansistrings; + + { finalize local data like ansistrings} + case aktprocsym^.definition^.proctypeoption of + potype_unitfinalize: + begin + { using current_module^.globalsymtable is hopefully } + { more robust than symtablestack and symtablestack^.next } + psymtable(current_module^.globalsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + psymtable(current_module^.localsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + end; + { units have seperate code for initialization and finalization } + potype_unitinit: ; + else + aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}finalize_data); + end; + + { finalize paras data } + if assigned(aktprocsym^.definition^.parast) then + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}finalize_data); + + { do we need to handle exceptions because of ansi/widestrings ? } + if not inlined and + ((procinfo^.flags and pi_needs_implicit_finally)<>0) and + { but it's useless in init/final code of units } + not(aktprocsym^.definition^.proctypeoption in [potype_unitfinalize,potype_unitinit]) then + begin + { the exception helper routines modify all registers } + aktprocsym^.definition^.usedregisters:=$ff; + + getlabel(noreraiselabel); + emitcall('FPC_POPADDRSTACK'); + exprasmlist^.concat(new(paicpu, + op_reg(A_POP,S_L,R_EAX))); + exprasmlist^.concat(new(paicpu, + op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); + emitjmp(C_E,noreraiselabel); + if (aktprocsym^.definition^.proctypeoption=potype_constructor) then + begin + if assigned(procinfo^._class) then + begin + pd:=procinfo^._class^.searchdestructor; + if assigned(pd) then + begin + getlabel(nodestroycall); + emit_const_ref(A_CMP,S_L,0,new_reference(procinfo^.framepointer, + procinfo^.selfpointer_offset)); + emitjmp(C_E,nodestroycall); + if procinfo^._class^.is_class then + begin + emit_const(A_PUSH,S_L,1); + emit_reg(A_PUSH,S_L,R_ESI); + end + else + begin + emit_reg(A_PUSH,S_L,R_ESI); + emit_sym(A_PUSH,S_L,newasmsymbol(procinfo^._class^.vmt_mangledname)); + end; + if (po_virtualmethod in pd^.procoptions) then + begin + emit_ref_reg(A_MOV,S_L,new_reference(R_ESI,0),R_EDI); + emit_ref(A_CALL,S_NO,new_reference(R_EDI,procinfo^._class^.vmtmethodoffset(pd^.extnumber))); + end + else + emitcall(pd^.mangledname); + { not necessary because the result is never assigned in the + case of an exception (FK) + emit_const_reg(A_MOV,S_L,0,R_ESI); + emit_const_ref(A_MOV,S_L,0,new_reference(procinfo^.framepointer,8)); + } + emitlab(nodestroycall); + end; + end + end + else + { must be the return value finalized before reraising the exception? } + if (procinfo^.returntype.def<>pdef(voiddef)) and + (procinfo^.returntype.def^.needs_inittable) and + ((procinfo^.returntype.def^.deftype<>objectdef) or + not(pobjectdef(procinfo^.returntype.def)^.is_class)) then + begin + reset_reference(hr); + hr.offset:=procinfo^.return_offset; + hr.base:=procinfo^.framepointer; + finalize(procinfo^.returntype.def,hr,ret_in_param(procinfo^.returntype.def)); + end; + + emitcall('FPC_RERAISE'); + emitlab(noreraiselabel); + end; + + { call __EXIT for main program } + if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then + begin + emitcall('FPC_DO_EXIT'); + end; + + { handle return value } + uses_eax:=false; + uses_edx:=false; + uses_esi:=false; + if not(po_assembler in aktprocsym^.definition^.procoptions) then + if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then + handle_return_value(inlined,uses_eax,uses_edx) + else + begin + { successful constructor deletes the zero flag } + { and returns self in eax } + { eax must be set to zero if the allocation failed !!! } + getlabel(okexitlabel); + emitjmp(C_NONE,okexitlabel); + emitlab(faillabel); + if procinfo^._class^.is_class then + begin + emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,8),R_ESI); + emitcall('FPC_HELP_FAIL_CLASS'); + end + else + begin + emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,12),R_ESI); +{$ifndef noAllocEdi} + getexplicitregister32(R_EDI); +{$endif noAllocEdi} + emit_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI); + emitcall('FPC_HELP_FAIL'); +{$ifndef noAllocEdi} + ungetregister32(R_EDI); +{$endif noAllocEdi} + end; + emitlab(okexitlabel); + + emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX); + emit_reg_reg(A_TEST,S_L,R_ESI,R_ESI); + uses_eax:=true; + uses_esi:=true; + end; + + { stabs uses the label also ! } + if aktexit2label^.is_used or + ((cs_debuginfo in aktmoduleswitches) and not inlined) then + emitlab(aktexit2label); + { gives problems for long mangled names } + {list^.concat(new(pai_symbol,init(aktprocsym^.definition^.mangledname+'_end')));} + + { should we restore edi ? } + { for all i386 gcc implementations } + if (po_savestdregs in aktprocsym^.definition^.procoptions) then + begin + if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EBX))); + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ESI))); + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDI))); + { here we could reset R_EBX + but that is risky because it only works + if genexitcode is called after genentrycode + so lets skip this for the moment PM + aktprocsym^.definition^.usedregisters:= + aktprocsym^.definition^.usedregisters or not ($80 shr byte(R_EBX)); + } + end; + + { for the save all registers we can simply use a pusha,popa which + push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax } + if (po_saveregisters in aktprocsym^.definition^.procoptions) then + begin + if uses_esi then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_ESI,new_reference(R_ESP,4)))); + if uses_edx then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDX,new_reference(R_ESP,20)))); + if uses_eax then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EAX,new_reference(R_ESP,28)))); + exprasmlist^.concat(new(paicpu,op_none(A_POPA,S_L))) + end; + if not(nostackframe) then + begin + if not inlined then + exprasmlist^.concat(new(paicpu,op_none(A_LEAVE,S_NO))); + end + else + begin + if (gettempsize<>0) and not inlined then + exprasmlist^.insert(new(paicpu, + op_const_reg(A_ADD,S_L,gettempsize,R_ESP))); + end; + + { parameters are limited to 65535 bytes because } + { ret allows only imm16 } + if (parasize>65535) and not(pocall_clearstack in aktprocsym^.definition^.proccalloptions) then + CGMessage(cg_e_parasize_too_big); + + { at last, the return is generated } + + if not inlined then + if (po_interrupt in aktprocsym^.definition^.procoptions) then + begin + if uses_esi then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_ESI,new_reference(R_ESP,16)))); + if uses_edx then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDX,new_reference(R_ESP,12)))); + if uses_eax then + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EAX,new_reference(R_ESP,0)))); + generate_interrupt_stackframe_exit; + end + else + begin + {Routines with the poclearstack flag set use only a ret.} + { also routines with parasize=0 } + if (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then + begin +{$ifndef OLD_C_STACK} + { complex return values are removed from stack in C code PM } + if ret_in_param(aktprocsym^.definition^.rettype.def) then + exprasmlist^.concat(new(paicpu,op_const(A_RET,S_NO,4))) + else +{$endif not OLD_C_STACK} + exprasmlist^.concat(new(paicpu,op_none(A_RET,S_NO))); + end + else if (parasize=0) then + exprasmlist^.concat(new(paicpu,op_none(A_RET,S_NO))) + else + exprasmlist^.concat(new(paicpu,op_const(A_RET,S_NO,parasize))); + end; + + if not inlined then + exprasmlist^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname))); + +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and not inlined then + begin + aktprocsym^.concatstabto(exprasmlist); + if assigned(procinfo^._class) then + if (not assigned(procinfo^.parent) or + not assigned(procinfo^.parent^._class)) then + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"$t:v'+procinfo^._class^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.selfpointer_offset))))) + else + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"$t:r*'+procinfo^._class^.numberstring+'",'+ + tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI]))))); + + { define calling EBP as pseudo local var PM } + { this enables test if the function is a local one !! } + if assigned(procinfo^.parent) and (lexlevel>normal_function_level) then + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"parent_ebp:'+voidpointerdef^.numberstring+'",'+ + tostr(N_LSYM)+',0,0,'+tostr(procinfo^.framepointer_offset))))); + + if (pdef(aktprocsym^.definition^.rettype.def) <> pdef(voiddef)) then + begin + if ret_in_param(aktprocsym^.definition^.rettype.def) then + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset))))) + else + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset))))); + if (m_result in aktmodeswitches) then + if ret_in_param(aktprocsym^.definition^.rettype.def) then + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"RESULT:X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset))))) + else + exprasmlist^.concat(new(pai_stabs,init(strpnew( + '"RESULT:X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset))))); + end; + mangled_length:=length(aktprocsym^.definition^.mangledname); + getmem(p,2*mangled_length+50); + strpcopy(p,'192,0,0,'); + strpcopy(strend(p),aktprocsym^.definition^.mangledname); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(p),'-'); + strpcopy(strend(p),aktprocsym^.definition^.mangledname); + end; + exprasmlist^.concat(new(pai_stabn,init(strnew(p)))); + {list^.concat(new(pai_stabn,init(strpnew('192,0,0,' + +aktprocsym^.definition^.mangledname)))); + p[0]:='2';p[1]:='2';p[2]:='4'; + strpcopy(strend(p),'_end');} + strpcopy(p,'224,0,0,'+aktexit2label^.name); + if (target_os.use_function_relative_addresses) then + begin + strpcopy(strend(p),'-'); + strpcopy(strend(p),aktprocsym^.definition^.mangledname); + end; + exprasmlist^.concatlist(withdebuglist); + exprasmlist^.concat(new(pai_stabn,init( + strnew(p)))); + { strpnew('224,0,0,' + +aktprocsym^.definition^.mangledname+'_end'))));} + freemem(p,2*mangled_length+50); + end; +{$endif GDB} + exprasmlist:=oldexprasmlist; + end; + + procedure genimplicitunitfinal(alist : paasmoutput); + + begin + { using current_module^.globalsymtable is hopefully } + { more robust than symtablestack and symtablestack^.next } + psymtable(current_module^.globalsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + psymtable(current_module^.localsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + exprasmlist^.insert(new(pai_symbol,initname_global('FINALIZE$$'+current_module^.modulename^,0))); + exprasmlist^.insert(new(pai_symbol,initname_global(target_os.cprefix+current_module^.modulename^+'_finalize',0))); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + target_os.use_function_relative_addresses then + exprasmlist^.insert(new(pai_stab_function_name,init(strpnew('FINALIZE$$'+current_module^.modulename^)))); +{$endif GDB} + exprasmlist^.concat(new(paicpu,op_none(A_RET,S_NO))); + alist^.concatlist(exprasmlist); + end; + + procedure genimplicitunitinit(alist : paasmoutput); + + begin + { using current_module^.globalsymtable is hopefully } + { more robust than symtablestack and symtablestack^.next } + psymtable(current_module^.globalsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + psymtable(current_module^.localsymtable)^.foreach({$ifndef TP}@{$endif}finalize_data); + exprasmlist^.insert(new(pai_symbol,initname_global('INIT$$'+current_module^.modulename^,0))); + exprasmlist^.insert(new(pai_symbol,initname_global(target_os.cprefix+current_module^.modulename^+'_init',0))); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and + target_os.use_function_relative_addresses then + exprasmlist^.insert(new(pai_stab_function_name,init(strpnew('INIT$$'+current_module^.modulename^)))); +{$endif GDB} + exprasmlist^.concat(new(paicpu,op_none(A_RET,S_NO))); + alist^.concatlist(exprasmlist); + end; + +{$ifdef test_dest_loc} + procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); + + begin + if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then + begin + emit_reg_reg(A_MOV,s,reg,dest_loc.register); + set_location(p^.location,dest_loc); + in_dest_loc:=true; + end + else + if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then + begin + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,s,reg,newreference(dest_loc.reference)))); + set_location(p^.location,dest_loc); + in_dest_loc:=true; + end + else + internalerror(20080); + end; + +{$endif test_dest_loc} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.109 2000/06/27 12:17:29 jonas + * fix for web bug 1011: no exception stack stuff is generated for + inlined procedures, the entry/exitcode of the parent will do that + + Revision 1.108 2000/06/10 17:31:42 jonas + * loadord2reg doesn't generate any "movl %reg1,%reg1" anymore + + Revision 1.107 2000/06/05 20:39:05 pierre + * fix for inline bug + + Revision 1.106 2000/05/26 20:16:00 jonas + * fixed wrong register deallocations in several ansistring related + procedures. The IDE's now function fine when compiled with -OG3p3r + + Revision 1.105 2000/05/23 14:20:49 pierre + * Use stacksize param instead of gettempsize + + Revision 1.104 2000/05/18 17:05:15 peter + * fixed size of const parameters in asm readers + + Revision 1.103 2000/05/17 11:06:11 pierre + add a comment about ENTER and linux + + Revision 1.102 2000/05/14 18:49:04 florian + + Int64/QWord stuff for array of const added + + Revision 1.101 2000/05/09 14:17:33 pierre + * handle interrupt function correctly + + Revision 1.100 2000/05/04 09:29:31 pierre + * saveregisters now does not overwrite registers used as return value for functions + + Revision 1.99 2000/04/28 08:53:47 pierre + * fix my last fix for other targets then win32 + + Revision 1.98 2000/04/26 10:03:45 pierre + * correct bugs for ts010026 and ts010029 in win32 mode + in copyvaluparas + + use SHL instead of IMUL if constant is a power of 2 in copyvalueparas + + Revision 1.97 2000/04/24 12:48:37 peter + * removed unused vars + + Revision 1.96 2000/04/10 12:23:18 jonas + * modified copyshortstring so it takes an extra paramter which allows it + to delete the sref itself (so the reg deallocations are put in the + right place for the optimizer) + + Revision 1.95 2000/04/10 09:01:15 pierre + * fix for bug 922 in copyvalueparas + + Revision 1.94 2000/04/03 20:51:22 florian + * initialize/finalize_data checks if procinfo is assigned else + crashes happend at end of compiling if there were ansistrings in the + interface/implementation part of units: it was the result of the fix + of 701 :( + + Revision 1.93 2000/04/02 10:18:18 florian + * bug 701 fixed: ansistrings in interface and implementation part of the units + are now finalized correctly even if there are no explicit initialization/ + finalization statements + + Revision 1.92 2000/04/01 14:18:45 peter + * use arraydef.elesize instead of elementtype.def.size + + Revision 1.91 2000/03/31 22:56:46 pierre + * fix the handling of value parameters in cdecl function + + Revision 1.90 2000/03/28 22:31:46 pierre + * fix for problem in tbs0299 for 4 byte stack alignment + + Revision 1.89 2000/03/21 23:36:46 pierre + fix for bug 312 + + Revision 1.88 2000/03/19 11:55:08 peter + * fixed temp ansi handling within array constructor + + Revision 1.87 2000/03/19 08:17:36 peter + * tp7 fix + + Revision 1.86 2000/03/01 15:36:11 florian + * some new stuff for the new cg + + Revision 1.85 2000/03/01 12:35:44 pierre + * fix for bug 855 + + Revision 1.84 2000/03/01 00:03:12 pierre + * fixes for locals in inlined procedures + fix for bug797 + + stabs generation for inlined paras and locals + + Revision 1.83 2000/02/18 21:25:48 florian + * fixed a bug in int64/qword handling was a quite ugly one + + Revision 1.82 2000/02/18 20:53:14 pierre + * fixes a stabs problem for functions + + includes a stabs local var for with statements + the name is with in lowercase followed by an index + for nested with. + + Withdebuglist added because the stabs declarations of local + var are postponed to end of function. + + Revision 1.81 2000/02/10 23:44:43 florian + * big update for exception handling code generation: possible mem holes + fixed, break/continue/exit should work always now as expected + + Revision 1.80 2000/02/09 17:36:10 jonas + * added missing regalloc for ecx in range check code + + Revision 1.79 2000/02/09 13:22:50 peter + * log truncated + + Revision 1.78 2000/02/04 21:00:31 florian + * some (small) problems with register saving fixed + + Revision 1.77 2000/02/04 20:00:21 florian + * an exception in a construcor calls now the destructor (this applies only + to classes) + + Revision 1.76 2000/02/04 14:29:57 pierre + + add pseudo local var parent_ebp for local procs + + Revision 1.75 2000/01/25 08:46:03 pierre + * Range check for int64 produces a warning only + + Revision 1.74 2000/01/24 12:17:22 florian + * some improvemenst to cmov support + * disabled excpetion frame generation in cosntructors temporarily + + Revision 1.73 2000/01/23 21:29:14 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.72 2000/01/23 11:11:36 michael + + Fixes from Jonas. + + Revision 1.71 2000/01/22 16:02:37 jonas + * fixed more regalloc bugs (for set adding and unsigned + multiplication) + + Revision 1.70 2000/01/16 22:17:11 peter + * renamed call_offset to para_offset + + Revision 1.69 2000/01/12 10:38:17 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.68 2000/01/09 12:35:02 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.67 2000/01/09 01:44:21 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.66 2000/01/07 01:14:22 peter + * updated copyright to 2000 + + Revision 1.65 1999/12/22 01:01:47 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.64 1999/12/20 21:42:35 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.63 1999/12/01 22:45:54 peter + * fixed wrong assembler with in-node + + Revision 1.62 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.61 1999/11/20 01:22:18 pierre + + cond FPC_USE_CPREFIX (needs also some RTL changes) + this allows to use unit global vars as DLL exports + (the underline prefix seems needed by dlltool) + + Revision 1.60 1999/11/17 17:04:58 pierre + * Notes/hints changes + + Revision 1.59 1999/11/15 14:04:00 pierre + * self pointer stabs for local function was wrong +} \ No newline at end of file diff --git a/befpc/compiler/cobjects.pas b/befpc/compiler/cobjects.pas new file mode 100644 index 0000000..80056b2 --- /dev/null +++ b/befpc/compiler/cobjects.pas @@ -0,0 +1,2459 @@ +{ + $Id: cobjects.pas,v 1.1.1.1 2001-07-23 17:15:49 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This module provides some basic objects + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} + +{$ifdef tp} + {$E+,N+,D+,F+} +{$endif} +{$I-} +{$R-}{ necessary for crc calculation } + +unit cobjects; + +{ define OLDSPEEDVALUE} + + interface + + uses +{$ifdef DELPHI4} + dmisc, + sysutils +{$else DELPHI4} + strings +{$ifndef linux} + ,dos +{$else} + ,linux +{$endif} +{$endif DELPHI4} + ; + + const + { the real size will be [-hasharray..hasharray] ! } +{$ifdef TP} + hasharraysize = 127; +{$else} + hasharraysize = 2047; +{$endif} + + type + pstring = ^string; + +{$ifdef TP} + { redeclare dword only in case of emergency, some small things + of the compiler won't work then correctly (FK) + } + dword = longint; +{$endif TP} + + pfileposinfo = ^tfileposinfo; + tfileposinfo = record + line : longint; + column : word; + fileindex : word; + end; + + pmemdebug = ^tmemdebug; + tmemdebug = object + constructor init(const s:string); + destructor done; + procedure show; + private + startmem : longint; + infostr : string[40]; + end; + + plinkedlist_item = ^tlinkedlist_item; + tlinkedlist_item = object + next,previous : plinkedlist_item; + { does nothing } + constructor init; + destructor done;virtual; + function getcopy:plinkedlist_item;virtual; + end; + + pstring_item = ^tstring_item; + tstring_item = object(tlinkedlist_item) + str : pstring; + constructor init(const s : string); + destructor done;virtual; + end; + + + { this implements a double linked list } + plinkedlist = ^tlinkedlist; + tlinkedlist = object + first,last : plinkedlist_item; + constructor init; + destructor done; + { destructors the linkedlist without cleaning the items up } + destructor done_noclear; + + { disposes the items of the list } + procedure clear; + + { concats a new item at the end } + procedure concat(p : plinkedlist_item); + + { inserts a new item at the begin } + procedure insert(p : plinkedlist_item); + + { inserts another list at the begin and make this list empty } + procedure insertlist(p : plinkedlist); + + { concats another list at the end and make this list empty } + procedure concatlist(p : plinkedlist); + + procedure concatlistcopy(p : plinkedlist); + + { removes p from the list (p isn't disposed) } + { it's not tested if p is in the list ! } + procedure remove(p : plinkedlist_item); + + { is the linkedlist empty ? } + function empty:boolean; + + { items in the list } + function count:longint; + end; + + { some help data types } + pstringqueueitem = ^tstringqueueitem; + tstringqueueitem = object + data : pstring; + next : pstringqueueitem; + end; + + { String Queue} + PStringQueue=^TStringQueue; + TStringQueue=object + first,last : PStringqueueItem; + constructor Init; + destructor Done; + function Empty:boolean; + function Get:string; + function Find(const s:string):PStringqueueItem; + function Delete(const s:string):boolean; + procedure Insert(const s:string); + procedure Concat(const s:string); + procedure Clear; + end; + + { containeritem } + pcontaineritem = ^tcontaineritem; + tcontaineritem = object + next : pcontaineritem; + constructor init; + destructor done;virtual; + end; + + { container } + pcontainer = ^tcontainer; + tcontainer = object + root, + last : pcontaineritem; + constructor init; + destructor done; + { true when the container is empty } + function empty:boolean; + { inserts a string } + procedure insert(item:pcontaineritem); + { gets a string } + function get:pcontaineritem; + { deletes all items } + procedure clear; + end; + + { containeritem } + pstringcontaineritem = ^tstringcontaineritem; + tstringcontaineritem = object(tcontaineritem) + data : pstring; + file_info : tfileposinfo; + constructor init(const s:string); + constructor Init_TokenInfo(const s:string;const pos:tfileposinfo); + destructor done;virtual; + end; + + { string container } + pstringcontainer = ^tstringcontainer; + tstringcontainer = object(tcontainer) + doubles : boolean; { if this is set to true, doubles are allowed } + constructor init; + constructor init_no_double; + procedure insert(const s : string); + procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo); + { gets a string } + function get : string; + function get_with_tokeninfo(var file_info : tfileposinfo) : string; + { true if string is in the container } + function find(const s:string):boolean; + end; + + + { namedindexobject for use with dictionary and indexarray } + Pnamedindexobject=^Tnamedindexobject; + Tnamedindexobject=object + indexnr : longint; + _name : Pstring; + next, + left,right : Pnamedindexobject; + speedvalue : longint; + constructor init; + constructor initname(const n:string); + destructor done;virtual; + procedure setname(const n:string);virtual; + function name:string;virtual; + end; + + Pdictionaryhasharray=^Tdictionaryhasharray; + Tdictionaryhasharray=array[-hasharraysize..hasharraysize] of Pnamedindexobject; + + Tnamedindexcallback = procedure(p:Pnamedindexobject); + + Pdictionary=^Tdictionary; + Tdictionary=object + noclear : boolean; + replace_existing : boolean; + constructor init; + destructor done;virtual; + procedure usehash; + procedure clear; + function delete(const s:string):Pnamedindexobject; + function empty:boolean; + procedure foreach(proc2call:Tnamedindexcallback); + function insert(obj:Pnamedindexobject):Pnamedindexobject; + function rename(const olds,news : string):Pnamedindexobject; + function search(const s:string):Pnamedindexobject; + function speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; + private + root : Pnamedindexobject; + hasharray : Pdictionaryhasharray; + procedure cleartree(obj:Pnamedindexobject); + function insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; + procedure inserttree(currtree,currroot:Pnamedindexobject); + end; + + pdynamicarray = ^tdynamicarray; + tdynamicarray = object + posn, + count, + limit, + elemlen, + growcount : longint; + data : pchar; + constructor init(Aelemlen,Agrow:longint); + destructor done; + function size:longint; + function usedsize:longint; + procedure grow; + procedure align(i:longint); + procedure seek(i:longint); + procedure write(var d;len:longint); + procedure read(var d;len:longint); + procedure writepos(pos:longint;var d;len:longint); + procedure readpos(pos:longint;var d;len:longint); + end; + + tindexobjectarray=array[1..16000] of Pnamedindexobject; + Pnamedindexobjectarray=^tindexobjectarray; + + pindexarray=^tindexarray; + tindexarray=object + first : Pnamedindexobject; + count : longint; + constructor init(Agrowsize:longint); + destructor done; + procedure clear; + procedure foreach(proc2call : Tnamedindexcallback); + procedure deleteindex(p:Pnamedindexobject); + procedure delete(p:Pnamedindexobject); + procedure insert(p:Pnamedindexobject); + function search(nr:longint):Pnamedindexobject; + private + growsize, + size : longint; + data : Pnamedindexobjectarray; + procedure grow(gsize:longint); + end; + +{$ifdef BUFFEREDFILE} + { this is implemented to allow buffered binary I/O } + pbufferedfile = ^tbufferedfile; + tbufferedfile = object + f : file; + buf : pchar; + bufsize,buflast,bufpos : longint; + + { 0 closed, 1 input, 2 output } + iomode : byte; + + { true, if the compile should change the endian of the output } + change_endian : boolean; + + { calcules a crc for the file, } + { but it's assumed, that there no seek while do_crc is true } + do_crc : boolean; + crc : longint; + { temporary closing feature } + tempclosed : boolean; + tempmode : byte; + temppos : longint; + + { inits a buffer with the size bufsize which is assigned to } + { the file filename } + constructor init(const filename : string;_bufsize : longint); + + { closes the file, if needed, and releases the memory } + destructor done;virtual; + + { opens the file for input, other accesses are rejected } + function reset:boolean; + + { opens the file for output, other accesses are rejected } + procedure rewrite; + + { reads or writes the buffer from or to disk } + procedure flush; + + { writes a string to the file } + { the string is written without a length byte } + procedure write_string(const s : string); + + { writes a zero terminated string } + procedure write_pchar(p : pchar); + + { write specific data types, takes care of } + { byte order } + procedure write_byte(b : byte); + procedure write_word(w : word); + procedure write_long(l : longint); + procedure write_double(d : double); + + { writes any data } + procedure write_data(var data;count : longint); + + { reads any data } + procedure read_data(var data;bytes : longint;var count : longint); + + { closes the file and releases the buffer } + procedure close; + + { temporary closing } + procedure tempclose; + procedure tempreopen; + + { goto the given position } + procedure seek(l : longint); + + { installes an user defined buffer } + { and releases the old one, but be } + { careful, if the old buffer contains } + { data, this data is lost } + procedure setbuf(p : pchar;s : longint); + + { reads the file time stamp of the file, } + { the file must be opened } + function getftime : longint; + + { returns filesize } + function getsize : longint; + + { returns the path } + function getpath : string; + + { resets the crc } + procedure clear_crc; + + { returns the crc } + function getcrc : longint; + end; +{$endif BUFFEREDFILE} + +{$ifdef fixLeaksOnError} + PStackItem = ^TStackItem; + TStackItem = record + next: PStackItem; + data: pointer; + end; + + PStack = ^TStack; + TStack = object + constructor init; + destructor done; + procedure push(p: pointer); + function pop: pointer; + function top: pointer; + function isEmpty: boolean; + private + head: PStackItem; + end; +{$endif fixLeaksOnError} + + function getspeedvalue(const s : string) : longint; + + { releases the string p and assignes nil to p } + { if p=nil then freemem isn't called } + procedure stringdispose(var p : pstring); + + { idem for ansistrings } + procedure ansistringdispose(var p : pchar;length : longint); + + { allocates mem for a copy of s, copies s to this mem and returns } + { a pointer to this mem } + function stringdup(const s : string) : pstring; + + { allocates memory for s and copies s as zero terminated string + to that mem and returns a pointer to that mem } + function strpnew(const s : string) : pchar; + procedure strdispose(var p : pchar); + + { makes a char lowercase, with spanish, french and german char set } + function lowercase(c : char) : char; + + { makes zero terminated string to a pascal string } + { the data in p is modified and p is returned } + function pchar2pstring(p : pchar) : pstring; + + { ambivalent to pchar2pstring } + function pstring2pchar(p : pstring) : pchar; + + implementation + + uses + comphook; + +{***************************************************************************** + Memory debug +*****************************************************************************} + + constructor tmemdebug.init(const s:string); + begin + infostr:=s; +{$ifdef Delphi} + startmem:=0; +{$else} + startmem:=memavail; +{$endif Delphi} + end; + + procedure tmemdebug.show; + var + l : longint; + begin +{$ifndef Delphi} + write('memory [',infostr,'] '); + l:=memavail; + if l>startmem then + writeln(l-startmem,' released') + else + writeln(startmem-l,' allocated'); +{$endif Delphi} + end; + + destructor tmemdebug.done; + begin + show; + end; + +{***************************************************************************** + Stack +*****************************************************************************} + + + +{$ifdef fixLeaksOnError} +constructor TStack.init; +begin + head := nil; +end; + +procedure TStack.push(p: pointer); +var s: PStackItem; +begin + new(s); + s^.data := p; + s^.next := head; + head := s; +end; + +function TStack.pop: pointer; +var s: PStackItem; +begin + pop := top; + if assigned(head) then + begin + s := head^.next; + dispose(head); + head := s; + end +end; + +function TStack.top: pointer; +begin + if not isEmpty then + top := head^.data + else top := NIL; +end; + +function TStack.isEmpty: boolean; +begin + isEmpty := head = nil; +end; + +destructor TStack.done; +var temp: PStackItem; +begin + while head <> nil do + begin + temp := head^.next; + dispose(head); + head := temp; + end; +end; +{$endif fixLeaksOnError} + + +{$ifndef OLDSPEEDVALUE} + +{***************************************************************************** + Crc 32 +*****************************************************************************} + +var + Crc32Tbl : array[0..255] of longint; + +procedure MakeCRC32Tbl; +var + crc : longint; + i,n : byte; +begin + for i:=0 to 255 do + begin + crc:=i; + for n:=1 to 8 do + if odd(crc) then + crc:=(crc shr 1) xor longint($edb88320) + else + crc:=crc shr 1; + Crc32Tbl[i]:=crc; + end; +end; + + +{$ifopt R+} + {$define Range_check_on} +{$endif opt R+} + +{$R- needed here } +{CRC 32} +Function GetSpeedValue(Const s:String):longint; +var + i,InitCrc : longint; +begin + if Crc32Tbl[1]=0 then + MakeCrc32Tbl; + InitCrc:=$ffffffff; + for i:=1 to Length(s) do + InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8); + GetSpeedValue:=InitCrc; +end; + +{$ifdef Range_check_on} + {$R+} + {$undef Range_check_on} +{$endif Range_check_on} + +{$else} + +{$ifndef TP} + function getspeedvalue(const s : string) : longint; + var + p1,p2:^byte; + i : longint; + + begin + p1:=@s; + longint(p2):=longint(p1)+p1^+1; + inc(longint(p1)); + i:=0; + while p1<>p2 do + begin + i:=i + ord(p1^); + inc(longint(p1)); + end; + getspeedvalue:=i; + end; +{$else} + function getspeedvalue(const s : string) : longint; + type + ptrrec=record + ofs,seg:word; + end; + var + l,w : longint; + p1,p2 : ^byte; + begin + p1:=@s; + ptrrec(p2).seg:=ptrrec(p1).seg; + ptrrec(p2).ofs:=ptrrec(p1).ofs+p1^+1; + inc(p1); + l:=0; + while p1<>p2 do + begin + l:=l + ord(p1^); + inc(p1); + end; + getspeedvalue:=l; + end; +{$endif} + +{$endif OLDSPEEDVALUE} + + + function pchar2pstring(p : pchar) : pstring; + var + w,i : longint; + begin + w:=strlen(p); + for i:=w-1 downto 0 do + p[i+1]:=p[i]; + p[0]:=chr(w); + pchar2pstring:=pstring(p); + end; + + + function pstring2pchar(p : pstring) : pchar; + var + w,i : longint; + begin + w:=length(p^); + for i:=1 to w do + p^[i-1]:=p^[i]; + p^[w]:=#0; + pstring2pchar:=pchar(p); + end; + + + function lowercase(c : char) : char; + begin + case c of + #65..#90 : c := chr(ord (c) + 32); + #154 : c:=#129; { german } + #142 : c:=#132; { german } + #153 : c:=#148; { german } + #144 : c:=#130; { french } + #128 : c:=#135; { french } + #143 : c:=#134; { swedish/norge (?) } + #165 : c:=#164; { spanish } + #228 : c:=#229; { greek } + #226 : c:=#231; { greek } + #232 : c:=#227; { greek } + end; + lowercase := c; + end; + + + function strpnew(const s : string) : pchar; + var + p : pchar; + begin + getmem(p,length(s)+1); + strpcopy(p,s); + strpnew:=p; + end; + + + procedure strdispose(var p : pchar); + begin + if assigned(p) then + begin + freemem(p,strlen(p)+1); + p:=nil; + end; + end; + + + procedure stringdispose(var p : pstring); + begin + if assigned(p) then + freemem(p,length(p^)+1); + p:=nil; + end; + + + procedure ansistringdispose(var p : pchar;length : longint); + begin + if assigned(p) then + freemem(p,length+1); + p:=nil; + end; + + + function stringdup(const s : string) : pstring; + var + p : pstring; + begin + getmem(p,length(s)+1); + p^:=s; + stringdup:=p; + end; + + +{**************************************************************************** + TStringQueue +****************************************************************************} + +constructor TStringQueue.Init; +begin + first:=nil; + last:=nil; +end; + + +function TStringQueue.Empty:boolean; +begin + Empty:=(first=nil); +end; + + +function TStringQueue.Get:string; +var + newnode : pstringqueueitem; +begin + if first=nil then + begin + Get:=''; + exit; + end; + Get:=first^.data^; + stringdispose(first^.data); + newnode:=first; + first:=first^.next; + dispose(newnode); +end; + + +function TStringQueue.Find(const s:string):PStringqueueItem; +var + p : PStringqueueItem; +begin + p:=first; + while assigned(p) do + begin + if p^.data^=s then + break; + p:=p^.next; + end; + Find:=p; +end; + + +function TStringQueue.Delete(const s:string):boolean; +var + prev,p : PStringqueueItem; +begin + Delete:=false; + prev:=nil; + p:=first; + while assigned(p) do + begin + if p^.data^=s then + begin + if p=last then + last:=prev; + if assigned(prev) then + prev^.next:=p^.next + else + first:=p^.next; + dispose(p); + Delete:=true; + exit; + end; + prev:=p; + p:=p^.next; + end; +end; + + +procedure TStringQueue.Insert(const s:string); +var + newnode : pstringqueueitem; +begin + new(newnode); + newnode^.next:=first; + newnode^.data:=stringdup(s); + first:=newnode; + if last=nil then + last:=newnode; +end; + + +procedure TStringQueue.Concat(const s:string); +var + newnode : pstringqueueitem; +begin + new(newnode); + newnode^.next:=nil; + newnode^.data:=stringdup(s); + if first=nil then + first:=newnode + else + last^.next:=newnode; + last:=newnode; +end; + + +procedure TStringQueue.Clear; +var + newnode : pstringqueueitem; +begin + while (first<>nil) do + begin + newnode:=first; + stringdispose(first^.data); + first:=first^.next; + dispose(newnode); + end; + last:=nil; +end; + + +destructor TStringQueue.Done; +begin + Clear; +end; + + +{**************************************************************************** + TContainerItem + ****************************************************************************} + +constructor TContainerItem.Init; +begin +end; + + +destructor TContainerItem.Done; +begin +end; + + +{**************************************************************************** + TStringContainerItem + ****************************************************************************} + +constructor TStringContainerItem.Init(const s:string); +begin + inherited Init; + data:=stringdup(s); + file_info.fileindex:=0; + file_info.line:=0; + file_info.column:=0; +end; + + +constructor TStringContainerItem.Init_TokenInfo(const s:string;const pos:tfileposinfo); +begin + inherited Init; + data:=stringdup(s); + file_info:=pos; +end; + + +destructor TStringContainerItem.Done; +begin + stringdispose(data); +end; + + + +{**************************************************************************** + TCONTAINER + ****************************************************************************} + + constructor tcontainer.init; + begin + root:=nil; + last:=nil; + end; + + + destructor tcontainer.done; + begin + clear; + end; + + + function tcontainer.empty:boolean; + begin + empty:=(root=nil); + end; + + + procedure tcontainer.insert(item:pcontaineritem); + begin + item^.next:=nil; + if root=nil then + root:=item + else + last^.next:=item; + last:=item; + end; + + + procedure tcontainer.clear; + var + newnode : pcontaineritem; + begin + newnode:=root; + while assigned(newnode) do + begin + root:=newnode^.next; + dispose(newnode,done); + newnode:=root; + end; + last:=nil; + root:=nil; + end; + + + function tcontainer.get:pcontaineritem; + begin + if root=nil then + get:=nil + else + begin + get:=root; + root:=root^.next; + end; + end; + + +{**************************************************************************** + TSTRINGCONTAINER + ****************************************************************************} + + constructor tstringcontainer.init; + begin + inherited init; + doubles:=true; + end; + + + constructor tstringcontainer.init_no_double; + begin + inherited init; + doubles:=false; + end; + + + procedure tstringcontainer.insert(const s : string); + var + newnode : pstringcontaineritem; + begin + if (s='') or + ((not doubles) and find(s)) then + exit; + new(newnode,init(s)); + inherited insert(newnode); + end; + + + procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo); + var + newnode : pstringcontaineritem; + begin + if (not doubles) and find(s) then + exit; + new(newnode,init_tokeninfo(s,file_info)); + inherited insert(newnode); + end; + + + function tstringcontainer.get : string; + var + p : pstringcontaineritem; + begin + p:=pstringcontaineritem(inherited get); + if p=nil then + get:='' + else + begin + get:=p^.data^; + dispose(p,done); + end; + end; + + + function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string; + var + p : pstringcontaineritem; + begin + p:=pstringcontaineritem(inherited get); + if p=nil then + begin + get_with_tokeninfo:=''; + file_info.fileindex:=0; + file_info.line:=0; + file_info.column:=0; + end + else + begin + get_with_tokeninfo:=p^.data^; + file_info:=p^.file_info; + dispose(p,done); + end; + end; + + + function tstringcontainer.find(const s:string):boolean; + var + newnode : pstringcontaineritem; + begin + find:=false; + newnode:=pstringcontaineritem(root); + while assigned(newnode) do + begin + if newnode^.data^=s then + begin + find:=true; + exit; + end; + newnode:=pstringcontaineritem(newnode^.next); + end; + end; + + +{**************************************************************************** + TLINKEDLIST_ITEM + ****************************************************************************} + + constructor tlinkedlist_item.init; + begin + previous:=nil; + next:=nil; + end; + + + destructor tlinkedlist_item.done; + begin + end; + + + function tlinkedlist_item.getcopy:plinkedlist_item; + var + l : longint; + p : plinkedlist_item; + begin + l:=sizeof(self); + getmem(p,l); + move(self,p^,l); + getcopy:=p; + end; + + +{**************************************************************************** + TSTRING_ITEM + ****************************************************************************} + + constructor tstring_item.init(const s : string); + begin + str:=stringdup(s); + end; + + + destructor tstring_item.done; + begin + stringdispose(str); + inherited done; + end; + + +{**************************************************************************** + TLINKEDLIST + ****************************************************************************} + + constructor tlinkedlist.init; + begin + first:=nil; + last:=nil; + end; + + + destructor tlinkedlist.done; + + begin + clear; + end; + + destructor tlinkedlist.done_noclear; + + begin + end; + + procedure tlinkedlist.clear; + var + newnode : plinkedlist_item; + begin + newnode:=first; + while assigned(newnode) do + begin + first:=newnode^.next; + dispose(newnode,done); + newnode:=first; + end; + end; + + + procedure tlinkedlist.insertlist(p : plinkedlist); + begin + { empty list ? } + if not(assigned(p^.first)) then + exit; + + p^.last^.next:=first; + + { we have a double linked list } + if assigned(first) then + first^.previous:=p^.last; + + first:=p^.first; + + if not(assigned(last)) then + last:=p^.last; + + { p becomes empty } + p^.first:=nil; + p^.last:=nil; + end; + + + procedure tlinkedlist.concat(p : plinkedlist_item); + begin + if not(assigned(first)) then + begin + first:=p; + p^.previous:=nil; + p^.next:=nil; + end + else + begin + last^.next:=p; + p^.previous:=last; + p^.next:=nil; + end; + last:=p; + end; + + + procedure tlinkedlist.insert(p : plinkedlist_item); + begin + if not(assigned(first)) then + begin + last:=p; + p^.previous:=nil; + p^.next:=nil; + end + else + begin + first^.previous:=p; + p^.previous:=nil; + p^.next:=first; + end; + first:=p; + end; + + + procedure tlinkedlist.remove(p : plinkedlist_item); + begin + if not(assigned(p)) then + exit; + if (first=p) and (last=p) then + begin + first:=nil; + last:=nil; + end + else if first=p then + begin + first:=p^.next; + if assigned(first) then + first^.previous:=nil; + end + else if last=p then + begin + last:=last^.previous; + if assigned(last) then + last^.next:=nil; + end + else + begin + p^.previous^.next:=p^.next; + p^.next^.previous:=p^.previous; + end; + p^.next:=nil; + p^.previous:=nil; + end; + + + procedure tlinkedlist.concatlist(p : plinkedlist); + begin + if not(assigned(p^.first)) then + exit; + + if not(assigned(first)) then + first:=p^.first + else + begin + last^.next:=p^.first; + p^.first^.previous:=last; + end; + + last:=p^.last; + + { make p empty } + p^.last:=nil; + p^.first:=nil; + end; + + + procedure tlinkedlist.concatlistcopy(p : plinkedlist); + var + newnode,newnode2 : plinkedlist_item; + begin + newnode:=p^.first; + while assigned(newnode) do + begin + newnode2:=newnode^.getcopy; + if assigned(newnode2) then + begin + if not(assigned(first)) then + begin + first:=newnode2; + newnode2^.previous:=nil; + newnode2^.next:=nil; + end + else + begin + last^.next:=newnode2; + newnode2^.previous:=last; + newnode2^.next:=nil; + end; + last:=newnode2; + end; + newnode:=newnode^.next; + end; + end; + + + function tlinkedlist.empty:boolean; + begin + empty:=(first=nil); + end; + + + function tlinkedlist.count:longint; + var + i : longint; + hp : plinkedlist_item; + begin + hp:=first; + i:=0; + while assigned(hp) do + begin + inc(i); + hp:=hp^.next; + end; + count:=i; + end; + + +{**************************************************************************** + Tnamedindexobject + ****************************************************************************} + +constructor Tnamedindexobject.init; +begin + { index } + indexnr:=-1; + next:=nil; + { dictionary } + left:=nil; + right:=nil; + _name:=nil; + speedvalue:=-1; +end; + +constructor Tnamedindexobject.initname(const n:string); +begin + { index } + indexnr:=-1; + next:=nil; + { dictionary } + left:=nil; + right:=nil; + speedvalue:=-1; + _name:=stringdup(n); +end; + +destructor Tnamedindexobject.done; +begin + stringdispose(_name); +end; + +procedure Tnamedindexobject.setname(const n:string); +begin + if speedvalue=-1 then + begin + if assigned(_name) then + stringdispose(_name); + _name:=stringdup(n); + end; +end; + +function Tnamedindexobject.name:string; +begin + if assigned(_name) then + name:=_name^ + else + name:=''; +end; + + +{**************************************************************************** + TDICTIONARY +****************************************************************************} + + constructor Tdictionary.init; + begin + root:=nil; + hasharray:=nil; + noclear:=false; + replace_existing:=false; + end; + + + procedure Tdictionary.usehash; + begin + if not(assigned(root)) and + not(assigned(hasharray)) then + begin + new(hasharray); + fillchar(hasharray^,sizeof(hasharray^),0); + end; + end; + + + destructor Tdictionary.done; + begin + if not noclear then + clear; + if assigned(hasharray) then + dispose(hasharray); + end; + + + procedure Tdictionary.cleartree(obj:Pnamedindexobject); + begin + if assigned(obj^.left) then + cleartree(obj^.left); + if assigned(obj^.right) then + cleartree(obj^.right); + dispose(obj,done); + obj:=nil; + end; + + + procedure Tdictionary.clear; + var + w : longint; + begin + if assigned(root) then + cleartree(root); + if assigned(hasharray) then + for w:=-hasharraysize to hasharraysize do + if assigned(hasharray^[w]) then + cleartree(hasharray^[w]); + end; + + function Tdictionary.delete(const s:string):Pnamedindexobject; + + var p,speedvalue:longint; + n:Pnamedindexobject; + + procedure insert_right_bottom(var root,Atree:Pnamedindexobject); + + begin + while root^.right<>nil do + root:=root^.right; + root^.right:=Atree; + end; + + function delete_from_tree(root:Pnamedindexobject):Pnamedindexobject; + + type leftright=(left,right); + + var lr:leftright; + oldroot:Pnamedindexobject; + + begin + oldroot:=nil; + while (root<>nil) and (root^.speedvalue<>speedvalue) do + begin + oldroot:=root; + if speedvaluenil) and (root^._name^<>s) do + begin + oldroot:=root; + if snil then + begin + {Now the node pointing to root must point to the left + subtree of root. The right subtree of root must be + connected to the right bottom of the left subtree.} + if lr=left then + oldroot^.left:=root^.left + else + oldroot^.right:=root^.left; + if root^.right<>nil then + insert_right_bottom(root^.left,root^.right); + end + else + {There is no left subtree. So we can just replace the node to + delete with the right subtree.} + if lr=left then + oldroot^.left:=root^.right + else + oldroot^.right:=root^.right; + delete_from_tree:=root; + end; + + begin + speedvalue:=getspeedvalue(s); + n:=root; + if assigned(hasharray) then + begin + {First, check if the node to delete directly located under + the hasharray.} + p:=speedvalue mod hasharraysize; + n:=hasharray^[p]; + if (n<>nil) and (n^.speedvalue=speedvalue) and + (n^._name^=s) then + begin + {The node to delete is directly located under the + hasharray. Make the hasharray point to the left + subtree of the node and place the right subtree on + the right-bottom of the left subtree.} + if n^.left<>nil then + begin + hasharray^[p]:=n^.left; + if n^.right<>nil then + insert_right_bottom(n^.left,n^.right); + end + else + hasharray^[p]:=n^.right; + delete:=n; + exit; + end; + end + else + begin + {First check if the node to delete is the root.} + if (root<>nil) and (n^.speedvalue=speedvalue) + and (n^._name^=s) then + begin + if n^.left<>nil then + begin + root:=n^.left; + if n^.right<>nil then + insert_right_bottom(n^.left,n^.right); + end + else + root:=n^.right; + delete:=n; + exit; + end; + end; + delete:=delete_from_tree(n); + end; + + function Tdictionary.empty:boolean; + var + w : longint; + begin + if assigned(hasharray) then + begin + empty:=false; + for w:=-hasharraysize to hasharraysize do + if assigned(hasharray^[w]) then + exit; + empty:=true; + end + else + empty:=(root=nil); + end; + + + procedure Tdictionary.foreach(proc2call:Tnamedindexcallback); + + procedure a(p:Pnamedindexobject); + begin + proc2call(p); + if assigned(p^.left) then + a(p^.left); + if assigned(p^.right) then + a(p^.right); + end; + + var + i : longint; + begin + if assigned(hasharray) then + begin + for i:=-hasharraysize to hasharraysize do + if assigned(hasharray^[i]) then + a(hasharray^[i]); + end + else + if assigned(root) then + a(root); + end; + + + function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject; + begin + obj^.speedvalue:=getspeedvalue(obj^._name^); + if assigned(hasharray) then + insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize]) + else + insert:=insertnode(obj,root); + end; + + + function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; + begin + if currnode=nil then + begin + currnode:=newnode; + insertnode:=newnode; + end + { first check speedvalue, to allow a fast insert } + else + if currnode^.speedvalue>newnode^.speedvalue then + insertnode:=insertnode(newnode,currnode^.right) + else + if currnode^.speedvaluenewnode^._name^ then + insertnode:=insertnode(newnode,currnode^.right) + else + if currnode^._name^hp^.speedvalue then + begin + lasthp:=hp; + hp:=hp^.left + end + else + if spdvalhp^.name then + begin + lasthp:=hp; + hp:=hp^.left + end + else + begin + lasthp:=hp; + hp:=hp^.right; + end; + end; + end; + end; + + + function Tdictionary.search(const s:string):Pnamedindexobject; + begin + search:=speedsearch(s,getspeedvalue(s)); + end; + + + function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; + var + newnode:Pnamedindexobject; + begin + if assigned(hasharray) then + newnode:=hasharray^[speedvalue mod hasharraysize] + else + newnode:=root; + while assigned(newnode) do + begin + if speedvalue>newnode^.speedvalue then + newnode:=newnode^.left + else + if speedvaluenewnode^._name^ then + newnode:=newnode^.left + else + newnode:=newnode^.right; + end; + end; + speedsearch:=nil; + end; + + +{**************************************************************************** + tdynamicarray +****************************************************************************} + + constructor tdynamicarray.init(Aelemlen,Agrow:longint); + begin + posn:=0; + count:=0; + limit:=0; + data:=nil; + elemlen:=Aelemlen; + growcount:=Agrow; + grow; + end; + + function tdynamicarray.size:longint; + begin + size:=limit*elemlen; + end; + + function tdynamicarray.usedsize:longint; + begin + usedsize:=count*elemlen; + end; + + procedure tdynamicarray.grow; + var + osize : longint; + odata : pchar; + begin + osize:=size; + odata:=data; + inc(limit,growcount); + getmem(data,size); + if assigned(odata) then + begin + move(odata^,data^,osize); + freemem(odata,osize); + end; + fillchar(data[osize],growcount*elemlen,0); + end; + + procedure tdynamicarray.align(i:longint); + var + j : longint; + begin + j:=(posn*elemlen mod i); + if j<>0 then + begin + j:=i-j; + while limit<(posn+j) do + grow; + inc(posn,j); + if (posn>count) then + count:=posn; + end; + end; + + procedure tdynamicarray.seek(i:longint); + begin + while limitcount) then + count:=posn; + end; + + procedure tdynamicarray.write(var d;len:longint); + begin + while limit<(posn+len) do + grow; + move(d,data[posn*elemlen],len*elemlen); + inc(posn,len); + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.read(var d;len:longint); + begin + move(data[posn*elemlen],d,len*elemlen); + inc(posn,len); + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.writepos(pos:longint;var d;len:longint); + begin + while limit<(pos+len) do + grow; + move(d,data[pos*elemlen],len*elemlen); + posn:=pos+len; + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.readpos(pos:longint;var d;len:longint); + begin + while limit<(pos+len) do + grow; + move(data[pos*elemlen],d,len*elemlen); + posn:=pos+len; + if (posn>count) then + count:=posn; + end; + + destructor tdynamicarray.done; + begin + if assigned(data) then + freemem(data,size); + end; + + +{**************************************************************************** + tindexarray + ****************************************************************************} + + + constructor tindexarray.init(Agrowsize:longint); + begin + growsize:=Agrowsize; + size:=0; + count:=0; + data:=nil; + first:=nil; + end; + + destructor tindexarray.done; + begin + if assigned(data) then + begin + clear; + freemem(data,size*4); + data:=nil; + end; + end; + + function tindexarray.search(nr:longint):Pnamedindexobject; + begin + if nr<=count then + search:=data^[nr] + else + search:=nil; + end; + + + procedure tindexarray.clear; + var + i : longint; + begin + for i:=1 to count do + if assigned(data^[i]) then + begin + dispose(data^[i],done); + data^[i]:=nil; + end; + count:=0; + first:=nil; + end; + + + procedure tindexarray.foreach(proc2call : Tnamedindexcallback); + var + i : longint; + begin + for i:=1 to count do + if assigned(data^[i]) then + proc2call(data^[i]); + end; + + + procedure tindexarray.grow(gsize:longint); + var + osize : longint; + odata : Pnamedindexobjectarray; + begin + osize:=size; + odata:=data; + inc(size,gsize); + getmem(data,size*4); + if assigned(odata) then + begin + move(odata^,data^,osize*4); + freemem(odata,osize*4); + end; + fillchar(data^[osize+1],gsize*4,0); + end; + + + procedure tindexarray.deleteindex(p:Pnamedindexobject); + var + i : longint; + begin + i:=p^.indexnr; + { update counter } + if i=count then + dec(count); + { update linked list } + while (i>0) do + begin + dec(i); + if (i>0) and assigned(data^[i]) then + begin + data^[i]^.next:=data^[p^.indexnr]^.next; + break; + end; + end; + if i=0 then + first:=p^.next; + data^[p^.indexnr]:=nil; + { clear entry } + p^.indexnr:=-1; + p^.next:=nil; + end; + + + procedure tindexarray.delete(p:Pnamedindexobject); + begin + deleteindex(p); + dispose(p,done); + p:=nil; + end; + + + procedure tindexarray.insert(p:Pnamedindexobject); + var + i : longint; + begin + if p^.indexnr=-1 then + begin + inc(count); + p^.indexnr:=count; + end; + if p^.indexnr>count then + count:=p^.indexnr; + if count>size then + grow(((count div growsize)+1)*growsize); + data^[p^.indexnr]:=p; + { update linked list backward } + i:=p^.indexnr; + while (i>0) do + begin + dec(i); + if (i>0) and assigned(data^[i]) then + begin + data^[i]^.next:=p; + break; + end; + end; + if i=0 then + first:=p; + { update linked list forward } + i:=p^.indexnr; + while (i<=count) do + begin + inc(i); + if (i<=count) and assigned(data^[i]) then + begin + p^.next:=data^[i]; + exit; + end; + end; + if i>count then + p^.next:=nil; + end; + + +{$ifdef BUFFEREDFILE} + +{**************************************************************************** + TBUFFEREDFILE + ****************************************************************************} + + Const + crcseed = $ffffffff; + + crctable : array[0..255] of longint = ( + $00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f, + $e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988, + $09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2, + $f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7, + $136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9, + $fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172, + $3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c, + $dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59, + $26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423, + $cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924, + $2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106, + $98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433, + $7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d, + $91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e, + $6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950, + $8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65, + $4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7, + $a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0, + $44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa, + $be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f, + $5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81, + $b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a, + $ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84, + $0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1, + $f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb, + $196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc, + $f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e, + $38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b, + $d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55, + $316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236, + $cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28, + $2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d, + $9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f, + $72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38, + $92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242, + $68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777, + $88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69, + $616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2, + $a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc, + $40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9, + $bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693, + $54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94, + $b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d); + + constructor tbufferedfile.init(const filename : string;_bufsize : longint); + + begin + assign(f,filename); + bufsize:=_bufsize; + bufpos:=0; + buflast:=0; + do_crc:=false; + iomode:=0; + tempclosed:=false; + change_endian:=false; + clear_crc; + end; + + destructor tbufferedfile.done; + + begin + close; + end; + + procedure tbufferedfile.clear_crc; + + begin + crc:=crcseed; + end; + + procedure tbufferedfile.setbuf(p : pchar;s : longint); + + begin + flush; + freemem(buf,bufsize); + bufsize:=s; + buf:=p; + end; + + function tbufferedfile.reset:boolean; + + var + ofm : byte; + begin + ofm:=filemode; + iomode:=1; + getmem(buf,bufsize); + filemode:=0; + {$I-} + system.reset(f,1); + {$I+} + reset:=(ioresult=0); + filemode:=ofm; + end; + + procedure tbufferedfile.rewrite; + + begin + iomode:=2; + getmem(buf,bufsize); + system.rewrite(f,1); + end; + + procedure tbufferedfile.flush; + + var +{$ifdef FPC} + count : longint; +{$else} + count : integer; +{$endif} + + begin + if iomode=2 then + begin + if bufpos=0 then + exit; + blockwrite(f,buf^,bufpos) + end + else if iomode=1 then + if buflast=bufpos then + begin + blockread(f,buf^,bufsize,count); + buflast:=count; + end; + bufpos:=0; + end; + + function tbufferedfile.getftime : longint; + + var + l : longint; +{$ifdef linux} + Info : Stat; +{$endif} + begin +{$ifndef linux} + { this only works if the file is open !! } + dos.getftime(f,l); +{$else} + Fstat(f,Info); + l:=info.mtime; +{$endif} + getftime:=l; + end; + + function tbufferedfile.getsize : longint; + + begin + getsize:=filesize(f); + end; + + procedure tbufferedfile.seek(l : longint); + + begin + if iomode=2 then + begin + flush; + system.seek(f,l); + end + else if iomode=1 then + begin + { forces a reload } + bufpos:=buflast; + system.seek(f,l); + flush; + end; + end; + + type +{$ifdef tp} + bytearray1 = array [1..65535] of byte; +{$else} + bytearray1 = array [1..10000000] of byte; +{$endif} + + procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint); + + var + p : pchar; + c,i : longint; + + begin + p:=pchar(@data); + count:=0; + while bytes-count>0 do + begin + if bytes-count>buflast-bufpos then + begin + move((buf+bufpos)^,(p+count)^,buflast-bufpos); + inc(count,buflast-bufpos); + bufpos:=buflast; + flush; + { can't we read anything ? } + if bufpos=buflast then + break; + end + else + begin + move((buf+bufpos)^,(p+count)^,bytes-count); + inc(bufpos,bytes-count); + count:=bytes; + break; + end; + end; + if do_crc then + begin + c:=crc; + for i:=1 to bytes do + c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])]; + crc:=c; + end; + end; + + procedure tbufferedfile.write_data(var data;count : longint); + + var + c,i : longint; + + begin + if bufpos+count>bufsize then + flush; + move(data,(buf+bufpos)^,count); + inc(bufpos,count); + if do_crc then + begin + c:=crc; + for i:=1 to count do + c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])]; + crc:=c; + end; + end; + + function tbufferedfile.getcrc : longint; + + begin + getcrc:=crc xor crcseed; + end; + + procedure tbufferedfile.write_string(const s : string); + + begin + if bufpos+length(s)>bufsize then + flush; + { why is there not CRC here ??? } + move(s[1],(buf+bufpos)^,length(s)); + inc(bufpos,length(s)); + { should be + write_data(s[1],length(s)); } + end; + + procedure tbufferedfile.write_pchar(p : pchar); + + var + l : longint; + + begin + l:=strlen(p); + if l>=bufsize then + do_internalerror(222); + { why is there not CRC here ???} + if bufpos+l>bufsize then + flush; + move(p^,(buf+bufpos)^,l); + inc(bufpos,l); + { should be + write_data(p^,l); } + end; + + procedure tbufferedfile.write_byte(b : byte); + + begin + write_data(b,sizeof(byte)); + end; + + procedure tbufferedfile.write_long(l : longint); + + var + w1,w2 : word; + + begin + if change_endian then + begin + w1:=l and $ffff; + w2:=l shr 16; + l:=swap(w2)+(longint(swap(w1)) shl 16); + end; + write_data(l,sizeof(longint)); + end; + + procedure tbufferedfile.write_word(w : word); + + begin + if change_endian then + begin + w:=swap(w); + end; + write_data(w,sizeof(word)); + end; + + procedure tbufferedfile.write_double(d : double); + + begin + write_data(d,sizeof(double)); + end; + + function tbufferedfile.getpath : string; + + begin +{$ifdef dummy} + getpath:=strpas(filerec(f).name); +{$endif} + getpath:=''; + end; + + procedure tbufferedfile.close; + + begin + if iomode<>0 then + begin + flush; + system.close(f); + freemem(buf,bufsize); + buf:=nil; + iomode:=0; + end; + end; + + procedure tbufferedfile.tempclose; + + begin + if iomode<>0 then + begin + temppos:=system.filepos(f); + tempmode:=iomode; + tempclosed:=true; + system.close(f); + iomode:=0; + end + else + tempclosed:=false; + end; + + procedure tbufferedfile.tempreopen; + + var + ofm : byte; + + begin + if tempclosed then + begin + case tempmode of + 1 : begin + ofm:=filemode; + iomode:=1; + filemode:=0; + system.reset(f,1); + filemode:=ofm; + end; + 2 : begin + iomode:=2; + system.rewrite(f,1); + end; + end; + system.seek(f,temppos); + tempclosed:=false; + end; + end; + +{$endif BUFFEREDFILE} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.54 2000/05/11 09:56:20 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.53 2000/05/11 09:29:01 pierre + * disbal all code using MemAvail for Delphi reported by Kovacs Attila Zoltan + + Revision 1.52 2000/02/09 13:22:50 peter + * log truncated + + Revision 1.51 2000/01/11 17:16:04 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.50 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.49 1999/12/22 01:01:48 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.48 1999/12/06 18:21:03 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + + Revision 1.47 1999/11/15 14:59:55 pierre + * last was not handled correctly in TStringQueue + + Revision 1.46 1999/11/14 15:56:36 peter + * fixed stringqueue.delete + + Revision 1.45 1999/11/12 11:03:49 peter + * searchpaths changed to stringqueue object + + Revision 1.44 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.43 1999/10/26 12:30:41 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.42 1999/09/07 15:08:51 pierre + * runerror => do_internalerror + + Revision 1.41 1999/08/24 13:13:57 peter + * MEMDEBUG to see the sizes of asmlist,asmsymbols,symtables + + Revision 1.40 1999/08/12 23:19:05 pierre + * added inherited init call to tstringcontainer.init_no_double for Peter + + Revision 1.39 1999/08/05 14:58:07 florian + * some fixes for the floating point registers + * more things for the new code generator + +} \ No newline at end of file diff --git a/befpc/compiler/comphook.pas b/befpc/compiler/comphook.pas new file mode 100644 index 0000000..2150b77 --- /dev/null +++ b/befpc/compiler/comphook.pas @@ -0,0 +1,348 @@ +{ + $Id: comphook.pas,v 1.1.1.1 2001-07-23 17:15:49 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit handles the compilerhooks for output to external programs + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit comphook; +interface + +Const +{ <$10000 will show file and line } + V_None = $0; + V_Fatal = $1; + V_Error = $2; + V_Normal = $4; { doesn't show a text like Error: } + V_Warning = $8; + V_Note = $10; + V_Hint = $20; + V_Macro = $100; + V_Procedure = $200; + V_Conditional = $400; + V_Assem = $800; + V_Info = $10000; + V_Status = $20000; + V_Used = $40000; + V_Tried = $80000; + V_Debug = $100000; + V_Declarations = $200000; + V_Executable = $400000; + V_ShowFile = $ffff; + V_All = $ffffffff; + V_Default = V_Fatal + V_Error + V_Normal; + +type + PCompilerStatus = ^TCompilerStatus; + TCompilerStatus = record + { Current status } + currentmodule, + currentsourcepath, + currentsource : string; { filename } + currentline, + currentcolumn : longint; { current line and column } + { Total Status } + compiledlines : longint; { the number of lines which are compiled } + errorcount : longint; { number of generated errors } + { Settings for the output } + verbosity : longint; + maxerrorcount : longint; + errorwarning, + errornote, + errorhint, + skip_error, + use_stderr, + use_redir, + use_gccoutput : boolean; + { Redirection support } + redirfile : text; + end; +var + status : tcompilerstatus; + +{ Default Functions } +procedure def_stop; +procedure def_halt(i : longint); +Function def_status:boolean; +Function def_comment(Level:Longint;const s:string):boolean; +function def_internalerror(i:longint):boolean; +procedure def_initsymbolinfo; +procedure def_donesymbolinfo; +procedure def_extractsymbolinfo; +{$ifdef DEBUG} +{ allow easy stopping in GDB + using + b DEF_GDB_STOP + cond 1 LEVEL <= 8 } +procedure def_gdb_stop(level : longint); +{$endif DEBUG} +{ Function redirecting for IDE support } +type + tstopprocedure = procedure; + thaltprocedure = procedure(i : longint); + tstatusfunction = function:boolean; + tcommentfunction = function(Level:Longint;const s:string):boolean; + tinternalerrorfunction = function(i:longint):boolean; + + tinitsymbolinfoproc = procedure; + tdonesymbolinfoproc = procedure; + textractsymbolinfoproc = procedure; +const + do_stop : tstopprocedure = def_stop; + do_halt : thaltprocedure = def_halt; + do_status : tstatusfunction = def_status; + do_comment : tcommentfunction = def_comment; + do_internalerror : tinternalerrorfunction = def_internalerror; + + do_initsymbolinfo : tinitsymbolinfoproc = def_initsymbolinfo; + do_donesymbolinfo : tdonesymbolinfoproc = def_donesymbolinfo; + do_extractsymbolinfo : textractsymbolinfoproc = def_extractsymbolinfo; + +implementation + +{$ifdef USEEXCEPT} + uses tpexcept; +{$endif USEEXCEPT} + +{**************************************************************************** + Helper Routines +****************************************************************************} + +function gccfilename(const s : string) : string; +var + i : longint; +begin + for i:=1to length(s) do + begin + case s[i] of + '\' : gccfilename[i]:='/'; + 'A'..'Z' : gccfilename[i]:=chr(ord(s[i])+32); + else + gccfilename[i]:=s[i]; + end; + end; + {$ifndef TP} + {$ifopt H+} + setlength(gccfilename,length(s)); + {$else} + gccfilename[0]:=s[0]; + {$endif} + {$else} + gccfilename[0]:=s[0]; + {$endif} +end; + + +function tostr(i : longint) : string; +var + hs : string; +begin + str(i,hs); + tostr:=hs; +end; + + +{**************************************************************************** + Predefined default Handlers +****************************************************************************} + +{ predefined handler when then compiler stops } +procedure def_stop; +begin +{$ifndef USEEXCEPT} + Halt(1); +{$else USEEXCEPT} + Halt(1); +{$endif USEEXCEPT} +end; + +{$ifdef DEBUG} +{ allow easy stopping in GDB + using + b DEF_GDB_STOP + cond 1 LEVEL <= 8 } +procedure def_gdb_stop(level : longint); +begin + { Its only a dummy for GDB } +end; +{$endif DEBUG} + +procedure def_halt(i : longint); +begin + halt(i); +end; + +function def_status:boolean; +begin + def_status:=false; { never stop } +{ Status info?, Called every line } + if ((status.verbosity and V_Status)<>0) then + begin +{$ifndef Delphi} + if (status.compiledlines=1) then + WriteLn(memavail shr 10,' Kb Free'); +{$endif Delphi} + if (status.currentline>0) and (status.currentline mod 100=0) then +{$ifdef FPC} + WriteLn(status.currentline,' ',memavail shr 10,'/',system.heapsize shr 10,' Kb Free'); +{$else} +{$ifndef Delphi} + WriteLn(status.currentline,' ',memavail shr 10,' Kb Free'); +{$endif Delphi} +{$endif} + end +end; + + +Function def_comment(Level:Longint;const s:string):boolean; +const + { RHIDE expect gcc like error output } + rh_errorstr='error: '; + rh_warningstr='warning: '; + fatalstr='Fatal: '; + errorstr='Error: '; + warningstr='Warning: '; + notestr='Note: '; + hintstr='Hint: '; +var + hs : string; +begin + def_comment:=false; { never stop } + if (status.verbosity and Level)=Level then + begin + hs:=''; + if not(status.use_gccoutput) then + begin + if (status.verbosity and Level)=V_Hint then + hs:=hintstr; + if (status.verbosity and Level)=V_Note then + hs:=notestr; + if (status.verbosity and Level)=V_Warning then + hs:=warningstr; + if (status.verbosity and Level)=V_Error then + hs:=errorstr; + if (status.verbosity and Level)=V_Fatal then + hs:=fatalstr; + end + else + begin + if (status.verbosity and Level)=V_Hint then + hs:=rh_warningstr; + if (status.verbosity and Level)=V_Note then + hs:=rh_warningstr; + if (status.verbosity and Level)=V_Warning then + hs:=rh_warningstr; + if (status.verbosity and Level)=V_Error then + hs:=rh_errorstr; + if (status.verbosity and Level)=V_Fatal then + hs:=rh_errorstr; + end; + if (Level<=V_ShowFile) and (status.currentsource<>'') and (status.currentline>0) then + begin + { Adding the column should not confuse RHIDE, + even if it does not yet use it PM + but only if it is after error or warning !! PM } + if status.currentcolumn>0 then + begin + if status.use_gccoutput then + hs:=gccfilename(status.currentsource)+':'+tostr(status.currentline)+': '+hs + +tostr(status.currentcolumn)+': ' + else + hs:=status.currentsource+'('+tostr(status.currentline) + +','+tostr(status.currentcolumn)+') '+hs; + end + else + begin + if status.use_gccoutput then + hs:=gccfilename(status.currentsource)+': '+hs+tostr(status.currentline)+': ' + else + hs:=status.currentsource+'('+tostr(status.currentline)+') '+hs; + end; + end; + { add the message to the text } + hs:=hs+s; +{$ifdef FPC} + if status.use_stderr then + begin + writeln(stderr,hs); + flush(stderr); + end + else +{$endif} + begin + if status.use_redir then + writeln(status.redirfile,hs) + else + writeln(hs); + end; +{$ifdef DEBUG} + def_gdb_stop(level); +{$endif DEBUG} + end; +end; + + +function def_internalerror(i : longint) : boolean; +begin + do_comment(V_Fatal,'Internal error '+tostr(i)); + def_internalerror:=true; +end; + +procedure def_initsymbolinfo; +begin +end; + +procedure def_donesymbolinfo; +begin +end; + +procedure def_extractsymbolinfo; +begin +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.23 2000/05/29 10:04:40 pierre + * New bunch of Gabor changes + + Revision 1.22 2000/05/10 13:40:19 peter + * -Se option extended to increase errorcount for + warning,notes or hints + + Revision 1.21 2000/02/09 13:22:50 peter + * log truncated + + Revision 1.20 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.19 1999/11/18 15:34:45 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.18 1999/09/07 14:03:48 pierre + + added do_halt procedure + + Revision 1.17 1999/08/05 16:52:53 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + +} \ No newline at end of file diff --git a/befpc/compiler/compiler.pas b/befpc/compiler/compiler.pas new file mode 100644 index 0000000..91918f5 --- /dev/null +++ b/befpc/compiler/compiler.pas @@ -0,0 +1,444 @@ +{ + $Id: compiler.pas,v 1.1.1.1 2001-07-23 17:15:49 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit is the interface of the compiler which can be used by + external programs to link in the compiler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} + +{ + possible compiler switches: + ----------------------------------------------------------------- + TP to compile the compiler with Turbo or Borland Pascal + I386 generate a compiler for the Intel i386+ + M68K generate a compiler for the M68000 + GDB support of the GNU Debugger + EXTDEBUG some extra debug code is executed + SUPPORT_MMX only i386: releases the compiler switch + MMX which allows the compiler to generate + MMX instructions + EXTERN_MSG Don't compile the msgfiles in the compiler, always + use external messagefiles + NOAG386INT no Intel Assembler output + NOAG386NSM no NASM output + ----------------------------------------------------------------- +} + +{$ifdef FPC} + { One of Alpha, I386 or M68K must be defined } + {$UNDEF CPUOK} + + {$ifdef I386} + {$define CPUOK} + {$endif} + + {$ifdef M68K} + {$ifndef CPUOK} + {$DEFINE CPUOK} + {$else} + {$fatal cannot define two CPU switches} + {$endif} + {$endif} + + {$ifdef alpha} + {$ifndef CPUOK} + {$DEFINE CPUOK} + {$else} + {$fatal cannot define two CPU switches} + {$endif} + {$endif} + + {$ifdef powerpc} + {$ifndef CPUOK} + {$DEFINE CPUOK} + {$else} + {$fatal cannot define two CPU switches} + {$endif} + {$endif} + + {$ifndef CPUOK} + {$fatal One of the switches I386, Alpha, PowerPC or M68K must be defined} + {$endif} + + {$ifdef support_mmx} + {$ifndef i386} + {$fatal I386 switch must be on for MMX support} + {$endif i386} + {$endif support_mmx} +{$endif} + +unit compiler; +interface + +{ Use exception catching so the compiler goes futher after a Stop } +{$ifndef NOUSEEXCEPT} +{$ifdef i386} + {$define USEEXCEPT} +{$endif} + +{$ifdef TP} + {$ifdef DPMI} + {$undef USEEXCEPT} + {$endif} +{$endif} +{$endif ndef NOUSEEXCEPT} + +uses +{$ifdef fpc} + {$ifdef GO32V2} + emu387, +{ dpmiexcp, } + {$endif GO32V2} + {$ifdef LINUX} + catch, + {$endif LINUX} +{$endif} +{$ifdef USEEXCEPT} + tpexcept, +{$endif USEEXCEPT} +{$ifdef BrowserLog} + browlog, +{$endif BrowserLog} +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + verbose,comphook,systems, + cobjects,globals,options,parser,symtable,link,import,export,tokens; + +function Compile(const cmd:string):longint; + +Const + { do we need to link } + IsExe : boolean = false; + +implementation + +uses + cpubase; + +var + CompilerInitedAfterArgs, + CompilerInited : boolean; + olddo_stop : tstopprocedure; + +{$ifdef USEEXCEPT} + +procedure RecoverStop;{$ifndef FPC}far;{$endif} +begin + if recoverpospointer<>nil then + LongJmp(recoverpospointer^,1) + else + Do_Halt(1); +end; +{$endif USEEXCEPT} + +{$ifdef EXTDEBUG} +{$ifdef FPC} + Var + LostMemory : longint; + Procedure CheckMemory(LostMemory : longint); + begin + if LostMemory<>0 then + begin + Writeln('Memory Lost = '+tostr(LostMemory)); +{$ifdef DEBUG} + def_gdb_stop(V_Warning); +{$endif DEBUG} + end; + end; +{$endif FPC} +{$endif EXTDEBUG} +{**************************************************************************** + Compiler +****************************************************************************} + +procedure DoneCompiler; +begin + if not CompilerInited then + exit; +{ Free compiler if args are read } +{$ifdef BrowserLog} + DoneBrowserLog; +{$endif BrowserLog} +{$ifdef BrowserCol} + do_doneSymbolInfo; +{$endif BrowserCol} + if CompilerInitedAfterArgs then + begin + CompilerInitedAfterArgs:=false; + doneparser; + DoneImport; + DoneExport; + DoneLinker; + DoneCpu; + end; +{ Free memory for the others } + CompilerInited:=false; + DoneSymtable; + DoneGlobals; + donetokens; +{$ifdef USEEXCEPT} + recoverpospointer:=nil; + longjump_used:=false; +{$endif USEEXCEPT} +end; + + +procedure InitCompiler(const cmd:string); +begin + if CompilerInited then + DoneCompiler; +{ inits which need to be done before the arguments are parsed } + InitSystems; + InitVerbose; +{$ifdef BrowserLog} + InitBrowserLog; +{$endif BrowserLog} +{$ifdef BrowserCol} + do_initSymbolInfo; +{$endif BrowserCol} + InitGlobals; + inittokens; + InitSymtable; + CompilerInited:=true; +{ read the arguments } + read_arguments(cmd); +{ inits which depend on arguments } + initparser; + InitImport; + InitExport; + InitLinker; + InitCpu; + CompilerInitedAfterArgs:=true; +end; + +procedure minimal_stop;{$ifndef fpc}far;{$endif} +begin + DoneCompiler; + olddo_stop; +end; + + +function Compile(const cmd:string):longint; + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + + procedure writepathlist(w:longint;l:TSearchPathList); + var + hp : pstringqueueitem; + begin + hp:=l.first; + while assigned(hp) do + begin + Message1(w,hp^.data^); + hp:=hp^.next; + end; + end; + + function getrealtime : real; + var + h,m,s,s100 : word; + begin + gettime(h,m,s,s100); + getrealtime:=h*3600.0+m*60.0+s+s100/100.0; + end; + +var + starttime : real; +{$ifdef USEEXCEPT} + recoverpos : jmp_buf; +{$endif} +begin + + olddo_stop:=do_stop; +{$ifdef TP} + do_stop:=minimal_stop; +{$else TP} + do_stop:=@minimal_stop; +{$endif TP} +{ Initialize the compiler } + InitCompiler(cmd); + +{ show some info } + Message1(general_t_compilername,FixFileName(paramstr(0))); + Message1(general_d_sourceos,source_os.name); + Message1(general_i_targetos,target_os.name); + Message1(general_t_exepath,exepath); + WritePathList(general_t_unitpath,unitsearchpath); + WritePathList(general_t_includepath,includesearchpath); + WritePathList(general_t_librarypath,librarysearchpath); + WritePathList(general_t_objectpath,objectsearchpath); +{$ifdef TP} +{$ifndef Delphi} + Comment(V_Info,'Memory: '+tostr(MemAvail)+' Bytes Free'); +{$endif Delphi} +{$endif} + +{$ifdef USEEXCEPT} + if setjmp(recoverpos)=0 then + begin + recoverpospointer:=@recoverpos; +{$ifdef TP} + do_stop:=recoverstop; +{$else TP} + do_stop:=@recoverstop; +{$endif TP} +{$endif USEEXCEPT} + starttime:=getrealtime; + if parapreprocess then + parser.preprocess(inputdir+inputfile+inputextension) + else + parser.compile(inputdir+inputfile+inputextension,false); + if status.errorcount=0 then + begin + starttime:=getrealtime-starttime; + if starttime<0 then + starttime:=starttime+3600.0*24.0; + Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(starttime))+ + '.'+tostr(trunc(frac(starttime)*10))); + end; +{$ifdef USEEXCEPT} + end; +{$endif USEEXCEPT} + +{ Stop is always called, so we come here when a program is compiled or not } + do_stop:=olddo_stop; +{ Stop the compiler, frees also memory } +{ no message possible after this !! } + DoneCompiler; + +{ Set the return value if an error has occurred } + if status.errorcount=0 then + Compile:=0 + else + Compile:=1; + + DoneVerbose; +{$ifdef EXTDEBUG} +{$ifdef FPC} + LostMemory:=system.HeapSize-MemAvail-EntryMemUsed; + CheckMemory(LostMemory); +{$endif FPC} +{$ifndef newcg} + Writeln('Repetitive firstpass = '+tostr(firstpass_several)+'/'+tostr(total_of_firstpass)); +{$endif newcg} +{$endif EXTDEBUG} +{$ifdef fixLeaksOnError} + {$ifdef tp} + do_stop; + {$else tp} + do_stop(); + {$endif tp} +{$endif fixLeaksOnError} +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.51 2000/06/30 20:23:33 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.50 2000/05/29 10:04:40 pierre + * New bunch of Gabor changes + + Revision 1.49 2000/05/03 16:31:22 pierre + + easier debug when memory is lost + + Revision 1.48 2000/04/05 21:18:04 pierre + * set NOUSEEXCEPT to remove use of setjump/longjump + + Revision 1.47 2000/03/18 15:05:33 jonas + + added $maxfpuregisters 0 for compile() procedure + + Revision 1.46 2000/02/09 13:22:50 peter + * log truncated + + Revision 1.45 2000/01/11 17:16:04 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.44 2000/01/11 16:56:22 jonas + - removed call to do_stop at the end of compile() since it obviously breaks the + automatic compiling of units. Make cycle worked though! 8) + + Revision 1.43 2000/01/11 16:53:24 jonas + + call do_stop at the end of compile() + + Revision 1.42 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.41 1999/12/02 17:34:34 peter + * preprocessor support. But it fails on the caret in type blocks + + Revision 1.40 1999/11/18 13:43:48 pierre + + IsExe global var needed for IDE + + Revision 1.39 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.38 1999/11/09 23:47:53 pierre + + minimal_stop to avoid memory loss with -iTO switch + + Revision 1.37 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.36 1999/10/12 21:20:41 florian + * new codegenerator compiles again + + Revision 1.35 1999/09/28 19:48:45 florian + * bug 617 fixed + + Revision 1.34 1999/09/16 23:05:52 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.33 1999/09/07 15:10:04 pierre + * use do_halt instead of halt + + Revision 1.32 1999/09/02 18:47:44 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.31 1999/08/20 10:17:01 michael + + Patch from pierre + + Revision 1.30 1999/08/11 17:26:31 peter + * tlinker object is now inherited for win32 and dos + * postprocessexecutable is now a method of tlinker + + Revision 1.29 1999/08/09 22:13:43 peter + * fixed writing of lost memory which should be after donecompiler + + Revision 1.28 1999/08/04 13:02:40 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.27 1999/08/02 21:28:56 florian + * the main branch psub.pas is now used for + newcg compiler + + Revision 1.26 1999/08/02 20:46:57 michael + * Alpha aware switch detection + +} \ No newline at end of file diff --git a/befpc/compiler/comprsrc.pas b/befpc/compiler/comprsrc.pas new file mode 100644 index 0000000..4f3f99d --- /dev/null +++ b/befpc/compiler/comprsrc.pas @@ -0,0 +1,159 @@ +{ + $Id: comprsrc.pas,v 1.1.1.1 2001-07-23 17:15:49 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Handles the resource files handling + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit comprsrc; + +interface + +type + presourcefile=^tresourcefile; + tresourcefile=object + private + fname : string; + public + constructor Init(const fn:string); + destructor Done; + procedure Compile;virtual; + end; + +procedure CompileResourceFiles; + + +implementation + +uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + Systems,Globtype,Globals,Verbose,Files, + Script; + +{**************************************************************************** + TRESOURCEFILE +****************************************************************************} + +constructor tresourcefile.init(const fn:string); +begin + fname:=fn; +end; + + +destructor tresourcefile.done; +begin +end; + + +procedure tresourcefile.compile; +var + s, + resobj, + respath, + resbin : string; + resfound : boolean; +begin + if utilsdirectory<>'' then + respath:=FindFile(target_res.resbin+source_os.exeext,utilsdirectory,resfound) + else + respath:=FindExe(target_res.resbin,resfound); + resbin:=respath+target_res.resbin+source_os.exeext; + if (not resfound) and not(cs_link_extern in aktglobalswitches) then + begin + Message(exec_w_res_not_found); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + end; + resobj:=ForceExtension(current_module^.objfilename^,target_info.resobjext); + s:=target_res.rescmd; + Replace(s,'$OBJ',resobj); + Replace(s,'$RES',fname); + Replace(s,'$INC',respath); +{ Exec the command } + if not (cs_link_extern in aktglobalswitches) then + begin + Message1(exec_i_compilingresource,fname); + swapvectors; + exec(resbin,s); + swapvectors; + if (doserror<>0) then + begin + Message(exec_w_cant_call_linker); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + end + else + if (dosexitcode<>0) then + begin + Message(exec_w_error_while_linking); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + end; + end; + { Update asmres when externmode is set } + if cs_link_extern in aktglobalswitches then + AsmRes.AddLinkCommand(resbin,s,''); + current_module^.linkotherofiles.insert(resobj,link_allways); +end; + + +procedure CompileResourceFiles; +var + hr : presourcefile; +begin +(* OS/2 (EMX) must be processed elsewhere (in the linking/binding stage). *) + if target_info.target <> target_i386_os2 then + While not Current_module^.ResourceFiles.Empty do + begin + case target_info.target of + target_i386_win32: + hr:=new(presourcefile,init(Current_module^.ResourceFiles.get)); + else + Message(scan_e_resourcefiles_not_supported); + end; + hr^.compile; + dispose(hr,done); + end; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/06/25 19:08:28 hajny + + $R support for OS/2 (EMX) added + + Revision 1.11 2000/06/23 20:11:05 peter + * made resourcecompiling object so it can be inherited and replaced + for other targets if needed + + Revision 1.10 2000/02/09 13:22:50 peter + * log truncated + + Revision 1.9 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.8 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.7 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + +} diff --git a/befpc/compiler/cpuasm.pas b/befpc/compiler/cpuasm.pas new file mode 100644 index 0000000..74527b0 --- /dev/null +++ b/befpc/compiler/cpuasm.pas @@ -0,0 +1,1732 @@ +{ + $Id: cpuasm.pas,v 1.1.1.1 2001-07-23 17:15:51 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl and Peter Vreman + + Contains the assembler object for the i386 + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cpuasm; +interface + +uses + cobjects, + aasm,globals,verbose, + cpubase; + +{$ifndef NASMDEBUG} + {$define OPTEA} + {$define PASS2FLAG} +{$endif ndef NASMDEBUG} + +{$ifndef TP} + {$define ASMDEBUG} +{$endif} + +const + MaxPrefixes=4; + +type + pairegalloc = ^tairegalloc; + tairegalloc = object(tai) + allocation : boolean; + reg : tregister; + constructor alloc(r : tregister); + constructor dealloc(r : tregister); + end; + + { alignment for operator } + pai_align = ^tai_align; + tai_align = object(tai_align_abstract) + reg : tregister; + constructor init(b:byte); + constructor init_op(b: byte; _op: byte); + function getfillbuf:pchar; + end; + + paicpu = ^taicpu; + taicpu = object(tai) + is_jmp : boolean; { is this instruction a jump? (needed for optimizer) } + opcode : tasmop; + opsize : topsize; + condition : TAsmCond; + ops : longint; + oper : array[0..2] of toper; + constructor op_none(op : tasmop;_size : topsize); + + constructor op_reg(op : tasmop;_size : topsize;_op1 : tregister); + constructor op_const(op : tasmop;_size : topsize;_op1 : longint); + constructor op_ref(op : tasmop;_size : topsize;_op1 : preference); + + constructor op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister); + constructor op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference); + constructor op_reg_const(op:tasmop; _size: topsize; _op1: tregister; _op2: longint); + + constructor op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister); + constructor op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint); + constructor op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference); + + constructor op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister); + { this is only allowed if _op1 is an int value (_op1^.isintvalue=true) } + constructor op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference); + + constructor op_reg_reg_reg(op : tasmop;_size : topsize;_op1,_op2,_op3 : tregister); + constructor op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister); + constructor op_const_ref_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference;_op3 : tregister); + constructor op_reg_reg_ref(op : tasmop;_size : topsize;_op1,_op2 : tregister; _op3 : preference); + constructor op_const_reg_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : preference); + + { this is for Jmp instructions } + constructor op_cond_sym(op : tasmop;cond:TAsmCond;_size : topsize;_op1 : pasmsymbol); + + constructor op_sym(op : tasmop;_size : topsize;_op1 : pasmsymbol); + constructor op_sym_ofs(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint); + constructor op_sym_ofs_reg(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint;_op2 : tregister); + constructor op_sym_ofs_ref(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint;_op2 : preference); + + procedure loadconst(opidx:longint;l:longint); + procedure loadsymbol(opidx:longint;s:pasmsymbol;sofs:longint); + procedure loadref(opidx:longint;p:preference); + procedure loadreg(opidx:longint;r:tregister); + procedure loadoper(opidx:longint;o:toper); + procedure changeopsize(siz:topsize); + procedure SetCondition(c:TAsmCond); + + destructor done;virtual; + function getcopy:plinkedlist_item;virtual; + function GetString:string; + procedure SwapOperands; + procedure CheckNonCommutativeOpcodes; + private + segprefix : tregister; + procedure init(op : tasmop;_size : topsize); { this need to be called by all constructor } +{$ifndef NOAG386BIN} + public + { the next will reset all instructions that can change in pass 2 } + procedure ResetPass2; + function Pass1(offset:longint):longint;virtual; + procedure Pass2;virtual; + private + { next fields are filled in pass1, so pass2 is faster } + insentry : PInsEntry; + insoffset, + inssize : longint; + LastInsOffset : longint; { need to be public to be reset } + function InsEnd:longint; + procedure create_ot; + function Matches(p:PInsEntry):longint; + function calcsize(p:PInsEntry):longint; + procedure gencode; + function NeedAddrPrefix(opidx:byte):boolean; +{$endif NOAG386BIN} + end; + + +implementation +uses + og386; + +{***************************************************************************** + TaiRegAlloc +*****************************************************************************} + + constructor tairegalloc.alloc(r : tregister); + begin + inherited init; + typ:=ait_regalloc; + allocation:=true; + reg:=r; + end; + + + constructor tairegalloc.dealloc(r : tregister); + begin + inherited init; + typ:=ait_regalloc; + allocation:=false; + reg:=r; + end; + + +{**************************************************************************** + TAI_ALIGN + ****************************************************************************} + + constructor tai_align.init(b: byte); + begin + inherited init(b); + reg := R_ECX; + end; + + + constructor tai_align.init_op(b: byte; _op: byte); + begin + inherited init_op(b,_op); + reg := R_NO; + end; + + + function tai_align.getfillbuf:pchar; + const + alignarray:array[0..5] of string[8]=( + #$8D#$B4#$26#$00#$00#$00#$00, + #$8D#$B6#$00#$00#$00#$00, + #$8D#$74#$26#$00, + #$8D#$76#$00, + #$89#$F6, + #$90 + ); + var + bufptr : pchar; + j : longint; + begin + if not use_op then + begin + bufptr:=@buf; + while (fillsize>0) do + begin + for j:=0 to 5 do + if (fillsize>=length(alignarray[j])) then + break; + move(alignarray[j][1],bufptr^,length(alignarray[j])); + inc(bufptr,length(alignarray[j])); + dec(fillsize,length(alignarray[j])); + end; + end; + getfillbuf:=pchar(@buf); + end; + + +{***************************************************************************** + Taicpu Constructors +*****************************************************************************} + + procedure taicpu.loadconst(opidx:longint;l:longint); + begin + if opidx>=ops then + ops:=opidx+1; + with oper[opidx] do + begin + if typ=top_ref then + disposereference(ref); + val:=l; + typ:=top_const; + end; + end; + + + procedure taicpu.loadsymbol(opidx:longint;s:pasmsymbol;sofs:longint); + begin + if opidx>=ops then + ops:=opidx+1; + with oper[opidx] do + begin + if typ=top_ref then + disposereference(ref); + sym:=s; + symofs:=sofs; + typ:=top_symbol; + end; + { Mark the symbol as used } + if assigned(s) then + inc(s^.refs); + end; + + + procedure taicpu.loadref(opidx:longint;p:preference); + begin + if opidx>=ops then + ops:=opidx+1; + with oper[opidx] do + begin + if typ=top_ref then + disposereference(ref); + if p^.is_immediate then + begin +{$ifdef ASMDEBUG1} + Comment(V_Warning,'Reference immediate'); +{$endif} + val:=p^.offset; + disposereference(p); + typ:=top_const; + end + else + begin + ref:=p; + if not(ref^.segment in [R_DS,R_NO]) then + segprefix:=ref^.segment; + typ:=top_ref; + { mark symbol as used } + if assigned(ref^.symbol) then + inc(ref^.symbol^.refs); + end; + end; + end; + + + procedure taicpu.loadreg(opidx:longint;r:tregister); + begin + if opidx>=ops then + ops:=opidx+1; + with oper[opidx] do + begin + if typ=top_ref then + disposereference(ref); + reg:=r; + typ:=top_reg; + end; + end; + + procedure taicpu.loadoper(opidx:longint;o:toper); + begin + if opidx>=ops then + ops:=opidx+1; + if oper[opidx].typ=top_ref then + disposereference(oper[opidx].ref); + oper[opidx]:=o; + { copy also the reference } + if oper[opidx].typ=top_ref then + oper[opidx].ref:=newreference(o.ref^); + end; + + + procedure taicpu.changeopsize(siz:topsize); + begin + opsize:=siz; + end; + + + procedure taicpu.init(op : tasmop;_size : topsize); + begin + typ:=ait_instruction; + is_jmp:=false; + segprefix:=R_NO; + opcode:=op; + opsize:=_size; + ops:=0; + condition:=c_none; + fillchar(oper,sizeof(oper),0); +{$ifndef NOAG386BIN} + insentry:=nil; + LastInsOffset:=-1; + InsOffset:=0; + InsSize:=0; +{$endif} + end; + + + constructor taicpu.op_none(op : tasmop;_size : topsize); + begin + inherited init; + init(op,_size); + end; + + + constructor taicpu.op_reg(op : tasmop;_size : topsize;_op1 : tregister); + begin + inherited init; + init(op,_size); + ops:=1; + loadreg(0,_op1); + end; + + + constructor taicpu.op_const(op : tasmop;_size : topsize;_op1 : longint); + begin + inherited init; + init(op,_size); + ops:=1; + loadconst(0,_op1); + end; + + + constructor taicpu.op_ref(op : tasmop;_size : topsize;_op1 : preference); + begin + inherited init; + init(op,_size); + ops:=1; + loadref(0,_op1); + end; + + + constructor taicpu.op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister); + begin + inherited init; + init(op,_size); + ops:=2; + loadreg(0,_op1); + loadreg(1,_op2); + end; + + + constructor taicpu.op_reg_const(op:tasmop; _size: topsize; _op1: tregister; _op2: longint); + begin + inherited init; + init(op,_size); + ops:=2; + loadreg(0,_op1); + loadconst(1,_op2); + end; + + + constructor taicpu.op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference); + begin + inherited init; + init(op,_size); + ops:=2; + loadreg(0,_op1); + loadref(1,_op2); + end; + + + constructor taicpu.op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister); + begin + inherited init; + init(op,_size); + ops:=2; + loadconst(0,_op1); + loadreg(1,_op2); + end; + + + constructor taicpu.op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint); + begin + inherited init; + init(op,_size); + ops:=2; + loadconst(0,_op1); + loadconst(1,_op2); + end; + + + constructor taicpu.op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference); + begin + inherited init; + init(op,_size); + ops:=2; + loadconst(0,_op1); + loadref(1,_op2); + end; + + + constructor taicpu.op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister); + begin + inherited init; + init(op,_size); + ops:=2; + loadref(0,_op1); + loadreg(1,_op2); + end; + + + constructor taicpu.op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference); + begin + inherited init; + init(op,_size); + ops:=2; + loadref(0,_op1); + loadref(1,_op2); + end; + + + constructor taicpu.op_reg_reg_reg(op : tasmop;_size : topsize;_op1,_op2,_op3 : tregister); + begin + inherited init; + init(op,_size); + ops:=3; + loadreg(0,_op1); + loadreg(1,_op2); + loadreg(2,_op3); + end; + + constructor taicpu.op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister); + begin + inherited init; + init(op,_size); + ops:=3; + loadconst(0,_op1); + loadreg(1,_op2); + loadreg(2,_op3); + end; + + constructor taicpu.op_reg_reg_ref(op : tasmop;_size : topsize;_op1,_op2 : tregister;_op3 : preference); + begin + inherited init; + init(op,_size); + ops:=3; + loadreg(0,_op1); + loadreg(1,_op2); + loadref(2,_op3); + end; + + + constructor taicpu.op_const_ref_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference;_op3 : tregister); + begin + inherited init; + init(op,_size); + ops:=3; + loadconst(0,_op1); + loadref(1,_op2); + loadreg(2,_op3); + end; + + + constructor taicpu.op_const_reg_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : preference); + begin + inherited init; + init(op,_size); + ops:=3; + loadconst(0,_op1); + loadreg(1,_op2); + loadref(2,_op3); + end; + + + constructor taicpu.op_cond_sym(op : tasmop;cond:TAsmCond;_size : topsize;_op1 : pasmsymbol); + begin + inherited init; + init(op,_size); + condition:=cond; + ops:=1; + loadsymbol(0,_op1,0); + end; + + + constructor taicpu.op_sym(op : tasmop;_size : topsize;_op1 : pasmsymbol); + begin + inherited init; + init(op,_size); + ops:=1; + loadsymbol(0,_op1,0); + end; + + + constructor taicpu.op_sym_ofs(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint); + begin + inherited init; + init(op,_size); + ops:=1; + loadsymbol(0,_op1,_op1ofs); + end; + + + constructor taicpu.op_sym_ofs_reg(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint;_op2 : tregister); + begin + inherited init; + init(op,_size); + ops:=2; + loadsymbol(0,_op1,_op1ofs); + loadreg(1,_op2); + end; + + + constructor taicpu.op_sym_ofs_ref(op : tasmop;_size : topsize;_op1 : pasmsymbol;_op1ofs:longint;_op2 : preference); + begin + inherited init; + init(op,_size); + ops:=2; + loadsymbol(0,_op1,_op1ofs); + loadref(1,_op2); + end; + + + destructor taicpu.done; + var + i : longint; + begin +{$ifndef nojmpfix} + if is_jmp then + dec(PasmLabel(oper[0].sym)^.refs) + else +{$endif nojmpfix} + for i:=1 to ops do + if (oper[i-1].typ=top_ref) then + dispose(oper[i-1].ref); + inherited done; + end; + + + function taicpu.getcopy:plinkedlist_item; + var + i : longint; + p : plinkedlist_item; + begin + p:=inherited getcopy; + { make a copy of the references } + for i:=1 to ops do + if (paicpu(p)^.oper[i-1].typ=top_ref) then + begin + new(paicpu(p)^.oper[i-1].ref); + paicpu(p)^.oper[i-1].ref^:=oper[i-1].ref^; + end; + getcopy:=p; + end; + + + procedure taicpu.SetCondition(c:TAsmCond); + begin + condition:=c; + end; + + + function taicpu.GetString:string; +{$ifdef ASMDEBUG} + var + i : longint; + s : string; + addsize : boolean; +{$endif} + begin +{$ifdef ASMDEBUG} + s:='['+int_op2str[opcode]; + for i:=1to ops do + begin + if i=1 then + s:=s+' ' + else + s:=s+','; + { type } + addsize:=false; + if (oper[i-1].ot and OT_XMMREG)=OT_XMMREG then + s:=s+'xmmreg' + else + if (oper[i-1].ot and OT_MMXREG)=OT_MMXREG then + s:=s+'mmxreg' + else + if (oper[i-1].ot and OT_FPUREG)=OT_FPUREG then + s:=s+'fpureg' + else + if (oper[i-1].ot and OT_REGISTER)=OT_REGISTER then + begin + s:=s+'reg'; + addsize:=true; + end + else + if (oper[i-1].ot and OT_IMMEDIATE)=OT_IMMEDIATE then + begin + s:=s+'imm'; + addsize:=true; + end + else + if (oper[i-1].ot and OT_MEMORY)=OT_MEMORY then + begin + s:=s+'mem'; + addsize:=true; + end + else + s:=s+'???'; + { size } + if addsize then + begin + if (oper[i-1].ot and OT_BITS8)<>0 then + s:=s+'8' + else + if (oper[i-1].ot and OT_BITS16)<>0 then + s:=s+'16' + else + if (oper[i-1].ot and OT_BITS32)<>0 then + s:=s+'32' + else + s:=s+'??'; + { signed } + if (oper[i-1].ot and OT_SIGNED)<>0 then + s:=s+'s'; + end; + end; + GetString:=s+']'; +{$else} + GetString:=''; +{$endif ASMDEBUG} + end; + + + procedure taicpu.SwapOperands; + var + p : TOper; + begin + { Fix the operands which are in AT&T style and we need them in Intel style } + case ops of + 2 : begin + { 0,1 -> 1,0 } + p:=oper[0]; + oper[0]:=oper[1]; + oper[1]:=p; + end; + 3 : begin + { 0,1,2 -> 2,1,0 } + p:=oper[0]; + oper[0]:=oper[2]; + oper[2]:=p; + end; + end; + end; + +{ This check must be done with the operand in ATT order + i.e.after swapping in the intel reader + but before swapping in the NASM and TASM writers PM } +procedure taicpu.CheckNonCommutativeOpcodes; +begin + if ((ops=2) and + (oper[0].typ=top_reg) and + (oper[1].typ=top_reg) and + { if the first is ST and the second is also a register + it is necessarily ST1 .. ST7 } + (oper[0].reg=R_ST)) or + ((ops=1) and + (oper[0].typ=top_reg) and + (oper[0].reg in [R_ST1..R_ST7])) or + (ops=0) then + if opcode=A_FSUBR then + opcode:=A_FSUB + else if opcode=A_FSUB then + opcode:=A_FSUBR + else if opcode=A_FDIVR then + opcode:=A_FDIV + else if opcode=A_FDIV then + opcode:=A_FDIVR + else if opcode=A_FSUBRP then + opcode:=A_FSUBP + else if opcode=A_FSUBP then + opcode:=A_FSUBRP + else if opcode=A_FDIVRP then + opcode:=A_FDIVP + else if opcode=A_FDIVP then + opcode:=A_FDIVRP; +end; + + +{***************************************************************************** + Assembler +*****************************************************************************} + +{$ifndef NOAG386BIN} + +type + ea=packed record + sib_present : boolean; + bytes : byte; + size : byte; + modrm : byte; + sib : byte; + end; + +procedure taicpu.create_ot; +{ + this function will also fix some other fields which only needs to be once +} +var + i,l,relsize : longint; +begin + if ops=0 then + exit; + { update oper[].ot field } + for i:=0 to ops-1 do + with oper[i] do + begin + case typ of + top_reg : + ot:=reg_2_type[reg]; + top_ref : + begin + { create ot field } + ot:=OT_MEMORY or opsize_2_type[i,opsize]; + if (ref^.base=R_NO) and (ref^.index=R_NO) then + ot:=ot or OT_MEM_OFFS; + { handle also the offsetfixup } + inc(ref^.offset,ref^.offsetfixup); + ref^.offsetfixup:=0; + { fix scalefactor } + if (ref^.index=R_NO) then + ref^.scalefactor:=0 + else + if (ref^.scalefactor=0) then + ref^.scalefactor:=1; + end; + top_const : + begin + if (opsize<>S_W) and (val>=-128) and (val<=127) then + ot:=OT_IMM8 or OT_SIGNED + else + ot:=OT_IMMEDIATE or opsize_2_type[i,opsize]; + end; + top_symbol : + begin + if LastInsOffset=-1 then + l:=0 + else + l:=InsOffset-LastInsOffset; + inc(l,symofs); + if assigned(sym) then + inc(l,sym^.address); + { instruction size will then always become 2 (PFV) } + relsize:=(InsOffset+2)-l; + if (not assigned(sym) or + ((sym^.typ<>AS_EXTERNAL) and (sym^.address<>0))) and + (relsize>=-128) and (relsize<=127) then + ot:=OT_IMM32 or OT_SHORT + else + ot:=OT_IMM32 or OT_NEAR; + end; + end; + end; +end; + + +function taicpu.InsEnd:longint; +begin + InsEnd:=InsOffset+InsSize; +end; + + +function taicpu.Matches(p:PInsEntry):longint; +{ * IF_SM stands for Size Match: any operand whose size is not + * explicitly specified by the template is `really' intended to be + * the same size as the first size-specified operand. + * Non-specification is tolerated in the input instruction, but + * _wrong_ specification is not. + * + * IF_SM2 invokes Size Match on only the first _two_ operands, for + * three-operand instructions such as SHLD: it implies that the + * first two operands must match in size, but that the third is + * required to be _unspecified_. + * + * IF_SB invokes Size Byte: operands with unspecified size in the + * template are really bytes, and so no non-byte specification in + * the input instruction will be tolerated. IF_SW similarly invokes + * Size Word, and IF_SD invokes Size Doubleword. + * + * (The default state if neither IF_SM nor IF_SM2 is specified is + * that any operand with unspecified size in the template is + * required to have unspecified size in the instruction too...) +} +var + i,j,asize,oprs : longint; + siz : array[0..2] of longint; +begin + Matches:=100; + + { Check the opcode and operands } + if (p^.opcode<>opcode) or (p^.ops<>ops) then + begin + Matches:=0; + exit; + end; + + { Check that no spurious colons or TOs are present } + for i:=0 to p^.ops-1 do + if (oper[i].ot and (not p^.optypes[i]) and (OT_COLON or OT_TO))<>0 then + begin + Matches:=0; + exit; + end; + + { Check that the operand flags all match up } + for i:=0 to p^.ops-1 do + begin + if (p^.optypes[i] and (not oper[i].ot) or + ((p^.optypes[i] and OT_SIZE_MASK) and + ((p^.optypes[i] xor oper[i].ot) and OT_SIZE_MASK)))<>0 then + begin + if ((p^.optypes[i] and (not oper[i].ot) and OT_NON_SIZE) or + (oper[i].ot and OT_SIZE_MASK))<>0 then + begin + Matches:=0; + exit; + end + else + Matches:=1; + end; + end; + +{ Check operand sizes } + { as default an untyped size can get all the sizes, this is different + from nasm, but else we need to do a lot checking which opcodes want + size or not with the automatic size generation } + asize:=$ffffffff; + if (p^.flags and IF_SB)<>0 then + asize:=OT_BITS8 + else if (p^.flags and IF_SW)<>0 then + asize:=OT_BITS16 + else if (p^.flags and IF_SD)<>0 then + asize:=OT_BITS32; + if (p^.flags and IF_ARMASK)<>0 then + begin + siz[0]:=0; + siz[1]:=0; + siz[2]:=0; + if (p^.flags and IF_AR0)<>0 then + siz[0]:=asize + else if (p^.flags and IF_AR1)<>0 then + siz[1]:=asize + else if (p^.flags and IF_AR2)<>0 then + siz[2]:=asize; + end + else + begin + { siz[0]:=asize; + siz[1]:=asize; + siz[2]:=asize; } + { we can leave because the size for all operands is forced to be + the same } + exit; + end; + + if (p^.flags and (IF_SM or IF_SM2))<>0 then + begin + if (p^.flags and IF_SM2)<>0 then + oprs:=2 + else + oprs:=p^.ops; + for i:=0 to oprs-1 do + if ((p^.optypes[i] and OT_SIZE_MASK) <> 0) then + begin + for j:=0 to oprs-1 do + siz[j]:=p^.optypes[i] and OT_SIZE_MASK; + break; + end; + end + else + oprs:=2; + + { Check operand sizes } + for i:=0to p^.ops-1 do + begin + if ((p^.optypes[i] and OT_SIZE_MASK)=0) and + ((oper[i].ot and OT_SIZE_MASK and (not siz[i]))<>0) and + { Immediates can always include smaller size } + ((oper[i].ot and OT_IMMEDIATE)=0) and + (((p^.optypes[i] and OT_SIZE_MASK) or siz[i])<(oper[i].ot and OT_SIZE_MASK)) then + Matches:=2; + end; +end; + + +procedure taicpu.ResetPass2; +begin + { we are here in a second pass, check if the instruction can be optimized } + if assigned(InsEntry) and + ((InsEntry^.flags and IF_PASS2)<>0) then + begin + InsEntry:=nil; + InsSize:=0; + end; + LastInsOffset:=-1; +end; + + +function taicpu.Pass1(offset:longint):longint; +var + m,i : longint; +begin + Pass1:=0; +{ Save the old offset and set the new offset } + InsOffset:=Offset; +{ Things which may only be done once, not when a second pass is done to + optimize } + if Insentry=nil then + begin + { Check if error last time then InsSize=-1 } + if InsSize=-1 then + exit; + { We need intel style operands } + SwapOperands; + { create the .ot fields } + create_ot; + { set the file postion } + aktfilepos:=fileinfo; + end + else + begin +{$ifdef PASS2FLAG} + { we are here in a second pass, check if the instruction can be optimized } + if (InsEntry^.flags and IF_PASS2)=0 then + begin + Pass1:=InsSize; + exit; + end; + { update the .ot fields, some top_const can be updated } + create_ot; +{$endif} + end; +{ Lookup opcode in the table } + InsSize:=-1; + i:=instabcache^[opcode]; + if i=-1 then + begin +{$ifdef TP} + Message1(asmw_e_opcode_not_in_table,''); +{$else} + Message1(asmw_e_opcode_not_in_table,att_op2str[opcode]); +{$endif} + exit; + end; + insentry:=@instab[i]; + while (insentry^.opcode=opcode) do + begin + m:=matches(insentry); + if m=100 then + begin + InsSize:=calcsize(insentry); + if (segprefix<>R_NO) then + inc(InsSize); + Pass1:=InsSize; + LastInsOffset:=InsOffset; + exit; + end; + inc(i); + insentry:=@instab[i]; + end; + if insentry^.opcode<>opcode then + Message1(asmw_e_invalid_opcode_and_operands,GetString); +{ No instruction found, set insentry to nil and inssize to -1 } + insentry:=nil; + inssize:=-1; + LastInsOffset:=-1; +end; + + +procedure taicpu.Pass2; +var + c : longint; +begin + { error in pass1 ? } + if insentry=nil then + exit; + aktfilepos:=fileinfo; + { Segment override } + if (segprefix<>R_NO) then + begin + case segprefix of + R_CS : c:=$2e; + R_DS : c:=$3e; + R_ES : c:=$26; + R_FS : c:=$64; + R_GS : c:=$65; + R_SS : c:=$36; + end; + objectoutput^.writebytes(c,1); + { fix the offset for GenNode } + inc(InsOffset); + end; + { Generate the instruction } + GenCode; +end; + + +function taicpu.NeedAddrPrefix(opidx:byte):boolean; +var + i,b : tregister; +begin + if (OT_MEMORY and (not oper[opidx].ot))=0 then + begin + i:=oper[opidx].ref^.index; + b:=oper[opidx].ref^.base; + if not(i in [R_NO,R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESP,R_ESI,R_EDI]) or + not(b in [R_NO,R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESP,R_ESI,R_EDI]) then + begin + NeedAddrPrefix:=true; + exit; + end; + end; + NeedAddrPrefix:=false; +end; + + +function regval(r:tregister):byte; +begin + case r of + R_EAX,R_AX,R_AL,R_ES,R_CR0,R_DR0,R_ST,R_ST0,R_MM0 : + regval:=0; + R_ECX,R_CX,R_CL,R_CS,R_DR1,R_ST1,R_MM1 : + regval:=1; + R_EDX,R_DX,R_DL,R_SS,R_CR2,R_DR2,R_ST2,R_MM2 : + regval:=2; + R_EBX,R_BX,R_BL,R_DS,R_CR3,R_DR3,R_TR3,R_ST3,R_MM3 : + regval:=3; + R_ESP,R_SP,R_AH,R_FS,R_CR4,R_TR4,R_ST4,R_MM4 : + regval:=4; + R_EBP,R_BP,R_CH,R_GS,R_TR5,R_ST5,R_MM5 : + regval:=5; + R_ESI,R_SI,R_DH,R_DR6,R_TR6,R_ST6,R_MM6 : + regval:=6; + R_EDI,R_DI,R_BH,R_DR7,R_TR7,R_ST7,R_MM7 : + regval:=7; + else + begin + internalerror(777001); + regval:=0; + end; + end; +end; + + +function process_ea(const input:toper;var output:ea;rfield:longint):boolean; +const + regs : array[0..31] of tregister=( + R_MM0, R_EAX, R_AX, R_AL, R_MM1, R_ECX, R_CX, R_CL, + R_MM2, R_EDX, R_DX, R_DL, R_MM3, R_EBX, R_BX, R_BL, + R_MM4, R_ESP, R_SP, R_AH, R_MM5, R_EBP, R_BP, R_CH, + R_MM6, R_ESI, R_SI, R_DH, R_MM7, R_EDI, R_DI, R_BH + ); +var + j : longint; + i,b : tregister; + sym : pasmsymbol; + md,s : byte; + base,index,scalefactor, + o : longint; +begin + process_ea:=false; +{ register ? } + if (input.typ=top_reg) then + begin + j:=0; + while (j<=high(regs)) do + begin + if input.reg=regs[j] then + break; + inc(j); + end; + if j<=high(regs) then + begin + output.sib_present:=false; + output.bytes:=0; + output.modrm:=$c0 or (rfield shl 3) or (j shr 2); + output.size:=1; + process_ea:=true; + end; + exit; + end; +{ memory reference } + i:=input.ref^.index; + b:=input.ref^.base; + s:=input.ref^.scalefactor; + o:=input.ref^.offset; + sym:=input.ref^.symbol; +{ it's direct address } + if (b=R_NO) and (i=R_NO) then + begin + { it's a pure offset } + output.sib_present:=false; + output.bytes:=4; + output.modrm:=5 or (rfield shl 3); + end + else + { it's an indirection } + begin + { 16 bit address? } + if not((i in [R_NO,R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESP,R_ESI,R_EDI]) and + (b in [R_NO,R_EAX,R_EBX,R_ECX,R_EDX,R_EBP,R_ESP,R_ESI,R_EDI])) then + Message(asmw_e_16bit_not_supported); +{$ifdef OPTEA} + { make single reg base } + if (b=R_NO) and (s=1) then + begin + b:=i; + i:=R_NO; + end; + { convert [3,5,9]*EAX to EAX+[2,4,8]*EAX } + if (b=R_NO) and + (((s=2) and (i<>R_ESP)) or + (s=3) or (s=5) or (s=9)) then + begin + b:=i; + dec(s); + end; + { swap ESP into base if scalefactor is 1 } + if (s=1) and (i=R_ESP) then + begin + i:=b; + b:=R_ESP; + end; +{$endif} + { wrong, for various reasons } + if (i=R_ESP) or ((s<>1) and (s<>2) and (s<>4) and (s<>8) and (i<>R_NO)) then + exit; + { base } + case b of + R_EAX : base:=0; + R_ECX : base:=1; + R_EDX : base:=2; + R_EBX : base:=3; + R_ESP : base:=4; + R_NO, + R_EBP : base:=5; + R_ESI : base:=6; + R_EDI : base:=7; + else + exit; + end; + { index } + case i of + R_EAX : index:=0; + R_ECX : index:=1; + R_EDX : index:=2; + R_EBX : index:=3; + R_NO : index:=4; + R_EBP : index:=5; + R_ESI : index:=6; + R_EDI : index:=7; + else + exit; + end; + case s of + 0, + 1 : scalefactor:=0; + 2 : scalefactor:=1; + 4 : scalefactor:=2; + 8 : scalefactor:=3; + else + exit; + end; + if (b=R_NO) or + ((b<>R_EBP) and (o=0) and (sym=nil)) then + md:=0 + else + if ((o>=-128) and (o<=127) and (sym=nil)) then + md:=1 + else + md:=2; + if (b=R_NO) or (md=2) then + output.bytes:=4 + else + output.bytes:=md; + { SIB needed ? } + if (i=R_NO) and (b<>R_ESP) then + begin + output.sib_present:=false; + output.modrm:=(md shl 6) or (rfield shl 3) or base; + end + else + begin + output.sib_present:=true; + output.modrm:=(md shl 6) or (rfield shl 3) or 4; + output.sib:=(scalefactor shl 6) or (index shl 3) or base; + end; + end; + if output.sib_present then + output.size:=2+output.bytes + else + output.size:=1+output.bytes; + process_ea:=true; +end; + + +function taicpu.calcsize(p:PInsEntry):longint; +var + codes : pchar; + c : byte; + len : longint; + ea_data : ea; +begin + len:=0; + codes:=@p^.code; + repeat + c:=ord(codes^); + inc(codes); + case c of + 0 : + break; + 1,2,3 : + begin + inc(codes,c); + inc(len,c); + end; + 8,9,10 : + begin + inc(codes); + inc(len); + end; + 4,5,6,7 : + begin + if opsize=S_W then + inc(len,2) + else + inc(len); + end; + 15, + 12,13,14, + 16,17,18, + 20,21,22, + 40,41,42 : + inc(len); + 24,25,26, + 31, + 48,49,50 : + inc(len,2); + 28,29,30, { we don't have 16 bit immediates code } + 32,33,34, + 52,53,54, + 56,57,58 : + inc(len,4); + 192,193,194 : + if NeedAddrPrefix(c-192) then + inc(len); + 208 : + inc(len); + 200, + 201, + 202, + 209, + 210, + 217,218,219 : ; + 216 : + begin + inc(codes); + inc(len); + end; + 224,225,226 : + begin + InternalError(777002); + end; + else + begin + if (c>=64) and (c<=191) then + begin + if not process_ea(oper[(c shr 3) and 7], ea_data, 0) then + Message(asmw_e_invalid_effective_address) + else + inc(len,ea_data.size); + end + else + InternalError(777003); + end; + end; + until false; + calcsize:=len; +end; + + +procedure taicpu.GenCode; +{ + * the actual codes (C syntax, i.e. octal): + * \0 - terminates the code. (Unless it's a literal of course.) + * \1, \2, \3 - that many literal bytes follow in the code stream + * \4, \6 - the POP/PUSH (respectively) codes for CS, DS, ES, SS + * (POP is never used for CS) depending on operand 0 + * \5, \7 - the second byte of POP/PUSH codes for FS, GS, depending + * on operand 0 + * \10, \11, \12 - a literal byte follows in the code stream, to be added + * to the register value of operand 0, 1 or 2 + * \17 - encodes the literal byte 0. (Some compilers don't take + * kindly to a zero byte in the _middle_ of a compile time + * string constant, so I had to put this hack in.) + * \14, \15, \16 - a signed byte immediate operand, from operand 0, 1 or 2 + * \20, \21, \22 - a byte immediate operand, from operand 0, 1 or 2 + * \24, \25, \26 - an unsigned byte immediate operand, from operand 0, 1 or 2 + * \30, \31, \32 - a word immediate operand, from operand 0, 1 or 2 + * \34, \35, \36 - select between \3[012] and \4[012] depending on 16/32 bit + * assembly mode or the address-size override on the operand + * \37 - a word constant, from the _segment_ part of operand 0 + * \40, \41, \42 - a long immediate operand, from operand 0, 1 or 2 + * \50, \51, \52 - a byte relative operand, from operand 0, 1 or 2 + * \60, \61, \62 - a word relative operand, from operand 0, 1 or 2 + * \64, \65, \66 - select between \6[012] and \7[012] depending on 16/32 bit + * assembly mode or the address-size override on the operand + * \70, \71, \72 - a long relative operand, from operand 0, 1 or 2 + * \1ab - a ModRM, calculated on EA in operand a, with the spare + * field the register value of operand b. + * \2ab - a ModRM, calculated on EA in operand a, with the spare + * field equal to digit b. + * \30x - might be an 0x67 byte, depending on the address size of + * the memory reference in operand x. + * \310 - indicates fixed 16-bit address size, i.e. optional 0x67. + * \311 - indicates fixed 32-bit address size, i.e. optional 0x67. + * \320 - indicates fixed 16-bit operand size, i.e. optional 0x66. + * \321 - indicates fixed 32-bit operand size, i.e. optional 0x66. + * \322 - indicates that this instruction is only valid when the + * operand size is the default (instruction to disassembler, + * generates no code in the assembler) + * \330 - a literal byte follows in the code stream, to be added + * to the condition code value of the instruction. + * \340 - reserve bytes of uninitialised storage. + * Operand 0 had better be a segmentless constant. +} + +var + currval : longint; + currsym : pasmsymbol; + + procedure getvalsym(opidx:longint); + begin + case oper[opidx].typ of + top_ref : + begin + currval:=oper[opidx].ref^.offset; + currsym:=oper[opidx].ref^.symbol; + end; + top_const : + begin + currval:=oper[opidx].val; + currsym:=nil; + end; + top_symbol : + begin + currval:=oper[opidx].symofs; + currsym:=oper[opidx].sym; + end; + else + Message(asmw_e_immediate_or_reference_expected); + end; + end; + +const + CondVal:array[TAsmCond] of byte=($0, + $7, $3, $2, $6, $2, $4, $F, $D, $C, $E, $6, $2, + $3, $7, $3, $5, $E, $C, $D, $F, $1, $B, $9, $5, + $0, $A, $A, $B, $8, $4); +var + c : byte; + pb, + codes : pchar; + bytes : array[0..3] of byte; + rfield, + data,s,opidx : longint; + ea_data : ea; +begin + codes:=insentry^.code; + { Force word push/pop for registers } + if (opsize=S_W) and ((codes[0]=#4) or (codes[0]=#6) or + ((codes[0]=#1) and ((codes[2]=#5) or (codes[2]=#7)))) then + begin + bytes[0]:=$66; + objectoutput^.writebytes(bytes,1); + end; + repeat + c:=ord(codes^); + inc(codes); + case c of + 0 : + break; + 1,2,3 : + begin + objectoutput^.writebytes(codes^,c); + inc(codes,c); + end; + 4,6 : + begin + case oper[0].reg of + R_CS : + begin + if c=4 then + bytes[0]:=$f + else + bytes[0]:=$e; + end; + R_NO, + R_DS : + begin + if c=4 then + bytes[0]:=$1f + else + bytes[0]:=$1e; + end; + R_ES : + begin + if c=4 then + bytes[0]:=$7 + else + bytes[0]:=$6; + end; + R_SS : + begin + if c=4 then + bytes[0]:=$17 + else + bytes[0]:=$16; + end; + else + InternalError(777004); + end; + objectoutput^.writebytes(bytes,1); + end; + 5,7 : + begin + case oper[0].reg of + R_FS : + begin + if c=5 then + bytes[0]:=$a1 + else + bytes[0]:=$a0; + end; + R_GS : + begin + if c=5 then + bytes[0]:=$a9 + else + bytes[0]:=$a8; + end; + else + InternalError(777005); + end; + objectoutput^.writebytes(bytes,1); + end; + 8,9,10 : + begin + bytes[0]:=ord(codes^)+regval(oper[c-8].reg); + inc(codes); + objectoutput^.writebytes(bytes,1); + end; + 15 : + begin + bytes[0]:=0; + objectoutput^.writebytes(bytes,1); + end; + 12,13,14 : + begin + getvalsym(c-12); + if (currval<-128) or (currval>127) then + Message2(asmw_e_value_exceeds_bounds,'signed byte',tostr(currval)); + if assigned(currsym) then + objectoutput^.writereloc(currval,1,currsym,relative_false) + else + objectoutput^.writebytes(currval,1); + end; + 16,17,18 : + begin + getvalsym(c-16); + if (currval<-256) or (currval>255) then + Message2(asmw_e_value_exceeds_bounds,'byte',tostr(currval)); + if assigned(currsym) then + objectoutput^.writereloc(currval,1,currsym,relative_false) + else + objectoutput^.writebytes(currval,1); + end; + 20,21,22 : + begin + getvalsym(c-20); + if (currval<0) or (currval>255) then + Message2(asmw_e_value_exceeds_bounds,'unsigned byte',tostr(currval)); + if assigned(currsym) then + objectoutput^.writereloc(currval,1,currsym,relative_false) + else + objectoutput^.writebytes(currval,1); + end; + 24,25,26 : + begin + getvalsym(c-24); + if (currval<-65536) or (currval>65535) then + Message2(asmw_e_value_exceeds_bounds,'word',tostr(currval)); + if assigned(currsym) then + objectoutput^.writereloc(currval,2,currsym,relative_false) + else + objectoutput^.writebytes(currval,2); + end; + 28,29,30 : + begin + getvalsym(c-28); + if assigned(currsym) then + objectoutput^.writereloc(currval,4,currsym,relative_false) + else + objectoutput^.writebytes(currval,4); + end; + 32,33,34 : + begin + getvalsym(c-32); + if assigned(currsym) then + objectoutput^.writereloc(currval,4,currsym,relative_false) + else + objectoutput^.writebytes(currval,4); + end; + 40,41,42 : + begin + getvalsym(c-40); + data:=currval-insend; + if assigned(currsym) then + inc(data,currsym^.address); + if (data>127) or (data<-128) then + Message1(asmw_e_short_jmp_out_of_range,tostr(data)); + objectoutput^.writebytes(data,1); + end; + 52,53,54 : + begin + getvalsym(c-52); + if assigned(currsym) then + objectoutput^.writereloc(currval,4,currsym,relative_true) + else + objectoutput^.writereloc(currval-insend,4,nil,relative_false) + end; + 56,57,58 : + begin + getvalsym(c-56); + if assigned(currsym) then + objectoutput^.writereloc(currval,4,currsym,relative_true) + else + objectoutput^.writereloc(currval-insend,4,nil,relative_false) + end; + 192,193,194 : + begin + if NeedAddrPrefix(c-192) then + begin + bytes[0]:=$67; + objectoutput^.writebytes(bytes,1); + end; + end; + 200 : + begin + bytes[0]:=$67; + objectoutput^.writebytes(bytes,1); + end; + 208 : + begin + bytes[0]:=$66; + objectoutput^.writebytes(bytes,1); + end; + 216 : + begin + bytes[0]:=ord(codes^)+condval[condition]; + inc(codes); + objectoutput^.writebytes(bytes,1); + end; + 201, + 202, + 209, + 210, + 217,218,219 : + begin + { these are dissambler hints or 32 bit prefixes which + are not needed } + end; + 31, + 48,49,50, + 224,225,226 : + begin + InternalError(777006); + end + else + begin + if (c>=64) and (c<=191) then + begin + if (c<127) then + begin + if (oper[c and 7].typ=top_reg) then + rfield:=regval(oper[c and 7].reg) + else + rfield:=regval(oper[c and 7].ref^.base); + end + else + rfield:=c and 7; + opidx:=(c shr 3) and 7; + if not process_ea(oper[opidx], ea_data, rfield) then + Message(asmw_e_invalid_effective_address); + + pb:=@bytes; + pb^:=chr(ea_data.modrm); + inc(pb); + if ea_data.sib_present then + begin + pb^:=chr(ea_data.sib); + inc(pb); + end; + + s:=pb-pchar(@bytes); + objectoutput^.writebytes(bytes,s); + + case ea_data.bytes of + 0 : ; + 1 : + begin + if (oper[opidx].ot and OT_MEMORY)=OT_MEMORY then + objectoutput^.writereloc(oper[opidx].ref^.offset,1,oper[opidx].ref^.symbol,relative_false) + else + begin + bytes[0]:=oper[opidx].ref^.offset; + objectoutput^.writebytes(bytes,1); + end; + inc(s); + end; + 2,4 : + begin + objectoutput^.writereloc(oper[opidx].ref^.offset,ea_data.bytes, + oper[opidx].ref^.symbol,relative_false); + inc(s,ea_data.bytes); + end; + end; + end + else + InternalError(777007); + end; + end; + until false; +end; +{$endif NOAG386BIN} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.15 2000/05/23 20:34:35 peter + * fixed instruction matching when a size flag is specified for all + operands + + Revision 1.14 2000/05/12 21:26:22 pierre + * fix the FDIV FDIVR FSUB FSUBR and popping equivalent + simply by swapping from reverse to normal and vice-versa + when passing from one syntax to the other ! + + Revision 1.13 2000/05/09 14:12:35 pierre + * fix for test/testpusw problem + + Revision 1.12 2000/02/09 13:22:51 peter + * log truncated + + Revision 1.11 2000/01/23 21:29:14 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.10 2000/01/12 10:38:18 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.9 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.8 2000/01/07 00:07:24 peter + * display fpu,mmx,xmm names instead of reg?? + + Revision 1.7 1999/12/24 15:22:52 peter + * reset insentry/lastinsoffset so writing smartlink works correct for + short jmps + + Revision 1.6 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.5 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.4 1999/11/05 16:01:46 jonas + + first implementation of choosing least used register for alignment code + (not yet working, between ifdef alignreg) + + Revision 1.3 1999/08/25 11:59:57 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.2 1999/08/12 14:36:01 peter + + KNI instructions + + Revision 1.1 1999/08/04 00:22:57 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.17 1999/08/01 23:55:53 michael + * Moved taitempalloc + +} diff --git a/befpc/compiler/cpubase.pas b/befpc/compiler/cpubase.pas new file mode 100644 index 0000000..b8c1987 --- /dev/null +++ b/befpc/compiler/cpubase.pas @@ -0,0 +1,1023 @@ +{ + $Id: cpubase.pas,v 1.1.1.1 2001-07-23 17:15:51 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl and Peter Vreman + + Contains the base types for the i386 + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cpubase; + +{$ifdef newOptimizations} +{$define foropt} +{$define replacereg} +{$define arithopt} +{$define foldarithops} +{$endif newOptimizations} + +interface +{$ifdef TP} + {$L-,Y-} +{$endif} + +uses + globals,strings,cobjects,aasm; + +const +{ Size of the instruction table converted by nasmconv.pas } + instabentries = {$i i386nop.inc} + maxinfolen = 8; + +{ By default we want everything } +{$define ATTOP} +{$define ATTREG} +{$define INTELOP} +{$define ITTABLE} + +{ For TP we can't use asmdebug due the table sizes } +{$ifndef TP} + {$define ASMDEBUG} +{$endif} + +{ We Don't need the intel style opcodes if we don't have a intel + reader or generator } +{$ifndef ASMDEBUG} +{$ifdef NORA386INT} + {$ifdef NOAG386NSM} + {$ifdef NOAG386INT} + {$undef INTELOP} + {$endif} + {$endif} +{$endif} +{$endif} + +{ We Don't need the AT&T style opcodes if we don't have a AT&T + reader or generator } +{$ifdef NORA386ATT} + {$ifdef NOAG386ATT} + {$undef ATTOP} + {$ifdef NOAG386DIR} + {$undef ATTREG} + {$endif} + {$endif} +{$endif} + +{ We need the AT&T suffix table for both asm readers and AT&T writer } +{$define ATTSUF} +{$ifdef NORA386INT} + {$ifdef NORA386ATT} + {$ifdef NOAG386ATT} + {$undef ATTSUF} + {$endif} + {$endif} +{$endif} + +const +{ Operand types } + OT_NONE = $00000000; + + OT_BITS8 = $00000001; { size, and other attributes, of the operand } + OT_BITS16 = $00000002; + OT_BITS32 = $00000004; + OT_BITS64 = $00000008; { FPU only } + OT_BITS80 = $00000010; + OT_FAR = $00000020; { this means 16:16 or 16:32, like in CALL/JMP } + OT_NEAR = $00000040; + OT_SHORT = $00000080; + + OT_SIZE_MASK = $000000FF; { all the size attributes } + OT_NON_SIZE = not OT_SIZE_MASK; + + OT_SIGNED = $00000100; { the operand need to be signed -128-127 } + + OT_TO = $00000200; { operand is followed by a colon } + { reverse effect in FADD, FSUB &c } + OT_COLON = $00000400; + + OT_REGISTER = $00001000; + OT_IMMEDIATE = $00002000; + OT_IMM8 = $00002001; + OT_IMM16 = $00002002; + OT_IMM32 = $00002004; + OT_IMM64 = $00002008; + OT_IMM80 = $00002010; + OT_REGMEM = $00200000; { for r/m, ie EA, operands } + OT_REGNORM = $00201000; { 'normal' reg, qualifies as EA } + OT_REG8 = $00201001; + OT_REG16 = $00201002; + OT_REG32 = $00201004; + OT_MMXREG = $00201008; { MMX registers } + OT_XMMREG = $00201010; { Katmai registers } + OT_MEMORY = $00204000; { register number in 'basereg' } + OT_MEM8 = $00204001; + OT_MEM16 = $00204002; + OT_MEM32 = $00204004; + OT_MEM64 = $00204008; + OT_MEM80 = $00204010; + OT_FPUREG = $01000000; { floating point stack registers } + OT_FPU0 = $01000800; { FPU stack register zero } + OT_REG_SMASK = $00070000; { special register operands: these may be treated differently } + { a mask for the following } + OT_REG_ACCUM = $00211000; { accumulator: AL, AX or EAX } + OT_REG_AL = $00211001; { REG_ACCUM | BITSxx } + OT_REG_AX = $00211002; { ditto } + OT_REG_EAX = $00211004; { and again } + OT_REG_COUNT = $00221000; { counter: CL, CX or ECX } + OT_REG_CL = $00221001; { REG_COUNT | BITSxx } + OT_REG_CX = $00221002; { ditto } + OT_REG_ECX = $00221004; { another one } + OT_REG_DX = $00241002; + + OT_REG_SREG = $00081002; { any segment register } + OT_REG_CS = $01081002; { CS } + OT_REG_DESS = $02081002; { DS, ES, SS (non-CS 86 registers) } + OT_REG_FSGS = $04081002; { FS, GS (386 extended registers) } + + OT_REG_CDT = $00101004; { CRn, DRn and TRn } + OT_REG_CREG = $08101004; { CRn } + OT_REG_CR4 = $08101404; { CR4 (Pentium only) } + OT_REG_DREG = $10101004; { DRn } + OT_REG_TREG = $20101004; { TRn } + + OT_MEM_OFFS = $00604000; { special type of EA } + { simple [address] offset } + OT_ONENESS = $00800000; { special type of immediate operand } + { so UNITY == IMMEDIATE | ONENESS } + OT_UNITY = $00802000; { for shift/rotate instructions } + +{Instruction flags } + IF_NONE = $00000000; + IF_SM = $00000001; { size match first two operands } + IF_SM2 = $00000002; + IF_SB = $00000004; { unsized operands can't be non-byte } + IF_SW = $00000008; { unsized operands can't be non-word } + IF_SD = $00000010; { unsized operands can't be nondword } + IF_AR0 = $00000020; { SB, SW, SD applies to argument 0 } + IF_AR1 = $00000040; { SB, SW, SD applies to argument 1 } + IF_AR2 = $00000060; { SB, SW, SD applies to argument 2 } + IF_ARMASK = $00000060; { mask for unsized argument spec } + IF_PRIV = $00000100; { it's a privileged instruction } + IF_SMM = $00000200; { it's only valid in SMM } + IF_PROT = $00000400; { it's protected mode only } + IF_UNDOC = $00001000; { it's an undocumented instruction } + IF_FPU = $00002000; { it's an FPU instruction } + IF_MMX = $00004000; { it's an MMX instruction } + IF_3DNOW = $00008000; { it's a 3DNow! instruction } + IF_SSE = $00010000; { it's a SSE (KNI, MMX2) instruction } + IF_PMASK = $FF000000; { the mask for processor types } + IF_PFMASK = $F001FF00; { the mask for disassembly "prefer" } + IF_8086 = $00000000; { 8086 instruction } + IF_186 = $01000000; { 186+ instruction } + IF_286 = $02000000; { 286+ instruction } + IF_386 = $03000000; { 386+ instruction } + IF_486 = $04000000; { 486+ instruction } + IF_PENT = $05000000; { Pentium instruction } + IF_P6 = $06000000; { P6 instruction } + IF_KATMAI = $07000000; { Katmai instructions } + IF_CYRIX = $10000000; { Cyrix-specific instruction } + IF_AMD = $20000000; { AMD-specific instruction } + { added flags } + IF_PRE = $40000000; { it's a prefix instruction } + IF_PASS2 = $80000000; { if the instruction can change in a second pass } + +type + TAttSuffix = (AttSufNONE,AttSufINT,AttSufFPU,AttSufFPUint); + + TAsmOp= +{$i i386op.inc} + + op2strtable=array[tasmop] of string[11]; + + pstr2opentry = ^tstr2opentry; + tstr2opentry = object(Tnamedindexobject) + op: TAsmOp; + end; + +const + firstop = low(tasmop); + lastop = high(tasmop); + + AsmPrefixes = 6; + AsmPrefix : array[0..AsmPrefixes-1] of TasmOP =( + A_LOCK,A_REP,A_REPE,A_REPNE,A_REPNZ,A_REPZ + ); + + AsmOverrides = 6; + AsmOverride : array[0..AsmOverrides-1] of TasmOP =( + A_SEGCS,A_SEGES,A_SEGDS,A_SEGFS,A_SEGGS,A_SEGSS + ); + + +{$ifdef INTELOP} + int_op2str:op2strtable= +{$i i386int.inc} +{$endif INTELOP} + +{$ifdef ATTOP} + att_op2str:op2strtable= +{$i i386att.inc} +{$endif ATTOP} + +{$ifdef ATTSUF} + att_needsuffix:array[tasmop] of TAttSuffix= +{$i i386atts.inc} +{$endif ATTSUF} + + +{***************************************************************************** + Operand Sizes +*****************************************************************************} + +type + topsize = (S_NO, + S_B,S_W,S_L,S_BW,S_BL,S_WL, + S_IS,S_IL,S_IQ, + S_FS,S_FL,S_FX,S_D,S_Q,S_FV + ); + +const + { Intel style operands ! } + opsize_2_type:array[0..2,topsize] of longint=( + (OT_NONE, + OT_BITS8,OT_BITS16,OT_BITS32,OT_BITS16,OT_BITS32,OT_BITS32, + OT_BITS16,OT_BITS32,OT_BITS64, + OT_BITS32,OT_BITS64,OT_BITS80,OT_BITS64,OT_BITS64,OT_BITS64 + ), + (OT_NONE, + OT_BITS8,OT_BITS16,OT_BITS32,OT_BITS8,OT_BITS8,OT_BITS16, + OT_BITS16,OT_BITS32,OT_BITS64, + OT_BITS32,OT_BITS64,OT_BITS80,OT_BITS64,OT_BITS64,OT_BITS64 + ), + (OT_NONE, + OT_BITS8,OT_BITS16,OT_BITS32,OT_NONE,OT_NONE,OT_NONE, + OT_BITS16,OT_BITS32,OT_BITS64, + OT_BITS32,OT_BITS64,OT_BITS80,OT_BITS64,OT_BITS64,OT_BITS64 + ) + ); + +{$ifdef ATTOP} + att_opsize2str : array[topsize] of string[2] = ('', + 'b','w','l','bw','bl','wl', + 's','l','q', + 's','l','t','d','q','v' + ); +{$endif} + + +{***************************************************************************** + Conditions +*****************************************************************************} + +type + TAsmCond=(C_None, + C_A,C_AE,C_B,C_BE,C_C,C_E,C_G,C_GE,C_L,C_LE,C_NA,C_NAE, + C_NB,C_NBE,C_NC,C_NE,C_NG,C_NGE,C_NL,C_NLE,C_NO,C_NP, + C_NS,C_NZ,C_O,C_P,C_PE,C_PO,C_S,C_Z + ); + +const + cond2str:array[TAsmCond] of string[3]=('', + 'a','ae','b','be','c','e','g','ge','l','le','na','nae', + 'nb','nbe','nc','ne','ng','nge','nl','nle','no','np', + 'ns','nz','o','p','pe','po','s','z' + ); + inverse_cond:array[TAsmCond] of TAsmCond=(C_None, + C_NA,C_NAE,C_NB,C_NBE,C_NC,C_NE,C_NG,C_NGE,C_NL,C_NLE,C_A,C_AE, + C_B,C_BE,C_C,C_E,C_G,C_GE,C_L,C_LE,C_O,C_P, + C_S,C_Z,C_NO,C_NP,C_NP,C_P,C_NS,C_NZ + ); + +const + CondAsmOps=3; + CondAsmOp:array[0..CondAsmOps-1] of TasmOp=( + A_CMOVcc, A_Jcc, A_SETcc + ); + CondAsmOpStr:array[0..CondAsmOps-1] of string[4]=( + 'CMOV','J','SET' + ); + + +{***************************************************************************** + Registers +*****************************************************************************} + +type + { enumeration for registers, don't change the order } + { it's used by the register size conversions } + tregister = (R_NO, + R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI, + R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI, + R_AL,R_CL,R_DL,R_BL,R_AH,R_CH,R_BH,R_DH, + R_CS,R_DS,R_ES,R_SS,R_FS,R_GS, + R_ST,R_ST0,R_ST1,R_ST2,R_ST3,R_ST4,R_ST5,R_ST6,R_ST7, + R_DR0,R_DR1,R_DR2,R_DR3,R_DR6,R_DR7, + R_CR0,R_CR2,R_CR3,R_CR4, + R_TR3,R_TR4,R_TR5,R_TR6,R_TR7, + R_MM0,R_MM1,R_MM2,R_MM3,R_MM4,R_MM5,R_MM6,R_MM7, + R_XMM0,R_XMM1,R_XMM2,R_XMM3,R_XMM4,R_XMM5,R_XMM6,R_XMM7 + ); + + tregisterset = set of tregister; + + reg2strtable = array[tregister] of string[6]; + +const + firstreg = low(tregister); + lastreg = high(tregister); + + firstsreg = R_CS; + lastsreg = R_GS; + + regset8bit : tregisterset = [R_AL..R_DH]; + regset16bit : tregisterset = [R_AX..R_DI,R_CS..R_SS]; + regset32bit : tregisterset = [R_EAX..R_EDI]; + + { Convert reg to opsize } + reg_2_opsize:array[firstreg..lastreg] of topsize = (S_NO, + S_L,S_L,S_L,S_L,S_L,S_L,S_L,S_L, + S_W,S_W,S_W,S_W,S_W,S_W,S_W,S_W, + S_B,S_B,S_B,S_B,S_B,S_B,S_B,S_B, + S_W,S_W,S_W,S_W,S_W,S_W, + S_FL,S_FL,S_FL,S_FL,S_FL,S_FL,S_FL,S_FL,S_FL, + S_L,S_L,S_L,S_L,S_L,S_L, + S_L,S_L,S_L,S_L, + S_L,S_L,S_L,S_L,S_L, + S_D,S_D,S_D,S_D,S_D,S_D,S_D,S_D, + S_D,S_D,S_D,S_D,S_D,S_D,S_D,S_D + ); + + { Convert reg to operand type } + reg_2_type:array[firstreg..lastreg] of longint = (OT_NONE, + OT_REG_EAX,OT_REG_ECX,OT_REG32,OT_REG32,OT_REG32,OT_REG32,OT_REG32,OT_REG32, + OT_REG_AX,OT_REG_CX,OT_REG_DX,OT_REG16,OT_REG16,OT_REG16,OT_REG16,OT_REG16, + OT_REG_AL,OT_REG_CL,OT_REG8,OT_REG8,OT_REG8,OT_REG8,OT_REG8,OT_REG8, + OT_REG_CS,OT_REG_DESS,OT_REG_DESS,OT_REG_DESS,OT_REG_FSGS,OT_REG_FSGS, + OT_FPU0,OT_FPU0,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG,OT_FPUREG, + OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG,OT_REG_DREG, + OT_REG_CREG,OT_REG_CREG,OT_REG_CREG,OT_REG_CR4, + OT_REG_TREG,OT_REG_TREG,OT_REG_TREG,OT_REG_TREG,OT_REG_TREG, + OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG,OT_MMXREG, + OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG,OT_XMMREG + ); + +{$ifdef INTELOP} + int_reg2str : reg2strtable = ('', + 'eax','ecx','edx','ebx','esp','ebp','esi','edi', + 'ax','cx','dx','bx','sp','bp','si','di', + 'al','cl','dl','bl','ah','ch','bh','dh', + 'cs','ds','es','ss','fs','gs', + 'st','st(0)','st(1)','st(2)','st(3)','st(4)','st(5)','st(6)','st(7)', + 'dr0','dr1','dr2','dr3','dr6','dr7', + 'cr0','cr2','cr3','cr4', + 'tr3','tr4','tr5','tr6','tr7', + 'mm0','mm1','mm2','mm3','mm4','mm5','mm6','mm7', + 'xmm0','xmm1','xmm2','xmm3','xmm4','xmm5','xmm6','xmm7' + ); + + int_nasmreg2str : reg2strtable = ('', + 'eax','ecx','edx','ebx','esp','ebp','esi','edi', + 'ax','cx','dx','bx','sp','bp','si','di', + 'al','cl','dl','bl','ah','ch','bh','dh', + 'cs','ds','es','ss','fs','gs', + 'st0','st0','st1','st2','st3','st4','st5','st6','st7', + 'dr0','dr1','dr2','dr3','dr6','dr7', + 'cr0','cr2','cr3','cr4', + 'tr3','tr4','tr5','tr6','tr7', + 'mm0','mm1','mm2','mm3','mm4','mm5','mm6','mm7', + 'xmm0','xmm1','xmm2','xmm3','xmm4','xmm5','xmm6','xmm7' + ); +{$endif} + +{$ifdef ATTREG} + att_reg2str : reg2strtable = ('', + '%eax','%ecx','%edx','%ebx','%esp','%ebp','%esi','%edi', + '%ax','%cx','%dx','%bx','%sp','%bp','%si','%di', + '%al','%cl','%dl','%bl','%ah','%ch','%bh','%dh', + '%cs','%ds','%es','%ss','%fs','%gs', + '%st','%st(0)','%st(1)','%st(2)','%st(3)','%st(4)','%st(5)','%st(6)','%st(7)', + '%dr0','%dr1','%dr2','%dr3','%dr6','%dr7', + '%cr0','%cr2','%cr3','%cr4', + '%tr3','%tr4','%tr5','%tr6','%tr7', + '%mm0','%mm1','%mm2','%mm3','%mm4','%mm5','%mm6','%mm7', + '%xmm0','%xmm1','%xmm2','%xmm3','%xmm4','%xmm5','%xmm6','%xmm7' + ); +{$endif ATTREG} + + +{***************************************************************************** + Flags +*****************************************************************************} + +type + TResFlags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,F_A,F_AE,F_B,F_BE); + +const + { arrays for boolean location conversions } + flag_2_cond : array[TResFlags] of TAsmCond = + (C_E,C_NE,C_G,C_L,C_GE,C_LE,C_C,C_NC,C_A,C_AE,C_B,C_BE); + + +{***************************************************************************** + Reference +*****************************************************************************} + +type + trefoptions=(ref_none,ref_parafixup,ref_localfixup,ref_selffixup); + + { immediate/reference record } + preference = ^treference; + treference = packed record + is_immediate : boolean; { is this used as reference or immediate } + segment, + base, + index : tregister; + scalefactor : byte; + offset : longint; + symbol : pasmsymbol; + offsetfixup : longint; + options : trefoptions; +{$ifdef newcg} + alignment : byte; +{$endif newcg} + end; + +{***************************************************************************** + Operands +*****************************************************************************} + + { Types of operand } + toptype=(top_none,top_reg,top_ref,top_const,top_symbol); + + toper=record + ot : longint; + case typ : toptype of + top_none : (); + top_reg : (reg:tregister); + top_ref : (ref:preference); + top_const : (val:longint); + top_symbol : (sym:pasmsymbol;symofs:longint); + end; + +{***************************************************************************** + Generic Location +*****************************************************************************} + +type + TLoc=( + LOC_INVALID, { added for tracking problems} + LOC_FPU, { FPU stack } + LOC_REGISTER, { in a processor register } + LOC_MEM, { in memory } + LOC_REFERENCE, { like LOC_MEM, but lvalue } + LOC_JUMP, { boolean results only, jump to false or true label } + LOC_FLAGS, { boolean results only, flags are set } + LOC_CREGISTER, { Constant register which shouldn't be modified } + LOC_MMXREGISTER, { MMX register } + LOC_CMMXREGISTER,{ Constant MMX register } + LOC_CFPUREGISTER { if it is a FPU register variable on the fpu stack } + ); + + plocation = ^tlocation; + tlocation = packed record + case loc : tloc of + LOC_MEM,LOC_REFERENCE : (reference : treference); + LOC_FPU : (); + LOC_JUMP : (); + LOC_FLAGS : (resflags : tresflags); + LOC_INVALID : (); + + { it's only for better handling } + LOC_MMXREGISTER : (mmxreg : tregister); + { segment in reference at the same place as in loc_register } + LOC_REGISTER,LOC_CREGISTER : ( + case longint of + 1 : (register,segment,registerhigh : tregister); + { overlay a registerlow } + 2 : (registerlow : tregister); + ); + end; + +{***************************************************************************** + Constants +*****************************************************************************} + +const + general_registers = [R_EAX,R_EBX,R_ECX,R_EDX]; + + intregs = general_registers; + fpuregs = []; + mmregs = [R_MM0..R_MM7]; + + lvaluelocations = [LOC_REFERENCE,LOC_CFPUREGISTER, + LOC_CREGISTER,LOC_MMXREGISTER,LOC_CMMXREGISTER]; + + registers_saved_on_cdecl = [R_ESI,R_EDI,R_EBX]; + + { generic register names } + stack_pointer = R_ESP; + frame_pointer = R_EBP; + self_pointer = R_ESI; + accumulator = R_EAX; + { the register where the vmt offset is passed to the destructor } + { helper routine } + vmt_offset_reg = R_EDI; + + scratch_regs : array[1..1] of tregister = (R_EDI); + + max_scratch_regs = 1; + +{ low and high of the available maximum width integer general purpose } +{ registers } + LoGPReg = R_EAX; + HiGPReg = R_EDI; + +{ low and high of every possible width general purpose register (same as } +{ above on most architctures apart from the 80x86) } + LoReg = R_EAX; + HiReg = R_BL; + + cpuflags = []; + + { sizes } + pointersize = 4; + extended_size = 10; + sizepostfix_pointer = S_L; + + +{***************************************************************************** + Instruction table +*****************************************************************************} + +{$ifndef NOAG386BIN} +type + tinsentry=packed record + opcode : tasmop; + ops : byte; + optypes : array[0..2] of longint; + code : array[0..maxinfolen] of char; + flags : longint; + end; + pinsentry=^tinsentry; + + TInsTabCache=array[TasmOp] of longint; + PInsTabCache=^TInsTabCache; + +const + InsTab:array[0..instabentries-1] of TInsEntry= +{$i i386tab.inc} + +var + InsTabCache : PInsTabCache; +{$endif NOAG386BIN} + + +{***************************************************************************** + Opcode propeties (needed for optimizer) +*****************************************************************************} + +{$ifndef NOOPT} +Type +{What an instruction can change} + TInsChange = (Ch_None, + {Read from a register} + Ch_REAX, Ch_RECX, Ch_REDX, Ch_REBX, Ch_RESP, Ch_REBP, Ch_RESI, Ch_REDI, + {write from a register} + Ch_WEAX, Ch_WECX, Ch_WEDX, Ch_WEBX, Ch_WESP, Ch_WEBP, Ch_WESI, Ch_WEDI, + {read and write from/to a register} + Ch_RWEAX, Ch_RWECX, Ch_RWEDX, Ch_RWEBX, Ch_RWESP, Ch_RWEBP, Ch_RWESI, Ch_RWEDI, + {modify the contents of a register with the purpose of using + this changed content afterwards (add/sub/..., but e.g. not rep + or movsd)} +{$ifdef arithopt} + Ch_MEAX, Ch_MECX, Ch_MEDX, Ch_MEBX, Ch_MESP, Ch_MEBP, Ch_MESI, Ch_MEDI, +{$endif arithopt} + Ch_CDirFlag {clear direction flag}, Ch_SDirFlag {set dir flag}, + Ch_RFlags, Ch_WFlags, Ch_RWFlags, Ch_FPU, + Ch_Rop1, Ch_Wop1, Ch_RWop1,{$ifdef arithopt}Ch_Mop1,{$endif} + Ch_Rop2, Ch_Wop2, Ch_RWop2,{$ifdef arithopt}Ch_Mop2,{$endif} + Ch_Rop3, Ch_WOp3, Ch_RWOp3,{$ifdef arithopt}Ch_Mop3,{$endif} + + Ch_WMemEDI, + Ch_All + ); + +{$ifndef arithopt} +Const + Ch_MEAX = Ch_RWEAX; + Ch_MECX = Ch_RWECX; + Ch_MEDX = Ch_RWEDX; + Ch_MEBX = Ch_RWEBX; + Ch_MESP = Ch_RWESP; + Ch_MEBP = Ch_RWEBP; + Ch_MESI = Ch_RWESI; + Ch_MEDI = Ch_RWEDI; + Ch_Mop1 = Ch_RWOp1; + Ch_Mop2 = Ch_RWOp2; + Ch_Mop3 = Ch_RWOp3; +{$endif arithopt} + +const + MaxCh = 3; { Max things a instruction can change } +type + TInsProp = packed record + Ch : Array[1..MaxCh] of TInsChange; + end; + +const + InsProp : array[tasmop] of TInsProp = +{$i i386prop.inc} + +{$endif NOOPT} + + +{***************************************************************************** + Init/Done +*****************************************************************************} + + procedure InitCpu; + procedure DoneCpu; + +{***************************************************************************** + Helpers +*****************************************************************************} + + const + maxvarregs = 4; + varregs : array[1..maxvarregs] of tregister = + (R_EBX,R_EDX,R_ECX,R_EAX); + + maxfpuvarregs = 8; + max_operands = 3; + + function imm_2_type(l:longint):longint; + + { the following functions allow to convert registers } + { for example reg8toreg32(R_AL) returns R_EAX } + { for example reg16toreg32(R_AL) gives an undefined } + { result } + { these functions expects that the turn of } + { tregister isn't changed } + function reg8toreg16(reg : tregister) : tregister; + function reg8toreg32(reg : tregister) : tregister; + function reg16toreg8(reg : tregister) : tregister; + function reg32toreg8(reg : tregister) : tregister; + function reg32toreg16(reg : tregister) : tregister; + function reg16toreg32(reg : tregister) : tregister; + + { these procedures must be defined by all target cpus } + function regtoreg8(reg : tregister) : tregister; + function regtoreg16(reg : tregister) : tregister; + function regtoreg32(reg : tregister) : tregister; + + { can be ignored on 32 bit systems } + function regtoreg64(reg : tregister) : tregister; + + { returns the operand prefix for a given register } + function regsize(reg : tregister) : topsize; + + { resets all values of ref to defaults } + procedure reset_reference(var ref : treference); + { set mostly used values of a new reference } + function new_reference(base : tregister;offset : longint) : preference; + + function newreference(const r : treference) : preference; + procedure disposereference(var r : preference); + + function reg2str(r : tregister) : string; + + function is_calljmp(o:tasmop):boolean; + + +implementation + +{$ifdef heaptrc} + uses + ppheap; +{$endif heaptrc} + +{***************************************************************************** + Helpers +*****************************************************************************} + + function imm_2_type(l:longint):longint; + begin + if (l>=-128) and (l<=127) then + imm_2_type:=OT_IMM8 or OT_SIGNED + else + if (l>=-255) and (l<=255) then + imm_2_type:=OT_IMM8 + else + if (l>=-32768) and (l<=32767) then + imm_2_type:=OT_IMM16 or OT_SIGNED + else + if (l>=-65536) and (l<=65535) then + imm_2_type:=OT_IMM16 or OT_SIGNED + else + imm_2_type:=OT_IMM32; + end; + + function reg2str(r : tregister) : string; + const + a : array[R_NO..R_BL] of string[3] = + ('','EAX','ECX','EDX','EBX','ESP','EBP','ESI','EDI', + 'AX','CX','DX','BX','SP','BP','SI','DI', + 'AL','CL','DL','BL'); + begin + if r in [R_ST0..R_ST7] then + reg2str:='ST('+tostr(longint(r)-longint(R_ST0))+')' + else + reg2str:=a[r]; + end; + + + function is_calljmp(o:tasmop):boolean; + begin + case o of + A_CALL, + A_JCXZ, + A_JECXZ, + A_JMP, + A_LOOP, + A_LOOPE, + A_LOOPNE, + A_LOOPNZ, + A_LOOPZ, + A_Jcc : + is_calljmp:=true; + else + is_calljmp:=false; + end; + end; + + + procedure disposereference(var r : preference); + begin + dispose(r); + r:=nil; + end; + + + function newreference(const r : treference) : preference; + var + p : preference; + begin + new(p); + p^:=r; + newreference:=p; + end; + + + function reg8toreg16(reg : tregister) : tregister; + + begin + reg8toreg16:=reg32toreg16(reg8toreg32(reg)); + end; + + function reg16toreg8(reg : tregister) : tregister; + + begin + reg16toreg8:=reg32toreg8(reg16toreg32(reg)); + end; + + function reg16toreg32(reg : tregister) : tregister; + + begin + reg16toreg32:=tregister(byte(reg)-byte(R_EDI)); + end; + + function reg32toreg16(reg : tregister) : tregister; + + begin + reg32toreg16:=tregister(byte(reg)+byte(R_EDI)); + end; + + function reg32toreg8(reg : tregister) : tregister; + + begin + reg32toreg8:=tregister(byte(reg)+byte(R_DI)); + end; + + function reg8toreg32(reg : tregister) : tregister; + + begin + reg8toreg32:=tregister(byte(reg)-byte(R_DI)); + end; + + function regtoreg8(reg : tregister) : tregister; + + begin + regtoreg8:=reg32toreg8(reg); + end; + + function regtoreg16(reg : tregister) : tregister; + + begin + regtoreg16:=reg32toreg16(reg); + end; + + function regtoreg32(reg : tregister) : tregister; + + begin + regtoreg32:=reg; + end; + + function regtoreg64(reg : tregister) : tregister; + + begin + { to avoid warning } + regtoreg64:=R_NO; + end; + +function regsize(reg : tregister) : topsize; +begin + if reg in regset8bit then + regsize:=S_B + else if reg in regset16bit then + regsize:=S_W + else if reg in regset32bit then + regsize:=S_L; +end; + + +procedure reset_reference(var ref : treference); +begin + FillChar(ref,sizeof(treference),0); +end; + + +function new_reference(base : tregister;offset : longint) : preference; +var + r : preference; +begin + new(r); + FillChar(r^,sizeof(treference),0); + r^.base:=base; + r^.offset:=offset; + new_reference:=r; +end; + +{***************************************************************************** + Instruction table +*****************************************************************************} + +procedure DoneCpu; +begin + {exitproc:=saveexit; } +{$ifndef NOAG386BIN} + if assigned(instabcache) then + dispose(instabcache); +{$endif NOAG386BIN} +end; + + +procedure BuildInsTabCache; +{$ifndef NOAG386BIN} +var + i : longint; +{$endif} +begin +{$ifndef NOAG386BIN} + new(instabcache); + FillChar(instabcache^,sizeof(tinstabcache),$ff); + i:=0; + while (i to is_calljmp + + Revision 1.18 1999/12/02 11:26:41 peter + * newoptimizations define added + + Revision 1.17 1999/11/09 23:06:45 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.16 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.15 1999/10/27 16:11:28 peter + * insns.dat is used to generate all i386*.inc files + + Revision 1.14 1999/10/14 14:57:51 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.13 1999/09/15 20:35:39 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.12 1999/09/10 18:48:01 florian + * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.11 1999/09/08 16:04:05 peter + * better support for object fields and more error checks for + field accesses which create buggy code + + Revision 1.10 1999/08/28 15:34:19 florian + * bug 519 fixed + + Revision 1.9 1999/08/19 20:05:09 michael + + Fixed ifdef NOAG386BIN bug + + Revision 1.8 1999/08/19 13:02:10 pierre + + label faillabel added for _FAIL support + + Revision 1.7 1999/08/18 13:26:23 jonas + + some constants for the new optimizer + + Revision 1.6 1999/08/13 15:36:30 peter + * fixed suffix writing for a_setcc + + Revision 1.5 1999/08/12 14:36:02 peter + + KNI instructions + + Revision 1.4 1999/08/07 14:20:58 florian + * some small problems fixed + + Revision 1.3 1999/08/05 14:58:09 florian + * some fixes for the floating point registers + * more things for the new code generator + + Revision 1.2 1999/08/04 13:45:25 florian + + floating point register variables !! + * pairegalloc is now generated for register variables + +} diff --git a/befpc/compiler/cpuinfo.pas b/befpc/compiler/cpuinfo.pas new file mode 100644 index 0000000..e120191 --- /dev/null +++ b/befpc/compiler/cpuinfo.pas @@ -0,0 +1,49 @@ +{ + $Id: cpuinfo.pas,v 1.1.1.1 2001-07-23 17:15:51 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Basic Processor information + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit CPUInfo; + +Interface + +Type +{$ifdef FPC} + AWord = dword; +{$else FPC} + AWord = Longint; +{$endif FPC} + +Const + { Size of native extended type } + extended_size = 10; + +Implementation + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.2 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.1 1999/08/04 11:13:38 florian + + initial revision + +} diff --git a/befpc/compiler/crc.pas b/befpc/compiler/crc.pas new file mode 100644 index 0000000..158c6e5 --- /dev/null +++ b/befpc/compiler/crc.pas @@ -0,0 +1,108 @@ +{ + $Id: crc.pas,v 1.1.1.1 2001-07-23 17:15:51 memson Exp $ + Copyright (c) 2000 by Free Pascal Development Team + + Routines to compute CRC values + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit CRC; + +Interface +Function Crc32(Const HStr:String):longint; +Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint; +Function UpdCrc32(InitCrc:longint;b:byte):longint; + + +Implementation + +{***************************************************************************** + Crc 32 +*****************************************************************************} + +var + Crc32Tbl : array[0..255] of longint; + +procedure MakeCRC32Tbl; +var + crc : longint; + i,n : byte; +begin + for i:=0 to 255 do + begin + crc:=i; + for n:=1 to 8 do + if odd(crc) then + crc:=(crc shr 1) xor longint($edb88320) + else + crc:=crc shr 1; + Crc32Tbl[i]:=crc; + end; +end; + + +{$ifopt R+} +{$define Range_check_on} +{$endif opt R+} + +{$R- needed here } +{CRC 32} +Function Crc32(Const HStr:String):longint; +var + i,InitCrc : longint; +begin + if Crc32Tbl[1]=0 then + MakeCrc32Tbl; + InitCrc:=longint($ffffffff); + for i:=1 to Length(Hstr) do + InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8); + Crc32:=InitCrc; +end; + + + +Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint; +var + i : word; + p : pchar; +begin + if Crc32Tbl[1]=0 then + MakeCrc32Tbl; + p:=@InBuf; + for i:=1 to InLen do + begin + InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8); + inc(longint(p)); + end; + UpdateCrc32:=InitCrc; +end; + + + +Function UpdCrc32(InitCrc:longint;b:byte):longint; +begin + if Crc32Tbl[1]=0 then + MakeCrc32Tbl; + UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8); +end; + +{$ifdef Range_check_on} +{$R+} +{$undef Range_check_on} +{$endif Range_check_on} + +end. \ No newline at end of file diff --git a/befpc/compiler/cresstr.pas b/befpc/compiler/cresstr.pas new file mode 100644 index 0000000..8aa6e84 --- /dev/null +++ b/befpc/compiler/cresstr.pas @@ -0,0 +1,341 @@ +{ + $Id: cresstr.pas,v 1.1.1.1 2001-07-23 17:15:51 memson Exp $ + Copyright (c) 1998-2000 by Michael van Canneyt + + Handles resourcestrings + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cresstr; +interface + +uses + cobjects; + +Type + { These are used to form a singly-linked list, ordered by hash value } + PResourceStringItem = ^TResourceStringItem; + TResourceStringItem = object(TLinkedList_Item) + Name : String; + Value : Pchar; + Len, + hash : longint; + constructor Init(const AName:string;AValue:pchar;ALen:longint); + destructor Done;virtual; + procedure CalcHash; + end; + + PResourceStrings=^TResourceStrings; + TResourceStrings=object + private + List : TLinkedList; + public + ResStrCount : longint; + constructor Init; + destructor Done; + function Register(Const name : string;p : pchar;len : longint) : longint; + procedure CreateResourceStringList; + Procedure WriteResourceFile(FileName : String); + end; + +var + ResourceStrings : PResourceStrings; + + +implementation + +uses + globals,aasm,verbose,files; + + +{ --------------------------------------------------------------------- + Calculate hash value, based on the string + ---------------------------------------------------------------------} + +{ --------------------------------------------------------------------- + TRESOURCESTRING_ITEM + ---------------------------------------------------------------------} + +constructor TResourceStringItem.Init(const AName:string;AValue:pchar;ALen:longint); +begin + inherited Init; + Name:=AName; + Len:=ALen; + GetMem(Value,Len); + Move(AValue^,Value^,Len); + CalcHash; +end; + + +destructor TResourceStringItem.Done; +begin + FreeMem(Value,Len); +end; + + +procedure TResourceStringItem.CalcHash; +Var + g,I : longint; +begin + hash:=0; + For I:=0 to Len-1 do { 0 terminated } + begin + hash:=hash shl 4; + inc(Hash,Ord(Value[i])); + g:=hash and ($f shl 28); + if g<>0 then + begin + hash:=hash xor (g shr 24); + hash:=hash xor g; + end; + end; + If Hash=0 then + Hash:=Not(0); +end; + + +{ --------------------------------------------------------------------- + TRESOURCESTRINGS + ---------------------------------------------------------------------} + +Constructor TResourceStrings.Init; +begin + List.Init; + ResStrCount:=0; +end; + + +Destructor TResourceStrings.Done; +begin + List.Done; +end; + + +{ --------------------------------------------------------------------- + Create the full asmlist for resourcestrings. + ---------------------------------------------------------------------} + +procedure TResourceStrings.CreateResourceStringList; + + Procedure AppendToAsmResList (P : PResourceStringItem); + Var + l1 : pasmlabel; + s : pchar; + l : longint; + begin + With P^ Do + begin + if (Value=nil) or (len=0) then + resourcestringlist^.concat(new(pai_const,init_32bit(0))) + else + begin + getdatalabel(l1); + resourcestringlist^.concat(new(pai_const_symbol,init(l1))); + consts^.concat(new(pai_const,init_32bit(len))); + consts^.concat(new(pai_const,init_32bit(len))); + consts^.concat(new(pai_const,init_32bit(-1))); + consts^.concat(new(pai_label,init(l1))); + getmem(s,len+1); + move(Value^,s^,len); + s[len]:=#0; + consts^.concat(new(pai_string,init_length_pchar(s,len))); + consts^.concat(new(pai_const,init_8bit(0))); + end; + { append Current value (nil) and hash...} + resourcestringlist^.concat(new(pai_const,init_32bit(0))); + resourcestringlist^.concat(new(pai_const,init_32bit(hash))); + { Append the name as a ansistring. } + getdatalabel(l1); + L:=Length(Name); + resourcestringlist^.concat(new(pai_const_symbol,init(l1))); + consts^.concat(new(pai_const,init_32bit(l))); + consts^.concat(new(pai_const,init_32bit(l))); + consts^.concat(new(pai_const,init_32bit(-1))); + consts^.concat(new(pai_label,init(l1))); + getmem(s,l+1); + move(Name[1],s^,l); + s[l]:=#0; + consts^.concat(new(pai_string,init_length_pchar(s,l))); + consts^.concat(new(pai_const,init_8bit(0))); + end; + end; + +Var + R : PresourceStringItem; +begin + if not(assigned(resourcestringlist)) then + resourcestringlist:=new(paasmoutput,init); + resourcestringlist^.insert(new(pai_const,init_32bit(resstrcount))); + resourcestringlist^.insert(new(pai_symbol,initname_global(current_module^.modulename^+'_'+'RESOURCESTRINGLIST',0))); + R:=PResourceStringItem(List.First); + While assigned(R) do + begin + AppendToAsmResList(R); + R:=PResourceStringItem(R^.Next); + end; + resourcestringlist^.concat(new(pai_symbol_end,initname(current_module^.modulename^+'_'+'RESOURCESTRINGLIST'))); +end; + + +{ --------------------------------------------------------------------- + Insert 1 resource string in all tables. + ---------------------------------------------------------------------} + +function TResourceStrings.Register(const name : string;p : pchar;len : longint) : longint; +begin + List.Concat(new(PResourceStringItem,Init(lower(current_module^.modulename^+'.'+Name),p,len))); + Register:=ResStrCount; + inc(ResStrCount); +end; + + +Procedure TResourceStrings.WriteResourceFile(Filename : String); +Type + TMode = (quoted,unquoted); +Var + F : Text; + Mode : TMode; + R : PResourceStringItem; + C : char; + Col,i : longint; + + Procedure Add(Const S : String); + begin + Write(F,S); + Col:=Col+length(s); + end; + +begin + If List.Empty then + exit; + FileName:=ForceExtension(lower(FileName),'.rst'); + message1 (general_i_writingresourcefile,filename); + Assign(F,Filename); + {$i-} + Rewrite(f); + {$i+} + If IOresult<>0 then + begin + message(general_e_errorwritingresourcefile); + exit; + end; + R:=PResourceStringItem(List.First); + While assigned(R) do + begin + writeln(f); + Writeln(f,'# hash value = ',R^.hash); + col:=0; + Add(R^.Name+'='); + Mode:=unquoted; + For I:=0 to R^.Len-1 do + begin + C:=R^.Value[i]; + If (ord(C)>31) and (Ord(c)<=128) and (c<>'''') then + begin + If mode=Quoted then + Add(c) + else + begin + Add(''''+c); + mode:=quoted + end; + end + else + begin + If Mode=quoted then + begin + Add(''''); + mode:=unquoted; + end; + Add('#'+tostr(ord(c))); + end; + If Col>72 then + begin + if mode=quoted then + Write (F,''''); + Writeln(F,'+'); + Col:=0; + Mode:=unQuoted; + end; + end; + if mode=quoted then + writeln (f,''''); + Writeln(f); + R:=PResourceStringItem(R^.Next); + end; + close(f); +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.18 2000/06/04 08:48:54 jonas + * resource string numbering + + Revision 1.17 2000/06/01 19:09:57 peter + * made resourcestrings OOP so it's easier to handle it per module + + Revision 1.16 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.15 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.14 1999/08/27 15:55:36 michael + * Fixed small bug: next field in resourcelist was not initialized + + Revision 1.13 1999/08/26 20:24:39 michael + + Hopefuly last fixes for resourcestrings + + Revision 1.12 1999/08/25 16:41:07 peter + * resources are working again + + Revision 1.11 1999/08/23 11:48:23 michael + * resourcestrings ams list needs unitname prepended + + Revision 1.10 1999/08/23 11:45:41 michael + * Hopefully final attempt at resourcestrings + + Revision 1.9 1999/08/15 21:57:59 michael + Changes for resource strings + + Revision 1.8 1999/07/29 20:54:01 peter + * write .size also + + Revision 1.7 1999/07/26 09:42:00 florian + * bugs 494-496 fixed + + Revision 1.6 1999/07/25 19:27:15 michael + + Fixed hash computing, now compatible with gnu .mo file + + Revision 1.5 1999/07/24 18:35:41 michael + * Forgot to add unitname to resourcestring data + + Revision 1.4 1999/07/24 16:22:10 michael + + Improved resourcestring handling + + Revision 1.3 1999/07/24 15:12:58 michael + changes for resourcestrings + + Revision 1.2 1999/07/22 20:04:58 michael + + Added computehashvalue + + Revision 1.1 1999/07/22 09:34:04 florian + + initial revision + +} diff --git a/befpc/compiler/csopt386.pas b/befpc/compiler/csopt386.pas new file mode 100644 index 0000000..addf24a --- /dev/null +++ b/befpc/compiler/csopt386.pas @@ -0,0 +1,1299 @@ +{ + $Id: csopt386.pas,v 1.1.1.1 2001-07-23 17:15:53 memson Exp $ + Copyright (c) 1998-2000 by Jonas Maebe, member of the Free Pascal + development team + + This unit contains the common subexpression elimination procedure. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit CSOpt386; + +{$ifdef newOptimizations} +{$define foropt} +{$define replacereg} +{$define arithopt} +{$define foldarithops} +{$endif newOptimizations} + +Interface + +Uses aasm; + +{Procedure CSOpt386(First, Last: Pai);} +Procedure CSE(AsmL: PAasmOutput; First, Last: Pai); + +Implementation + +Uses + CObjects, verbose, hcodegen, globals,cpubase,cpuasm,DAOpt386, tgeni386; + +{ +Function PaiInSequence(P: Pai; Const Seq: TContent): Boolean; +Var P1: Pai; + Counter: Byte; + TmpResult: Boolean; +Begin + TmpResult := False; + P1 := Seq.StartMod; + Counter := 1; + While Not(TmpResult) And + (Counter <= Seq.NrOfMods) Do + Begin + If (P = P1) Then TmpResult := True; + Inc(Counter); + p1 := Pai(p1^.Next); + End; + PaiInSequence := TmpResult; +End; +} + +Function CheckSequence(p: Pai; Reg: TRegister; Var Found: Longint; Var RegInfo: TRegInfo): Boolean; +{checks whether the current instruction sequence (starting with p) and the + one between StartMod and EndMod of Reg are the same. If so, the number of + instructions that match is stored in Found and true is returned, otherwise + Found holds the number of instructions between StartMod and EndMod and false + is returned} +Var hp2, hp3{, EndMod}: Pai; + PrevNonRemovablePai: Pai; + {Cnt,} OldNrOfMods: Longint; + OrgRegInfo, HighRegInfo: TRegInfo; + HighFound, OrgRegFound: Byte; + RegCounter: TRegister; + OrgRegResult: Boolean; + TmpResult: Boolean; + {TmpState: Byte;} +Begin {CheckSequence} + Reg := Reg32(Reg); + TmpResult := False; + FillChar(OrgRegInfo, SizeOf(OrgRegInfo), 0); + OrgRegFound := 0; + HighFound := 0; + OrgRegResult := False; + RegCounter := R_EAX; + GetLastInstruction(p, PrevNonRemovablePai); + While (RegCounter <= R_EDI) And + (PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].Typ <> Con_Ref) Do + Inc(RegCounter); + While (RegCounter <= R_EDI) Do + Begin + FillChar(RegInfo, SizeOf(RegInfo), 0); + RegInfo.NewRegsEncountered := [procinfo^.FramePointer, R_ESP]; + RegInfo.OldRegsEncountered := RegInfo.NewRegsEncountered; + RegInfo.New2OldReg[procinfo^.FramePointer] := procinfo^.FramePointer; + RegInfo.New2OldReg[R_ESP] := R_ESP; + Found := 0; + hp2 := PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].StartMod; + If (PrevNonRemovablePai <> PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].StartMod) + Then OldNrOfMods := PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].NrOfMods + Else OldNrOfMods := 1; + hp3 := p; + While (Found <> OldNrOfMods) And + { old new } + InstructionsEquivalent(hp2, hp3, RegInfo) Do + Begin + GetNextInstruction(hp2, hp2); + GetNextInstruction(hp3, hp3); + Inc(Found) + End; + If (Found <> OldNrOfMods) or + { the following is to avoid problems with rangecheck code (see testcse2) } + (assigned(hp3) and + ((reg in regInfo.regsLoadedForRef) and + (reg in PPaiProp(hp3^.optInfo)^.usedRegs) and + not regLoadedWithNewValue(reg,false,hp3))) then + Begin + TmpResult := False; + If (found > 0) then +{this is correct because we only need to turn off the CanBeRemoved flag + when an instruction has already been processed by CheckSequence + (otherwise CanBeRemoved can't be true and thus can't have to be turned off). + If it has already been processed by CheckSequence and flagged to be + removed, it means that it has been checked against a previous sequence + and that it was equal (otherwise CheckSequence would have returned false + and the instruction wouldn't have been removed). If this "If found > 0" + check is left out, incorrect optimizations are performed.} + Found := PPaiProp(Pai(p)^.OptInfo)^.Regs[Reg].NrOfMods + End + Else TmpResult := True; + If TmpResult And + (Found > HighFound) + Then + Begin + HighFound := Found; + HighRegInfo := RegInfo; + End; + If (RegCounter = Reg) Then + Begin + OrgRegFound := Found; + OrgRegResult := TmpResult; + OrgRegInfo := RegInfo + End; + Repeat + Inc(RegCounter); + Until (RegCounter > R_EDI) or + ((PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].Typ = Con_Ref) {And + ((Regcounter = Reg) Or + Not(PaiInSequence(p, PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter]))) } + ); + End; + If (HighFound > 0) And + (Not(OrgRegResult) Or + (HighFound > OrgRegFound)) + Then + Begin +{$ifndef fpc} + TmpResult := True; +{$else fpc} + CheckSequence := True; +{$endif fpc} + RegInfo := HighRegInfo; + Found := HighFound + End + Else + Begin +{$ifndef fpc} + TmpResult := OrgRegResult; +{$else fpc} + CheckSequence := OrgRegResult; +{$endif fpc} + Found := OrgRegFound; + RegInfo := OrgRegInfo; + End; +{$ifndef fpc} + CheckSequence := TmpResult; +{$endif fpc} +End; {CheckSequence} + +Procedure SetAlignReg(p: Pai); +Const alignSearch = 12; +var regsUsable: TRegSet; + prevInstrCount, nextInstrCount: Longint; + prevState, nextWState,nextRState: Array[R_EAX..R_EDI] of byte; + regCounter, lastRemoved: TRegister; + prev, next: Pai; +{$ifdef alignregdebug} + temp: Pai; +{$endif alignregdebug} +begin + regsUsable := [R_EAX,R_ECX,R_EDX,R_EBX,{R_ESP,R_EBP,}R_ESI,R_EDI]; + for regCounter := R_EAX to R_EDI do + begin + prevState[regCounter] := PPaiProp(p^.optInfo)^.Regs[regCounter].wState; + nextWState[regCounter] := PPaiProp(p^.optInfo)^.Regs[regCounter].wState; + nextRState[regCounter] := PPaiProp(p^.optInfo)^.Regs[regCounter].rState; + end; + getLastInstruction(p,prev); + getNextInstruction(p,next); + lastRemoved := pai_align(p)^.reg; + nextInstrCount := 0; + prevInstrCount := 0; + while ((assigned(prev) and + assigned(prev^.optInfo) and + (prevInstrCount < alignSearch)) or + (assigned(next) and + assigned(next^.optInfo) and + (nextInstrCount < alignSearch))) And + (regsUsable <> []) do + begin +{$ifdef alignregdebug} + if assigned(prev) then + begin + temp := new(pai_asm_comment,init(strpnew('got here'))); + temp^.next := prev^.next; + temp^.previous := prev; + prev^.next := temp; + if assigned(temp^.next) then + temp^.next^.previous := temp; + end; +{$endif alignregdebug} + if assigned(prev) and assigned(prev^.optinfo) and + (prevInstrCount < alignSearch) then + begin + if (prev^.typ = ait_instruction) And + (insProp[PaiCpu(prev)^.opcode].ch[1] <> Ch_ALL) and + (PaiCpu(prev)^.opcode <> A_JMP) then + begin + inc(prevInstrCount); + for regCounter := R_EAX to R_EDI do + begin + if (regCounter in regsUsable) And + (PPaiProp(prev^.optInfo)^.Regs[regCounter].wState <> + prevState[regCounter]) then + begin + lastRemoved := regCounter; + exclude(regsUsable,regCounter); +{$ifdef alignregdebug} + temp := new(pai_asm_comment,init(strpnew( + att_reg2str[regCounter]+' removed'))); + temp^.next := prev^.next; + temp^.previous := prev; + prev^.next := temp; + if assigned(temp^.next) then + temp^.next^.previous := temp; + if regsUsable = [] then + begin + temp := new(pai_asm_comment,init(strpnew( + 'regsUsable empty here'))); + temp^.next := prev^.next; + temp^.previous := prev; + prev^.next := temp; + if assigned(temp^.next) then + temp^.next^.previous := temp; + end; +{$endif alignregdebug} + end; + prevState[regCounter] := + PPaiProp(prev^.optInfo)^.Regs[regCounter].wState; + end; + getLastInstruction(prev,prev); + end + else + If GetLastInstruction(prev,prev) and + assigned(prev^.optinfo) then + for regCounter := R_EAX to R_EDI do + prevState[regCounter] := + PPaiProp(prev^.optInfo)^.Regs[regCounter].wState + end; + if assigned(next) and assigned(next^.optInfo) and + (nextInstrCount < alignSearch) then + begin + if (next^.typ = ait_instruction) and + (insProp[PaiCpu(next)^.opcode].ch[1] <> Ch_ALL) and + (PaiCpu(next)^.opcode <> A_JMP) then + begin + inc(nextInstrCount); + for regCounter := R_EAX to R_EDI do + begin + if (regCounter in regsUsable) And + ((PPaiProp(next^.optInfo)^.Regs[regCounter].wState <> + nextWState[regCounter]) or + (PPaiProp(next^.optInfo)^.Regs[regCounter].rState <> + nextRState[regCounter])) Then + begin + lastRemoved := regCounter; + exclude(regsUsable,regCounter); +{$ifdef alignregdebug} + temp := new(pai_asm_comment,init(strpnew( + att_reg2str[regCounter]+' removed'))); + temp^.next := next^.next; + temp^.previous := next; + next^.next := temp; + if assigned(temp^.next) then + temp^.next^.previous := temp; + if regsUsable = [] then + begin + temp := new(pai_asm_comment,init(strpnew( + 'regsUsable empty here'))); + temp^.next := next^.next; + temp^.previous := next; + next^.next := temp; + if assigned(temp^.next) then + temp^.next^.previous := temp; + end; +{$endif alignregdebug} + end; + nextWState[regCounter] := + PPaiProp(next^.optInfo)^.Regs[regCounter].wState; + nextRState[regCounter] := + PPaiProp(next^.optInfo)^.Regs[regCounter].rState; + end + end + else + for regCounter := R_EAX to R_EDI do + begin + nextWState[regCounter] := + PPaiProp(next^.optInfo)^.Regs[regCounter].wState; + nextRState[regCounter] := + PPaiProp(next^.optInfo)^.Regs[regCounter].rState; + end; + getNextInstruction(next,next); + end; + end; + if regsUsable <> [] then + for regCounter := R_EAX to R_EDI do + if regCounter in regsUsable then + begin + lastRemoved := regCounter; + break + end; +{$ifdef alignregdebug} + next := new(pai_asm_comment,init(strpnew(att_reg2str[lastRemoved]+ + ' chosen as alignment register'))); + next^.next := p^.next; + next^.previous := p; + p^.next := next; + if assigned(next^.next) then + next^.next^.previous := next; +{$endif alignregdebug} + pai_align(p)^.reg := lastRemoved; +End; + +Procedure RestoreRegContentsTo(reg: TRegister; const c: TContent; p, endP: pai); +var +{$ifdef replaceregdebug} + hp: pai; +{$endif replaceregdebug} + tmpState: byte; +begin +{$ifdef replaceregdebug} + hp := new(pai_asm_comment,init(strpnew( + 'restored '+att_reg2str[reg]+' with data from here...'))); + hp^.next := p; + hp^.previous := p^.previous; + p^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; +{$endif replaceregdebug} + PPaiProp(p^.optInfo)^.Regs[reg] := c; + While (p <> endP) Do + Begin + PPaiProp(p^.optInfo)^.Regs[reg] := c; + getNextInstruction(p,p); + end; + tmpState := PPaiProp(p^.optInfo)^.Regs[reg].wState; + repeat + PPaiProp(p^.optInfo)^.Regs[reg] := c; + until not getNextInstruction(p,p) or + (PPaiProp(p^.optInfo)^.Regs[reg].wState <> tmpState); +{$ifdef replaceregdebug} + if assigned(p) then + begin + hp := new(pai_asm_comment,init(strpnew( + 'restored '+att_reg2str[reg]+' till here...'))); + hp^.next := p; + hp^.previous := p^.previous; + p^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; + end; +{$endif replaceregdebug} +end; + +{$ifdef replacereg} +function FindRegDealloc(reg: tregister; p: pai): boolean; +{ assumes reg is a 32bit register } +begin + findregdealloc := false; + while assigned(p^.previous) and + ((Pai(p^.previous)^.typ in (skipinstr+[ait_align])) or + ((Pai(p^.previous)^.typ = ait_label) and + not(Pai_Label(p^.previous)^.l^.is_used))) do + begin + p := pai(p^.previous); + if (p^.typ = ait_regalloc) and + (pairegalloc(p)^.reg = reg) then + begin + findregdealloc := not(pairegalloc(p)^.allocation); + break; + end; + end +end; + +Procedure ClearRegContentsFrom(reg: TRegister; p, endP: pai); +{ first clears the contents of reg from p till endP. Then the contents are } +{ cleared until the first instruction that changes reg } +var +{$ifdef replaceregdebug} + hp: pai; +{$endif replaceregdebug} + tmpState: byte; +begin + PPaiProp(p^.optInfo)^.Regs[reg].typ := con_unknown; + While (p <> endP) Do + Begin + PPaiProp(p^.optInfo)^.Regs[reg].typ := con_unknown; + getNextInstruction(p,p); + end; + tmpState := PPaiProp(p^.optInfo)^.Regs[reg].wState; + repeat + PPaiProp(p^.optInfo)^.Regs[reg].typ := con_unknown; + until not getNextInstruction(p,p) or + (PPaiProp(p^.optInfo)^.Regs[reg].wState <> tmpState); +{$ifdef replaceregdebug} + if assigned(p) then + begin + hp := new(pai_asm_comment,init(strpnew( + 'cleared '+att_reg2str[reg]+' till here...'))); + hp^.next := p; + hp^.previous := p^.previous; + p^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; + end; +{$endif replaceregdebug} +end; + +function NoHardCodedRegs(p: paicpu; orgReg, newReg: tRegister): boolean; +var chCount: byte; +begin + case p^.opcode of + A_IMUL: noHardCodedRegs := p^.ops <> 1; + A_SHL,A_SHR,A_SHLD,A_SHRD: noHardCodedRegs := + (p^.oper[0].typ <> top_reg) or + ((orgReg <> R_ECX) and (newReg <> R_ECX)); + else + begin + NoHardCodedRegs := true; + with InsProp[p^.opcode] do + for chCount := 1 to MaxCh do + if Ch[chCount] in ([Ch_REAX..Ch_MEDI,Ch_WMemEDI,Ch_All]-[Ch_RESP,Ch_WESP,Ch_RWESP]) then + begin + NoHardCodedRegs := false; + break + end; + end; + end; +end; + +Procedure ChangeReg(var Reg: TRegister; orgReg, newReg: TRegister); +begin + if reg = newReg then + reg := orgReg + else if reg = regtoreg8(newReg) then + reg := regtoreg8(orgReg) + else if reg = regtoreg16(newReg) then + reg := regtoreg16(orgReg); +end; + +procedure changeOp(var o: toper; orgReg, newReg: tregister); +begin + case o.typ of + top_reg: changeReg(o.reg,orgReg,newReg); + top_ref: + begin + changeReg(o.ref^.base,orgReg,newReg); + changeReg(o.ref^.index,orgReg,newReg); + end; + end; +end; + +Procedure DoReplaceReg(orgReg,newReg: tregister; hp: paicpu); +var opCount: byte; +begin + for opCount := 0 to 2 do + changeOp(hp^.oper[opCount],orgReg,newReg) +end; + +function RegSizesOK(oldReg,newReg: TRegister; p: paicpu): boolean; +{ oldreg and newreg must be 32bit components } +var opCount: byte; +begin + RegSizesOK := true; + { if only one of them is a general purpose register ... } + if (IsGP32reg(oldReg) xor IsGP32Reg(newReg)) then + begin + for opCount := 0 to 2 do + if (p^.oper[opCount].typ = top_reg) and + (p^.oper[opCount].reg in [R_AL..R_DH]) then + begin + RegSizesOK := false; + break + end + end; +end; + +procedure DoReplaceReadReg(orgReg,newReg: tregister; p: paicpu); +var opCount: byte; +begin + { handle special case } + case p^.opcode of + A_IMUL: + begin + case p^.ops of + 1: internalerror(1301001); + 2,3: + begin + changeOp(p^.oper[0],orgReg,newReg); + if p^.ops = 3 then + changeOp(p^.oper[1],orgReg,newReg); + end; + end; + end; + A_DIV,A_IDIV,A_MUL: internalerror(1301002); + else + begin + for opCount := 0 to 2 do + if p^.oper[opCount].typ = top_ref then + changeOp(p^.oper[opCount],orgReg,newReg); + for opCount := 1 to MaxCh do + case InsProp[p^.opcode].Ch[opCount] of + Ch_ROp1: + if p^.oper[0].typ = top_reg then + ChangeReg(p^.oper[0].reg,orgReg,newReg); + Ch_ROp2: + if p^.oper[1].typ = top_reg then + ChangeReg(p^.oper[1].reg,orgReg,newReg); + Ch_ROp3: + if p^.oper[2].typ = top_reg then + ChangeReg(p^.oper[2].reg,orgReg,newReg); + end; + end; + end; +end; + +function ReplaceReg(asmL: PaasmOutput; orgReg, newReg: TRegister; p: pai; + const c: TContent; orgRegCanBeModified: Boolean; + var returnEndP: pai): Boolean; +{ Tries to replace orgreg with newreg in all instructions coming after p } +{ until orgreg gets loaded with a new value. Returns true if successful, } +{ false otherwise. If successful, the contents of newReg are set to c, } +{ which should hold the contents of newReg before the current sequence } +{ started } +{ if the function returns true, returnEndP holds the last instruction } +{ where newReg was replaced by orgReg } +var endP, hp: Pai; + removeLast, sequenceEnd, tmpResult, newRegModified, orgRegRead: Boolean; + + function storeBack(p1: pai): boolean; + { returns true if p1 contains an instruction that stores the contents } + { of newReg back to orgReg } + begin + storeBack := + (p1^.typ = ait_instruction) and + (paicpu(p1)^.opcode = A_MOV) and + (paicpu(p1)^.oper[0].typ = top_reg) and + (paicpu(p1)^.oper[0].reg = newReg) and + (paicpu(p1)^.oper[1].typ = top_reg) and + (paicpu(p1)^.oper[1].reg = orgReg); + end; + +begin + ReplaceReg := false; + tmpResult := true; + sequenceEnd := false; + newRegModified := false; + orgRegRead := false; + removeLast := false; + endP := p; + while tmpResult and not sequenceEnd do + begin + tmpResult := + getNextInstruction(endP,endP) and + (endP^.typ = ait_instruction); + if tmpresult and not assigned(endP^.optInfo) then + begin +{ hp := new(pai_asm_comment,init(strpnew('next no optinfo'))); + hp^.next := endp; + hp^.previous := endp^.previous; + endp^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp;} + exit; + end; + If tmpResult and + { don't take into account instructions that will be removed } + Not (PPaiProp(endP^.optInfo)^.canBeRemoved) then + begin + { if the newReg gets stored back to the oldReg, we can change } + { "mov %oldReg,%newReg; ; mov %newReg, } + { %oldReg" to "" } + removeLast := storeBack(endP); + sequenceEnd := + { no support for (i)div, mul and imul with hardcoded operands } + (noHardCodedRegs(paicpu(endP),orgReg,newReg) and + { if newReg gets loaded with a new value, we can stop } + { replacing newReg with oldReg here (possibly keeping } + { the original contents of oldReg so we still know them } + { afterwards) } + RegLoadedWithNewValue(newReg,true,paicpu(endP)) or + { we can also stop if we reached the end of the use of } + { newReg's current contents } + (GetNextInstruction(endp,hp) and + FindRegDealloc(newReg,hp))); + { to be able to remove the first and last instruction of } + { movl %reg1, %reg2 } + { (replacing reg2 with reg1 here) } + { movl %reg2, %reg1 } + { %reg2 must not be use afterwards (it can be as the } + { result of a peepholeoptimization) } + removeLast := removeLast and sequenceEnd; + newRegModified := + newRegModified or + (not(regLoadedWithNewValue(newReg,true,paicpu(endP))) and + RegModifiedByInstruction(newReg,endP)); + orgRegRead := newRegModified and RegReadByInstruction(orgReg,endP); + sequenceEnd := SequenceEnd and + (removeLast or + { since newReg will be replaced by orgReg, we can't allow that newReg } + { gets modified if orgReg is still read afterwards (since after } + { replacing, this would mean that orgReg first gets modified and then } + { gets read in the assumption it still contains the unmodified value) } + not(newRegModified and orgRegRead)) (* and + { since newReg will be replaced by orgReg, we can't allow that newReg } + { gets modified if orgRegCanBeModified = false } + (orgRegCanBeModified or not(newRegModified)) *); + tmpResult := + not(removeLast) and + not(newRegModified and orgRegRead) and +(* (orgRegCanBeModified or not(newRegModified)) and *) + (endP^.typ = ait_instruction) and + not(paicpu(endP)^.is_jmp) and + NoHardCodedRegs(paicpu(endP),orgReg,newReg) and + RegSizesOk(orgReg,newReg,paicpu(endP)) and + not RegModifiedByInstruction(orgReg,endP); + end; + end; + sequenceEnd := sequenceEnd and + (removeLast or + (orgRegCanBeModified or not(newRegModified))) and + (not(assigned(endp)) or + not(endp^.typ = ait_instruction) or + (noHardCodedRegs(paicpu(endP),orgReg,newReg) and + RegSizesOk(orgReg,newReg,paicpu(endP)) and + not(newRegModified and + (orgReg in PPaiProp(endP^.optInfo)^.usedRegs) and + not(RegLoadedWithNewValue(orgReg,true,paicpu(endP)))))); + if SequenceEnd then + begin +{$ifdef replaceregdebug} + hp := new(pai_asm_comment,init(strpnew( + 'replacing '+att_reg2str[newreg]+' with '+att_reg2str[orgreg]+ + ' from here...'))); + hp^.next := p; + hp^.previous := p^.previous; + p^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; + + hp := new(pai_asm_comment,init(strpnew( + 'replaced '+att_reg2str[newreg]+' with '+att_reg2str[orgreg]+ + ' till here'))); + hp^.next := endp^.next; + hp^.previous := endp; + endp^.next := hp; + if assigned(hp^.next) then + hp^.next^.previous := hp; +{$endif replaceregdebug} + replaceReg := true; + returnEndP := endP; + getNextInstruction(p,hp); + while hp <> endP do + begin + if not(PPaiProp(hp^.optInfo)^.canBeRemoved) and + (hp^.typ = ait_instruction) then + DoReplaceReg(orgReg,newReg,paicpu(hp)); + GetNextInstruction(hp,hp) + end; + if assigned(endp) and (endp^.typ = ait_instruction) then + DoReplaceReadReg(orgReg,newReg,paicpu(endP)); +{ the replacing stops either at the moment that } +{ a) the newreg gets loaded with a new value (one not depending on the } +{ current value of newreg) } +{ b) newreg is completely replaced in this sequence and it's current value } +{ isn't used anymore } +{ In case b, the newreg was completely replaced by oldreg, so it's contents } +{ are unchanged compared the start of this sequence, so restore them } + If removeLast or + RegLoadedWithNewValue(newReg,true,endP) then + GetLastInstruction(endP,hp) + else hp := endP; + if removeLast or + (p <> endp) or + not RegLoadedWithNewValue(newReg,true,endP) then + RestoreRegContentsTo(newReg, c ,p, hp); +{ In both case a and b, it is possible that the new register was modified } +{ (e.g. an add/sub), so if it was replaced by oldreg in that instruction, } +{ oldreg's contents have been changed. To take this into account, we simply } +{ set the contents of orgreg to "unknown" after this sequence } + if newRegModified then + ClearRegContentsFrom(orgReg,p,hp); + if removeLast then + ppaiprop(endP^.optinfo)^.canBeRemoved := true; + allocRegBetween(asml,orgReg,p,endP); + end +{$ifdef replaceregdebug} + else + begin + hp := new(pai_asm_comment,init(strpnew( + 'replacing '+att_reg2str[newreg]+' with '+att_reg2str[orgreg]+ + ' from here...'))); + hp^.previous := p^.previous; + hp^.next := p; + p^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; + + hp := new(pai_asm_comment,init(strpnew( + 'replacing '+att_reg2str[newreg]+' with '+att_reg2str[orgreg]+ + ' failed here'))); + hp^.next := endp^.next; + hp^.previous := endp; + endp^.next := hp; + if assigned(hp^.next) then + hp^.next^.previous := hp; + end; +{$endif replaceregdebug} +End; +{$endif replacereg} + +{$ifdef arithopt} +Function FindRegWithConst(p: Pai; size: topsize; l: longint; Var Res: TRegister): Boolean; +{Finds a register which contains the constant l} +Var Counter: TRegister; +{$ifdef testing} + hp: pai; +{$endif testing} + tmpresult: boolean; +Begin + Counter := R_NO; + repeat + inc(counter); + tmpresult := (PPaiProp(p^.OptInfo)^.Regs[Counter].Typ = Con_Const) and + (paicpu(PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod)^.opsize = size) and + (paicpu(PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod)^.oper[0].typ = top_const) and + (paicpu(PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod)^.oper[0].val = l); +{$ifdef testing} + if (PPaiProp(p^.OptInfo)^.Regs[Counter].Typ = Con_Const) then + begin + hp := new(pai_asm_comment,init(strpnew( + 'checking const load of '+tostr(l)+' here...'))); + hp^.next := PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod; + hp^.previous := PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod^.previous; + PPaiProp(p^.OptInfo)^.Regs[Counter].StartMod^.previous := hp; + if assigned(hp^.previous) then + hp^.previous^.next := hp; + end; +{$endif testing} + until tmpresult or (Counter = R_EDI); + res := counter; + FindRegWithConst := tmpResult; +End; +{$endif arithopt} + +Procedure DoCSE(AsmL: PAasmOutput; First, Last: Pai); +{marks the instructions that can be removed by RemoveInstructs. They're not + removed immediately because sometimes an instruction needs to be checked in + two different sequences} +Var Cnt, Cnt2: Longint; + p, hp1, hp2: Pai; + hp3, hp4: pai; +{$ifdef replacereg} + hp5 : pai; +{$else} + {$ifdef csdebug} + hp5 : pai; + {$endif} +{$endif} + RegInfo: TRegInfo; + RegCounter: TRegister; + TmpState: Byte; +Begin + p := First; + SkipHead(p); + First := p; + While (p <> Last) Do + Begin + Case p^.typ Of + ait_align: + if not(pai_align(p)^.use_op) then + SetAlignReg(p); + ait_instruction: + Begin + Case Paicpu(p)^.opcode Of + A_CLD: If GetLastInstruction(p, hp1) And + (PPaiProp(hp1^.OptInfo)^.DirFlag = F_NotSet) Then + PPaiProp(Pai(p)^.OptInfo)^.CanBeRemoved := True; + A_MOV, A_MOVZX, A_MOVSX: + Begin + Case Paicpu(p)^.oper[0].typ Of + Top_Ref: + Begin {destination is always a register in this case} + With PPaiProp(p^.OptInfo)^.Regs[Reg32(Paicpu(p)^.oper[1].reg)] Do + Begin + If (p = StartMod) And + GetLastInstruction (p, hp1) And + (hp1^.typ <> ait_marker) Then +{so we don't try to check a sequence when p is the first instruction of the block} + begin +{$ifdef csdebug} + hp5 := new(pai_asm_comment,init(strpnew( + 'cse checking '+att_reg2str[Reg32(Paicpu(p)^.oper[1].reg)]))); + insertLLItem(asml,p,p^.next,hp5); +{$endif csdebug} + If CheckSequence(p, Paicpu(p)^.oper[1].reg, Cnt, RegInfo) And + (Cnt > 0) Then + Begin + hp1 := nil; +{ although it's perfectly ok to remove an instruction which doesn't contain } +{ the register that we've just checked (CheckSequence takes care of that), } +{ the sequence containing this other register should also be completely } +{ checked and removed, otherwise we may get situations like this: } +{ } +{ movl 12(%ebp), %edx movl 12(%ebp), %edx } +{ movl 16(%ebp), %eax movl 16(%ebp), %eax } +{ movl 8(%edx), %edx movl 8(%edx), %edx } +{ movl (%eax), eax movl (%eax), eax } +{ cmpl %eax, %edx cmpl %eax, %edx } +{ jnz l123 getting converted to jnz l123 } +{ movl 12(%ebp), %edx movl 4(%eax), eax } +{ movl 16(%ebp), %eax } +{ movl 8(%edx), %edx } +{ movl 4(%eax), eax } + hp2 := p; + Cnt2 := 1; + While Cnt2 <= Cnt Do + Begin + If (hp1 = nil) And + Not(RegInInstruction(Paicpu(hp2)^.oper[1].reg, p)) And + ((p^.typ = ait_instruction) And + ((paicpu(p)^.OpCode = A_MOV) or + (paicpu(p)^.opcode = A_MOVZX) or + (paicpu(p)^.opcode = A_MOVSX)) And + (paicpu(p)^.Oper[0].typ = top_ref)) Then + hp1 := p; +{$ifndef noremove} + if regInInstruction(Paicpu(hp2)^.oper[1].reg,p) then + PPaiProp(p^.OptInfo)^.CanBeRemoved := True; +{$endif noremove} + Inc(Cnt2); + GetNextInstruction(p, p); + End; + hp3 := New(Pai_Marker,Init(NoPropInfoStart)); + InsertLLItem(AsmL, Pai(hp2^.Previous), hp2, hp3); + {hp4 is used to get the contents of the registers before the sequence} + GetLastInstruction(hp2, hp4); +{$IfDef CSDebug} + For RegCounter := R_EAX To R_EDI Do + If (RegCounter in RegInfo.RegsLoadedForRef) Then + Begin + hp5 := new(pai_asm_comment,init(strpnew('New: '+att_reg2str[RegCounter]+', Old: '+ + att_reg2str[RegInfo.New2OldReg[RegCounter]]))); + InsertLLItem(AsmL, Pai(hp2^.previous), hp2, hp5); + End; +{$EndIf CSDebug} + { If some registers were different in the old and the new sequence, move } + { the contents of those old registers to the new ones } + For RegCounter := R_EAX To R_EDI Do + If Not(RegCounter in [R_ESP,procinfo^.framepointer]) And + (RegInfo.New2OldReg[RegCounter] <> R_NO) Then + Begin + AllocRegBetween(AsmL,RegInfo.New2OldReg[RegCounter], + PPaiProp(hp4^.OptInfo)^.Regs[RegInfo.New2OldReg[RegCounter]].StartMod,hp2); + If Not(RegCounter In RegInfo.RegsLoadedForRef) And + {old reg new reg} + (RegInfo.New2OldReg[RegCounter] <> RegCounter) Then + Begin +{$ifdef replacereg} + getLastInstruction(p,hp3); + If not(regCounter in usableRegs + [R_EDI,R_ESI]) or + not ReplaceReg(asmL,RegInfo.New2OldReg[RegCounter], + regCounter,hp3, + PPaiProp(hp4^.optInfo)^.Regs[regCounter],true,hp5) then + begin +{$endif replacereg} + hp3 := New(Paicpu,Op_Reg_Reg(A_MOV, S_L, + {old reg new reg} + RegInfo.New2OldReg[RegCounter], RegCounter)); + InsertLLItem(AsmL, Pai(hp2^.previous), hp2, hp3); +{$ifdef replacereg} + end +{$endif replacereg} + End + Else +{ imagine the following code: } +{ normal wrong optimized } +{ movl 8(%ebp), %eax movl 8(%ebp), %eax } +{ movl (%eax), %eax movl (%eax), %eax } +{ cmpl 8(%ebp), %eax cmpl 8(%ebp), %eax } +{ jne l1 jne l1 } +{ movl 8(%ebp), %eax } +{ movl (%eax), %edi movl %eax, %edi } +{ movl %edi, -4(%ebp) movl %edi, -4(%ebp) } +{ movl 8(%ebp), %eax } +{ pushl 70(%eax) pushl 70(%eax) } +{ } +{ The error is that at the moment that the last instruction is executed, } +{ %eax doesn't contain 8(%ebp) anymore. Solution: the contents of } +{ registers that are completely removed from a sequence (= registers in } +{ RegLoadedForRef, have to be changed to their contents from before the } +{ sequence. } + If RegCounter in RegInfo.RegsLoadedForRef Then + Begin +{load Cnt2 with the total number of instructions of this sequence} + Cnt2 := PPaiProp(hp4^.OptInfo)^. + Regs[RegInfo.New2OldReg[RegCounter]].NrOfMods; + + hp3 := hp2; + For Cnt := 1 to Pred(Cnt2) Do + GetNextInstruction(hp3, hp3); + TmpState := PPaiProp(hp3^.OptInfo)^.Regs[RegCounter].WState; + GetNextInstruction(hp3, hp3); +{$ifdef csdebug} + Writeln('Cnt2: ',Cnt2); + hp5 := new(pai_asm_comment,init(strpnew('starting here...'))); + InsertLLItem(AsmL, Pai(hp2^.previous), hp2, hp5); +{$endif csdebug} + hp3 := hp2; +{first change the contents of the register inside the sequence} + For Cnt := 1 to Cnt2 Do + Begin +{save the WState of the last pai object of the sequence for later use} + TmpState := PPaiProp(hp3^.OptInfo)^.Regs[RegCounter].WState; +{$ifdef csdebug} + hp5 := new(pai_asm_comment,init(strpnew('WState for '+att_reg2str[Regcounter]+': ' + +tostr(tmpstate)))); + InsertLLItem(AsmL, hp3, pai(hp3^.next), hp5); +{$endif csdebug} + PPaiProp(hp3^.OptInfo)^.Regs[RegCounter] := + PPaiProp(hp4^.OptInfo)^.Regs[RegCounter]; + GetNextInstruction(hp3, hp3); + End; +{here, hp3 = p = Pai object right after the sequence, TmpState = WState of + RegCounter at the last Pai object of the sequence} + GetLastInstruction(hp3, hp3); + While GetNextInstruction(hp3, hp3) And + (PPaiProp(hp3^.OptInfo)^.Regs[RegCounter].WState + = TmpState) Do +{$ifdef csdebug} + begin + hp5 := new(pai_asm_comment,init(strpnew('WState for '+att_reg2str[Regcounter]+': '+ + tostr(PPaiProp(hp3^.OptInfo)^.Regs[RegCounter].WState)))); + InsertLLItem(AsmL, hp3, pai(hp3^.next), hp5); +{$endif csdebug} + PPaiProp(hp3^.OptInfo)^.Regs[RegCounter] := + PPaiProp(hp4^.OptInfo)^.Regs[RegCounter]; +{$ifdef csdebug} + end; +{$endif csdebug} +{$ifdef csdebug} + hp5 := new(pai_asm_comment,init(strpnew('stopping here...'))); + InsertLLItem(AsmL, hp3, pai(hp3^.next), hp5); +{$endif csdebug} + End; + End; + hp3 := New(Pai_Marker,Init(NoPropInfoEnd)); + InsertLLItem(AsmL, Pai(hp2^.Previous), hp2, hp3); + If hp1 <> nil Then + p := hp1; + Continue; + End + Else + If (PPaiProp(p^.OptInfo)^. + Regs[Reg32(Paicpu(p)^.oper[1].reg)].Typ = Con_Ref) And + (PPaiProp(p^.OptInfo)^.CanBeRemoved) Then + if (cnt > 0) then + begin + hp2 := p; + Cnt2 := 1; + While Cnt2 <= Cnt Do + Begin + If RegInInstruction(Paicpu(hp2)^.oper[1].reg, p) Then + PPaiProp(p^.OptInfo)^.CanBeRemoved := False; + Inc(Cnt2); + GetNextInstruction(p, p); + End; + Continue; + End + else + begin + { Fix for web bug 972 } + regCounter := Reg32(Paicpu(p)^.oper[1].reg); + cnt := PPaiProp(p^.optInfo)^.Regs[regCounter].nrOfMods; + hp3 := p; + for cnt2 := 1 to cnt do + if not(regModifiedByInstruction(regCounter,hp3) and + not(PPaiProp(hp3^.optInfo)^.canBeRemoved)) then + getNextInstruction(hp3,hp3) + else + break; + getLastInstruction(p,hp4); + RestoreRegContentsTo(regCounter, + PPaiProp(hp4^.optInfo)^.Regs[regCounter], + p,hp3); + end; + End; + End; + End; +{$ifdef replacereg} + top_Reg: + { try to replace the new reg with the old reg } + if not(PPaiProp(p^.optInfo)^.canBeRemoved) and + { only remove if we're not storing something in a regvar } + (paicpu(p)^.oper[1].reg in (usableregs+[R_EDI])) and + (paicpu(p)^.opcode = A_MOV) and + getLastInstruction(p,hp4) then + begin + case paicpu(p)^.oper[1].typ of + top_Reg: + { we only have to start replacing from the instruction after the mov, } + { but replacereg only starts with getnextinstruction(p,p) } + if ReplaceReg(asmL,paicpu(p)^.oper[0].reg, + paicpu(p)^.oper[1].reg,p, + PPaiProp(hp4^.optInfo)^.Regs[paicpu(p)^.oper[1].reg],false,hp1) then + begin + PPaiProp(p^.optInfo)^.canBeRemoved := true; + allocRegBetween(asmL,paicpu(p)^.oper[0].reg, + PPaiProp(p^.optInfo)^.regs[paicpu(p)^.oper[0].reg].startMod, + hp1); + end; + end + end; +{$endif replacereg} + top_symbol,Top_Const: + Begin + Case Paicpu(p)^.oper[1].typ Of + Top_Reg: + Begin + regCounter := Reg32(Paicpu(p)^.oper[1].reg); + If GetLastInstruction(p, hp1) Then + With PPaiProp(hp1^.OptInfo)^.Regs[regCounter] Do + If (Typ = Con_Const) And + (paicpu(startMod)^.opsize >= paicpu(p)^.opsize) and + opsequal(paicpu(StartMod)^.oper[0],paicpu(p)^.oper[0]) Then + begin + PPaiProp(p^.OptInfo)^.CanBeRemoved := True; + allocRegBetween(asmL,regCounter,startMod,p); + end; + End; +{$ifdef arithopt} + Top_Ref: + if (paicpu(p)^.oper[0].typ = top_const) and + getLastInstruction(p,hp1) and + findRegWithConst(hp1,paicpu(p)^.opsize,paicpu(p)^.oper[0].val,regCounter) then + begin + paicpu(p)^.loadreg(0,regCounter); + allocRegBetween(AsmL,reg32(regCounter), + PPaiProp(hp1^.optinfo)^.regs[regCounter].startMod,p); + end; +{$endif arithopt} + End; + End; + End; + End; + A_STD: If GetLastInstruction(p, hp1) And + (PPaiProp(hp1^.OptInfo)^.DirFlag = F_Set) Then + PPaiProp(Pai(p)^.OptInfo)^.CanBeRemoved := True; + End + End; + End; + GetNextInstruction(p, p); + End; +End; + +Procedure RemoveInstructs(AsmL: PAasmOutput; First, Last: Pai); +{ Removes the marked instructions and disposes the PPaiProps of the other } +{ instructions } +Var p, hp1: Pai; +begin + p := First; + While (p <> Last) Do + Begin + If (p^.typ = ait_marker) and + (pai_marker(p)^.kind in [noPropInfoStart,noPropInfoEnd]) then + begin + hp1 := pai(p^.next); + asmL^.remove(p); + dispose(p,done); + p := hp1 + end + else +{$ifndef noinstremove} + if assigned(p^.optInfo) and + PPaiProp(p^.optInfo)^.canBeRemoved then + begin +{$IfDef TP} + Dispose(PPaiProp(p^.OptInfo)); +{$EndIf} + hp1 := pai(p^.next); + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + End + Else +{$endif noinstremove} + Begin +{$IfDef TP} + if assigned(p^.optInfo) then + Dispose(PPaiProp(p^.OptInfo)); +{$EndIf TP} + p^.OptInfo := nil; + p := pai(p^.next);; + End; + End; +{$IfNDef TP} + FreeMem(PaiPropBlock, NrOfPaiObjs*(((SizeOf(TPaiProp)+3)div 4)*4)) +{$EndIf TP} +End; + +Procedure CSE(AsmL: PAasmOutput; First, Last: Pai); +Begin + DoCSE(AsmL, First, Last); + RemoveInstructs(AsmL, First, Last); +End; + +End. + +{ + $Log: not supported by cvs2svn $ + Revision 1.61 2000/06/18 18:13:12 peter + * removed unused var + + Revision 1.60 2000/06/03 09:41:37 jonas + * fixed web bug 972, test for the bug in tests/testopt/testcse3.pp + + Revision 1.59 2000/06/01 11:01:20 peter + * removed notes + + Revision 1.58 2000/04/29 16:57:44 jonas + * fixed incompatibility with range chcking code, -O2 and higher + now work correctly together with -Cr + + Revision 1.57 2000/04/10 12:45:57 jonas + * fixed a serious bug in the CSE which (I think) only showed with + -dnewoptimizations when using multi-dimensional arrays with + elements of a size different from 1, 2 or 4 (especially strings). + * made the DFA/CSE more robust (much less dependent on specifics of the + code generator) + + Revision 1.56 2000/03/25 19:05:47 jonas + * fixed some things for -Or. Make cycle now works with -OG2p3r if + you use -Aas. There still a bug in popt386.pas that causes a + problem with the binary writer, but I haven't found it yet + + Revision 1.55 2000/03/24 15:54:49 jonas + * fix for -dnewoptimizations and -Or (never remove stores to regvars) + but make cycle with -OG2p3r still fails :( + + Revision 1.54 2000/02/24 18:41:38 peter + * removed warnings/notes + + Revision 1.53 2000/02/19 13:50:29 jonas + * fixed bug in -dnewoptizations (showed itself only if -Or was + used as well I think) + + Revision 1.52 2000/02/17 07:46:49 jonas + * -dreplacereg no logner tries to optimize "movl %reg1,%reg1" (which are + always marked as CanBeRemoved) + + some comments in -dreplacereg code + * small fix which could cause crash when optimizer is compiler with -dTP + + Revision 1.51 2000/02/12 19:28:56 jonas + * fix for imul optimization in popt386 (exclude top_ref as first + argument) + * in csopt386: change "mov reg1,reg2; ; + mov reg2,reg1" to "" (-dnewopt...) + + Revision 1.50 2000/02/12 14:10:14 jonas + + change "mov reg1,reg2;imul x,reg2" to "imul x,reg1,reg2" in popt386 + (-dnewoptimizations) + * shl(d) and shr(d) are considered to have a hardcoded register if + they use cl as shift count (since you can't replace them with + another register) in csopt386 (also for -dnewoptimizations) + + Revision 1.49 2000/02/12 10:54:18 jonas + * fixed edi allocation in allocRegBetween + * fixed bug I introduced yesterday, added comment to prevent it from + happening again in the future + + Revision 1.48 2000/02/11 23:50:03 jonas + * fixed crashing bug under Dos with -dnewoptimizations (found it, + John!). Don't understand why it didn't crash under Linux :( + + Revision 1.47 2000/02/10 16:04:43 jonas + * fixed stupid typo! + + Revision 1.46 2000/02/10 15:07:41 jonas + * fixed small bug introduced with my previous fix + + Revision 1.45 2000/02/10 14:57:13 jonas + * fixed bug due to lack of support for top_symbol operands + + Revision 1.44 2000/02/09 13:22:51 peter + * log truncated + + Revision 1.43 2000/02/04 13:52:17 jonas + * better support for regvars (still needs a move of the call to the optimize + procedure to a place where resetusableregisters is not yet called to work) + * small regallocation fixes for -dnewoptimizations + + Revision 1.42 2000/01/28 15:15:31 jonas + * moved skipinstr from daopt386 to aasm + * fixed crashing bug with -dreplacereg in csopt386.pas + + Revision 1.41 2000/01/23 11:11:37 michael + + Fixes from Jonas. + + Revision 1.40 2000/01/22 16:10:06 jonas + + all code generator generated "mov reg1,reg2" instructions are now + attempted to be removed using the replacereg code + (-dnewoptimizations) + * small fixes to -dreplacereg code + + Revision 1.39 2000/01/13 13:07:05 jonas + * released -dalignreg + * some small fixes to -dnewOptimizations helper procedures + + Revision 1.38 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.37 2000/01/03 17:11:17 jonas + * fixed bug with -dreplacereg + + Revision 1.36 1999/12/05 16:48:43 jonas + * CSE of constant loading in regs works properly again + + if a constant is stored into memory using "mov const, ref" and + there is a reg that contains this const, it is changed into + "mov reg, ref" + + Revision 1.35 1999/12/02 11:26:41 peter + * newoptimizations define added + + Revision 1.34 1999/11/21 13:09:41 jonas + * fixed some missed optimizations because 8bit regs were not always + taken into account + + Revision 1.33 1999/11/20 11:37:03 jonas + * make cycle works with -dreplacereg (register renaming)! I have not + tested it yet together with -darithopt, but I don't expect problems + + Revision 1.32 1999/11/14 11:26:53 jonas + + basic register renaming (not yet working completely, between + -dreplacereg/-dreplaceregdebug) + + Revision 1.31 1999/11/06 16:21:57 jonas + + search optimial register to use in alignment code (compile with + -dalignreg, -dalignregdebug to see chosen register in + assembler code). Still needs support in ag386bin. + + Revision 1.30 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.29 1999/11/05 16:01:46 jonas + + first implementation of choosing least used register for alignment code + (not yet working, between ifdef alignreg) + + Revision 1.28 1999/10/11 11:11:31 jonas + * fixed bug which sometimes caused a crash when optimizing blocks of code with + assembler blocks (didn't notice before because of lack of zero page protection + under Win9x :( ) + + Revision 1.27 1999/10/01 13:51:40 jonas + * CSE now updates the RegAlloc's + + Revision 1.26 1999/09/30 14:43:13 jonas + * fixed small efficiency which caused some missed optimizations (saves 1 + assembler instruction on the whole compiler/RTL source tree! :) + + Revision 1.25 1999/09/27 23:44:50 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.24 1999/08/25 11:59:58 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/daopt386.pas b/befpc/compiler/daopt386.pas new file mode 100644 index 0000000..ccafd2d --- /dev/null +++ b/befpc/compiler/daopt386.pas @@ -0,0 +1,2441 @@ +{ + $Id: daopt386.pas,v 1.1.1.1 2001-07-23 17:15:55 memson Exp $ + Copyright (c) 1998-2000 by Jonas Maebe, member of the Freepascal + development team + + This unit contains the data flow analyzer and several helper procedures + and functions. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} + +{$ifDef TP} + {$UnDef JumpAnal} +{$Endif TP} + +Unit DAOpt386; + +{$ifdef newOptimizations} +{$define foropt} +{$define replacereg} +{$define arithopt} +{$define foldarithops} +{$endif newOptimizations} + +Interface + +Uses + GlobType, + CObjects,Aasm, + cpubase,cpuasm; + +Type + TRegArray = Array[R_EAX..R_BL] of TRegister; + TRegSet = Set of R_EAX..R_BL; + TRegInfo = Record + NewRegsEncountered, OldRegsEncountered: TRegSet; + RegsLoadedForRef: TRegSet; + New2OldReg: TRegArray; + End; + +{possible actions on an operand: read, write or modify (= read & write)} + TOpAction = (OpAct_Read, OpAct_Write, OpAct_Modify, OpAct_Unknown); + +{*********************** Procedures and Functions ************************} + +Procedure InsertLLItem(AsmL: PAasmOutput; prev, foll, new_one: PLinkedList_Item); + +Function Reg32(Reg: TRegister): TRegister; +Function RefsEquivalent(Const R1, R2: TReference; Var RegInfo: TRegInfo; OpAct: TOpAction): Boolean; +Function RefsEqual(Const R1, R2: TReference): Boolean; +Function IsGP32Reg(Reg: TRegister): Boolean; +Function RegInRef(Reg: TRegister; Const Ref: TReference): Boolean; +function RegReadByInstruction(reg: TRegister; hp: pai): boolean; +function RegModifiedByInstruction(Reg: TRegister; p1: Pai): Boolean; +function RegInInstruction(Reg: TRegister; p1: Pai): Boolean; +function RegInOp(Reg: TRegister; const o:toper): Boolean; + +Function GetNextInstruction(Current: Pai; Var Next: Pai): Boolean; +Function GetLastInstruction(Current: Pai; Var Last: Pai): Boolean; +Procedure SkipHead(var P: Pai); + +Procedure RemoveLastDeallocForFuncRes(asmL: PAasmOutput; p: pai); +Function regLoadedWithNewValue(reg: tregister; canDependOnPrevValue: boolean; + hp: pai): boolean; +Procedure UpdateUsedRegs(Var UsedRegs: TRegSet; p: Pai); +Procedure AllocRegBetween(AsmL: PAasmOutput; Reg: TRegister; p1, p2: Pai); + +Function RegsEquivalent(OldReg, NewReg: TRegister; Var RegInfo: TRegInfo; OpAct: TopAction): Boolean; +Function InstructionsEquivalent(p1, p2: Pai; Var RegInfo: TRegInfo): Boolean; +Function OpsEqual(const o1,o2:toper): Boolean; + +Function DFAPass1(AsmL: PAasmOutput; BlockStart: Pai): Pai; +Function DFAPass2( +{$ifdef statedebug} + AsmL: PAasmOutPut; +{$endif statedebug} + BlockStart, BlockEnd: Pai): Boolean; +Procedure ShutDownDFA; + +Function FindLabel(L: PasmLabel; Var hp: Pai): Boolean; + +{******************************* Constants *******************************} + +Const + +{Possible register content types} + con_Unknown = 0; + con_ref = 1; + con_const = 2; + +{********************************* Types *********************************} + +type +{the possible states of a flag} + TFlagContents = (F_Unknown, F_NotSet, F_Set); + + TContent = Packed Record + {start and end of block instructions that defines the + content of this register.} + StartMod: pai; + {starts at 0, gets increased everytime the register is written to} + WState: Byte; + {starts at 0, gets increased everytime the register is read from} + RState: Byte; + {how many instructions starting with StarMod does the block consist of} + NrOfMods: Byte; + {the type of the content of the register: unknown, memory, constant} + Typ: Byte; + End; + +{Contents of the integer registers} + TRegContent = Array[R_EAX..R_EDI] Of TContent; + +{contents of the FPU registers} + TRegFPUContent = Array[R_ST..R_ST7] Of TContent; + +{$ifdef tempOpts} +{ linked list which allows searching/deleting based on value, no extra frills} + PSearchLinkedListItem = ^TSearchLinkedListItem; + TSearchLinkedListItem = object(TLinkedList_Item) + constructor init; + function equals(p: PSearchLinkedListItem): boolean; virtual; + end; + + PSearchDoubleIntItem = ^TSearchDoubleInttem; + TSearchDoubleIntItem = object(TLinkedList_Item) + constructor init(_int1,_int2: longint); + function equals(p: PSearchLinkedListItem): boolean; virtual; + private + int1, int2: longint; + end; + + PSearchLinkedList = ^TSearchLinkedList; + TSearchLinkedList = object(TLinkedList) + function searchByValue(p: PSearchLinkedListItem): boolean; + procedure removeByValue(p: PSearchLinkedListItem); + end; +{$endif tempOpts} + +{information record with the contents of every register. Every Pai object + gets one of these assigned: a pointer to it is stored in the OptInfo field} + TPaiProp = Record + Regs: TRegContent; +{ FPURegs: TRegFPUContent;} {currently not yet used} + { allocated Registers } + UsedRegs: TRegSet; + { status of the direction flag } + DirFlag: TFlagContents; +{$ifdef tempOpts} + { currently used temps } + tempAllocs: PSearchLinkedList; +{$endif tempOpts} + { can this instruction be removed? } + CanBeRemoved: Boolean; + End; + + PPaiProp = ^TPaiProp; + +{$IfNDef TP} + TPaiPropBlock = Array[1..250000] Of TPaiProp; + PPaiPropBlock = ^TPaiPropBlock; +{$EndIf TP} + + TInstrSinceLastMod = Array[R_EAX..R_EDI] Of Byte; + + TLabelTableItem = Record + PaiObj: Pai; +{$IfDef JumpAnal} + InstrNr: Longint; + RefsFound: Word; + JmpsProcessed: Word +{$EndIf JumpAnal} + End; +{$IfDef tp} + TLabelTable = Array[0..10000] Of TLabelTableItem; +{$Else tp} + TLabelTable = Array[0..2500000] Of TLabelTableItem; +{$Endif tp} + PLabelTable = ^TLabelTable; + +{******************************* Variables *******************************} + +Var +{the amount of PaiObjects in the current assembler list} + NrOfPaiObjs: Longint; + +{$IfNDef TP} +{Array which holds all TPaiProps} + PaiPropBlock: PPaiPropBlock; +{$EndIf TP} + + LoLab, HiLab, LabDif: Longint; + + LTable: PLabelTable; + +{*********************** End of Interface section ************************} + + +Implementation + +Uses + globals, systems, strings, verbose, hcodegen, symconst, tgeni386; + +Type + TRefCompare = function(const r1, r2: TReference): Boolean; + +Var + {How many instructions are between the current instruction and the last one + that modified the register} + NrOfInstrSinceLastMod: TInstrSinceLastMod; + +{$ifdef tempOpts} + constructor TSearchLinkedListItem.init; + begin + end; + + function TSearchLinkedListItem.equals(p: PSearchLinkedListItem): boolean; + begin + equals := false; + end; + + constructor TSearchDoubleIntItem.init(_int1,_int2: longint); + begin + int1 := _int1; + int2 := _int2; + end; + + function TSearchDoubleIntItem.equals(p: PSearchLinkedListItem): boolean; + begin + equals := (TSearchDoubleIntItem(p).int1 = int1) and + (TSearchDoubleIntItem(p).int2 = int2); + end; + + function TSearchLinkedList.searchByValue(p: PSearchLinkedListItem): boolean; + var temp: PSearchLinkedListItem; + begin + temp := first; + while (temp <> last^.next) and + not(temp^.equals(p)) do + temp := temp^.next; + searchByValue := temp <> last^.next; + end; + + procedure TSearchLinkedList.removeByValue(p: PSearchLinkedListItem); + begin + temp := first; + while (temp <> last^.next) and + not(temp^.equals(p)) do + temp := temp^.next; + if temp <> last^.next then + begin + remove(temp); + dispose(temp,done); + end; + end; + +Procedure updateTempAllocs(Var UsedRegs: TRegSet; p: Pai); +{updates UsedRegs with the RegAlloc Information coming after P} +Begin + Repeat + While Assigned(p) And + ((p^.typ in (SkipInstr - [ait_RegAlloc])) or + ((p^.typ = ait_label) And + Not(Pai_Label(p)^.l^.is_used))) Do + p := Pai(p^.next); + While Assigned(p) And + (p^.typ=ait_RegAlloc) Do + Begin + if pairegalloc(p)^.allocation then + UsedRegs := UsedRegs + [PaiRegAlloc(p)^.Reg] + else + UsedRegs := UsedRegs - [PaiRegAlloc(p)^.Reg]; + p := pai(p^.next); + End; + Until Not(Assigned(p)) Or + (Not(p^.typ in SkipInstr) And + Not((p^.typ = ait_label) And + Not(Pai_Label(p)^.l^.is_used))); +End; + +{$endif tempOpts} + +{************************ Create the Label table ************************} + +Function FindLoHiLabels(Var LowLabel, HighLabel, LabelDif: Longint; BlockStart: Pai): Pai; +{Walks through the paasmlist to find the lowest and highest label number} +Var LabelFound: Boolean; + P, lastP: Pai; +Begin + LabelFound := False; + LowLabel := MaxLongint; + HighLabel := 0; + P := BlockStart; + lastP := p; + While Assigned(P) Do + Begin + If (Pai(p)^.typ = ait_label) Then + If (Pai_Label(p)^.l^.is_used) + Then + Begin + LabelFound := True; + If (Pai_Label(p)^.l^.labelnr < LowLabel) Then + LowLabel := Pai_Label(p)^.l^.labelnr; + If (Pai_Label(p)^.l^.labelnr > HighLabel) Then + HighLabel := Pai_Label(p)^.l^.labelnr; + End; + lastP := p; + GetNextInstruction(p, p); + End; + if (lastP^.typ = ait_marker) and + (pai_marker(lastP)^.kind = asmBlockStart) then + FindLoHiLabels := lastP + else FindLoHiLabels := nil; + If LabelFound + Then LabelDif := HighLabel+1-LowLabel + Else LabelDif := 0; +End; + +Function FindRegAlloc(Reg: TRegister; StartPai: Pai; alloc: boolean): Boolean; +{ Returns true if a ait_alloc object for Reg is found in the block of Pai's } +{ starting with StartPai and ending with the next "real" instruction } +Begin + FindRegAlloc := false; + Repeat + While Assigned(StartPai) And + ((StartPai^.typ in (SkipInstr - [ait_regAlloc])) Or + ((StartPai^.typ = ait_label) and + Not(Pai_Label(StartPai)^.l^.Is_Used))) Do + StartPai := Pai(StartPai^.Next); + If Assigned(StartPai) And + (StartPai^.typ = ait_regAlloc) and (PairegAlloc(StartPai)^.allocation = alloc) Then + Begin + if PairegAlloc(StartPai)^.Reg = Reg then + begin + FindRegAlloc:=true; + break; + end; + StartPai := Pai(StartPai^.Next); + End + else + break; + Until false; +End; + +Procedure RemoveLastDeallocForFuncRes(asmL: PAasmOutput; p: pai); + + Procedure DoRemoveLastDeallocForFuncRes(asmL: PAasmOutput; reg: TRegister); + var + hp2: pai; + begin + hp2 := p; + repeat + hp2 := pai(hp2^.previous); + if assigned(hp2) and + (hp2^.typ = ait_regalloc) and + not(pairegalloc(hp2)^.allocation) and + (pairegalloc(hp2)^.reg = reg) then + begin + asml^.remove(hp2); + dispose(hp2,done); + break; + end; + until not(assigned(hp2)) or + regInInstruction(reg,hp2); + end; + +begin + if assigned(procinfo^.returntype.def) then + case procinfo^.returntype.def^.deftype of + arraydef,recorddef,pointerdef, + stringdef,enumdef,procdef,objectdef,errordef, + filedef,setdef,procvardef, + classrefdef,forwarddef: + DoRemoveLastDeallocForFuncRes(asmL,R_EAX); + orddef: + if procinfo^.returntype.def^.size <> 0 then + begin + DoRemoveLastDeallocForFuncRes(asmL,R_EAX); + { for int64/qword } + if procinfo^.returntype.def^.size = 8 then + DoRemoveLastDeallocForFuncRes(asmL,R_EDX); + end; + end; +end; + +procedure getNoDeallocRegs(var regs: TRegSet); +var regCounter: TRegister; +begin + regs := []; + if assigned(procinfo^.returntype.def) then + case procinfo^.returntype.def^.deftype of + arraydef,recorddef,pointerdef, + stringdef,enumdef,procdef,objectdef,errordef, + filedef,setdef,procvardef, + classrefdef,forwarddef: + regs := [R_EAX]; + orddef: + if procinfo^.returntype.def^.size <> 0 then + begin + regs := [R_EAX]; + { for int64/qword } + if procinfo^.returntype.def^.size = 8 then + regs := regs + [R_EDX]; + end; + end; + for regCounter := R_EAX to R_EBX do + if not(regCounter in usableregs) then + regs := regs + [regCounter]; +end; + +Procedure AddRegDeallocFor(asmL: paasmOutput; reg: TRegister; p: pai); +var hp1: pai; + funcResRegs: TRegset; + funcResReg: boolean; +begin + if not(reg in usableregs) then + exit; + getNoDeallocRegs(funcResRegs); + funcResRegs := funcResRegs - usableregs; + funcResReg := reg in funcResRegs; + hp1 := p; + while not(funcResReg and + (p^.typ = ait_instruction) and + (paicpu(p)^.opcode = A_JMP) and + (pasmlabel(paicpu(p)^.oper[0].sym) = aktexit2label)) and + getLastInstruction(p, p) And + not(regInInstruction(reg, p)) Do + hp1 := p; + { don't insert a dealloc for registers which contain the function result } + { if they are followed by a jump to the exit label (for exit(...)) } + if not(funcResReg) or + not((hp1^.typ = ait_instruction) and + (paicpu(hp1)^.opcode = A_JMP) and + (pasmlabel(paicpu(hp1)^.oper[0].sym) = aktexit2label)) then + begin + p := new(paiRegAlloc, deAlloc(reg)); + insertLLItem(AsmL, hp1^.previous, hp1, p); + end; +end; + +Procedure BuildLabelTableAndFixRegAlloc(asmL: PAasmOutput; Var LabelTable: PLabelTable; LowLabel: Longint; + Var LabelDif: Longint; BlockStart, BlockEnd: Pai); +{Builds a table with the locations of the labels in the paasmoutput. + Also fixes some RegDeallocs like "# %eax released; push (%eax)"} +Var p, hp1, hp2, lastP: Pai; + regCounter: TRegister; + UsedRegs, noDeallocRegs: TRegSet; +Begin + UsedRegs := []; + If (LabelDif <> 0) Then + Begin +{$IfDef TP} + If (MaxAvail >= LabelDif*SizeOf(Pai)) + Then + Begin +{$EndIf TP} + GetMem(LabelTable, LabelDif*SizeOf(TLabelTableItem)); + FillChar(LabelTable^, LabelDif*SizeOf(TLabelTableItem), 0); +{$IfDef TP} + End + Else LabelDif := 0; +{$EndIf TP} + End; + p := BlockStart; + lastP := p; + While (P <> BlockEnd) Do + Begin + Case p^.typ Of + ait_Label: + If Pai_Label(p)^.l^.is_used Then + LabelTable^[Pai_Label(p)^.l^.labelnr-LowLabel].PaiObj := p; + ait_regAlloc: + { ESI and EDI are (de)allocated manually, don't mess with them } + if not(paiRegAlloc(p)^.Reg in [R_EDI,R_ESI]) then + begin + if PairegAlloc(p)^.Allocation then + Begin + If Not(paiRegAlloc(p)^.Reg in UsedRegs) Then + UsedRegs := UsedRegs + [paiRegAlloc(p)^.Reg] + Else + addRegDeallocFor(asmL, paiRegAlloc(p)^.reg, p); + End + else + begin + UsedRegs := UsedRegs - [paiRegAlloc(p)^.Reg]; + hp1 := p; + hp2 := nil; + While Not(FindRegAlloc(paiRegAlloc(p)^.Reg, Pai(hp1^.Next),true)) And + GetNextInstruction(hp1, hp1) And + RegInInstruction(paiRegAlloc(p)^.Reg, hp1) Do + hp2 := hp1; + If hp2 <> nil Then + Begin + hp1 := Pai(p^.previous); + AsmL^.Remove(p); + InsertLLItem(AsmL, hp2, Pai(hp2^.Next), p); + p := hp1; + end; + end; + end; + end; + repeat + lastP := p; + P := Pai(P^.Next); + until not(Assigned(p)) or + not(p^.typ in (SkipInstr - [ait_regalloc])); + End; + { don't add deallocation for function result variable or for regvars} + getNoDeallocRegs(noDeallocRegs); + usedRegs := usedRegs - noDeallocRegs; + for regCounter := R_EAX to R_EDI do + if regCounter in usedRegs then + addRegDeallocFor(asmL,regCounter,lastP); +End; + +{************************ Search the Label table ************************} + +Function FindLabel(L: PasmLabel; Var hp: Pai): Boolean; + +{searches for the specified label starting from hp as long as the + encountered instructions are labels, to be able to optimize constructs like + + jne l2 jmp l2 + jmp l3 and l1: + l1: l2: + l2:} + +Var TempP: Pai; + +Begin + TempP := hp; + While Assigned(TempP) and + (TempP^.typ In SkipInstr + [ait_label,ait_align]) Do + If (TempP^.typ <> ait_Label) Or + (pai_label(TempP)^.l <> L) + Then GetNextInstruction(TempP, TempP) + Else + Begin + hp := TempP; + FindLabel := True; + exit + End; + FindLabel := False; +End; + +{************************ Some general functions ************************} + +Function TCh2Reg(Ch: TInsChange): TRegister; +{converts a TChange variable to a TRegister} +Begin + If (Ch <= Ch_REDI) Then + TCh2Reg := TRegister(Byte(Ch)) + Else + If (Ch <= Ch_WEDI) Then + TCh2Reg := TRegister(Byte(Ch) - Byte(Ch_REDI)) + Else + If (Ch <= Ch_RWEDI) Then + TCh2Reg := TRegister(Byte(Ch) - Byte(Ch_WEDI)) + Else + If (Ch <= Ch_MEDI) Then + TCh2Reg := TRegister(Byte(Ch) - Byte(Ch_RWEDI)) + Else InternalError($db) +End; + +Function Reg32(Reg: TRegister): TRegister; +{Returns the 32 bit component of Reg if it exists, otherwise Reg is returned} +Begin + Reg32 := Reg; + If (Reg >= R_AX) + Then + If (Reg <= R_DI) + Then Reg32 := Reg16ToReg32(Reg) + Else + If (Reg <= R_BL) + Then Reg32 := Reg8toReg32(Reg); +End; + +{ inserts new_one between prev and foll } +Procedure InsertLLItem(AsmL: PAasmOutput; prev, foll, new_one: PLinkedList_Item); +Begin + If Assigned(prev) Then + If Assigned(foll) Then + Begin + If Assigned(new_one) Then + Begin + new_one^.previous := prev; + new_one^.next := foll; + prev^.next := new_one; + foll^.previous := new_one; + Pai(new_one)^.fileinfo := Pai(foll)^.fileinfo; + End; + End + Else AsmL^.Concat(new_one) + Else If Assigned(Foll) Then AsmL^.Insert(new_one) +End; + +{********************* Compare parts of Pai objects *********************} + +Function RegsSameSize(Reg1, Reg2: TRegister): Boolean; +{returns true if Reg1 and Reg2 are of the same size (so if they're both + 8bit, 16bit or 32bit)} +Begin + If (Reg1 <= R_EDI) + Then RegsSameSize := (Reg2 <= R_EDI) + Else + If (Reg1 <= R_DI) + Then RegsSameSize := (Reg2 in [R_AX..R_DI]) + Else + If (Reg1 <= R_BL) + Then RegsSameSize := (Reg2 in [R_AL..R_BL]) + Else RegsSameSize := False +End; + +Procedure AddReg2RegInfo(OldReg, NewReg: TRegister; Var RegInfo: TRegInfo); +{updates the ???RegsEncountered and ???2???Reg fields of RegInfo. Assumes that + OldReg and NewReg have the same size (has to be chcked in advance with + RegsSameSize) and that neither equals R_NO} +Begin + With RegInfo Do + Begin + NewRegsEncountered := NewRegsEncountered + [NewReg]; + OldRegsEncountered := OldRegsEncountered + [OldReg]; + New2OldReg[NewReg] := OldReg; + Case OldReg Of + R_EAX..R_EDI: + Begin + NewRegsEncountered := NewRegsEncountered + [Reg32toReg16(NewReg)]; + OldRegsEncountered := OldRegsEncountered + [Reg32toReg16(OldReg)]; + New2OldReg[Reg32toReg16(NewReg)] := Reg32toReg16(OldReg); + If (NewReg in [R_EAX..R_EBX]) And + (OldReg in [R_EAX..R_EBX]) Then + Begin + NewRegsEncountered := NewRegsEncountered + [Reg32toReg8(NewReg)]; + OldRegsEncountered := OldRegsEncountered + [Reg32toReg8(OldReg)]; + New2OldReg[Reg32toReg8(NewReg)] := Reg32toReg8(OldReg); + End; + End; + R_AX..R_DI: + Begin + NewRegsEncountered := NewRegsEncountered + [Reg16toReg32(NewReg)]; + OldRegsEncountered := OldRegsEncountered + [Reg16toReg32(OldReg)]; + New2OldReg[Reg16toReg32(NewReg)] := Reg16toReg32(OldReg); + If (NewReg in [R_AX..R_BX]) And + (OldReg in [R_AX..R_BX]) Then + Begin + NewRegsEncountered := NewRegsEncountered + [Reg16toReg8(NewReg)]; + OldRegsEncountered := OldRegsEncountered + [Reg16toReg8(OldReg)]; + New2OldReg[Reg16toReg8(NewReg)] := Reg16toReg8(OldReg); + End; + End; + R_AL..R_BL: + Begin + NewRegsEncountered := NewRegsEncountered + [Reg8toReg32(NewReg)] + + [Reg8toReg16(NewReg)]; + OldRegsEncountered := OldRegsEncountered + [Reg8toReg32(OldReg)] + + [Reg8toReg16(OldReg)]; + New2OldReg[Reg8toReg32(NewReg)] := Reg8toReg32(OldReg); + End; + End; + End; +End; + +Procedure AddOp2RegInfo(const o:Toper; Var RegInfo: TRegInfo); +Begin + Case o.typ Of + Top_Reg: + If (o.reg <> R_NO) Then + AddReg2RegInfo(o.reg, o.reg, RegInfo); + Top_Ref: + Begin + If o.ref^.base <> R_NO Then + AddReg2RegInfo(o.ref^.base, o.ref^.base, RegInfo); + If o.ref^.index <> R_NO Then + AddReg2RegInfo(o.ref^.index, o.ref^.index, RegInfo); + End; + End; +End; + + +Function RegsEquivalent(OldReg, NewReg: TRegister; Var RegInfo: TRegInfo; OPAct: TOpAction): Boolean; +Begin + If Not((OldReg = R_NO) Or (NewReg = R_NO)) Then + If RegsSameSize(OldReg, NewReg) Then + With RegInfo Do +{here we always check for the 32 bit component, because it is possible that + the 8 bit component has not been set, event though NewReg already has been + processed. This happens if it has been compared with a register that doesn't + have an 8 bit component (such as EDI). In that case the 8 bit component is + still set to R_NO and the comparison in the Else-part will fail} + If (Reg32(OldReg) in OldRegsEncountered) Then + If (Reg32(NewReg) in NewRegsEncountered) Then + RegsEquivalent := (OldReg = New2OldReg[NewReg]) + + { If we haven't encountered the new register yet, but we have encountered the + old one already, the new one can only be correct if it's being written to + (and consequently the old one is also being written to), otherwise + + movl -8(%ebp), %eax and movl -8(%ebp), %eax + movl (%eax), %eax movl (%edx), %edx + + are considered equivalent} + + Else + If (OpAct = OpAct_Write) Then + Begin + AddReg2RegInfo(OldReg, NewReg, RegInfo); + RegsEquivalent := True + End + Else Regsequivalent := False + Else + If Not(Reg32(NewReg) in NewRegsEncountered) Then + Begin + AddReg2RegInfo(OldReg, NewReg, RegInfo); + RegsEquivalent := True + End + Else RegsEquivalent := False + Else RegsEquivalent := False + Else RegsEquivalent := OldReg = NewReg +End; + +Function RefsEquivalent(Const R1, R2: TReference; var RegInfo: TRegInfo; OpAct: TOpAction): Boolean; +Begin + If R1.is_immediate Then + RefsEquivalent := R2.is_immediate and (R1.Offset = R2.Offset) + Else + RefsEquivalent := (R1.Offset+R1.OffsetFixup = R2.Offset+R2.OffsetFixup) And + RegsEquivalent(R1.Base, R2.Base, RegInfo, OpAct) And + RegsEquivalent(R1.Index, R2.Index, RegInfo, OpAct) And + (R1.Segment = R2.Segment) And (R1.ScaleFactor = R2.ScaleFactor) And + (R1.Symbol = R2.Symbol); +End; + + +Function RefsEqual(Const R1, R2: TReference): Boolean; +Begin + If R1.is_immediate Then + RefsEqual := R2.is_immediate and (R1.Offset = R2.Offset) + Else + RefsEqual := (R1.Offset+R1.OffsetFixup = R2.Offset+R2.OffsetFixup) And + (R1.Segment = R2.Segment) And (R1.Base = R2.Base) And + (R1.Index = R2.Index) And (R1.ScaleFactor = R2.ScaleFactor) And + (R1.Symbol=R2.Symbol); +End; + +Function IsGP32Reg(Reg: TRegister): Boolean; +{Checks if the register is a 32 bit general purpose register} +Begin + If (Reg >= R_EAX) and (Reg <= R_EBX) + Then IsGP32Reg := True + Else IsGP32reg := False +End; + +Function RegInRef(Reg: TRegister; Const Ref: TReference): Boolean; +Begin {checks whether Ref contains a reference to Reg} + Reg := Reg32(Reg); + RegInRef := (Ref.Base = Reg) Or (Ref.Index = Reg) +End; + +function RegReadByInstruction(reg: TRegister; hp: pai): boolean; +var p: paicpu; + opCount: byte; +begin + RegReadByInstruction := false; + reg := reg32(reg); + p := paicpu(hp); + if hp^.typ <> ait_instruction then + exit; + case p^.opcode of + A_IMUL: + case p^.ops of + 1: regReadByInstruction := (reg = R_EAX) or reginOp(reg,p^.oper[0]); + 2,3: + regReadByInstruction := regInOp(reg,p^.oper[0]) or + regInOp(reg,p^.oper[1]); + end; + A_IDIV,A_DIV,A_MUL: + begin + regReadByInstruction := + regInOp(reg,p^.oper[0]) or (reg = R_EAX); + end; + else + begin + for opCount := 0 to 2 do + if (p^.oper[opCount].typ = top_ref) and + RegInRef(reg,p^.oper[opCount].ref^) then + begin + RegReadByInstruction := true; + exit + end; + for opCount := 1 to MaxCh do + case InsProp[p^.opcode].Ch[opCount] of + Ch_REAX..CH_REDI,CH_RWEAX..Ch_MEDI: + if reg = TCh2Reg(InsProp[p^.opcode].Ch[opCount]) then + begin + RegReadByInstruction := true; + exit + end; + Ch_RWOp1,Ch_ROp1{$ifdef arithopt},Ch_MOp1{$endif}: + if (p^.oper[0].typ = top_reg) and + (reg32(p^.oper[0].reg) = reg) then + begin + RegReadByInstruction := true; + exit + end; + Ch_RWOp2,Ch_ROp2{$ifdef arithopt},Ch_MOp2{$endif}: + if (p^.oper[1].typ = top_reg) and + (reg32(p^.oper[1].reg) = reg) then + begin + RegReadByInstruction := true; + exit + end; + Ch_RWOp3,Ch_ROp3{$ifdef arithopt},Ch_MOp3{$endif}: + if (p^.oper[2].typ = top_reg) and + (reg32(p^.oper[2].reg) = reg) then + begin + RegReadByInstruction := true; + exit + end; + end; + end; + end; +end; + +function regInInstruction(Reg: TRegister; p1: Pai): Boolean; +{ Checks if Reg is used by the instruction p1 } +{ Difference with "regReadBysinstruction() or regModifiedByInstruction()": } +{ this one ignores CH_ALL opcodes, while regModifiedByInstruction doesn't } +var p: paicpu; + opCount: byte; +begin + reg := reg32(reg); + regInInstruction := false; + p := paicpu(p1); + if p1^.typ <> ait_instruction then + exit; + case p^.opcode of + A_IMUL: + case p^.ops of + 1: regInInstruction := (reg = R_EAX) or reginOp(reg,p^.oper[0]); + 2,3: + regInInstruction := regInOp(reg,p^.oper[0]) or + regInOp(reg,p^.oper[1]) or regInOp(reg,p^.oper[2]); + end; + A_IDIV,A_DIV,A_MUL: + regInInstruction := + regInOp(reg,p^.oper[0]) or + (reg = R_EAX) or (reg = R_EDX) + else + begin + for opCount := 1 to MaxCh do + case InsProp[p^.opcode].Ch[opCount] of + CH_REAX..CH_MEDI: + if tch2reg(InsProp[p^.opcode].Ch[opCount]) = reg then + begin + regInInstruction := true; + exit; + end; + Ch_ROp1..Ch_MOp1: + if regInOp(reg,p^.oper[0]) then + begin + regInInstruction := true; + exit + end; + Ch_ROp2..Ch_MOp2: + if regInOp(reg,p^.oper[1]) then + begin + regInInstruction := true; + exit + end; + Ch_ROp3..Ch_MOp3: + if regInOp(reg,p^.oper[2]) then + begin + regInInstruction := true; + exit + end; + end; + end; + end; +end; + +Function RegInOp(Reg: TRegister; const o:toper): Boolean; +Begin + RegInOp := False; + reg := reg32(reg); + Case o.typ Of + top_reg: RegInOp := Reg = reg32(o.reg); + top_ref: RegInOp := (Reg = o.ref^.Base) Or + (Reg = o.ref^.Index); + End; +End; + +Function RegModifiedByInstruction(Reg: TRegister; p1: Pai): Boolean; +Var InstrProp: TInsProp; + TmpResult: Boolean; + Cnt: Byte; +Begin + TmpResult := False; + Reg := Reg32(Reg); + If (p1^.typ = ait_instruction) Then + Case paicpu(p1)^.opcode of + A_IMUL: + With paicpu(p1)^ Do + TmpResult := + ((ops = 1) and (reg in [R_EAX,R_EDX])) or + ((ops = 2) and (Reg32(oper[1].reg) = reg)) or + ((ops = 3) and (Reg32(oper[2].reg) = reg)); + A_DIV, A_IDIV, A_MUL: + With paicpu(p1)^ Do + TmpResult := + (Reg = R_EAX) or + (Reg = R_EDX); + Else + Begin + Cnt := 1; + InstrProp := InsProp[paicpu(p1)^.OpCode]; + While (Cnt <= MaxCh) And + (InstrProp.Ch[Cnt] <> Ch_None) And + Not(TmpResult) Do + Begin + Case InstrProp.Ch[Cnt] Of + Ch_WEAX..Ch_MEDI: + TmpResult := Reg = TCh2Reg(InstrProp.Ch[Cnt]); + Ch_RWOp1,Ch_WOp1{$ifdef arithopt},Ch_Mop1{$endif arithopt}: + TmpResult := (paicpu(p1)^.oper[0].typ = top_reg) and + (Reg32(paicpu(p1)^.oper[0].reg) = reg); + Ch_RWOp2,Ch_WOp2{$ifdef arithopt},Ch_Mop2{$endif arithopt}: + TmpResult := (paicpu(p1)^.oper[1].typ = top_reg) and + (Reg32(paicpu(p1)^.oper[1].reg) = reg); + Ch_RWOp3,Ch_WOp3{$ifdef arithopt},Ch_Mop3{$endif arithopt}: + TmpResult := (paicpu(p1)^.oper[2].typ = top_reg) and + (Reg32(paicpu(p1)^.oper[2].reg) = reg); + Ch_FPU: TmpResult := Reg in [R_ST..R_ST7,R_MM0..R_MM7]; + Ch_ALL: TmpResult := true; + End; + Inc(Cnt) + End + End + End; + RegModifiedByInstruction := TmpResult +End; + +{********************* GetNext and GetLastInstruction *********************} +Function GetNextInstruction(Current: Pai; Var Next: Pai): Boolean; +{ skips ait_regalloc, ait_regdealloc and ait_stab* objects and puts the } +{ next pai object in Next. Returns false if there isn't any } +Begin + Repeat + If (Current^.typ = ait_marker) And + (Pai_Marker(Current)^.Kind = AsmBlockStart) Then + Begin + GetNextInstruction := False; + Next := Nil; + Exit + End; + Current := Pai(Current^.Next); + While Assigned(Current) And + ((Current^.typ In SkipInstr) or + ((Current^.typ = ait_label) And + Not(Pai_Label(Current)^.l^.is_used))) Do + Current := Pai(Current^.Next); + If Assigned(Current) And + (Current^.typ = ait_Marker) And + (Pai_Marker(Current)^.Kind = NoPropInfoStart) Then + Begin + While Assigned(Current) And + ((Current^.typ <> ait_Marker) Or + (Pai_Marker(Current)^.Kind <> NoPropInfoEnd)) Do + Current := Pai(Current^.Next); + End; + Until Not(Assigned(Current)) Or + (Current^.typ <> ait_Marker) Or + (Pai_Marker(Current)^.Kind <> NoPropInfoEnd); + Next := Current; + If Assigned(Current) And + Not((Current^.typ In SkipInstr) or + ((Current^.typ = ait_label) And + Not(Pai_Label(Current)^.l^.is_used))) + Then + GetNextInstruction := + not((current^.typ = ait_marker) and + (pai_marker(current)^.kind = asmBlockStart)) + Else + Begin + GetNextInstruction := False; + Next := nil; + End; +End; + +Function GetLastInstruction(Current: Pai; Var Last: Pai): Boolean; +{skips the ait-types in SkipInstr puts the previous pai object in + Last. Returns false if there isn't any} +Begin + Repeat + Current := Pai(Current^.previous); + While Assigned(Current) And + (((Current^.typ = ait_Marker) And + Not(Pai_Marker(Current)^.Kind in [AsmBlockEnd,NoPropInfoEnd])) or + (Current^.typ In SkipInstr) or + ((Current^.typ = ait_label) And + Not(Pai_Label(Current)^.l^.is_used))) Do + Current := Pai(Current^.previous); + If Assigned(Current) And + (Current^.typ = ait_Marker) And + (Pai_Marker(Current)^.Kind = NoPropInfoEnd) Then + Begin + While Assigned(Current) And + ((Current^.typ <> ait_Marker) Or + (Pai_Marker(Current)^.Kind <> NoPropInfoStart)) Do + Current := Pai(Current^.previous); + End; + Until Not(Assigned(Current)) Or + (Current^.typ <> ait_Marker) Or + (Pai_Marker(Current)^.Kind <> NoPropInfoStart); + If Not(Assigned(Current)) or + (Current^.typ In SkipInstr) or + ((Current^.typ = ait_label) And + Not(Pai_Label(Current)^.l^.is_used)) or + ((Current^.typ = ait_Marker) And + (Pai_Marker(Current)^.Kind = AsmBlockEnd)) + Then + Begin + Last := nil; + GetLastInstruction := False + End + Else + Begin + Last := Current; + GetLastInstruction := True; + End; +End; + +Procedure SkipHead(var P: Pai); +Var OldP: Pai; +Begin + Repeat + OldP := P; + If (P^.typ in SkipInstr) Or + ((P^.typ = ait_marker) And + (Pai_Marker(P)^.Kind = AsmBlockEnd)) Then + GetNextInstruction(P, P) + Else If ((P^.Typ = Ait_Marker) And + (Pai_Marker(P)^.Kind = NoPropInfoStart)) Then + {a marker of the NoPropInfoStart can't be the first instruction of a + paasmoutput list} + GetNextInstruction(Pai(P^.Previous),P); +{ If (P^.Typ = Ait_Marker) And + (Pai_Marker(P)^.Kind = AsmBlockStart) Then + Begin + P := Pai(P^.Next); + While (P^.typ <> Ait_Marker) Or + (Pai_Marker(P)^.Kind <> AsmBlockEnd) Do + P := Pai(P^.Next) + End;} + Until P = OldP +End; +{******************* The Data Flow Analyzer functions ********************} + +function regLoadedWithNewValue(reg: tregister; canDependOnPrevValue: boolean; + hp: pai): boolean; +{ assumes reg is a 32bit register } +var p: paicpu; +begin + p := paicpu(hp); + regLoadedWithNewValue := + assigned(hp) and + (hp^.typ = ait_instruction) and + (((p^.opcode = A_MOV) or + (p^.opcode = A_MOVZX) or + (p^.opcode = A_MOVSX) or + (p^.opcode = A_LEA)) and + (p^.oper[1].typ = top_reg) and + (Reg32(p^.oper[1].reg) = reg) and + (canDependOnPrevValue or + (p^.oper[0].typ <> top_ref) or + not regInRef(reg,p^.oper[0].ref^)) or + ((p^.opcode = A_POP) and + (Reg32(p^.oper[0].reg) = reg))); +end; + +Procedure UpdateUsedRegs(Var UsedRegs: TRegSet; p: Pai); +{updates UsedRegs with the RegAlloc Information coming after P} +Begin + Repeat + While Assigned(p) And + ((p^.typ in (SkipInstr - [ait_RegAlloc])) or + ((p^.typ = ait_label) And + Not(Pai_Label(p)^.l^.is_used))) Do + p := Pai(p^.next); + While Assigned(p) And + (p^.typ=ait_RegAlloc) Do + Begin + if pairegalloc(p)^.allocation then + UsedRegs := UsedRegs + [PaiRegAlloc(p)^.Reg] + else + UsedRegs := UsedRegs - [PaiRegAlloc(p)^.Reg]; + p := pai(p^.next); + End; + Until Not(Assigned(p)) Or + (Not(p^.typ in SkipInstr) And + Not((p^.typ = ait_label) And + Not(Pai_Label(p)^.l^.is_used))); +End; + +Procedure AllocRegBetween(AsmL: PAasmOutput; Reg: TRegister; p1, p2: Pai); +{ allocates register Reg between (and including) instructions p1 and p2 } +{ the type of p1 and p2 must not be in SkipInstr } +var + hp: pai; + lastRemovedWasDealloc: boolean; +Begin + If not(reg in usableregs+[R_EDI,R_ESI]) or + not(assigned(p1)) Then + { this happens with registers which are loaded implicitely, outside the } + { current block (e.g. esi with self) } + exit; + lastRemovedWasDealloc := false; +{$ifdef allocregdebug} + hp := new(pai_asm_comment,init(strpnew('allocating '+att_reg2str[reg]+ + ' from here...'))); + insertllitem(asml,p1^.previous,p1,hp); + hp := new(pai_asm_comment,init(strpnew('allocated '+att_reg2str[reg]+ + ' till here...'))); + insertllitem(asml,p2,p1^.next,hp); +{$endif allocregdebug} + if Assigned(p1^.optInfo) and + not (reg in PPaiProp(p1^.OptInfo)^.UsedRegs) then + begin + hp := new(paiRegalloc,alloc(reg)); + insertLLItem(asmL,p1^.previous,p1,hp); + end; + Repeat + If Assigned(p1^.OptInfo) Then + Include(PPaiProp(p1^.OptInfo)^.UsedRegs,Reg); + p1 := Pai(p1^.next); + Repeat + While assigned(p1) and + (p1^.typ in (SkipInstr-[ait_regalloc])) Do + p1 := Pai(p1^.next); +{ remove all allocation/deallocation info about the register in between } + If assigned(p1) and + (p1^.typ = ait_regalloc) Then + If (PaiRegAlloc(p1)^.Reg = Reg) Then + Begin + lastRemovedWasDealloc := not PaiRegAlloc(p1)^.allocation; + hp := Pai(p1^.Next); + AsmL^.Remove(p1); + Dispose(p1, Done); + p1 := hp; + End + Else p1 := Pai(p1^.next); + Until not(assigned(p1)) or + Not(p1^.typ in SkipInstr); + Until not(assigned(p1)) or + (p1 = p2); + if assigned(p1) and lastRemovedWasDealloc then + begin + hp := new(paiRegalloc,dealloc(reg)); + insertLLItem(asmL,p1,p1^.next,hp); + end; +End; + + +Procedure IncState(Var S: Byte); +{Increases S by 1, wraps around at $ffff to 0 (so we won't get overflow + errors} +Begin + If (s <> $ff) + Then Inc(s) + Else s := 0 +End; + +Function sequenceDependsonReg(Const Content: TContent; seqReg, Reg: TRegister): Boolean; +{ Content is the sequence of instructions that describes the contents of } +{ seqReg. Reg is being overwritten by the current instruction. If the } +{ content of seqReg depends on reg (ie. because of a } +{ "movl (seqreg,reg), seqReg" instruction), this function returns true } +Var p: Pai; + Counter: Byte; + TmpResult: Boolean; + RegsChecked: TRegSet; +Begin + RegsChecked := []; + p := Content.StartMod; + TmpResult := False; + Counter := 1; + While Not(TmpResult) And + (Counter <= Content.NrOfMods) Do + Begin + If (p^.typ = ait_instruction) and + ((Paicpu(p)^.opcode = A_MOV) or + (Paicpu(p)^.opcode = A_MOVZX) or + (Paicpu(p)^.opcode = A_MOVSX) or + (paicpu(p)^.opcode = A_LEA)) and + (Paicpu(p)^.oper[0].typ = top_ref) Then + With Paicpu(p)^.oper[0].ref^ Do + If ((Base = procinfo^.FramePointer) or + (assigned(symbol) and (base = R_NO))) And + (Index = R_NO) Then + Begin + RegsChecked := RegsChecked + [Reg32(Paicpu(p)^.oper[1].reg)]; + If Reg = Reg32(Paicpu(p)^.oper[1].reg) Then + Break; + End + Else + tmpResult := + regReadByInstruction(reg,p) and + regModifiedByInstruction(seqReg,p) + Else + tmpResult := + regReadByInstruction(reg,p) and + regModifiedByInstruction(seqReg,p); + Inc(Counter); + GetNextInstruction(p,p) + End; + sequenceDependsonReg := TmpResult +End; + +Procedure DestroyReg(p1: PPaiProp; Reg: TRegister; doIncState:Boolean); +{Destroys the contents of the register Reg in the PPaiProp p1, as well as the + contents of registers are loaded with a memory location based on Reg. + doIncState is false when this register has to be destroyed not because + it's contents are directly modified/overwritten, but because of an indirect + action (ie. this register holds the contents of a variable and the value + of the variable in memory is changed } +Var TmpWState, TmpRState: Byte; + Counter: TRegister; +Begin + Reg := Reg32(Reg); + { the following happens for fpu registers } + if (reg < low(NrOfInstrSinceLastMod)) or + (reg > high(NrOfInstrSinceLastMod)) then + exit; + NrOfInstrSinceLastMod[Reg] := 0; + If (Reg >= R_EAX) And (Reg <= R_EDI) + Then + Begin + With p1^.Regs[Reg] Do + Begin + if doIncState then + IncState(WState); + TmpWState := WState; + TmpRState := RState; + FillChar(p1^.Regs[Reg], SizeOf(TContent), 0); + WState := TmpWState; + RState := TmpRState; + End; + For counter := R_EAX to R_EDI Do + With p1^.Regs[counter] Do + If (Typ = Con_Ref) And + sequenceDependsOnReg(p1^.Regs[counter],counter,reg) Then + Begin + if doIncState then + IncState(WState); + TmpWState := WState; + TmpRState := RState; + FillChar(p1^.Regs[Counter], SizeOf(TContent), 0); + WState := TmpWState; + RState := TmpRState; + End; + End; +End; + +{Procedure AddRegsToSet(p: Pai; Var RegSet: TRegSet); +Begin + If (p^.typ = ait_instruction) Then + Begin + Case Paicpu(p)^.oper[0].typ Of + top_reg: + If Not(Paicpu(p)^.oper[0].reg in [R_NO,R_ESP,procinfo^.FramePointer]) Then + RegSet := RegSet + [Paicpu(p)^.oper[0].reg]; + top_ref: + With TReference(Paicpu(p)^.oper[0]^) Do + Begin + If Not(Base in [procinfo^.FramePointer,R_NO,R_ESP]) + Then RegSet := RegSet + [Base]; + If Not(Index in [procinfo^.FramePointer,R_NO,R_ESP]) + Then RegSet := RegSet + [Index]; + End; + End; + Case Paicpu(p)^.oper[1].typ Of + top_reg: + If Not(Paicpu(p)^.oper[1].reg in [R_NO,R_ESP,procinfo^.FramePointer]) Then + If RegSet := RegSet + [TRegister(TwoWords(Paicpu(p)^.oper[1]).Word1]; + top_ref: + With TReference(Paicpu(p)^.oper[1]^) Do + Begin + If Not(Base in [procinfo^.FramePointer,R_NO,R_ESP]) + Then RegSet := RegSet + [Base]; + If Not(Index in [procinfo^.FramePointer,R_NO,R_ESP]) + Then RegSet := RegSet + [Index]; + End; + End; + End; +End;} + +Function OpsEquivalent(const o1, o2: toper; Var RegInfo: TRegInfo; OpAct: TopAction): Boolean; +Begin {checks whether the two ops are equivalent} + OpsEquivalent := False; + if o1.typ=o2.typ then + Case o1.typ Of + Top_Reg: + OpsEquivalent :=RegsEquivalent(o1.reg,o2.reg, RegInfo, OpAct); + Top_Ref: + OpsEquivalent := RefsEquivalent(o1.ref^, o2.ref^, RegInfo, OpAct); + Top_Const: + OpsEquivalent := o1.val = o2.val; + Top_None: + OpsEquivalent := True + End; +End; + + +Function OpsEqual(const o1,o2:toper): Boolean; +Begin {checks whether the two ops are equal} + OpsEqual := False; + if o1.typ=o2.typ then + Case o1.typ Of + Top_Reg : + OpsEqual:=o1.reg=o2.reg; + Top_Ref : + OpsEqual := RefsEqual(o1.ref^, o2.ref^); + Top_Const : + OpsEqual:=o1.val=o2.val; + Top_Symbol : + OpsEqual:=(o1.sym=o2.sym) and (o1.symofs=o2.symofs); + Top_None : + OpsEqual := True + End; +End; + +Function InstructionsEquivalent(p1, p2: Pai; Var RegInfo: TRegInfo): Boolean; +{$ifdef csdebug} +var + hp: pai; +{$endif csdebug} +Begin {checks whether two Paicpu instructions are equal} + If Assigned(p1) And Assigned(p2) And + (Pai(p1)^.typ = ait_instruction) And + (Pai(p1)^.typ = ait_instruction) And + (Paicpu(p1)^.opcode = Paicpu(p2)^.opcode) And + (Paicpu(p1)^.oper[0].typ = Paicpu(p2)^.oper[0].typ) And + (Paicpu(p1)^.oper[1].typ = Paicpu(p2)^.oper[1].typ) And + (Paicpu(p1)^.oper[2].typ = Paicpu(p2)^.oper[2].typ) + Then + {both instructions have the same structure: + " , "} + If ((Paicpu(p1)^.opcode = A_MOV) or + (Paicpu(p1)^.opcode = A_MOVZX) or + (Paicpu(p1)^.opcode = A_MOVSX)) And + (Paicpu(p1)^.oper[0].typ = top_ref) {then .oper[1]t = top_reg} Then + If Not(RegInRef(Paicpu(p1)^.oper[1].reg, Paicpu(p1)^.oper[0].ref^)) Then + {the "old" instruction is a load of a register with a new value, not with + a value based on the contents of this register (so no "mov (reg), reg")} + If Not(RegInRef(Paicpu(p2)^.oper[1].reg, Paicpu(p2)^.oper[0].ref^)) And + RefsEqual(Paicpu(p1)^.oper[0].ref^, Paicpu(p2)^.oper[0].ref^) + Then + {the "new" instruction is also a load of a register with a new value, and + this value is fetched from the same memory location} + Begin + With Paicpu(p2)^.oper[0].ref^ Do + Begin + If Not(Base in [procinfo^.FramePointer, R_NO, R_ESP]) Then + RegInfo.RegsLoadedForRef := RegInfo.RegsLoadedForRef + [Base]; + If Not(Index in [procinfo^.FramePointer, R_NO, R_ESP]) Then + RegInfo.RegsLoadedForRef := RegInfo.RegsLoadedForRef + [Index]; + End; + {add the registers from the reference (.oper[0]) to the RegInfo, all registers + from the reference are the same in the old and in the new instruction + sequence} + AddOp2RegInfo(Paicpu(p1)^.oper[0], RegInfo); + {the registers from .oper[1] have to be equivalent, but not necessarily equal} + InstructionsEquivalent := + RegsEquivalent(Paicpu(p1)^.oper[1].reg, Paicpu(p2)^.oper[1].reg, RegInfo, OpAct_Write); + End + {the registers are loaded with values from different memory locations. If + this was allowed, the instructions "mov -4(esi),eax" and "mov -4(ebp),eax" + would be considered equivalent} + Else InstructionsEquivalent := False + Else + {load register with a value based on the current value of this register} + Begin + With Paicpu(p2)^.oper[0].ref^ Do + Begin + If Not(Base in [procinfo^.FramePointer, + Reg32(Paicpu(p2)^.oper[1].reg),R_NO,R_ESP]) Then + {it won't do any harm if the register is already in RegsLoadedForRef} + Begin + RegInfo.RegsLoadedForRef := RegInfo.RegsLoadedForRef + [Base]; +{$ifdef csdebug} + Writeln(att_reg2str[base], ' added'); +{$endif csdebug} + end; + If Not(Index in [procinfo^.FramePointer, + Reg32(Paicpu(p2)^.oper[1].reg),R_NO,R_ESP]) Then + Begin + RegInfo.RegsLoadedForRef := RegInfo.RegsLoadedForRef + [Index]; +{$ifdef csdebug} + Writeln(att_reg2str[index], ' added'); +{$endif csdebug} + end; + + End; + If Not(Reg32(Paicpu(p2)^.oper[1].reg) In [procinfo^.FramePointer,R_NO,R_ESP]) + Then + Begin + RegInfo.RegsLoadedForRef := RegInfo.RegsLoadedForRef - + [Reg32(Paicpu(p2)^.oper[1].reg)]; +{$ifdef csdebug} + Writeln(att_reg2str[Reg32(Paicpu(p2)^.oper[1].reg)], ' removed'); +{$endif csdebug} + end; + InstructionsEquivalent := + OpsEquivalent(Paicpu(p1)^.oper[0], Paicpu(p2)^.oper[0], RegInfo, OpAct_Read) And + OpsEquivalent(Paicpu(p1)^.oper[1], Paicpu(p2)^.oper[1], RegInfo, OpAct_Write) + End + Else + {an instruction <> mov, movzx, movsx} + begin + {$ifdef csdebug} + hp := new(pai_asm_comment,init(strpnew('checking if equivalent'))); + hp^.previous := p2; + hp^.next := p2^.next; + p2^.next^.previous := hp; + p2^.next := hp; + {$endif csdebug} + InstructionsEquivalent := + OpsEquivalent(Paicpu(p1)^.oper[0], Paicpu(p2)^.oper[0], RegInfo, OpAct_Unknown) And + OpsEquivalent(Paicpu(p1)^.oper[1], Paicpu(p2)^.oper[1], RegInfo, OpAct_Unknown) And + OpsEquivalent(Paicpu(p1)^.oper[2], Paicpu(p2)^.oper[2], RegInfo, OpAct_Unknown) + end + {the instructions haven't even got the same structure, so they're certainly + not equivalent} + Else + begin + {$ifdef csdebug} + hp := new(pai_asm_comment,init(strpnew('different opcodes/format'))); + hp^.previous := p2; + hp^.next := p2^.next; + p2^.next^.previous := hp; + p2^.next := hp; + {$endif csdebug} + InstructionsEquivalent := False; + end; + {$ifdef csdebug} + hp := new(pai_asm_comment,init(strpnew('instreq: '+tostr(byte(instructionsequivalent))))); + hp^.previous := p2; + hp^.next := p2^.next; + p2^.next^.previous := hp; + p2^.next := hp; + {$endif csdebug} +End; + +(* +Function InstructionsEqual(p1, p2: Pai): Boolean; +Begin {checks whether two Paicpu instructions are equal} + InstructionsEqual := + Assigned(p1) And Assigned(p2) And + ((Pai(p1)^.typ = ait_instruction) And + (Pai(p1)^.typ = ait_instruction) And + (Paicpu(p1)^.opcode = Paicpu(p2)^.opcode) And + (Paicpu(p1)^.oper[0].typ = Paicpu(p2)^.oper[0].typ) And + (Paicpu(p1)^.oper[1].typ = Paicpu(p2)^.oper[1].typ) And + OpsEqual(Paicpu(p1)^.oper[0].typ, Paicpu(p1)^.oper[0], Paicpu(p2)^.oper[0]) And + OpsEqual(Paicpu(p1)^.oper[1].typ, Paicpu(p1)^.oper[1], Paicpu(p2)^.oper[1])) +End; +*) + +Procedure ReadReg(p: PPaiProp; Reg: TRegister); +Begin + Reg := Reg32(Reg); + If Reg in [R_EAX..R_EDI] Then + IncState(p^.Regs[Reg].RState) +End; + + +Procedure ReadRef(p: PPaiProp; Ref: PReference); +Begin + If Ref^.Base <> R_NO Then + ReadReg(p, Ref^.Base); + If Ref^.Index <> R_NO Then + ReadReg(p, Ref^.Index); +End; + +Procedure ReadOp(P: PPaiProp;const o:toper); +Begin + Case o.typ Of + top_reg: ReadReg(P, o.reg); + top_ref: ReadRef(P, o.ref); + top_symbol : ; + End; +End; + + +Function RefInInstruction(Const Ref: TReference; p: Pai; + RefsEq: TRefCompare): Boolean; +{checks whehter Ref is used in P} +Var TmpResult: Boolean; +Begin + TmpResult := False; + If (p^.typ = ait_instruction) Then + Begin + If (Paicpu(p)^.oper[0].typ = Top_Ref) Then + TmpResult := RefsEq(Ref, Paicpu(p)^.oper[0].ref^); + If Not(TmpResult) And (Paicpu(p)^.oper[1].typ = Top_Ref) Then + TmpResult := RefsEq(Ref, Paicpu(p)^.oper[1].ref^); + If Not(TmpResult) And (Paicpu(p)^.oper[2].typ = Top_Ref) Then + TmpResult := RefsEq(Ref, Paicpu(p)^.oper[2].ref^); + End; + RefInInstruction := TmpResult; +End; + +Function RefInSequence(Const Ref: TReference; Content: TContent; + RefsEq: TRefCompare): Boolean; +{checks the whole sequence of Content (so StartMod and and the next NrOfMods + Pai objects) to see whether Ref is used somewhere} +Var p: Pai; + Counter: Byte; + TmpResult: Boolean; +Begin + p := Content.StartMod; + TmpResult := False; + Counter := 1; + While Not(TmpResult) And + (Counter <= Content.NrOfMods) Do + Begin + If (p^.typ = ait_instruction) And + RefInInstruction(Ref, p, RefsEq) + Then TmpResult := True; + Inc(Counter); + GetNextInstruction(p,p) + End; + RefInSequence := TmpResult +End; + +Function ArrayRefsEq(const r1, r2: TReference): Boolean;{$ifdef tp}far;{$endif} +Begin + ArrayRefsEq := (R1.Offset+R1.OffsetFixup = R2.Offset+R2.OffsetFixup) And + (R1.Segment = R2.Segment) And + (R1.Symbol=R2.Symbol) And + ((Assigned(R1.Symbol)) Or + (R1.Base = R2.Base)) +End; + + +Procedure DestroyRefs(p: pai; Const Ref: TReference; WhichReg: TRegister); +{destroys all registers which possibly contain a reference to Ref, WhichReg + is the register whose contents are being written to memory (if this proc + is called because of a "mov?? %reg, (mem)" instruction)} +Var RefsEq: TRefCompare; + Counter: TRegister; +Begin + WhichReg := Reg32(WhichReg); + If (Ref.base = procinfo^.FramePointer) or + Assigned(Ref.Symbol) Then + Begin + If (Ref.Index = R_NO) And + (Not(Assigned(Ref.Symbol)) or + (Ref.base = R_NO)) Then + { local variable which is not an array } + RefsEq := {$ifdef fpc}@{$endif}RefsEqual + Else + { local variable which is an array } + RefsEq := {$ifdef fpc}@{$endif}ArrayRefsEq; + +{write something to a parameter, a local or global variable, so + * with uncertain optimizations on: + - destroy the contents of registers whose contents have somewhere a + "mov?? (Ref), %reg". WhichReg (this is the register whose contents + are being written to memory) is not destroyed if it's StartMod is + of that form and NrOfMods = 1 (so if it holds ref, but is not a + pointer based on Ref) + * with uncertain optimizations off: + - also destroy registers that contain any pointer} + For Counter := R_EAX to R_EDI Do + With PPaiProp(p^.OptInfo)^.Regs[Counter] Do + Begin + If (typ = Con_Ref) And + ((Not(cs_UncertainOpts in aktglobalswitches) And + (NrOfMods <> 1) + ) Or + (RefInSequence(Ref,PPaiProp(p^.OptInfo)^.Regs[Counter],RefsEq) And + ((Counter <> WhichReg) Or + ((NrOfMods <> 1) And + {StarMod is always of the type ait_instruction} + (Paicpu(StartMod)^.oper[0].typ = top_ref) And + RefsEq(Paicpu(StartMod)^.oper[0].ref^, Ref) + ) + ) + ) + ) + Then + DestroyReg(PPaiProp(p^.OptInfo), Counter, false) + End + End + Else +{write something to a pointer location, so + * with uncertain optimzations on: + - do not destroy registers which contain a local/global variable or a + parameter, except if DestroyRefs is called because of a "movsl" + * with uncertain optimzations off: + - destroy every register which contains a memory location + } + For Counter := R_EAX to R_EDI Do + With PPaiProp(p^.OptInfo)^.Regs[Counter] Do + If (typ = Con_Ref) And + (Not(cs_UncertainOpts in aktglobalswitches) Or + {for movsl} + (Ref.Base = R_EDI) Or + {don't destroy if reg contains a parameter, local or global variable} + Not((NrOfMods = 1) And + (Paicpu(StartMod)^.oper[0].typ = top_ref) And + ((Paicpu(StartMod)^.oper[0].ref^.base = procinfo^.FramePointer) Or + Assigned(Paicpu(StartMod)^.oper[0].ref^.Symbol) + ) + ) + ) + Then DestroyReg(PPaiProp(p^.OptInfo), Counter, false) +End; + +Procedure DestroyAllRegs(p: PPaiProp); +Var Counter: TRegister; +Begin {initializes/desrtoys all registers} + For Counter := R_EAX To R_EDI Do + Begin + ReadReg(p, Counter); + DestroyReg(p, Counter, true); + End; + p^.DirFlag := F_Unknown; +End; + +Procedure DestroyOp(PaiObj: Pai; const o:Toper); +{$ifdef statedebug} +var hp: pai; +{$endif statedebug} + +Begin + Case o.typ Of + top_reg: + begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+att_reg2str[o.reg]))); + hp^.next := paiobj^.next; + hp^.previous := paiobj; + paiobj^.next := hp; + if assigned(hp^.next) then + hp^.next^.previous := hp; +{$endif statedebug} + DestroyReg(PPaiProp(PaiObj^.OptInfo), reg32(o.reg), true); + end; + top_ref: + Begin + ReadRef(PPaiProp(PaiObj^.OptInfo), o.ref); + DestroyRefs(PaiObj, o.ref^, R_NO); + End; + top_symbol:; + End; +End; + +Function DFAPass1(AsmL: PAasmOutput; BlockStart: Pai): Pai; +{gathers the RegAlloc data... still need to think about where to store it to + avoid global vars} +Var BlockEnd: Pai; +Begin + BlockEnd := FindLoHiLabels(LoLab, HiLab, LabDif, BlockStart); + BuildLabelTableAndFixRegAlloc(AsmL, LTable, LoLab, LabDif, BlockStart, BlockEnd); + DFAPass1 := BlockEnd; +End; + +{$ifdef arithopt} +Procedure AddInstr2RegContents({$ifdef statedebug} asml: paasmoutput; {$endif} +p: paicpu; reg: TRegister); +{$ifdef statedebug} +var hp: pai; +{$endif statedebug} +Begin + Reg := Reg32(Reg); + With PPaiProp(p^.optinfo)^.Regs[reg] Do + If (Typ = Con_Ref) + Then + Begin + IncState(WState); + {also store how many instructions are part of the sequence in the first + instructions PPaiProp, so it can be easily accessed from within + CheckSequence} + Inc(NrOfMods, NrOfInstrSinceLastMod[Reg]); + PPaiProp(Pai(StartMod)^.OptInfo)^.Regs[Reg].NrOfMods := NrOfMods; + NrOfInstrSinceLastMod[Reg] := 0; +{$ifdef StateDebug} + hp := new(pai_asm_comment,init(strpnew(att_reg2str[reg]+': '+tostr(PPaiProp(p^.optinfo)^.Regs[reg].WState) + + ' -- ' + tostr(PPaiProp(p^.optinfo)^.Regs[reg].nrofmods)))); + InsertLLItem(AsmL, p, p^.next, hp); +{$endif StateDebug} + End + Else + Begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+att_reg2str[reg]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(PPaiProp(p^.optinfo), Reg, true); +{$ifdef StateDebug} + hp := new(pai_asm_comment,init(strpnew(att_reg2str[reg]+': '+tostr(PPaiProp(p^.optinfo)^.Regs[reg].WState)))); + InsertLLItem(AsmL, p, p^.next, hp); +{$endif StateDebug} + End +End; + +Procedure AddInstr2OpContents({$ifdef statedebug} asml: paasmoutput; {$endif} +p: paicpu; const oper: TOper); +Begin + If oper.typ = top_reg Then + AddInstr2RegContents({$ifdef statedebug} asml, {$endif}p, oper.reg) + Else + Begin + ReadOp(PPaiProp(p^.optinfo), oper); + DestroyOp(p, oper); + End +End; +{$endif arithopt} + +Procedure DoDFAPass2( +{$Ifdef StateDebug} +AsmL: PAasmOutput; +{$endif statedebug} +BlockStart, BlockEnd: Pai); +{Analyzes the Data Flow of an assembler list. Starts creating the reg + contents for the instructions starting with p. Returns the last pai which has + been processed} +Var + CurProp: PPaiProp; +{$ifdef AnalyzeLoops} + TmpState: Byte; +{$endif AnalyzeLoops} + Cnt, InstrCnt : Longint; + InstrProp: TInsProp; + UsedRegs: TRegSet; + p, hp : Pai; + TmpRef: TReference; + TmpReg: TRegister; +Begin + p := BlockStart; + UsedRegs := []; + UpdateUsedregs(UsedRegs, p); + SkipHead(P); + BlockStart := p; + InstrCnt := 1; + FillChar(NrOfInstrSinceLastMod, SizeOf(NrOfInstrSinceLastMod), 0); + While (P <> BlockEnd) Do + Begin +{$IfDef TP} + New(CurProp); +{$Else TP} + CurProp := @PaiPropBlock^[InstrCnt]; +{$EndIf TP} + If (p <> BlockStart) + Then + Begin +{$ifdef JumpAnal} + If (p^.Typ <> ait_label) Then +{$endif JumpAnal} + Begin + GetLastInstruction(p, hp); + CurProp^.Regs := PPaiProp(hp^.OptInfo)^.Regs; + CurProp^.DirFlag := PPaiProp(hp^.OptInfo)^.DirFlag; + End + End + Else + Begin + FillChar(CurProp^, SizeOf(CurProp^), 0); +{ For TmpReg := R_EAX to R_EDI Do + CurProp^.Regs[TmpReg].WState := 1;} + End; + CurProp^.UsedRegs := UsedRegs; + CurProp^.CanBeRemoved := False; + UpdateUsedRegs(UsedRegs, Pai(p^.Next)); +{$ifdef TP} + PPaiProp(p^.OptInfo) := CurProp; +{$Endif TP} + For TmpReg := R_EAX To R_EDI Do + Inc(NrOfInstrSinceLastMod[TmpReg]); + Case p^.typ Of + ait_label: +{$Ifndef JumpAnal} + If (Pai_label(p)^.l^.is_used) Then + DestroyAllRegs(CurProp); +{$Else JumpAnal} + Begin + If (Pai_Label(p)^.is_used) Then + With LTable^[Pai_Label(p)^.l^.labelnr-LoLab] Do +{$IfDef AnalyzeLoops} + If (RefsFound = Pai_Label(p)^.l^.RefCount) +{$Else AnalyzeLoops} + If (JmpsProcessed = Pai_Label(p)^.l^.RefCount) +{$EndIf AnalyzeLoops} + Then +{all jumps to this label have been found} +{$IfDef AnalyzeLoops} + If (JmpsProcessed > 0) + Then +{$EndIf AnalyzeLoops} + {we've processed at least one jump to this label} + Begin + If (GetLastInstruction(p, hp) And + Not(((hp^.typ = ait_instruction)) And + (paicpu_labeled(hp)^.is_jmp)) + Then + {previous instruction not a JMP -> the contents of the registers after the + previous intruction has been executed have to be taken into account as well} + For TmpReg := R_EAX to R_EDI Do + Begin + If (CurProp^.Regs[TmpReg].WState <> + PPaiProp(hp^.OptInfo)^.Regs[TmpReg].WState) + Then DestroyReg(CurProp, TmpReg, true) + End + End +{$IfDef AnalyzeLoops} + Else + {a label from a backward jump (e.g. a loop), no jump to this label has + already been processed} + If GetLastInstruction(p, hp) And + Not(hp^.typ = ait_instruction) And + (paicpu_labeled(hp)^.opcode = A_JMP)) + Then + {previous instruction not a jmp, so keep all the registers' contents from the + previous instruction} + Begin + CurProp^.Regs := PPaiProp(hp^.OptInfo)^.Regs; + CurProp^.DirFlag := PPaiProp(hp^.OptInfo)^.DirFlag; + End + Else + {previous instruction a jmp and no jump to this label processed yet} + Begin + hp := p; + Cnt := InstrCnt; + {continue until we find a jump to the label or a label which has already + been processed} + While GetNextInstruction(hp, hp) And + Not((hp^.typ = ait_instruction) And + (paicpu(hp)^.is_jmp) and + (pasmlabel(paicpu(hp)^.oper[0].sym)^.labelnr = Pai_Label(p)^.l^.labelnr)) And + Not((hp^.typ = ait_label) And + (LTable^[Pai_Label(hp)^.l^.labelnr-LoLab].RefsFound + = Pai_Label(hp)^.l^.RefCount) And + (LTable^[Pai_Label(hp)^.l^.labelnr-LoLab].JmpsProcessed > 0)) Do + Inc(Cnt); + If (hp^.typ = ait_label) + Then + {there's a processed label after the current one} + Begin + CurProp^.Regs := PaiPropBlock^[Cnt].Regs; + CurProp^.DirFlag := PaiPropBlock^[Cnt].DirFlag; + End + Else + {there's no label anymore after the current one, or they haven't been + processed yet} + Begin + GetLastInstruction(p, hp); + CurProp^.Regs := PPaiProp(hp^.OptInfo)^.Regs; + CurProp^.DirFlag := PPaiProp(hp^.OptInfo)^.DirFlag; + DestroyAllRegs(PPaiProp(hp^.OptInfo)) + End + End +{$EndIf AnalyzeLoops} + Else +{not all references to this label have been found, so destroy all registers} + Begin + GetLastInstruction(p, hp); + CurProp^.Regs := PPaiProp(hp^.OptInfo)^.Regs; + CurProp^.DirFlag := PPaiProp(hp^.OptInfo)^.DirFlag; + DestroyAllRegs(CurProp) + End; + End; +{$EndIf JumpAnal} + +{$ifdef GDB} + ait_stabs, ait_stabn, ait_stab_function_name:; +{$endif GDB} + ait_align: ; { may destroy flags !!! } + ait_instruction: + Begin + if paicpu(p)^.is_jmp then + begin +{$IfNDef JumpAnal} + ; +{$Else JumpAnal} + With LTable^[pasmlabel(paicpu(p)^.oper[0].sym)^.labelnr-LoLab] Do + If (RefsFound = pasmlabel(paicpu(p)^.oper[0].sym)^.RefCount) Then + Begin + If (InstrCnt < InstrNr) + Then + {forward jump} + If (JmpsProcessed = 0) Then + {no jump to this label has been processed yet} + Begin + PaiPropBlock^[InstrNr].Regs := CurProp^.Regs; + PaiPropBlock^[InstrNr].DirFlag := CurProp^.DirFlag; + Inc(JmpsProcessed); + End + Else + Begin + For TmpReg := R_EAX to R_EDI Do + If (PaiPropBlock^[InstrNr].Regs[TmpReg].WState <> + CurProp^.Regs[TmpReg].WState) Then + DestroyReg(@PaiPropBlock^[InstrNr], TmpReg, true); + Inc(JmpsProcessed); + End +{$ifdef AnalyzeLoops} + Else +{ backward jump, a loop for example} +{ If (JmpsProcessed > 0) Or + Not(GetLastInstruction(PaiObj, hp) And + (hp^.typ = ait_labeled_instruction) And + (paicpu_labeled(hp)^.opcode = A_JMP)) + Then} +{instruction prior to label is not a jmp, or at least one jump to the label + has yet been processed} + Begin + Inc(JmpsProcessed); + For TmpReg := R_EAX to R_EDI Do + If (PaiPropBlock^[InstrNr].Regs[TmpReg].WState <> + CurProp^.Regs[TmpReg].WState) + Then + Begin + TmpState := PaiPropBlock^[InstrNr].Regs[TmpReg].WState; + Cnt := InstrNr; + While (TmpState = PaiPropBlock^[Cnt].Regs[TmpReg].WState) Do + Begin + DestroyReg(@PaiPropBlock^[Cnt], TmpReg, true); + Inc(Cnt); + End; + While (Cnt <= InstrCnt) Do + Begin + Inc(PaiPropBlock^[Cnt].Regs[TmpReg].WState); + Inc(Cnt) + End + End; + End +{ Else } +{instruction prior to label is a jmp and no jumps to the label have yet been + processed} +{ Begin + Inc(JmpsProcessed); + For TmpReg := R_EAX to R_EDI Do + Begin + TmpState := PaiPropBlock^[InstrNr].Regs[TmpReg].WState; + Cnt := InstrNr; + While (TmpState = PaiPropBlock^[Cnt].Regs[TmpReg].WState) Do + Begin + PaiPropBlock^[Cnt].Regs[TmpReg] := CurProp^.Regs[TmpReg]; + Inc(Cnt); + End; + TmpState := PaiPropBlock^[InstrNr].Regs[TmpReg].WState; + While (TmpState = PaiPropBlock^[Cnt].Regs[TmpReg].WState) Do + Begin + DestroyReg(@PaiPropBlock^[Cnt], TmpReg, true); + Inc(Cnt); + End; + While (Cnt <= InstrCnt) Do + Begin + Inc(PaiPropBlock^[Cnt].Regs[TmpReg].WState); + Inc(Cnt) + End + End + End} +{$endif AnalyzeLoops} + End; +{$EndIf JumpAnal} + end + else + begin + InstrProp := InsProp[Paicpu(p)^.opcode]; + Case Paicpu(p)^.opcode Of + A_MOV, A_MOVZX, A_MOVSX: + Begin + Case Paicpu(p)^.oper[0].typ Of + Top_Reg: + Case Paicpu(p)^.oper[1].typ Of + Top_Reg: + Begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+ + att_reg2str[Paicpu(p)^.oper[1].reg]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(CurProp, Paicpu(p)^.oper[1].reg, true); + ReadReg(CurProp, Paicpu(p)^.oper[0].reg); +{ CurProp^.Regs[Paicpu(p)^.oper[1].reg] := + CurProp^.Regs[Paicpu(p)^.oper[0].reg]; + If (CurProp^.Regs[Paicpu(p)^.oper[1].reg].ModReg = R_NO) Then + CurProp^.Regs[Paicpu(p)^.oper[1].reg].ModReg := + Paicpu(p)^.oper[0].reg;} + End; + Top_Ref: + Begin + ReadReg(CurProp, Paicpu(p)^.oper[0].reg); + ReadRef(CurProp, Paicpu(p)^.oper[1].ref); + DestroyRefs(p, Paicpu(p)^.oper[1].ref^, Paicpu(p)^.oper[0].reg); + End; + End; + Top_Ref: + Begin {destination is always a register in this case} + ReadRef(CurProp, Paicpu(p)^.oper[0].ref); + TmpReg := Reg32(Paicpu(p)^.oper[1].reg); + If RegInRef(TmpReg, Paicpu(p)^.oper[0].ref^) And + (CurProp^.Regs[TmpReg].Typ = Con_Ref) + Then + Begin + With CurProp^.Regs[TmpReg] Do + Begin + IncState(WState); + {also store how many instructions are part of the sequence in the first + instructions PPaiProp, so it can be easily accessed from within + CheckSequence} + Inc(NrOfMods, NrOfInstrSinceLastMod[TmpReg]); + PPaiProp(Pai(StartMod)^.OptInfo)^.Regs[TmpReg].NrOfMods := NrOfMods; + NrOfInstrSinceLastMod[TmpReg] := 0; + End; + End + Else + Begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying & initing '+att_reg2str[tmpreg]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(CurProp, TmpReg, true); + If Not(RegInRef(TmpReg, Paicpu(p)^.oper[0].ref^)) Then + With CurProp^.Regs[TmpReg] Do + Begin + Typ := Con_Ref; + StartMod := p; + NrOfMods := 1; + End + End; +{$ifdef StateDebug} + hp := new(pai_asm_comment,init(strpnew(att_reg2str[TmpReg]+': '+tostr(CurProp^.Regs[TmpReg].WState)))); + InsertLLItem(AsmL, p, p^.next, hp); +{$endif StateDebug} + + End; + top_symbol,Top_Const: + Begin + Case Paicpu(p)^.oper[1].typ Of + Top_Reg: + Begin + TmpReg := Reg32(Paicpu(p)^.oper[1].reg); +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+att_reg2str[tmpreg]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + With CurProp^.Regs[TmpReg] Do + Begin + DestroyReg(CurProp, TmpReg, true); + typ := Con_Const; + StartMod := p; + End + End; + Top_Ref: + Begin + ReadRef(CurProp, Paicpu(p)^.oper[1].ref); + DestroyRefs(P, Paicpu(p)^.oper[1].ref^, R_NO); + End; + End; + End; + End; + End; + A_DIV, A_IDIV, A_MUL: + Begin + ReadOp(Curprop, Paicpu(p)^.oper[0]); + ReadReg(CurProp,R_EAX); + If (Paicpu(p)^.OpCode = A_IDIV) or + (Paicpu(p)^.OpCode = A_DIV) Then + ReadReg(CurProp,R_EDX); +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying eax and edx'))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(CurProp, R_EAX, true); + DestroyReg(CurProp, R_EDX, true) + End; + A_IMUL: + Begin + ReadOp(CurProp,Paicpu(p)^.oper[0]); + ReadOp(CurProp,Paicpu(p)^.oper[1]); + If (Paicpu(p)^.oper[2].typ = top_none) Then + If (Paicpu(p)^.oper[1].typ = top_none) Then + Begin + ReadReg(CurProp,R_EAX); +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying eax and edx'))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(CurProp, R_EAX, true); + DestroyReg(CurProp, R_EDX, true) + End + Else + {$ifdef arithopt} + AddInstr2OpContents( + {$ifdef statedebug}asml,{$endif} + Paicpu(p), Paicpu(p)^.oper[1]) + {$else arithopt} + DestroyOp(p, Paicpu(p)^.oper[1]) + {$endif arithopt} + Else + {$ifdef arithopt} + AddInstr2OpContents({$ifdef statedebug}asml,{$endif} + Paicpu(p), Paicpu(p)^.oper[2]); + {$else arithopt} + DestroyOp(p, Paicpu(p)^.oper[2]); + {$endif arithopt} + End; +{$ifdef arithopt} + A_LEA: + begin + readop(curprop,paicpu(p)^.oper[0]); + if reginref(paicpu(p)^.oper[1].reg,paicpu(p)^.oper[0].ref^) then + AddInstr2RegContents({$ifdef statedebug}asml,{$endif} + paicpu(p), paicpu(p)^.oper[1].reg) + else + begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+ + att_reg2str[paicpu(p)^.oper[1].reg]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + destroyreg(curprop,paicpu(p)^.oper[1].reg,true); + end; + end; +{$endif arithopt} + Else + Begin + Cnt := 1; + While (Cnt <= MaxCh) And + (InstrProp.Ch[Cnt] <> Ch_None) Do + Begin + Case InstrProp.Ch[Cnt] Of + Ch_REAX..Ch_REDI: ReadReg(CurProp,TCh2Reg(InstrProp.Ch[Cnt])); + Ch_WEAX..Ch_RWEDI: + Begin + If (InstrProp.Ch[Cnt] >= Ch_RWEAX) Then + ReadReg(CurProp, TCh2Reg(InstrProp.Ch[Cnt])); +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew('destroying '+ + att_reg2str[TCh2Reg(InstrProp.Ch[Cnt])]))); + insertllitem(asml,p,p^.next,hp); +{$endif statedebug} + DestroyReg(CurProp, TCh2Reg(InstrProp.Ch[Cnt]), true); + End; +{$ifdef arithopt} + Ch_MEAX..Ch_MEDI: + AddInstr2RegContents({$ifdef statedebug} asml,{$endif} + Paicpu(p),TCh2Reg(InstrProp.Ch[Cnt])); +{$endif arithopt} + Ch_CDirFlag: CurProp^.DirFlag := F_NotSet; + Ch_SDirFlag: CurProp^.DirFlag := F_Set; + Ch_Rop1: ReadOp(CurProp, Paicpu(p)^.oper[0]); + Ch_Rop2: ReadOp(CurProp, Paicpu(p)^.oper[1]); + Ch_ROp3: ReadOp(CurProp, Paicpu(p)^.oper[2]); + Ch_Wop1..Ch_RWop1: + Begin + If (InstrProp.Ch[Cnt] in [Ch_RWop1]) Then + ReadOp(CurProp, Paicpu(p)^.oper[0]); + DestroyOp(p, Paicpu(p)^.oper[0]); + End; +{$ifdef arithopt} + Ch_Mop1: + AddInstr2OpContents({$ifdef statedebug} asml, {$endif} + Paicpu(p), Paicpu(p)^.oper[0]); +{$endif arithopt} + Ch_Wop2..Ch_RWop2: + Begin + If (InstrProp.Ch[Cnt] = Ch_RWop2) Then + ReadOp(CurProp, Paicpu(p)^.oper[1]); + DestroyOp(p, Paicpu(p)^.oper[1]); + End; +{$ifdef arithopt} + Ch_Mop2: + AddInstr2OpContents({$ifdef statedebug} asml, {$endif} + Paicpu(p), Paicpu(p)^.oper[1]); +{$endif arithopt} + Ch_WOp3..Ch_RWOp3: + Begin + If (InstrProp.Ch[Cnt] = Ch_RWOp3) Then + ReadOp(CurProp, Paicpu(p)^.oper[2]); + DestroyOp(p, Paicpu(p)^.oper[2]); + End; +{$ifdef arithopt} + Ch_Mop3: + AddInstr2OpContents({$ifdef statedebug} asml, {$endif} + Paicpu(p), Paicpu(p)^.oper[2]); +{$endif arithopt} + Ch_WMemEDI: + Begin + ReadReg(CurProp, R_EDI); + FillChar(TmpRef, SizeOf(TmpRef), 0); + TmpRef.Base := R_EDI; + DestroyRefs(p, TmpRef, R_NO) + End; + Ch_RFlags, Ch_WFlags, Ch_RWFlags, Ch_FPU: + Else + Begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew( + 'destroying all regs for prev instruction'))); + insertllitem(asml,p, p^.next,hp); +{$endif statedebug} + DestroyAllRegs(CurProp); + End; + End; + Inc(Cnt); + End + End; + end; + End; + End + Else + Begin +{$ifdef statedebug} + hp := new(pai_asm_comment,init(strpnew( + 'destroying all regs: unknown pai: '+tostr(ord(p^.typ))))); + insertllitem(asml,p, p^.next,hp); +{$endif statedebug} + DestroyAllRegs(CurProp); + End; + End; + Inc(InstrCnt); + GetNextInstruction(p, p); + End; +End; + +Function InitDFAPass2(BlockStart, BlockEnd: Pai): Boolean; +{reserves memory for the PPaiProps in one big memory block when not using + TP, returns False if not enough memory is available for the optimizer in all + cases} +Var p: Pai; + Count: Longint; +{ TmpStr: String; } +Begin + P := BlockStart; + SkipHead(P); + NrOfPaiObjs := 0; + While (P <> BlockEnd) Do + Begin +{$IfDef JumpAnal} + Case P^.Typ Of + ait_label: + Begin + If (Pai_Label(p)^.l^.is_used) Then + LTable^[Pai_Label(P)^.l^.labelnr-LoLab].InstrNr := NrOfPaiObjs + End; + ait_instruction: + begin + if paicpu(p)^.is_jmp then + begin + If (pasmlabel(paicpu(P)^.oper[0].sym)^.labelnr >= LoLab) And + (pasmlabel(paicpu(P)^.oper[0].sym)^.labelnr <= HiLab) Then + Inc(LTable^[pasmlabel(paicpu(P)^.oper[0].sym)^.labelnr-LoLab].RefsFound); + end; + end; +{ ait_instruction: + Begin + If (Paicpu(p)^.opcode = A_PUSH) And + (Paicpu(p)^.oper[0].typ = top_symbol) And + (PCSymbol(Paicpu(p)^.oper[0])^.offset = 0) Then + Begin + TmpStr := StrPas(PCSymbol(Paicpu(p)^.oper[0])^.symbol); + If} + End; +{$EndIf JumpAnal} + Inc(NrOfPaiObjs); + GetNextInstruction(p, p); + End; +{$IfDef TP} + If (MemAvail < (SizeOf(TPaiProp)*NrOfPaiObjs)) + Or (NrOfPaiObjs = 0) + {this doesn't have to be one contiguous block} + Then InitDFAPass2 := False + Else InitDFAPass2 := True; +{$Else} +{Uncomment the next line to see how much memory the reloading optimizer needs} +{ Writeln((NrOfPaiObjs*(((SizeOf(TPaiProp)+3)div 4)*4)));} +{no need to check mem/maxavail, we've got as much virtual memory as we want} + If NrOfPaiObjs <> 0 Then + Begin + InitDFAPass2 := True; + GetMem(PaiPropBlock, NrOfPaiObjs*(((SizeOf(TPaiProp)+3)div 4)*4)); + p := BlockStart; + SkipHead(p); + For Count := 1 To NrOfPaiObjs Do + Begin + PPaiProp(p^.OptInfo) := @PaiPropBlock^[Count]; + GetNextInstruction(p, p); + End; + End + Else InitDFAPass2 := False; + {$EndIf TP} +End; + +Function DFAPass2( +{$ifdef statedebug} + AsmL: PAasmOutPut; +{$endif statedebug} + BlockStart, BlockEnd: Pai): Boolean; +Begin + If InitDFAPass2(BlockStart, BlockEnd) Then + Begin + DoDFAPass2( +{$ifdef statedebug} + asml, +{$endif statedebug} + BlockStart, BlockEnd); + DFAPass2 := True + End + Else DFAPass2 := False; +End; + +Procedure ShutDownDFA; +Begin + If LabDif <> 0 Then + FreeMem(LTable, LabDif*SizeOf(TLabelTableItem)); +End; + +End. + +{ + $Log: not supported by cvs2svn $ + Revision 1.88 2000/06/01 11:01:20 peter + * removed notes + + Revision 1.87 2000/04/29 16:56:45 jonas + * destroyreg overwrote some memory if the reg was an FPU register + + Revision 1.86 2000/04/10 12:45:56 jonas + * fixed a serious bug in the CSE which (I think) only showed with + -dnewoptimizations when using multi-dimensional arrays with + elements of a size different from 1, 2 or 4 (especially strings). + * made the DFA/CSE more robust (much less dependent on specifics of the + code generator) + + Revision 1.85 2000/03/25 18:58:00 jonas + * moved AllocRegBetween() from csopt386 to this unit because it's now + also used by popt386 + + Revision 1.84 2000/02/24 18:41:38 peter + * removed warnings/notes + + Revision 1.83 2000/02/10 14:57:14 jonas + * fixed bug due to lack of support for top_symbol operands + + Revision 1.82 2000/02/09 13:22:51 peter + * log truncated + + Revision 1.81 2000/02/04 13:52:17 jonas + * better support for regvars (still needs a move of the call to the optimize + procedure to a place where resetusableregisters is not yet called to work) + * small regallocation fixes for -dnewoptimizations + + Revision 1.80 2000/01/28 15:15:31 jonas + * moved skipinstr from daopt386 to aasm + * fixed crashing bug with -dreplacereg in csopt386.pas + + Revision 1.79 2000/01/22 16:08:06 jonas + * better handling of exit(func_result) (no release of register that + holds the function result added) + * several other small improvements for reg allocation fixes + + Revision 1.78 2000/01/13 13:07:06 jonas + * released -dalignreg + * some small fixes to -dnewOptimizations helper procedures + + Revision 1.77 2000/01/09 01:44:21 jonas + + (de)allocation info for EDI to fix reported bug on mailinglist. + Also some (de)allocation info for ESI added. Between -dallocEDI + because at this time of the night bugs could easily slip in ;) + + Revision 1.76 2000/01/07 01:14:23 peter + * updated copyright to 2000 + + Revision 1.75 1999/12/05 16:48:43 jonas + * CSE of constant loading in regs works properly again + + if a constant is stored into memory using "mov const, ref" and + there is a reg that contains this const, it is changed into + "mov reg, ref" + + Revision 1.74 1999/12/02 11:26:41 peter + * newoptimizations define added + + Revision 1.73 1999/11/27 23:45:43 jonas + * even more missing register deallocations are added! + + Revision 1.72 1999/11/21 13:06:30 jonas + * improved fixing of missing regallocs (they're almost all correct + now!) + + Revision 1.71 1999/11/20 12:50:32 jonas + * fixed small typo (C_M* -> Ch_M*) so -darithopt compiles again + + Revision 1.70 1999/11/14 11:25:38 jonas + * fixed stupid typo in previous commit :( + + Revision 1.69 1999/11/13 19:01:51 jonas + * div, idiv and mul destroy edx!! + + Revision 1.68 1999/11/07 14:57:09 jonas + * much more complete/waterproof RegModifiedByInstruction() + + Revision 1.67 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.66 1999/11/05 16:01:46 jonas + + first implementation of choosing least used register for alignment code + (not yet working, between ifdef alignreg) + + Revision 1.65 1999/10/27 16:11:28 peter + * insns.dat is used to generate all i386*.inc files + + Revision 1.64 1999/10/23 14:44:24 jonas + * finally got around making GetNextInstruction return false when + the current pai object is a AsmBlockStart marker + * changed a loop in aopt386 which was incompatible with this change + + Revision 1.63 1999/10/14 14:57:52 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.62 1999/10/07 16:07:35 jonas + * small bugfix in ArrayRefsEq + +} diff --git a/befpc/compiler/depend b/befpc/compiler/depend new file mode 100644 index 0000000..368d2b5 --- /dev/null +++ b/befpc/compiler/depend @@ -0,0 +1,339 @@ +pp: pp.pas \ + globals.ppu \ + compiler.ppu + $(COMPILER) $(LOCALOPT) pp.pas + +globals.ppu: globals.pas \ + cobjects.ppu \ + systems.ppu + +cobjects.ppu: cobjects.pas + +systems.ppu: systems.pas + +compiler.ppu: compiler.pas \ + verbose.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + options.ppu \ + parser.ppu \ + symtable.ppu \ + link.ppu \ + import.ppu + +verbose.ppu: verbose.pas \ + messages.ppu \ + files.ppu \ + comphook.ppu \ + globals.ppu + +messages.ppu: messages.pas + +files.ppu: files.pas \ + cobjects.ppu \ + globals.ppu \ + ppu.ppu \ + verbose.ppu \ + systems.ppu + +ppu.ppu: ppu.pas + +comphook.ppu: comphook.pas + +options.ppu: options.pas \ + verbose.ppu \ + cobjects.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + scanner.ppu \ + link.ppu \ + messages.ppu \ + gendef.ppu + +scanner.ppu: scanner.pas \ + cobjects.ppu \ + globals.ppu \ + verbose.ppu \ + comphook.ppu \ + files.ppu \ + systems.ppu \ + symtable.ppu \ + switches.ppu + +symtable.ppu: symtable.pas \ + cobjects.ppu \ + verbose.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + aasm.ppu \ + files.ppu \ + gendef.ppu \ + types.ppu \ + ppu.ppu \ + hcodegen.ppu + +aasm.ppu: aasm.pas \ + cobjects.ppu \ + files.ppu \ + globals.ppu \ + verbose.ppu \ + systems.ppu + +gendef.ppu: gendef.pas \ + cobjects.ppu \ + systems.ppu \ + globals.ppu + +types.ppu: types.pas \ + cobjects.ppu \ + globals.ppu \ + symtable.ppu \ + verbose.ppu \ + aasm.ppu + +hcodegen.ppu: hcodegen.pas \ + verbose.ppu \ + aasm.ppu \ + tree.ppu \ + symtable.ppu \ + systems.ppu \ + comphook.ppu \ + cobjects.ppu \ + globals.ppu \ + files.ppu + +tree.ppu: tree.pas \ + cobjects.ppu \ + globals.ppu \ + symtable.ppu \ + aasm.ppu \ + types.ppu \ + verbose.ppu \ + files.ppu + +switches.ppu: switches.pas \ + globals.ppu \ + verbose.ppu \ + files.ppu \ + systems.ppu + +link.ppu: link.pas \ + cobjects.ppu \ + files.ppu \ + script.ppu \ + globals.ppu \ + systems.ppu \ + verbose.ppu + +script.ppu: script.pas \ + cobjects.ppu \ + globals.ppu \ + systems.ppu + +parser.ppu: parser.pas \ + cobjects.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + hcodegen.ppu \ + verbose.ppu \ + symtable.ppu \ + files.ppu \ + aasm.ppu \ + assemble.ppu \ + link.ppu \ + script.ppu \ + gendef.ppu \ + scanner.ppu \ + pbase.ppu \ + pdecl.ppu \ + psystem.ppu \ + pmodules.ppu + +assemble.ppu: assemble.pas \ + cobjects.ppu \ + globals.ppu \ + aasm.ppu \ + script.ppu \ + files.ppu \ + systems.ppu \ + verbose.ppu + +pbase.ppu: pbase.pas \ + cobjects.ppu \ + globals.ppu \ + symtable.ppu \ + files.ppu \ + scanner.ppu \ + systems.ppu \ + verbose.ppu + +pdecl.ppu: pdecl.pas \ + globals.ppu \ + symtable.ppu \ + cobjects.ppu \ + scanner.ppu \ + aasm.ppu \ + tree.ppu \ + pass_1.ppu \ + files.ppu \ + types.ppu \ + hcodegen.ppu \ + verbose.ppu \ + systems.ppu \ + pbase.ppu \ + ptconst.ppu \ + pexpr.ppu \ + psub.ppu \ + pexports.ppu + +pass_1.ppu: pass_1.pas \ + tree.ppu \ + cobjects.ppu \ + verbose.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + aasm.ppu \ + symtable.ppu \ + types.ppu \ + hcodegen.ppu \ + files.ppu + +ptconst.ppu: ptconst.pas \ + symtable.ppu \ + cobjects.ppu \ + globals.ppu \ + scanner.ppu \ + aasm.ppu \ + tree.ppu \ + pass_1.ppu \ + hcodegen.ppu \ + types.ppu \ + verbose.ppu \ + pbase.ppu \ + pexpr.ppu + +pexpr.ppu: pexpr.pas \ + symtable.ppu \ + tree.ppu \ + cobjects.ppu \ + globals.ppu \ + scanner.ppu \ + aasm.ppu \ + pass_1.ppu \ + systems.ppu \ + hcodegen.ppu \ + types.ppu \ + verbose.ppu \ + pbase.ppu \ + pdecl.ppu + +psub.ppu: psub.pas \ + cobjects.ppu \ + symtable.ppu \ + globals.ppu \ + scanner.ppu \ + aasm.ppu \ + tree.ppu \ + types.ppu \ + files.ppu \ + verbose.ppu \ + systems.ppu \ + import.ppu \ + gendef.ppu \ + hcodegen.ppu \ + temp_gen.ppu \ + pass_1.ppu \ + pass_2.ppu \ + pbase.ppu \ + pdecl.ppu \ + pexpr.ppu \ + pstatmnt.ppu + +import.ppu: import.pas \ + cobjects.ppu \ + systems.ppu \ + verbose.ppu + +temp_gen.ppu: temp_gen.pas \ + cobjects.ppu \ + globals.ppu \ + tree.ppu \ + hcodegen.ppu \ + verbose.ppu \ + files.ppu \ + aasm.ppu + +pass_2.ppu: pass_2.pas \ + tree.ppu \ + cobjects.ppu \ + verbose.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + files.ppu \ + symtable.ppu \ + types.ppu \ + aasm.ppu \ + scanner.ppu \ + pass_1.ppu \ + hcodegen.ppu \ + temp_gen.ppu + +pstatmnt.ppu: pstatmnt.pas \ + tree.ppu \ + cobjects.ppu \ + globals.ppu \ + files.ppu \ + verbose.ppu \ + systems.ppu \ + symtable.ppu \ + aasm.ppu \ + pass_1.ppu \ + types.ppu \ + scanner.ppu \ + hcodegen.ppu \ + ppu.ppu \ + pbase.ppu \ + pexpr.ppu \ + pdecl.ppu + +pexports.ppu: pexports.pas \ + cobjects.ppu \ + globals.ppu \ + scanner.ppu \ + symtable.ppu \ + pbase.ppu \ + verbose.ppu + +psystem.ppu: psystem.pas \ + symtable.ppu \ + globals.ppu \ + tree.ppu + +pmodules.ppu: pmodules.pas \ + cobjects.ppu \ + comphook.ppu \ + systems.ppu \ + globals.ppu \ + symtable.ppu \ + aasm.ppu \ + files.ppu \ + hcodegen.ppu \ + verbose.ppu \ + link.ppu \ + assemble.ppu \ + import.ppu \ + gendef.ppu \ + ppu.ppu \ + scanner.ppu \ + pbase.ppu \ + psystem.ppu \ + pdecl.ppu \ + psub.ppu \ + parser.ppu + diff --git a/befpc/compiler/dmisc.pas b/befpc/compiler/dmisc.pas new file mode 100644 index 0000000..5908346 --- /dev/null +++ b/befpc/compiler/dmisc.pas @@ -0,0 +1,873 @@ +{ + $Id: dmisc.pas,v 1.1.1.1 2001-07-23 17:15:55 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Dos unit for BP7 compatible RTL for Delphi + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit dmisc; + +interface + +uses + windows,sysutils; + +Const + Max_Path = 255; + + {Bitmasks for CPU Flags} + fcarry = $0001; + fparity = $0004; + fauxiliary = $0010; + fzero = $0040; + fsign = $0080; + foverflow = $0800; + + {Bitmasks for file attribute} + readonly = $01; + hidden = $02; + sysfile = $04; + volumeid = $08; + directory = $10; + archive = $20; + anyfile = $3F; + + {File Status} + fmclosed = $D7B0; + fminput = $D7B1; + fmoutput = $D7B2; + fminout = $D7B3; + + +Type +{ Needed for Win95 LFN Support } + ComStr = String[255]; + PathStr = String[255]; + DirStr = String[255]; + NameStr = String[255]; + ExtStr = String[255]; + + FileRec = TFileRec; + + DateTime = packed record + Year, + Month, + Day, + Hour, + Min, + Sec : word; + End; + + PWin32FindData = ^TWin32FindData; + TWin32FindData = packed record + dwFileAttributes: Cardinal; + ftCreationTime: TFileTime; + ftLastAccessTime: TFileTime; + ftLastWriteTime: TFileTime; + nFileSizeHigh: Cardinal; + nFileSizeLow: Cardinal; + dwReserved0: Cardinal; + dwReserved1: Cardinal; + cFileName: array[0..MAX_PATH - 1] of Char; + cAlternateFileName: array[0..13] of Char; + end; + + Searchrec = Packed Record + FindHandle : THandle; + W32FindData : TWin32FindData; + time : longint; + size : longint; + attr : longint; + name : string; + end; + + + registers = packed record + case i : integer of + 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); + 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte); + 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint); + end; + +Var + DosError : integer; + +{Interrupt} +Procedure Intr(intno: byte; var regs: registers); +Procedure MSDos(var regs: registers); + +{Info/Date/Time} +Function DosVersion: Word; +Procedure GetDate(var year, month, mday, wday: word); +Procedure GetTime(var hour, minute, second, sec100: word); +procedure SetDate(year,month,day: word); +Procedure SetTime(hour,minute,second,sec100: word); +Procedure UnpackTime(p: longint; var t: datetime); +Procedure PackTime(var t: datetime; var p: longint); + +{Exec} +Procedure Exec(const path: pathstr; const comline: comstr); +Function DosExitCode: word; + +{Disk} +Function DiskFree(drive: byte) : longint; +Function DiskSize(drive: byte) : longint; +Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec); +Procedure FindNext(var f: searchRec); +Procedure FindClose(Var f: SearchRec); + +{File} +Procedure GetFAttr(var f; var attr: word); +Procedure GetFTime(var f; var time: longint); +Function FSearch(path: pathstr; dirlist: string): pathstr; +Function FExpand(const path: pathstr): pathstr; +Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr); + +{Environment} +Function EnvCount: longint; +Function EnvStr(index: integer): string; +Function GetEnv(envvar: string): string; + +{Misc} +Procedure SetFAttr(var f; attr: word); +Procedure SetFTime(var f; time: longint); +Procedure GetCBreak(var breakvalue: boolean); +Procedure SetCBreak(breakvalue: boolean); +Procedure GetVerify(var verify: boolean); +Procedure SetVerify(verify: boolean); + +{Do Nothing Functions} +Procedure SwapVectors; +Procedure GetIntVec(intno: byte; var vector: pointer); +Procedure SetIntVec(intno: byte; vector: pointer); +Procedure Keep(exitcode: word); + +implementation +uses globals; + +{****************************************************************************** + --- Conversion --- +******************************************************************************} + + function GetLastError : DWORD;stdcall; + external 'Kernel32.dll' name 'GetLastError'; + function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;stdcall; + external 'Kernel32.dll' name 'FileTimeToDosDateTime'; + function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;stdcall; + external 'Kernel32.dll' name 'DosDateTimeToFileTime'; + function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;stdcall; + external 'Kernel32.dll' name 'FileTimeToLocalFileTime'; + function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;stdcall; + external 'Kernel32.dll' name 'LocalFileTimeToFileTime'; + +type + Longrec=packed record + lo,hi : word; + end; + +function Last2DosError(d:dword):integer; +begin + Last2DosError:=d; +end; + + +Function DosToWinAttr (Const Attr : Longint) : longint; +begin + DosToWinAttr:=Attr; +end; + + +Function WinToDosAttr (Const Attr : Longint) : longint; +begin + WinToDosAttr:=Attr; +end; + + +Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean; +var + lft : TFileTime; +begin + DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and + LocalFileTimeToFileTime(lft,Wtime); +end; + + +Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean; +var + lft : TFileTime; +begin + WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and + FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo); +end; + + +{****************************************************************************** + --- Dos Interrupt --- +******************************************************************************} + +procedure intr(intno : byte;var regs : registers); +begin + { !!!!!!!! } +end; + +procedure msdos(var regs : registers); +begin + { !!!!!!!! } +end; + + +{****************************************************************************** + --- Info / Date / Time --- +******************************************************************************} + + function GetVersion : longint;stdcall; + external 'Kernel32.dll' name 'GetVersion'; + procedure GetLocalTime(var t : TSystemTime);stdcall; + external 'Kernel32.dll' name 'GetLocalTime'; + function SetLocalTime(const t : TSystemTime) : boolean;stdcall; + external 'Kernel32.dll' name 'SetLocalTime'; + +function dosversion : word; +begin + dosversion:=GetVersion; +end; + + +procedure getdate(var year,month,mday,wday : word); +var + t : TSystemTime; +begin + GetLocalTime(t); + year:=t.wYear; + month:=t.wMonth; + mday:=t.wDay; + wday:=t.wDayOfWeek; +end; + + +procedure setdate(year,month,day : word); +var + t : TSystemTime; +begin + { we need the time set privilege } + { so this function crash currently } + {!!!!!} + GetLocalTime(t); + t.wYear:=year; + t.wMonth:=month; + t.wDay:=day; + { only a quite good solution, we can loose some ms } + SetLocalTime(t); +end; + + +procedure gettime(var hour,minute,second,sec100 : word); +var + t : TSystemTime; +begin + GetLocalTime(t); + hour:=t.wHour; + minute:=t.wMinute; + second:=t.wSecond; + sec100:=t.wMilliSeconds div 10; +end; + + +procedure settime(hour,minute,second,sec100 : word); +var + t : TSystemTime; +begin + { we need the time set privilege } + { so this function crash currently } + {!!!!!} + GetLocalTime(t); + t.wHour:=hour; + t.wMinute:=minute; + t.wSecond:=second; + t.wMilliSeconds:=sec100*10; + SetLocalTime(t); +end; + + +Procedure packtime(var t : datetime;var p : longint); +Begin + p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25); +End; + + +Procedure unpacktime(p : longint;var t : datetime); +Begin + with t do + begin + sec:=(p and 31) shl 1; + min:=(p shr 5) and 63; + hour:=(p shr 11) and 31; + day:=(p shr 16) and 31; + month:=(p shr 21) and 15; + year:=(p shr 25)+1980; + end; +End; + + +{****************************************************************************** + --- Exec --- +******************************************************************************} +var + lastdosexitcode : word; + +procedure exec(const path : pathstr;const comline : comstr); +var + SI: TStartupInfo; + PI: TProcessInformation; + Proc : THandle; + l : DWord; + AppPath, + AppParam : array[0..255] of char; +begin + FillChar(SI, SizeOf(SI), 0); + SI.cb:=SizeOf(SI); + SI.wShowWindow:=1; + Move(Path[1],AppPath,length(Path)); + AppPath[Length(Path)]:=#0; + AppParam[0]:='-'; + AppParam[1]:=' '; + Move(ComLine[1],AppParam[2],length(Comline)); + AppParam[Length(ComLine)+2]:=#0; + if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end + else + DosError:=0; + Proc:=PI.hProcess; + CloseHandle(PI.hThread); + if WaitForSingleObject(Proc, Infinite) <> $ffffffff then + GetExitCodeProcess(Proc,l) + else + l:=$ffffffff; + CloseHandle(Proc); + LastDosExitCode:=l; +end; + + +function dosexitcode : word; +begin + dosexitcode:=lastdosexitcode; +end; + + +procedure getcbreak(var breakvalue : boolean); +begin +{ !! No Win32 Function !! } +end; + + +procedure setcbreak(breakvalue : boolean); +begin +{ !! No Win32 Function !! } +end; + + +procedure getverify(var verify : boolean); +begin +{ !! No Win32 Function !! } +end; + + +procedure setverify(verify : boolean); +begin +{ !! No Win32 Function !! } +end; + + +{****************************************************************************** + --- Disk --- +******************************************************************************} + +function diskfree(drive : byte) : longint; +var + disk : array[1..4] of char; + secs,bytes, + free,total : DWord; +begin + if drive=0 then + begin + disk[1]:='\'; + disk[2]:=#0; + end + else + begin + disk[1]:=chr(drive+64); + disk[2]:=':'; + disk[3]:='\'; + disk[4]:=#0; + end; + if GetDiskFreeSpace(@disk,secs,bytes,free,total) then + diskfree:=free*secs*bytes + else + diskfree:=-1; +end; + + +function disksize(drive : byte) : longint; +var + disk : array[1..4] of char; + secs,bytes, + free,total : DWord; +begin + if drive=0 then + begin + disk[1]:='\'; + disk[2]:=#0; + end + else + begin + disk[1]:=chr(drive+64); + disk[2]:=':'; + disk[3]:='\'; + disk[4]:=#0; + end; + if GetDiskFreeSpace(@disk,secs,bytes,free,total) then + disksize:=total*secs*bytes + else + disksize:=-1; +end; + + +{****************************************************************************** + --- Findfirst FindNext --- +******************************************************************************} + +{ Needed kernel calls } + function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;stdcall + external 'Kernel32.dll' name 'FindFirstFileA'; + function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): Boolean;stdcall; + external 'Kernel32.dll' name 'FindNextFileA'; + function FindCloseFile (hFindFile: THandle): Boolean;stdcall; + external 'Kernel32.dll' name 'FindClose'; + +Procedure StringToPchar (Var S : String); +Var L : Longint; +begin + L:=ord(S[0]); + Move (S[1],S[0],L); + S[L]:=#0; +end; + + +procedure FindMatch(var f:searchrec); +Var + TheAttr : Longint; +begin + TheAttr:=DosToWinAttr(F.Attr); +{ Find file with correct attribute } + While (F.W32FindData.dwFileAttributes and TheAttr)=0 do + begin + if not FindNextFile (F.FindHandle,F.W32FindData) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; + end; +{ Convert some attributes back } + f.size:=F.W32FindData.NFileSizeLow; + f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes); + WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time); + f.Name:=StrPas(@F.W32FindData.cFileName); +end; + + +procedure findfirst(const path : pathstr;attr : word;var f : searchRec); +begin +{ no error } + doserror:=0; + F.Name:=Path; + F.Attr:=attr; + StringToPchar(f.name); +{ FindFirstFile is a Win32 Call. } + F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData); + If longint(F.FindHandle)=longint(Invalid_Handle_value) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; +{ Find file with correct attribute } + FindMatch(f); +end; + + +procedure findnext(var f : searchRec); +begin +{ no error } + doserror:=0; + if not FindNextFile (F.FindHandle,F.W32FindData) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; +{ Find file with correct attribute } + FindMatch(f); +end; + + +procedure swapvectors; +begin +end; + + +Procedure FindClose(Var f: SearchRec); +begin + If longint(F.FindHandle)<>longint(Invalid_Handle_value) then + FindCloseFile(F.FindHandle); +end; + + +{****************************************************************************** + --- File --- +******************************************************************************} + + function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;stdcall; + external 'Kernel32.dll' name 'GetFileTime'; + function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;stdcall; + external 'Kernel32.dll' name 'SetFileTime'; + function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean;stdcall; + external 'Kernel32.dll' name 'SetFileAttributesA'; + function GetFileAttributes(lpFileName : pchar) : longint;stdcall; + external 'Kernel32.dll' name 'GetFileAttributesA'; + +procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr); +var + p1,i : longint; +begin + { allow slash as backslash } + for i:=1 to length(path) do + if path[i]='/' then path[i]:='\'; + { get drive name } + p1:=pos(':',path); + if p1>0 then + begin + dir:=path[1]+':'; + delete(path,1,p1); + end + else + dir:=''; + { split the path and the name, there are no more path informtions } + { if path contains no backslashes } + while true do + begin + p1:=pos('\',path); + if p1=0 then + break; + dir:=dir+copy(path,1,p1); + delete(path,1,p1); + end; + { try to find out a extension } + p1:=pos('.',path); + if p1>0 then + begin + ext:=copy(path,p1,4); + delete(path,p1,length(path)-p1+1); + end + else + ext:=''; + name:=path; +end; + + +function fexpand(const path : pathstr) : pathstr; + +var + s,pa : string[79]; + i,j : longint; +begin + getdir(0,s); + pa:=upper(path); + { allow slash as backslash } + for i:=1 to length(pa) do + if pa[i]='/' then + pa[i]:='\'; + + if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then + begin + { we must get the right directory } + getdir(ord(pa[1])-ord('A')+1,s); + if (ord(pa[0])>2) and (pa[3]<>'\') then + if pa[1]=s[1] then + pa:=s+'\'+copy (pa,3,length(pa)) + else + pa:=pa[1]+':\'+copy (pa,3,length(pa)) + end + else + if pa[1]='\' then + pa:=s[1]+':'+pa + else if s[0]=#3 then + pa:=s+pa + else + pa:=s+'\'+pa; + + { Turbo Pascal gives current dir on drive if only drive given as parameter! } + if length(pa) = 2 then + begin + getdir(byte(pa[1])-64,s); + pa := s; + end; + + {First remove all references to '\.\'} + while pos ('\.\',pa)<>0 do + delete (pa,pos('\.\',pa),2); + {Now remove also all references to '\..\' + of course previous dirs..} + repeat + i:=pos('\..\',pa); + if i<>0 then + begin + j:=i-1; + while (j>1) and (pa[j]<>'\') do + dec (j); + if pa[j+1] = ':' then j := 3; + delete (pa,j,i-j+3); + end; + until i=0; + + { Turbo Pascal gets rid of a \.. at the end of the path } + { Now remove also any reference to '\..' at end of line + + of course previous dir.. } + i:=pos('\..',pa); + if i<>0 then + begin + if i = length(pa) - 2 then + begin + j:=i-1; + while (j>1) and (pa[j]<>'\') do + dec (j); + delete (pa,j,i-j+3); + end; + pa := pa + '\'; + end; + { Remove End . and \} + if (length(pa)>0) and (pa[length(pa)]='.') then + dec(byte(pa[0])); + { if only the drive + a '\' is left then the '\' should be left to prevtn the program + accessing the current directory on the drive rather than the root!} + { if the last char of path = '\' then leave it in as this is what TP does! } + if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then + dec(byte(pa[0])); + { if only a drive is given in path then there should be a '\' at the + end of the string given back } + if length(path) = 2 then pa := pa + '\'; + fexpand:=pa; +end; + +Function FSearch(path: pathstr; dirlist: string): pathstr; +var + i,p1 : longint; + s : searchrec; + newdir : pathstr; +begin +{ No wildcards allowed in these things } + if (pos('?',path)<>0) or (pos('*',path)<>0) then + fsearch:='' + else + begin + { allow slash as backslash } + for i:=1 to length(dirlist) do + if dirlist[i]='/' then dirlist[i]:='\'; + repeat + p1:=pos(';',dirlist); + if p1=0 then + begin + newdir:=copy(dirlist,1,p1-1); + delete(dirlist,1,p1); + end + else + begin + newdir:=dirlist; + dirlist:=''; + end; + if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then + newdir:=newdir+'\'; + findfirst(newdir+path,anyfile,s); + if doserror=0 then + newdir:=newdir+path + else + newdir:=''; + until (dirlist='') or (newdir<>''); + fsearch:=newdir; + end; +end; + + +procedure getftime(var f;var time : longint); +var + ft : TFileTime; +begin + if GetFileTime(filerec(f).Handle,nil,nil,@ft) and + WinToDosTime(ft,time) then + exit + else + time:=0; +end; + + +procedure setftime(var f;time : longint); +var + ft : TFileTime; +begin + if DosToWinTime(time,ft) then + SetFileTime(filerec(f).Handle,nil,nil,@ft); +end; + + +procedure getfattr(var f;var attr : word); +var + l : longint; +begin + l:=GetFileAttributes(filerec(f).name); + if l=longint($ffffffff) then + doserror:=getlasterror; + attr:=l; +end; + + +procedure setfattr(var f;attr : word); +begin + doserror:=0; + if not(SetFileAttributes(filerec(f).name,attr)) then + doserror:=getlasterror; +end; + + +{****************************************************************************** + --- Environment --- +******************************************************************************} + +{ + The environment is a block of zero terminated strings + terminated by a #0 +} + + function GetEnvironmentStrings : pchar;stdcall; + external 'Kernel32.dll' name 'GetEnvironmentStringsA'; + function FreeEnvironmentStrings(p : pchar) : boolean;stdcall; + external 'Kernel32.dll' name 'FreeEnvironmentStringsA'; + +function envcount : longint; +var + hp,p : pchar; + count : longint; +begin + p:=GetEnvironmentStrings; + hp:=p; + count:=0; + while hp^<>#0 do + begin + { next string entry} + hp:=hp+strlen(hp)+1; + inc(count); + end; + FreeEnvironmentStrings(p); + envcount:=count; +end; + + +Function EnvStr(index: integer): string; +var + hp,p : pchar; + count,i : longint; +begin + { envcount takes some time in win32 } + count:=envcount; + + { range checking } + if (index<=0) or (index>count) then + begin + envstr:=''; + exit; + end; + p:=GetEnvironmentStrings; + hp:=p; + + { retrive the string with the given index } + for i:=2 to index do + hp:=hp+strlen(hp)+1; + + envstr:=strpas(hp); + FreeEnvironmentStrings(p); +end; + + +Function GetEnv(envvar: string): string; +var + s : string; + i : longint; + hp,p : pchar; +begin + getenv:=''; + p:=GetEnvironmentStrings; + hp:=p; + while hp^<>#0 do + begin + s:=strpas(hp); + i:=pos('=',s); + if copy(s,1,i-1)=envvar then + begin + getenv:=copy(s,i+1,length(s)-i); + break; + end; + { next string entry} + hp:=hp+strlen(hp)+1; + end; + FreeEnvironmentStrings(p); +end; + + +{****************************************************************************** + --- Not Supported --- +******************************************************************************} + +Procedure keep(exitcode : word); +Begin +End; + +Procedure getintvec(intno : byte;var vector : pointer); +Begin +End; + +Procedure setintvec(intno : byte;vector : pointer); +Begin +End; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/05/12 05:51:43 pierre + * Reset DosError in Exec reported by Kovacs Attila Zoltan + + Revision 1.8 2000/05/11 09:56:20 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.7 2000/02/09 13:22:52 peter + * log truncated + + Revision 1.6 2000/01/07 01:14:23 peter + * updated copyright to 2000 + +} \ No newline at end of file diff --git a/befpc/compiler/errord.msg b/befpc/compiler/errord.msg new file mode 100644 index 0000000..b10613e --- /dev/null +++ b/befpc/compiler/errord.msg @@ -0,0 +1,1856 @@ +# +# $Id: errord.msg,v 1.1.1.1 2001-07-23 17:15:59 memson Exp $ +# This file is part of the Free Pascal Compiler +# Copyright (c) 1998-2000 by the Free Pascal Development team +# +# German (alternative) Language File for Free Pascal +# +# 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. +# +# +# The constants are build in the following order: +# __ +# +# is the part of the compiler the message is used +# asmr_ assembler parsing +# asmw_ assembler writing/binary writers +# unit_ unit handling +# scan_ scanner +# parser_ parser +# type_ type checking +# general_ general info +# exec_ calls to assembler, linker, binder +# +# the type of the message it should normally used for +# f_ fatal error +# e_ error +# w_ warning +# n_ note +# h_ hint +# i_ info +# l_ linenumber +# u_ used +# t_ tried +# m_ macro +# p_ procedure +# c_ conditional +# d_ debug message +# b_ display overloaded procedures +# x_ executable informations +# + +# +# General +# +# BeginOfTeX +% \section{General compiler messages} +% This section gives the compiler messages which are not fatal, but which +% display useful information. The number of such messages can be +% controlled with the various verbosity level \var{-v} switches. +% \begin{description} +general_t_compilername=01000_T_Compiler: $1 +% When the \var{-vt} switch is used, this line tells you what compiler +% is used. +general_d_sourceos=01001_D_Hostbetriebssystem: $1 +% When the \var{-vd} switch is used, this line tells you what the source +% operating system is. +general_i_targetos=01002_I_Zielbetriebssystem: $1 +% When the \var{-vd} switch is used, this line tells you what the target +% operating system is. +general_t_exepath=01003_T_Der Pfad der ausfhrbaren Datei ist: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's binaries. +general_t_unitpath=01004_T_Der Unitpfad ist: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for compiled units. You can set this path with the \var{-Fu} +general_t_includepath=01005_T_Der Includepfad ist: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's include files (files used in \var{\{\$I xxx\}} statements). +% You can set this path with the \var{-I} option. +general_t_librarypath=01006_T_Der Bibliothekspfad ist: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for the libraries. You can set this path with the \var{-Fl} option. +general_t_objectpath=01007_T_Der Objektdateienpfad: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for object files you link in (files used in \var{\{\$L xxx\}} statements). +% You can set this path with the \var{-Fo} option. +general_i_abslines_compiled=01008_I_$1 Zeilen kompiliert, $2 Sekunden +% When the \var{-vi} switch is used, the compiler reports the number +% of lines compiled, and the time it took to compile them (real time, +% not program time). +general_f_no_memory_left=01009_F_Speicher voll +% The compiler doesn't have enough memory to compile your program. There are +% several remedies for this: +% \begin{itemize} +% \item If you're using the build option of the compiler, try compiling the +% different units manually. +% \item If you're compiling a huge program, split it up in units, and compile +% these separately. +% \item If the previous two don't work, recompile the compiler with a bigger +% heap (you can use the \var{-Ch} option for this, \seeo{Ch}) +% \end{itemize} +general_i_writingresourcefile=01010_I_Resourcestringtabellendatei $1 wird geschrieben +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_Fehler beim Schreiben der Resourcestringtabellendatei: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +scan_f_end_of_file=02000_F_Unerwartetes Dateiende +% this typically happens in one of the following cases : +% \begin{itemize} +% \item The source file ends before the final \var{end.} statement. This +% happens mostly when the \var{begin} and \var{end} statements aren't +% balanced; +% \item An include file ends in the middle of a statement. +% \item A comment wasn't closed. +% \end{itemize} +scan_f_string_exceeds_line=02001_F_Zeichenkette geht ber Zeilenende hinaus +% You forgot probably to include the closing ' in a string, so it occupies +% multiple lines. +scan_f_illegal_char=02002_F_Unzulssiges Zeichen +% An illegal character was encountered in the input file. +scan_f_syn_expected=02003_F_Syntaxfehler, $1 erwartet aber $2 vorgefunden +% This indicates that the compiler expected a different token than +% the one you typed. It can occur almost everywhere where you make a +% mistake against the pascal language. +scan_t_start_include_file=02004_T_Die Include-Datei $1 wird jetzt gelesen +% When you provide the \var{-vt} switch, the compiler tells you +% when it starts reading an included file. +scan_w_comment_level=02005_W_Kommentarschachtelungstiefe $1 gefunden +% When the \var{-vw} switch is used, then the compiler warns you if +% it finds nested comments. Nested comments are not allowed in Turbo Pascal +% and can be a possible source of errors. +scan_n_far_directive_ignored=02006_N_$F Direktive (FAR) ignoriert +% The \var{FAR} directive is a 16-bit construction which is recorgnised +% but ignored by the compiler, since it produces 32 bit code. +scan_n_stack_check_global_under_linux=02007_N_Stackprfung ist unter Linux global +% Stack checking with the \var{-Cs} switch is ignored under \linux, since +% \linux does this for you. Only displayed when \var{-vn} is used. +scan_n_ignored_switch=02008_N_Compilerschalter $1 wurde ignoriert +% With \var{-vn} on, the compiler warns if it ignores a switch +scan_w_illegal_switch=02009_W_Compilerschalter $1 ist ungltig +% You included a compiler switch (i.e. \var{\{\$... \}}) which the compiler +% doesn't know. +scan_w_switch_is_global=02010_W_Dieser Compilerschalter hat globale Auswirkung +% When \var{-vw} is used, the compiler warns if a switch is global. +scan_e_illegal_char_const=02011_E_Ungltige Char-Konstantante +% This happens when you specify a character with its ASCII code, as in +% \var{\#96}, but the number is either illegal, or out of range. The range +% is 1-255. +scan_f_cannot_open_input=02012_F_Datei $1 kann nicht geffnet werden +% \fpc cannot find the program or unit source file you specified on the +% command line. +scan_f_cannot_open_includefile=02013_F_Includedatei $1 kann nicht geffnet werden +% \fpc cannot find the source file you specified in a \var{\{\$include ..\}} +% statement. +scan_e_too_much_endifs=02014_E_Zu viele $ENDIF oder $ELSE Direktiven +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_w_only_pack_records=02015_W_Record-Elemente knnen nur im Raster 1,2,4 oder 16 Bytes ausgerichtet werden +% You are specifying the \var{\{\$PACKRECORDS n\} } with an illegal value for +% \var{n}. Only 1,2,4 or 16 are valid in this case. +scan_w_only_pack_enum=02016_W_Fr Aufzhlungen knnen nur die Gren 1,2 or 4 Bytes angegeben werden +% You are specifying the \var{\{\$PACKENUM n\}} with an illegal value for +% \var{n}. Only 1,2 or 4 are valid in this case. +scan_e_endif_expected=02017_E_$1 erwartet fr $2 definiert in Zeile $3 +% Your conditional compilation statements are unbalanced. +scan_e_preproc_syntax_error=02018_E_Syntaxfehler im Argument einer $if Direktive +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_e_error_in_preproc_expr=02019_E_Syntaxfehler im Kontext einer $if Direktive +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_w_macro_cut_after_255_chars=02020_W_Inhalt des Makros wurde nach der Auswertung bei 255 Zeichen abgeschnitten +% The contents of macros cannot be longer than 255 characters. This is a +% safety in the compiler, to prevent buffer overflows. This is shown as a +% warning, i.e. when the \var{-vw} switch is used. +scan_e_endif_without_if=02021_E_ENDIF ohne IF(N)DEF +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_f_user_defined=02022_F_Benutzerdefiniert: $1 +% A user defined fatal error occurred. see also the \progref +scan_e_user_defined=02023_E_Benutzerdefiniert: $1 +% A user defined error occurred. see also the \progref +scan_w_user_defined=02024_W_Benutzerdefiniert: $1 +% A user defined warning occurred. see also the \progref +scan_n_user_defined=02025_N_Benutzerdefiniert: $1 +% A user defined note was encountered. see also the \progref +scan_h_user_defined=02026_H_Benutzerdefiniert: $1 +% A user defined hint was encountered. see also the \progref +scan_i_user_defined=02027_I_Benutzerdefiniert: $1 +% User defined information was encountered. see also the \progref +scan_e_keyword_cant_be_a_macro=02028_E_Ein Makro, welches den selben Namen wie ein Schlsselwort hat, wird ignoriert +% You cannot redefine keywords with macros. +scan_f_macro_buffer_overflow=02029_F_Makropufferberlauf whrend des Lesens oder Expandierens eines Makros +% Your macro or it's result was too long for the compiler. +scan_w_macro_deep_ten=02030_W_Expansion des Makros berschreitet eine Makroschachtelungstiefe von 16 +% When expanding a macro macros have been nested to a level of 16. +% The compiler will expand no further, since this may be a sign that +% recursion is used. +scan_e_wrong_styled_switch=02031_E_Compilerschalter in (* ... *)-Kommentaren sind nicht erlaubt +% Compiler switches should always be between \var{\{ \}} comment delimiters. +scan_d_handling_switch=02032_D_Bearbeite Schalter "$1" +% When you set debugging info on (\var{-vd}) the compiler tells you when it +% is evaluating conditional compile statements. +scan_c_endif_found=02033_C_ENDIF $1 bearbeitet +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifdef_found=02034_C_IFDEF $1 bearbeitet, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifopt_found=02035_C_IFOPT $1 bearbeitet, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_if_found=02036_C_IF $1 bearbeitet, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifndef_found=02037_C_IFNDEF $1 bearbeitet, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_else_found=02038_C_ELSE $1 bearbeitet, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_skipping_until=02039_C_Quelltext wird ignoriert bis... +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements, and whether it is skipping or +% compiling parts. +scan_i_press_enter=02040_I_Drcken Sie um fortzusetzen +% When the \var{-vi} switch is used, the compiler stops compilation +% and waits for the \var{Enter} key to be pressed when it encounters +% a \var{\{\$STOP\}} directive. +scan_w_unsupported_switch=02041_W_Nicht untersttzter Schalter $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unsupported switches. This means that the switch is used in Delphi or +% Turbo Pascal, but not in \fpc +scan_w_illegal_directive=02042_W_Ungltiges Compilerdirektive $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unrecognised switches. For a list of recognised switches, \progref +scan_t_back_in=02043_T_Wieder zurck in $1 +% When you use (\var{-vt}) the compiler tells you when it has finished +% reading an include file. +scan_w_unsupported_app_type=02044_W_Nicht untersttzter Anwendungstyp: $1 +% You get this warning, ff you specify an unknown application type +% with the directive \var{\{\$APPTYPE\}} +scan_w_app_type_not_support=02045_W_APPTYPE wird vom Zielbetriebssystem nicht untersttzt +% The \var{\{\$APPTYPE\}} directive is supported by win32 applications only. +scan_w_decription_not_support=02046_W_DESCRIPTION kann nur bei OS/2- und Windows-Programmen verwendet werden +% The \var{\{\$DESCRIPTION\}} directive is only supported for OS2 and Win32 targets. +scan_n_version_not_support=02047_N_VERSION wird vom Zielbetriebssystem nicht untersttzt +% The \var{\{\$VERSION\}} directive is only supported by win32 target. +scan_n_only_exe_version=02048_N_VERSION kann in Units nicht verwendet werden +% The \var{\{\$VERSION\}} directive is only used for executable or DLL sources. +scan_w_wrong_version_ignored=02049_W_Falsches Format fr VERSION-Directive $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_Nicht untersttzter Assemblermodus $1 angegeben +% When you specify an assembler mode with the \var{\{\$ASMMODE xxx\}} +% the compiler didn't recognize the mode you specified. +scan_w_no_asm_reader_switch_inside_asm=02051_W_ASM-Leser-Schalter ist innerhalb einer Asm-Sequenz nicht mglich, $1 wird erst in der nchsten Sequenz wirksam +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Parameter fr Schalter falsch, verwenden Sie ON/OFF oder +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_Resourcedateien werden vom aktuellen Zielbetriebssystem nicht untersttzt +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +scan_w_include_env_not_found=02054_W_$1 ist keine Umgebungsvariable +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_Nicht erlaubter Wert fr MAXFPUREGISTER-Direktive +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +scan_w_only_one_resourcefile_supported=02056_W_Nur ein Resourcedatei wird vom aktuellen Zielbetriebssystem untersttzt +% Only one resource file can be supported for this target - this is the case of +% OS/2 (EMX) currently. The first one found is used, the others are discarded. +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +parser_e_syntax_error=03000_E_Parser - Syntaxfehler +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_Schlsselwort FAR wurde ignoriert +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_Schlsselwort NEAR wurde ignoriert +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_Ignoriere Prozedurtyp INTERRUPT +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is igonred for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT-Prozeduren drfen nicht verschachtelt sein +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_Prozedurtyp $1 wird ignoriert +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_Nicht alle Deklarationen von "$1" sind mit OVERLOAD deklariert +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_Keine DLL-Datei angegeben +% No longer in use. +parser_e_export_name_double=03008_E_Doppelter Name fr exportierte Funktion $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_Doppelter Index fr exportierte Funktion $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Ungltiger Index for exportierte Funktion +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_Fr relozierbare DLL oder ausfhrbare Datei $1 funktionieren keine Debug-Information, deaktiviert. +parser_w_parser_win32_debug_needs_WN=03012_W_Um Win32-Code debuggen zu knnen mssen die Relozierungen mit -WN option abgeschaltet werden. +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_Konstruktor-Name muss INIT sein +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_Destruktor-Name muss DONE sein +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Ungltiger Open-Parameter +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_Schlsselwort INLINE nicht untersttzt +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Private Methoden drfen nicht VIRTUAL sein +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_Konstruktor muss PUBLIC sein +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_Destruktor muss PUBLIC sein +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_Klasse darf nur einen Destructor besitzen +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_Lokale Klassendefinitionen sind nicht zulssig +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_Anonyme Klassendefinitionen sind nicht zulssig +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_Das Objekt $1 hat keine VMT +parser_e_illegal_parameter_list=03024_E_Ungltige Parameterliste +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Falscher Parametertyp angegeben fr Argument Nr. $1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Falsche Parameterzahl angegeben +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_Bezeichner $1 ist keine Funktion, overload nicht mglich +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_Overload-Funktion darf nicht eine identische Parameterliste aufweisen +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_Funktionskopf ist nicht identisch mit Forward-Deklaration $1 +% You declared a function with same parameters but +% different result type or function specifiers. +parser_e_header_different_var_names=03030_E_Funktionskopf von $1 passt nicht zur Forward-Deklaration, Variablename ndert sich: $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_Werte in Aufzhlungen mssen aufsteigend sein +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Namen in Interface und Implementation sind verschieden! +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_WITH kann nicht auf Variablen in anderen Segmenten angewendet werden +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_Funktionsverschachtelung grsser als 31 +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_Bereichsprfungsfehler bei Konstantenbestimmung +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_Bereichsprfungsfehler bei Konstantenbestimmung +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_doppelter CASE-Wert +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_Obere Grenze der CASE-Bereichsangabe ist kleiner als untere Grenze +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_Klassen sind als typisierte Konstanten unzulssig +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_Funktionsvariablen von Overload-Funktionen sind unzulssig +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_Stringlnge muss ein Wert zwischen 1 und 255 sein +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_Benutzen Sie die erweiterte Syntax von NEW und DISPOSE fr Objekt-Instanzen +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_Verwendung von NEW oder DISPOSE mit untypisierten Pointern ist ohne Aussage +parser_e_no_new_dispose_on_void_pointers=03044_E_Verwendung von NEW oder DISPOSE mit untypisierten Pointern ist nicht mglich +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_Klassenbezeichner erwartet +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_Typbezeichner ist hier nicht zulssig +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_Methodenbezeichner erwartet +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_Funktionskopf passt zu keiner Methode der Klasse +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_Prozedur/Funktion $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Ungltige Fliesskommakonstante +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL darf nur in Konstruktoren verwendet werden +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_Destruktoren knnen keine Parameter haben +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_Nur Klassenmethoden knnen ber den Klassennamen angesprochen werden +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_Nur Klassenmethoden knnen in einer Klassenmethode angesprochen werden +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_Konstante und CASE-Typ passen nicht zueinander +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_Das Symbol kann nicht aus einer Bibliothek exportiert werden +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_Eine Inherit-Methode wird durch $1 verdeckt +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_Es gibt keine Vorgngerklasse mit einer Methode, die damit berschrieben werden knnte: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_Es gibt keine Member-Funktion um auf diese Property zuzugreifen +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_Die Stored Property - Direktive ist noch nicht implementiert +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Ungltiges Symbol fr den Zugriff auf die Property +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_Kann an dieser Stelle nicht auf das geschtzte Feld des Objekts zugreifen +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_Kann an dieser Stelle nicht auf das private Feld des Objekts zugreifen +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_Overload-Methode einer virtuellen Methode muss auch virtuell sein: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_Overload-Methode einer nicht-virtuellen Methode muss auch nicht-virtuell sein: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_Overload-Methoden, die virtuell sind, mssen den gleichen Rckgabetyp haben: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_Mit EXPORT deklarierte Funktionen drfen nicht verschachtelt sein +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_Methoden drfen nicht EXPORTiert werden +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_Aufrufe mit VAR-Parametern mssen exakt stimmen +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_Klasse ist keine Elternklasse zur aktuellen Klasse +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF ist nur in Methoden erlaubt +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_Methoden drfen nur in anderen Methoden direkt mit dem Klassen-Typbezeichner aufgerufen werden +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Unzulssige Verwendung von ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_Bereichsprfungsfehler im SET-Konstruktor oder doppeltes Set-Element +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_Zeiger auf Objekt erwartet +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_Ausdruck muss ein Konstruktor-Aufruf sein +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_Ausdruck muss ein Destruktor-Aufruf sein +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Unzulssige Reihenfolge der Record-Elemente +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_Typ des Ausdrucks muss eine Klasse oder ein Recordtyp sein +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_Prozeduren knnen keinen Wert zurckliefern +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_Konstruktoren und Destruktoren mssen Methoden sein +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_Operator besitzt kein Overload +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_Es ist nicht mglich, die Zuweisung fr gleiche Typen zu berladen +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_Unmgliche Operator-.berladung +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_Auslsen einer Exception an dieser Stelle nicht mglich +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_Die erweiterte Syntax von New oder Dispose ist fr Klassen unzulssig +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_Assembler-Funktion nicht mit diesem Rckgabetyp mglich +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_Das berladen von Prozeduren ist ausgeschaltet +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_Es ist nicht mglich, dieesen Operator zu berladen (benutzen Sie stattdessen '=') +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_Vergleichsoperator muss einen booleschen Wert zurckgeben +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_Nur virtuelle Methoden knnen abstrakt sein +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_Benutzung einer nicht untersttzten Erweiterung! +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_Das Mischen von Klassen und Objekten ist unzulssig +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_Unbekannte Prozedur, Direktive $1 wurde ignoriert +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_ABSOLUTE kann nur auf eine alleinstehende Variable angewendet werden +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \begin{itemize} +% \item [ absolute can only be associated a var or const ] +% \end{itemize} +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_ABSOLUTE kann nur auf Variablen und Konstanten angewendet werden +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_Es kann nur EINE Variable initialisiert werden +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_Abstrakte Methoden drfen keine Definition (mit Rumpf) haben +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_Diese berladene Funktion darf nicht lokal sein (muss Exportiert werden) +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_Virtuelle Methoden wurden ohne Konstruktor verwendet in $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_Makro definiert: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_Makro gelscht: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_Makro $1 auf $2 gesetzt +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_Kompiliere $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_Parse Interface von Unit $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_Parse Implementation von $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_Kompiliere $1 zum zweiten Mal +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_Array-Eigenschaften sind an dieser Stelle nicht erlaubt +% You cannot use array properties at that point. +parser_e_no_property_found_to_override=03109_E_Es gibt keine Property diesen Namens, die berschrieben werden knnte +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_Es ist nur eine einzelne Default-Property erlaubt, vererbte Default-Property in Klasse $1 gefunden +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_Die Default-Property muss eine Array-Property sein +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_Virtuelle Konstruktoren werden nur im Klassen-Objektmodell untersttzt +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_Keine Default-Property verfgbar +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_Die Klasse kann keinen PUBLISHED Bereich haben, benutzen Sie den {$M+} Schalter +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_Forward-Deklaration der Klasse $1 muss hier aufgelst werden, wenn sie als Elternklasse benutzt werden soll +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_Lokale Operatoren werden nicht untersttzt +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_Prozedur-Direktive $1 unzulssig im Interface-Bereich +% This procedure directive is not allowed in the \var{interface} section of +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_Prozedur Direktive $1 unzulssig im Implementation-Bereich +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_Prozedur-Direktive $1 unzulssig in einer Procvar-Deklaration +% This procedure directive cannot be part of a procedural of function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_Funktion ist bereits als Public oder Forward deklariert: $1 +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_Kann nicht EXPORT und EXTERNAL gleichzeitig benutzen +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_Schlsselwort NAME erwartet +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 noch nicht innerhalb von inline Prozeduren/Funktionen untersttzt +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_Inlining deaktiviert +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_Schreibe Browser-Log $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+\}} switch). +parser_h_maybe_deref_caret_missing=03126_H_Mglicherweise fehlt eine Zeiger-Dereferenzierung +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_Gewhlter Assembler-Leser nicht untersttzt +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_Prozedur-Direktive $1 steht in Konflikt mit anderen Direktiven +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_Aufrufkonvention passt nicht zur Forward-Deklaration +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_Register-Aufrufkonvention (fastcall) nicht untersttzt +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_Property kann keinen Vorgabewert haben +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_Der Vorgabewert einer Property muss eine Konstante sein +% The value of a \var{default} declared property must be known at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_Symbol darf nicht PUBLISHED sein, dies kann nur eine Klasse sein +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_Diese Property-Art kann nicht Published sein +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_Leerer Importname angegeben +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_Leerer Importname angegeben +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_Funktionsinterner Name hat sich nach der Verwendung einer Funktion gendert +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_Division durch Null +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Ungltige Fliesskomma-Operation +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_Obere Grenze des Bereichs ist kleiner als die untere Grenze +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_String "$1" ist lnger als $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_Stringlnge ist grsser als die Lnge des "array of char" +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Ungltiger Ausdruck nach der 'Message'-Direktive +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_Message-Handler akzeptieren nur einen "Call by Reference" Parameter +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_Doppeltes Message-Label: $1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_SELF darf nur in Message-Handlern ein expliziter Parameter sein +% The self parameter can be passed only explicit if it is a method which +% is declared as message method handler +parser_e_threadvars_only_sg=03147_E_Threadvariablen knnen nur statisch oder global sein +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_Direkter Assembler wird f+r binres Ausgabeformat nicht untersttzt +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_Laden Sie die OBJPAS Unit nicht manuell, benutzen Sie statdessen {$mode objfpc} oder {$mode delphi} +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_OVERRIDE darf in Objekten nicht verwendet werden +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +parser_e_cant_use_inittable_here=03151_E_Datentypen, die ein Initialiserung oder Finalisierung bentigen, knnen in varianten Records nicht verwendet werden +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_Resourcestrings drfen nur statisch oder global sein +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_EXIT mit Argument darf hier nicht verwendet werden +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_Der Typ des STORED-Symbols muss boolesch sein +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_Dieses Symbol ist als Speichersymbol unzulssig +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_Nur Klassen, die im "$M+"-Modus kompiliert wurden, drfen published sein +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_Prozedurdirektive erwartet +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_Der Wert fr einen Property-Index muss ordinalen Typs sein +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_Prozedurname zu kurz um exportiert zu werden +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_Es kann kein DEFFILE-Eintrag fr unit-globale Variablen erzeugt werden +parser_e_dlltool_unit_var_problem2=03161_E_Kompiliere ohne "-WD"-Option +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Typen passen nicht zusammen +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Inkompatible Typen: Habe "$1" erhalten, aber "$2" erwartet +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_Typen sind verschieden bei $1 und $2 +% The types are not equal +type_e_type_id_expected=04003_E_Typbezeichner erwartet +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_Variablenbezeichner erwartet +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_Integer-Ausdruck erwartet, aber "$1" erhalten +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_Booleschen Ausdruck erwartet, aber "$1" erhalten +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_Ganzahligen Ausdruck erwartet +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_Zeigertyp erwartet, aber "$1" erhalten +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_Klassentyp erwartet, aber "$1" erhalten +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_Variable oder Typbezeichner erwartet +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_Kann konstanten Ausdruck nicht auswerten +% No longer in use. +type_e_set_element_are_not_comp=04012_E_Set-Elemente sind nicht kompatibel +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_Operation fr Sets nicht implementiert +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_Automatische Typumwandlung von Fliesskommatyp nach COMP (=integer mit 64 bit) +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_Verwenden sie DIV um ein Integer-Ergebnis zu erhalten +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_Stringtypen passen nicht zueinander, da in "$V+"-Modus +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_Succ oder Pred kann nicht auf Aufzhlungen mit Zuweisungen angewendet werden +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_Kann Variablen dieses Typs nicht lesen oder schreiben +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_Kann ReadLn und WriteLn nicht bei typisierten Dateien verwenden +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_Kann Read und Write nicht bei untypisierten Dateien verwenden +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_Typkonflikt zwischen den Elementen des Sets +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_lo/hi(dword/qword) gibt oberes/unteres Word/DWord zurck +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword/int64/qword} +% which returns the lower/upper word of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type case the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_Integer- oder Real-Ausdruck erwartet +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Falscher Typ im Array-Konstructor +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Inkompatible Typen fr Argument Nr. #$1: habe $2 erhalten, aber $3 erwartet +% You are trying to pass an invalid type for the specified parameter. +type_e_no_method_and_procedure_not_compatible=04026_E_Methode (Variable) und Prozedur (Variable) sind nicht kompatibel +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_Unzulssige Konstante an interne Algebrafunktion bergeben +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_Von Konstanten kann keine Adresse bestimmt werden +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +type_e_argument_cant_be_assigned=04029_E_Auf das Argument kann nichts zugewiesen werden +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_Kann lokale Prozedur/Funktion nicht an Prozedurvariable zuweisen +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_Kann einer Adresse keine Werte zuweisen +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_Kann einer Konstanten keine Werte zuweisen +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_Bezeichner "$1" nicht gefunden +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_Interner Fehler in SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_Doppelter Bezeichner "$1" +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_Bezeichner ist bereits definiert in $1 in Zeile $2 +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_Unbekannter Bezeichner "$1" +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_Forward-Deklaration "$1" nicht gefunden +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_Bezeichnertyp ist bereits als Typ definiert +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_Fehler in Typdefinition +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_Typbezeichner nicht definiert +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_Forward-Typ "$1" nicht gefunden +% The compiler encountered an unknown type. +sym_e_only_static_in_static=05010_E_Nur statische Variablen knnen in statischen oder usseren Methoden verwendet werden +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Ungltiger Aufruf von tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_Record- oder Klassen-Typ erwartet +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_Instanzen von Klassen oder Objekten mit abstrakten Methoden sind unzulssig +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_Label "$1" nicht definiert +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_Label "$1" benutzt aber nicht definiert +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Ungltige Label-Deklaration +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO und LABEL werden nicht untersttzt (verwenden Sie den Schalter -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_Label nicht gefunden +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_Bezeichner ist kein Label +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_Label ist bereits definiert +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_Ungltige Typdeklaration von Set-Elementen +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_Forward-Klassendefinition nicht gefunden: $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_Unit "$1" wird von "$2" nicht verwendet +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_Parameter nicht verwendet: $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_Lokale Variable nicht verwendet: $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_Werte-Parameter "$1" wurde zugewiesen aber nie verwendet +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_Lokale Variable "$1" wurde zugewiesen aber nicht verwendet +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_Lokales $1-Element "$2" wird nicht verwendet +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Privates Feld $1.$2 wird nie verwendet +sym_n_private_identifier_only_set=05030_N_Privates Feld $1.$2 wurde zugewiesen aber nie verwendet +sym_n_private_method_not_used=05031_N_Private Methode $1.$2 wird nie verwendet + + +sym_e_set_expected=05032_E_Mengentyp erwartet +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_Funktionsergebnis scheint keine Menge zu sein +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_Typ "$1" ist im aktuellen Record mit C-Packing nicht korrekt ausgerichtet +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_Unbekannter Record-Feldbezeichner $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_Lokale Variable "$1" wird verwendet, bevor ihr ein Wert zugewiesen wurde +sym_n_uninitialized_variable=05037_W_Variable "$1" scheint nicht initialisert worden zu sein +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_Bezeichener verweist nicht auf ein Element: $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_Deklaration gefunden: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +sym_e_segment_too_large=05040_E_Datensegment zu gross (max. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK nicht zulssig +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE nicht zulssig +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_Ausdruck zu komplex - FPU Stackberlauf +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Ungltiger Ausdruck +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Ungltiger Ausdruck, kein Integer +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_Ungltige Kombination +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_Oberes Bereichsende < unteres Bereichsende +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Unzulssige Zhlvariable +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_Kann mich bestimmen, welche berladene Funktion aufgerufen werden soll +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_Grsse der Parameterliste bersteigt 65535 Bytes +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Unzulssige Typumwandlung +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_Umwandlung zwischen ganzen Zahlen und Pointern ist zwischen verschiedenen Plattformen nicht portabel +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_Dateitypen mssen VAR Parameter sein +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_Die Verwendung eines FAR-Zeigers ist in dieser Art nicht erlaubt +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_Unzulssiger "call by reference"-Parameter +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_Mit EXPORT deklarierte Funktionen knnen nicht aufgerufen werden +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_Mglicherweise unzulssiger Aufruf eines Konstruktors oder Destruktors (passt nicht in diesen Kontext) +% No longer in use. +cg_n_inefficient_code=06017_N_Uneffiziente Programmierung +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_Code wird niemals ausgefhrt +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_Prozeduraufruf mit Stackframe ESP/SP +% The compiler enocountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_Abstrakte Methoden knnen nicht direkt aufgerufen werden +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_Interner Fehler in getfloatreg(), Allozierungsfehler +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_Unbekannter Fliesskommatyp +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() Basis wurde zweimal definiert +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_Extended wird auf der m68k-Plattform nicht untersttzt +% The var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_Vorzeichenlose 32-Bit-Typen werden im MC68000-Modus nicht unterstzt +% The cardinal/dword is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_Interner Fehler in secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_Register $1 Gewichtung $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_Stacklimit in lokaler Routine berschritten +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_Stackframe wird ausgelassen +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_Bereichsberprfung fr 64-Bit-Integer wird fr die Zielplattform nicht untersttzt +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_Objektmethoden knnen nicht Inline sein +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_Procvar-Aufrufe knnen nicht Inline sein +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_Kein Code fr Inline-Prozedur gespeichert +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_Direkter Aufruf von Interruptprozedur $1 ist nicht mglich +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Auf Element Null von Ansi/Wide- oder Longstring kann nicht zugegriffen werden, benutzen Sie stattdessen (Set)Length +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_Include und Exclude sind fr diesen Fall noch nicht implementiert +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_Konstruktoren und Destruktoren knnen in diesem Kontext nicht aufgerufen werden +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_Kann Messagehandler-Methode nicht direkt aufrufen +% A message method handler method can't be called directly if it contains an +% explicit self argument +% \end{description} +# EndOfTeX +# +# Assembler reader +# +cg_e_goto_inout_of_exception_block=06039_E_Sprung in- oder aus Exceptionblock heraus +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +# EndOfTeX +cg_e_control_flow_outside_finally=06040_E_Kontrollfluss-Anweisungen sind in einem Finally-Block nicht erlaubt +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX + +# +# Assembler reader +# +asmr_d_start_reading=07000_D_Starte $1 Stil Assembler Parsen +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_Beende $1 Stil Assembler Parsen +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_Nicht-Label Bezeichner enthlt @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_Override-Operator wird nicht untersttzt +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_Fehler beim Ermitteln des Recordoffsets +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET ohne Bezeicner verwendet +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE verwendet ohne Bezeichner +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_Lokale Variable oder Parameter knnen hier nicht verwendet werden +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_Hier muss OFFSET verwendet werden +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_Hier muss "$" verwendet werden +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_Verwendung von mehreren verschiebbaren Symbolen nicht mglich +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_Verschiebbares Symbol kann nur addiert werden +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Ungltiger Konstantenausdruck +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_Verschiebbares Symbol ist nicht zulssig +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Ungltige Verweis-Syntax +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_Sie knnen "$1" von diesem Code aus nicht erreichen +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_Lokale Symbole/Labels sind nicht als Referenz zulssig +% You can't use local symbols/labels as references +asmr_e_wrong_base_index=07017_E_Ungltige Verwendung von Basis- und Index-Registern +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_Mglicher Fehler bei Objektfeld-Behandlung +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Falscher Skalierungsfaktor angegeben +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_Mehrfache Verwendung fon Index-Registern +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Ungltiger Operandentyp +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Unglitge Zeichenkette als Opcode-Operand: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE und @DATA werden nicht untersttzt +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_Null-Label-Bezug nicht mglich +asmr_e_expr_zero_divide=07025_E_Division durch Null in Assembler-Ausdruck +asmr_e_expr_illegal=07026_E_Ungltiger Ausdruck +asmr_e_escape_seq_ignored=07027_E_Escape-Sequenz ignoriert: $1 +asmr_e_invalid_symbol_ref=07028_E_Ungltige Symbolverwendung +asmr_w_fwait_emu_prob=07029_W_FWAIT kann Emulationsprobleme mit emu387 verursachen +asmr_w_fadd_to_faddp=07030_W_FADD ohne Operand wurde in FADDPbersetzt +asmr_w_enter_not_supported_by_linux=07031_W_Der ENTER-Befehl wird vom Linux-Kernel nicht untersttzt +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_Aufruf einer berladenen Funktion in Assembler +asmr_e_unsupported_symbol_type=07033_E_Nicht untersttzter Symboltyp fr Operand +asmr_e_constant_out_of_bounds=07034_E_Wert der Konstante ausserhalb des zulssigen Bereichs +asmr_e_error_converting_decimal=07035_E_Fehler beim Umwandeln in Dezimal $1 +asmr_e_error_converting_octal=07036_E_Fehler beim Umwandeln in Oktal $1 +asmr_e_error_converting_binary=07037_E_Fehler beim Umwandeln in Binr $1 +asmr_e_error_converting_hexadecimal=07038_E_Fehler beim Umwandeln in Hexadezimal $1 +asmr_h_direct_global_to_mangled=07039_H_$1 bersetzt nach $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 ist einer berladenen Funktion zugeordnet +asmr_e_cannot_use_SELF_outside_a_method=07041_E_Kann SELF nicht ausserhalb einer Methode verwenden +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_Kann OLDEBP ausserhalb einer verschachtelten Prozedur nicht verwenden +asmr_e_void_function=07043_W_Prozeduren knnen keinen Wert im Assembler-Code zurckliefern +asmr_e_SEG_not_supported=07044_E_SEG nicht untersttzt +asmr_e_size_suffix_and_dest_dont_match=07045_E_Grssensuffix und Ziel- oder Quellgrsse passen nicht zusammen +asmr_w_size_suffix_and_dest_dont_match=07046_W_Grssensuffix und Ziel- oder Quellgrsse passen nicht zusammen +asmr_e_syntax_error=07047_E_Assembler Syntaxfehler +asmr_e_invalid_opcode_and_operand=07048_E_Ungltige Kombination von Opcode und Operanden +asmr_e_syn_operand=07049_E_Assembler Syntaxfehler im Operanden +asmr_e_syn_constant=07050_E_Assembler Syntaxfehler in Konstanten +asmr_e_invalid_string_expression=07051_E_Ungltiger Stringausdruck +asmr_w_const32bit_for_address=07052_-Bit-Konstanten fr Adresse erzeugt +asmr_e_unknown_opcode=07053_E_Unbekannter Opcode $1 +asmr_e_invalid_or_missing_opcode=07054_E_Ungltiger oder fehlender Opcode +asmr_e_invalid_prefix_and_opcode=07055_E_Ungltige Kombination von Prefix und Opcode: $1 +asmr_e_invalid_override_and_opcode=07056_E_Ungltige Kombination von Override und Opcode: $1 +asmr_e_too_many_operands=07057_E_Zu viele Operanden in der Zeile +asmr_w_near_ignored=07058_W_NEAR ignoriert +asmr_w_far_ignored=07059_W_FAR ignoriert +asmr_e_dup_local_sym=07060_E_Doppelters lokales Symbol $1 +asmr_e_unknown_local_sym=07061_E_Undefiniertes lokales Symbol $1 +asmr_e_unknown_label_identifier=07062_E_Unbekannter Label-Bezeichner $1 +asmr_e_invalid_register=07063_E_Ungltiger Registername +asmr_e_invalid_fpu_register=07064_E_Ungltiger Name fr Fliesskommaregister +asmr_e_nor_not_supported=07065_E_NOR nicht untersttzt +asmr_w_modulo_not_supported=07066_W_Modulo nicht untersttzt +asmr_e_invalid_float_const=07067_E_Ungltige Fliesskommakonstante $1 +asmr_e_invalid_float_expr=07068_E_Ungltiger Fliesskommaausdruck +asmr_e_wrong_sym_type=07069_E_Falscher Symboltyp +asmr_e_cannot_index_relative_var=07070_E_Kann lokale Variable oder Parameter nicht mit Register indizieren +asmr_e_invalid_seg_override=07071_E_Ungltiger Segmentoverride-Ausdruck +asmr_w_id_supposed_external=07072_W_Bezeichner $1 ist vermutlich External +asmr_e_string_not_allowed_as_const=07073_E_Strings sind als Konstanten unzulssig +asmr_e_no_var_type_specified=07074_Typ der Variablen nicht angegeben +asmr_w_assembler_code_not_returned_to_text=07075_E_Assemblercode kehrt nicht zum Text zurck +asmr_e_not_directive_or_local_symbol=07076_E_Keine Direktive oder lokales Symbol $1 +asmr_w_using_defined_as_local=07077_E_Verwendung eines definierten Namens als lokales Label +asmr_e_dollar_without_identifier=07078_E_Dollarzeichen wird ohne Bezeichner verwendet +asmr_w_32bit_const_for_address=07079_W_32-Bit-Konstante fr Adresse erzeugt +asmr_n_align_is_target_specific=07080_N_.align ist abhngig von Zielplattform, verwende .balign oder .p2align +asmr_e_cannot_access_field_directly_for_parameters=07081_E_Kann fr Parameter nicht direkt auf Felder zugreifen +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_Kann auf Felder von Objekten/Klassen nicht direkt zugreifen +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_Zu viele Assembler-Dateien +asmw_f_assembler_output_not_supported=08001_F_Gewhlte Assemblerausgabe wird nicht untersttzt +asmw_f_comp_not_supported=08002_F_Comp nicht untersttzt +asmw_f_direct_not_supported=08003_F_Direct nicht untersttzt fr binres Schreiben +asmw_e_alloc_data_only_in_bss=08004_E_Allozieren von Daten ist nur in "bss"-Abschnitten zulssig +asmw_f_no_binary_writer_selected=08005_F_Kein Binrschreiber ausgewhlt +asmw_e_opcode_not_in_table=08006_E_Asm: Opcode $1 nicht in Tabelle enthalten +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 ungltige Kombination von Opcode und Operanden +asmw_e_16bit_not_supported=08008_E_Asm: 16-Bit-Verweise werden nicht unterttzt +asmw_e_invalid_effective_address=08009_E_Asm: Ungltige effektive Adresse +asmw_e_immediate_or_reference_expected=08010_E_Asm: Konstanten Ausdruck oder Referenz erwartet +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 Wert berschreitet Grenzen $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: "Short jump" ist ausserhalb der Bereichs $1 +asmw_e_undefined_label=08013_E_Asm: Undefiniertes Label: $1 + +# +# Executing linker/assembler +# +exec_w_source_os_redefined=09000_W_Quell-Betriebssystem wurde neu definiert +exec_i_assembling_pipe=09001_I_Assembliere (pipe) $1 +exec_d_cant_create_asmfile=09002_E_Kann Assemblerdatei nicht erzeugen: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_Kann Objektdatei nicht erzeugen: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_Kann Archivdatei nicht erzeugen: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_Assembler $1 nicht gefunden, schalte um auf externes Assemblieren +exec_t_using_assembler=09006_T_Benutze Assembler: $1 +exec_w_error_while_assembling=09007_W_Fehler whren des Assemblierens, Exitcode $1 +exec_w_cant_call_assembler=09008_W_Kann den Assembler nicht aufrufen, Fehler $1 beim Umschalten auf externen Assembler +exec_i_assembling=09009_I_Assembliere $1 +exec_i_assembling_smart=09010_I_Assembliere mit Smartlinking $1 +exec_w_objfile_not_found=09011_W_Objekt $1 nicht gefunden, Linken kann fehlschlagen! +exec_w_libfile_not_found=09012_W_Bibliothek $1 nicht gefunden, Linken kann fehlschlagen! +exec_w_error_while_linking=09013_W_Fehler whrend des Linkens +exec_w_cant_call_linker=09014_W_Kann Linker nicht aufrufen, schalte um auf externes Linken +exec_i_linking=09015_I_Linke $1 +exec_w_util_not_found=09016_W_Hilfsprogramm "$1" nicht gefunden, schalte um auf externes Linken +exec_t_using_util=09017_T_Benutze Hilfsprogramm $1 +exec_e_exe_not_supported=09018_E_Erzeugen von ausfhrbaren Dateien nicht untersttzt +exec_e_dll_not_supported=09019_E_Dynamische Bibliotheken nicht untersttzt +exec_i_closing_script=09020_I_Schliesse Skript $1 +exec_w_res_not_found=09021_W_Resource Compiler nicht gefunden, schalte um auf externen Modus +exec_i_compilingresource=09022_I_Kompiliere Resource $1 +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_Kann ausfhrbare Datei nicht nachbearbeiten: $1 +execinfo_f_cant_open_executable=09024_F_Kann ausfhrbare Datei nicht ffnen: $1 +execinfo_x_codesize=09025_X_Grsse des Codes: $1 Bytes +execinfo_x_initdatasize=09026_X_Grsse der initialisierten Daten: $1 Bytes +execinfo_x_uninitdatasize=09027_X_Grsse der nicht initialisierten Daten: $1 Bytes +execinfo_x_stackreserve=09028_X_Stack Bereich "reserved": $1 Bytes +execinfo_x_stackcommit=09029_X_Stack Bereich "commited": $1 Bytes +# +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_Suche Unit: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_Lade PPU: $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU-Name: $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU-Flags: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU-CRC: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU-Zeit: $1 +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_file_too_short=10006_U_PPU-Datei zu kurz +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_invalid_header=10007_U_PPU Ungltiger Header (kein PPU am Anfang) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_PPU Ungltige Version $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU ist fr einen anderen Prozessor kompiliert +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU ist fr ein anderes Zielsystem kompiliert +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU Quelle: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_Schreibe $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_Kann PPU-Datei nicht schreiben +% An err +unit_f_ppu_read_error=10014_F_Lese PPU-Datei +% Unexpected end of file +unit_f_ppu_read_unexpected_end=10015_F_Unerwartetes Ende der PPU-Datei +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_invalid_entry=10016_F_Ungltiger Eintrag in PPU-Datei: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU Dbx Zhler-Problem +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Ungltiger Unitname: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_Zu viele Units +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_Gegenseitige Abhngigkeit von Units zwischen $1 und $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_Kann Unit "$1" nicht bersetzen, keine Quellen vorhanden +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_Kann Unit "$1" nicht finden +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_Unit "$1" wurde nicht gefunden, aber "$2" existiert +unit_f_unit_name_error=10024_F_Unit "$1" gesucht, aber "$2" gefunden +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_bersetzen der Systemunit erfordert den Schalter -Us +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_Es traten $1 Fehler beim bersetzen des Moduls auf, halte an +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_Lade aus $1 ($2) die Unit $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_bersetze $1 erneut, Prfsumme fr $2 hat sich gendert +unit_u_recompile_source_found_alone=10029_U_bersetze "$1", nur Quellcode gefunden +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_bersetze Unit erneut, statische Biblothek ist lter als PPU-Datei +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_bersetze Unit erneut, gemeinsame Bibliothek ist lter als PPU-Datei +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_bersetze Unit erneut, obj und asm sind lter als PPU-Datei +% When you use the \var{-vu} flag, the compiler warns if the assembler of +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_bersetze Unit erneut, obj ist lter als asm +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_Parse Interface-Abschnitt von "$1" +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_Parse Implementation-Abschnitt von "$1" +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_Zweites Laden fr Unit "$1" +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU prfe Datei $1 Zeit $2 +% When you use the \var{-vu} flag, the compiler show the filename and +% date and time of the file which a recompile depends on +% \end{description} +# EndOfTeX +# +# Options +# +option_usage=11000_$1 [Optionen] [Optionen] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_Nur eine Quelldatei untersttzt +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_DEF-Datei kann nur fr OS/2 erzeugt werden +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_Verschachtelte Response-Dateien werden nicht untersttzt +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_F_Kein Name fr Quelldatei auf der Kommandzeile +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_Keine Angeben in Konfigurationsdatei "$1" gefunden +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Ungltiger Parameter: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? zeigt Hilfetext an +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_Zu viele verschachtelte Konfigurtionsdateien +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_Kann Datei nicht ffnen $1 +% The option file cannot be found. +option_reading_further_from=11010_N_Lese weitere Optionen aus $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_Zielsystem ist bereits gesetzt: $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_Gemeinsame Bibliotheken sind auf der DOS Platform nicht verfgbar, verwende stattdessen statische Bibliotheken +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_Zu viele IF(N)DEFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_Zu viele ENDIFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_Offene Bedingung am Dateiende +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_Erzeugung von Debug-Informationen wird von dieser ausfhrbaren Datei nicht untersttzt +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_Versuchen Sie mit -dGDB erneut zu kompilieren +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_E_Sie verwenden den nun berflssigen Schalter $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_E_Sie benutzen den nun berflssigen Schalter $1, bitte benutzen Sie $2 +% this warns you when you use a switch that is not supported anymore. You +% must now use the second switch instead. +% It is recommended that you change the switch to overcome problems in the +% future, when the switch meaning may change. +option_switch_bin_to_src_assembler=11020_N_Schalte Assembler auf den Standard-Assembler-Quellcodeschreiber +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_Das gewhlte Assembler-Ausgabeformat "$1" ist nicht mit "$2" kompatibel +option_asm_forced=11022_W_Verwendung des Assemblers "$1" erzwungen +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +%\end{description} +# EndOfTeX + +# +# Logo (option -l) +# +option_logo=11023_[ +Free Pascal Compiler Version $FPCVER [$FPCDATE] fr $FPCTARGET +Copyright (c) 1993-2000 Florian Klmpfl +] + +# +# Info (option -i) +# +option_info=11024_[ +Free Pascal Compiler Version $FPCVER + +Compiler Datum: $FPCDATE +Compiler Zielsystem: $FPCTARGET + +Dieses Programm unterliegt der GNU General Public Licence +Weitere Informationen sind in COPYING.FPC zu finden + +Fehlerberichte, Vorschlge usw. bitte senden an: + bugrep@freepascal.org +] + +# +# Help pages (option -? and -h) +# +option_help_pages=11025_[ +**0*_nach booleschen Optionen geben Sie + zum Ein- bzw. - zum Ausschalten an +**1a_lsche die erzeugte Assembler-Datei nicht +**2al_liste Quellcode-Zeilen in der Assembler-Datei +**2ar_liste Registerbelegungsinformation in Assembler-Datei +**2at_liste Temp. Variablenbelegungsinfo in Assembler-Datei +**1b_erzeuge Browser-Info +**2bl_erzeuge Info zu lokalen Symbolen +**1B_erzeuge alle Module (Build) +**1C_Optionen fr Code-Erzeugung: +3*2CD_erzeuge auch eine dynamische Bibliothek (nicht untersttzt) +**2Ch_ Bytes Heap (zwischen 1023 und 67107840) +**2Ci_I/O-Prfung +**2Cn_lasse die Linkstufe aus +**2Co_prfe berlauf von Integer-Operationen +**2Cr_fhre Bereichsprfung durch +**2Cs_setze Grsse des Stacks auf +**2Ct_fhre Stackprfung durch +3*2CS_erzeuge statische Bibliothek +3*2Cx_benutze Smartlinking +**1d_definiere das Symbol +*O1D_erzeuge eine DEF-Datei +*O2Dd_setze Beschreibung zu +*O2Dw_erzeuge PM-Anwendung +**1e_setze Pfad zur ausfhrbaren Datei +**1F_Dateinamen und Pfade: +**2FD_setze das Verzeichnis fr die Compiler-Hilfsprogramme +**2Fe_leite die Fehlerausgabe um nach +**2FE_setze den Pfad fr Exe/Unit-Dateien auf +*L2Fg_identisch mit -Fl +**2Fi_ergnze zum Include-Pfad +**2Fl_ergnze zum Bibliotheks-Pfad +*L2FL_benutze als dynamischen Linker +**2Fo_ergnze zum Objektdatei-Pfad +**2Fr_lade die Fehler-Meldungs Datei +**2Fu_ergnze zum Unit-Pfad +**2FU_Units werden nach ausgegen, hat Vorrang vor -FE +*g1g_erzeuge Informationen zur Fehlersuche: +*g2gg_Verwende gsym +*g2gd_Verwende dbx +*g2gh_Heaptrace-Unit einbinden +*g2gc_Zeigerberprfung +**1i_zeige alle Information ber den Compiler +**2iD_zeige Compilerdatum +**2iV_zeige Compilerversion +**2iSO_zeige Compiler-Betriebssystem +**2iSP_zeige Compilerprozessor +**2iTO_zeige Ziel-Betriebssystem +**2iTP_zeige Zielprozessor +**1I_ergnze zum Include-Pfad +**1k_bergebe an den Linker +**1l_zeige Logo +**1n_Standard-Konfigurationsdatei ignorieren +**1o_die erzeugte, ausfhrbaren Datei bekommt den Namen +**1pg_erzeuge Profiler-Code fr gprof +*L1P_benutze Pipes anstelle von temporren Assembler-Dateien +**1S_Syntax-Optionen: +**2S2_schalte einige der Delphi 2 Erweiterungen ein +**2Sc_untersttze spezielle C Operatoren (*=,+=,/= and -=) +**2Sd_sei Delphi-kompatibel +**2Se_halte Compiler nach dem ersten Fehler an +**2Sg_erlaube LABEL und GOTO +**2Sh_benutze ANSI-Strings +**2Si_benutze C++ artige INLINE +**2Sm_untersttze Makros wie in C (global) +**2So_sei TP/BP 7.0 kompatibel +**2Sp_sei gpc-kompatibel +**2Ss_Kon-und Destruktorname mssen "Init" und "Done" sein +**2St_erlaube Schlsselwort static in Objekten +**1s_rufe weder Assembler noch Linker auf (nur mit -a) +**1u_entferne die Definition fr das Symbol +**1U_Unit-Optionen: +**2Un_prfe den Unitnamen nicht +**2Us_erzeuge eine Systemunit +**1v_Meldungen, ist eine Kombination der folgenden Zeichen: +**2*_e : Fehler (Standard) d : Debug Info +**2*_w : Warnungen u : Unit Info +**2*_n : Anmerkungen t : angesprochene/benutzte Dateien +**2*_h : Hinweise m : definierte Macros +**2*_i : allgemeine Info p : kompilierte Prozeduren +**2*_l : Zeilennummern c : Preprozessordirective +**2*_a : alles 0 : nichts (ausser Fehlern) +**2*_b : alle Prozedurdekla- r : Rhide/GCC kompatibler Modus +**2*_ rationen im Fehlerfall x : Exe-Datei Info (nur Win32) +**2*_ +**1X_Optionen fr ausfhrbare Dateien: +*L2Xc_linke mit der C-Bibliothek +**2Xs_entferne alle Symbole von ausfhrbarer Datei +**2XD_dynamisch linken (definiert FPC_LINK_DYNAMIC) +**2XS_statisch linken (default) (definiert FPC_LINK_STATIC) +**2XX_smartlinken (definiert FPC_LINK_SMART) +**0*_Optionen fr den Prozessor: +3*1A_Ausgabeformat: +3*2Aas_Datei mit Hilfe von GNU AS +3*2Aasaout_Datei mit Hilfe von GNU AS fr aout (Go32v1) +3*2Anasmcoff_coff-Datei mit Hilfe von Nasm +3*2Anasmelf_elf32-Datei (Linux) mit Hilfe von Nasm +3*2Anasmobj_obj-Datei mit Hilfe von Nasm +3*2Amasm_obj-Datei mit Hilfe von Masm (Microsoft) +3*2Atasm_obj-Datei mit Hilfe von Tasm (Borland) +3*2Acoff_coff (Go32v2) benutze internen Schreiber +3*2Apecoff_pecoff (Win32) benutze internen Schreiber +3*1R_Assembler-Leser Format: +3*2Ratt_lese AT&T Assembler Variante +3*2Rintel_lese Intel Assembler Variante +3*2Rdirect_kopiere Assembler-Text direkt in die Assembler-Datei +3*1O_Optimierungen: +3*2Og_erzeuge kleineren Code +3*2OG_erzeuge schnelleren Code (Standard) +3*2Or_Registervariablen (enthlt eventuell noch Fehler) +3*2Ou_aktiviere unsichere Optimierungen (siehe Dokumentation) +3*2O1_Stufe 1 Optimierungen (schnelle Optimierungen) +3*2O2_Stufe 2 Optimierungen (-O1 + langsamere Optimierungen) +3*2O3_Stufe 3 Optimierungen (gleich wie -O2u) +3*2Op_Ziel-Prozessor: +3*3Op1_Optimierungen fr 386/486 +3*3Op2_Optimierungen fr Pentium/PentiumMMX (R) +3*3Op3_Optimierungen fr PPro/PII/c6x86/K6 (R) +3*1T_Ziel-Betriebssystem +3*2TGO32V1_Version 1 von DJ Delorie's DOS extender () +3*2TGO32V2_Version 2 von DJ Delorie's DOS extender +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +6*1A_Ausgabe Format: +6*2Aas_Unix o-Datei mit Hilfe von GNU AS +6*2Agas_GNU Motorola Assembler +6*2Amit_MIT Syntax (alter GAS) +6*2Amot_Standard Motorola Assembler +6*1O_Optimierungen: +6*2Oa_schalte Optimierer ein +6*2Og_erzeuge kleineren Code +6*2OG_erzeuge schnelleren Code (Standard) +6*2Ox_optimiere maximal (enthlt eventuell noch Fehler) +6*2O2_setze Ziel-Prozessor auf MC68020+ +6*1R_Assembler-Leser Format: +6*2RMOT_lese Assembler nach Motorola-Art +6*1T_Ziel-Betriebssystem: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_zeigt diese Hilfe an +6*2RMOT_lese Assembler nach Motorola-Art +6*1T_Ziel-Betriebssystem: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_zeigt diese Hilfe an +**1h_zeigt diese Hilfe ohne Warten an +] + +# +# The End... +# diff --git a/befpc/compiler/errore.msg b/befpc/compiler/errore.msg new file mode 100644 index 0000000..e660117 --- /dev/null +++ b/befpc/compiler/errore.msg @@ -0,0 +1,1857 @@ +# +# $Id: errore.msg,v 1.1.1.1 2001-07-23 17:16:02 memson Exp $ +# This file is part of the Free Pascal Compiler +# Copyright (c) 1999-2000 by the Free Pascal Development team +# +# English (default) Language File for Free Pascal +# +# 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. +# +# +# The constants are build in the following order: +# __ +# +# is the part of the compiler the message is used +# asmr_ assembler parsing +# asmw_ assembler writing/binary writers + +# unit_ unit handling +# scan_ scanner +# parser_ parser +# type_ type checking +# general_ general info +# exec_ calls to assembler, linker, binder +# +# the type of the message it should normally used for +# f_ fatal error +# e_ error +# w_ warning +# n_ note +# h_ hint +# i_ info +# l_ linenumber +# u_ used +# t_ tried +# m_ macro +# p_ procedure +# c_ conditional +# d_ debug message +# b_ display overloaded procedures +# x_ executable informations +# + +# +# General +# +# BeginOfTeX +% \section{General compiler messages} +% This section gives the compiler messages which are not fatal, but which +% display useful information. The number of such messages can be +% controlled with the various verbosity level \var{-v} switches. +% \begin{description} +general_t_compilername=01000_T_Compiler: $1 +% When the \var{-vt} switch is used, this line tells you what compiler +% is used. +general_d_sourceos=01001_D_Compiler OS: $1 +% When the \var{-vd} switch is used, this line tells you what the source +% operating system is. +general_i_targetos=01002_I_Target OS: $1 +% When the \var{-vd} switch is used, this line tells you what the target +% operating system is. +general_t_exepath=01003_T_Using executable path: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's binaries. +general_t_unitpath=01004_T_Using unit path: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for compiled units. You can set this path with the \var{-Fu} +general_t_includepath=01005_T_Using include path: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's include files (files used in \var{\{\$I xxx\}} statements). +% You can set this path with the \var{-I} option. +general_t_librarypath=01006_T_Using library path: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for the libraries. You can set this path with the \var{-Fl} option. +general_t_objectpath=01007_T_Using object path: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for object files you link in (files used in \var{\{\$L xxx\}} statements). +% You can set this path with the \var{-Fo} option. +general_i_abslines_compiled=01008_I_$1 Lines compiled, $2 sec +% When the \var{-vi} switch is used, the compiler reports the number +% of lines compiled, and the time it took to compile them (real time, +% not program time). +general_f_no_memory_left=01009_F_No memory left +% The compiler doesn't have enough memory to compile your program. There are +% several remedies for this: +% \begin{itemize} +% \item If you're using the build option of the compiler, try compiling the +% different units manually. +% \item If you're compiling a huge program, split it up in units, and compile +% these separately. +% \item If the previous two don't work, recompile the compiler with a bigger +% heap (you can use the \var{-Ch} option for this, \seeo{Ch}) +% \end{itemize} +general_i_writingresourcefile=01010_I_Writing Resource String Table file: $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_Writing Resource String Table file: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +scan_f_end_of_file=02000_F_Unexpected end of file +% this typically happens in one of the following cases : +% \begin{itemize} +% \item The source file ends before the final \var{end.} statement. This +% happens mostly when the \var{begin} and \var{end} statements aren't +% balanced; +% \item An include file ends in the middle of a statement. +% \item A comment wasn't closed. +% \end{itemize} +scan_f_string_exceeds_line=02001_F_String exceeds line +% You forgot probably to include the closing ' in a string, so it occupies +% multiple lines. +scan_f_illegal_char=02002_F_illegal character $1 ($2) +% An illegal character was encountered in the input file. +scan_f_syn_expected=02003_F_Syntax error, $1 expected but $2 found +% This indicates that the compiler expected a different token than +% the one you typed. It can occur almost everywhere where you make a +% mistake against the pascal language. +scan_t_start_include_file=02004_T_Start reading includefile $1 +% When you provide the \var{-vt} switch, the compiler tells you +% when it starts reading an included file. +scan_w_comment_level=02005_W_Comment level $1 found +% When the \var{-vw} switch is used, then the compiler warns you if +% it finds nested comments. Nested comments are not allowed in Turbo Pascal +% and can be a possible source of errors. +scan_n_far_directive_ignored=02006_N_$F directive (FAR) ignored +% The \var{FAR} directive is a 16-bit construction which is recorgnised +% but ignored by the compiler, since it produces 32 bit code. +scan_n_stack_check_global_under_linux=02007_N_Stack check is global under Linux +% Stack checking with the \var{-Cs} switch is ignored under \linux, since +% \linux does this for you. Only displayed when \var{-vn} is used. +scan_n_ignored_switch=02008_N_Ignored compiler switch $1 +% With \var{-vn} on, the compiler warns if it ignores a switch +scan_w_illegal_switch=02009_W_Illegal compiler switch $1 +% You included a compiler switch (i.e. \var{\{\$... \}}) which the compiler +% doesn't know. +scan_w_switch_is_global=02010_W_This compiler switch has a global effect +% When \var{-vw} is used, the compiler warns if a switch is global. +scan_e_illegal_char_const=02011_E_Illegal char constant +% This happens when you specify a character with its ASCII code, as in +% \var{\#96}, but the number is either illegal, or out of range. The range +% is 1-255. +scan_f_cannot_open_input=02012_F_Can't open file $1 +% \fpc cannot find the program or unit source file you specified on the +% command line. +scan_f_cannot_open_includefile=02013_F_Can't open include file $1 +% \fpc cannot find the source file you specified in a \var{\{\$include ..\}} +% statement. + +scan_e_too_much_endifs=02014_E_Too many $ENDIFs or $ELSEs +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_w_only_pack_records=02015_W_Records fields can be aligned to 1,2,4,8,16 or 32 bytes only +% You are specifying the \var{\{\$PACKRECORDS n\} } with an illegal value for +% \var{n}. Only 1, 2, 4, 8, 16 and 32 are valid in this case. +scan_w_only_pack_enum=02016_W_Enumerated can be saved in 1,2 or 4 bytes only +% You are specifying the \var{\{\$PACKENUM n\}} with an illegal value for +% \var{n}. Only 1,2 or 4 are valid in this case. +scan_e_endif_expected=02017_E_$ENDIF expected for $1 $2 defined in line $3 +% Your conditional compilation statements are unbalanced. +scan_e_preproc_syntax_error=02018_E_Syntax error while parsing a conditional compiling expression +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_e_error_in_preproc_expr=02019_E_Evaluating a conditional compiling expression +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_w_macro_cut_after_255_chars=02020_W_Macro contents is cut after char 255 to evalute expression +% The contents of macros canno be longer than 255 characters. This is a +% safety in the compiler, to prevent buffer overflows. This is shown as a +% warning, i.e. when the \var{-vw} switch is used. +scan_e_endif_without_if=02021_E_ENDIF without IF(N)DEF +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_f_user_defined=02022_F_User defined: $1 +% A user defined fatal error occurred. see also the \progref +scan_e_user_defined=02023_E_User defined: $1 +% A user defined error occurred. see also the \progref +scan_w_user_defined=02024_W_User defined: $1 +% A user defined warning occurred. see also the \progref +scan_n_user_defined=02025_N_User defined: $1 +% A user defined note was encountered. see also the \progref +scan_h_user_defined=02026_H_User defined: $1 +% A user defined hint was encountered. see also the \progref +scan_i_user_defined=02027_I_User defined: $1 +% User defined information was encountered. see also the \progref +scan_e_keyword_cant_be_a_macro=02028_E_Keyword redefined as macro has no effect +% You cannot redefine keywords with macros. +scan_f_macro_buffer_overflow=02029_F_Macro buffer overflow while reading or expanding a macro +% Your macro or it's result was too long for the compiler. +scan_w_macro_deep_ten=02030_W_Extension of macros exceeds a deep of 16. +% When expanding a macro macros have been nested to a level of 16. +% The compiler will expand no further, since this may be a sign that +% recursion is used. +scan_e_wrong_styled_switch=02031_E_compiler switches aren't allowed in (* ... *) styled comments +% Compiler switches should always be between \var{\{ \}} comment delimiters. +scan_d_handling_switch=02032_D_Handling switch "$1" +% When you set debugging info on (\var{-vd}) the compiler tells you when it +% is evaluating conditional compile statements. +scan_c_endif_found=02033_C_ENDIF $1 found +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifdef_found=02034_C_IFDEF $1 found, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifopt_found=02035_C_IFOPT $1 found, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_if_found=02036_C_IF $1 found, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifndef_found=02037_C_IFNDEF $1 found, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_else_found=02038_C_ELSE $1 found, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_skipping_until=02039_C_Skipping until... +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements, and whether it is skipping or +% compiling parts. +scan_i_press_enter=02040_I_Press to continue +% When the \var{-vi} switch is used, the compiler stops compilation +% and waits for the \var{Enter} key to be pressed when it encounters +% a \var{\{\$STOP\}} directive. +scan_w_unsupported_switch=02041_W_Unsupported switch $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unsupported switches. This means that the switch is used in Delphi or +% Turbo Pascal, but not in \fpc +scan_w_illegal_directive=02042_W_Illegal compiler directive $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unrecognised switches. For a list of recognised switches, \progref +scan_t_back_in=02043_T_Back in $1 +% When you use (\var{-vt}) the compiler tells you when it has finished +% reading an include file. +scan_w_unsupported_app_type=02044_W_Unsupported application type: $1 +% You get this warning, ff you specify an unknown application type +% with the directive \var{\{\$APPTYPE\}} +scan_w_app_type_not_support=02045_W_APPTYPE isn't support by the target OS +% The \var{\{\$APPTYPE\}} directive is supported by win32 applications only. +scan_w_decription_not_support=02046_W_DESCRIPTION is only supported for OS2 and Win32 +% The \var{\{\$DESCRIPTION\}} directive is only supported for OS2 and Win32 targets. +scan_n_version_not_support=02047_N_VERSION is not supported by target OS. +% The \var{\{\$VERSION\}} directive is only supported by win32 target. +scan_n_only_exe_version=02048_N_VERSION only for exes or DLLs +% The \var{\{\$VERSION\}} directive is only used for executable or DLL sources. +scan_w_wrong_version_ignored=02049_W_Wrong format for VERSION directive $1 +% The \var{\{\$VERSION\}} directive format is majorversion.minorversion +% where majorversion and minorversion are words. +scan_w_unsupported_asmmode_specifier=02050_W_Unsupported assembler style specified $1 +% When you specify an assembler mode with the \var{\{\$ASMMODE xxx\}} +% the compiler didn't recognize the mode you specified. +scan_w_no_asm_reader_switch_inside_asm=02051_W_ASM reader switch is not possible inside asm statement, $1 will be effective only for next +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Wrong switch toggle, use ON/OFF or +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_Resource files are not supported for this target +% The target you are compiling for doesn't support resource files. The +% only targets which can use resource files are Win32 and OS/2 (EMX) currently +scan_w_include_env_not_found=02054_W_Include environment $1 not found in environment +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_Illegal value for FPU register limit +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +scan_w_only_one_resourcefile_supported=02056_W_Only one resource file is supported for this target +% The target you are compiling for supports only one resource file. This is the +% case of OS/2 (EMX) currently. The first resource file found is used, the +% others are discarded. +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +parser_e_syntax_error=03000_E_Parser - Syntax Error +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_Procedure type FAR ignored +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_Procedure type NEAR ignored +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_Procedure type INTERRUPT ignored for not i386 +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is ignored for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT procedure can't be nested +% An \var{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_Procedure type $1 ignored +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_Not all declarations of $1 are declared with OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_No DLL File specified +% No longer in use. +parser_e_export_name_double=03008_E_Duplicate exported function name $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_Duplicate exported function index $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Invalid index for exported function +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_Relocatable DLL or executable $1 debug info does not work, disabled. +parser_w_parser_win32_debug_needs_WN=03012_W_To allow debugging for win32 code you need to disable relocation with -WN option +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_Constructor name must be INIT +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_Destructor name must be DONE +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Illegal open parameter +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_Procedure type INLINE not supported +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Private methods shouldn't be VIRTUAL +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_Constructor should be public +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_Destructor should be public +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_Class should have one destructor only +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_Local class definitions are not allowed +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_Anonym class definitions are not allowed +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_The object $1 has no VMT +parser_e_illegal_parameter_list=03024_E_Illegal parameter list +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Wrong parameter type specified for arg no. $1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Wrong amount of parameters specified +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_overloaded identifier $1 isn't a function +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_overloaded functions have the same parameter list +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_function header doesn't match the forward declaration $1 +% You declared a function with same parameters but +% different result type or function modifiers. +parser_e_header_different_var_names=03030_E_function header $1 doesn't match forward : var name changes $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_Values in enumeration types have to be ascending +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Interface and implementation names are different $1 => $2 +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With can not be used for variables in a different segment +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_function nesting > 31 +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_range check error while evaluating constants +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_range check error while evaluating constants +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_duplicate case label +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_Upper bound of case range is less than lower bound +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_typed constants of classes are not allowed +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_functions variables of overloaded functions are not allowed +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_string length must be a value from 1 to 255 +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_use extended syntax of NEW and DISPOSE for instances of objects +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_use of NEW or DISPOSE for untyped pointers is meaningless +parser_e_no_new_dispose_on_void_pointers=03044_E_use of NEW or DISPOSE is not possible for untyped pointers +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_class identifier expected +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_type identifier not allowed here +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_method identifier expected +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_function header doesn't match any method of this class +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_procedure/function $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Illegal floating point constant +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL can be used in constructors only +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_Destructors can't have parameters +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_Only class methods can be referred with class references +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_Only class methods can be accessed in class methods +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_Constant and CASE types do not match +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_The symbol can't be exported from a library +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_An inherited method is hidden by $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_There is no method in an ancestor class to be overridden: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_No member is provided to access property +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_Stored prorperty directive is not yet implemented +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Illegal symbol for property access +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_Cannot access a protected field of an object here +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_Cannot access a private field of an object here +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_overloaded method of virtual method should be virtual: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_overloaded method of non-virtual method should be non-virtual: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_overloaded methods which are virtual must have the same return type: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_EXPORT declared functions can't be nested +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_methods can't be EXPORTed +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_call by var parameters have to match exactly: Got $1 expected $2 +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_Class isn't a parent class of the current class +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF is only allowed in methods +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_methods can be only in other methods called direct with type identifier of the class +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Illegal use of ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_range check error in set constructor or duplicate set element +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_Pointer to object expected +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_Expression must be constructor call +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_Expression must be destructor call +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Illegal order of record elements +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_Expression type must be class or record type +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_Procedures can't return a value +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_constructors and destructors must be methods +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_Operator is not overloaded +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_Impossible to overload assignment for equal types +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_Impossible operator overload +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_Re-raise isn't possible there +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_The extended syntax of new or dispose isn't allowed for a class +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_Assembler incompatible with function return type +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_Procedure overloading is switched off +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_It is not possible to overload this operator (overload = instead) +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_Comparative operator must return a boolean value +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_Only virtual methods can be abstract +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_Use of unsupported feature! +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_The mix of CLASSES and OBJECTS isn't allowed +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_Unknown procedure directive had to be ignored: $1 +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_absolute can only be associated to ONE variable +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_absolute can only be associated a var or const +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_Only ONE variable can be initialized +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_Abstract methods shouldn't have any definition (with function body) +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_This overloaded function can't be local (must be exported) +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_Virtual methods are used without a constructor in $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_Macro defined: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_Macro undefined: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_Macro $1 set to $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_Compiling $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_Parsing interface of unit $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_Parsing implementation of $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_Compiling $1 for the second time +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_Array properties aren't allowed here +% You cannot use array properties at that point in the source. +parser_e_no_property_found_to_override=03109_E_No property found to override +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_Only one default property is allowed, found inherited default property in class $1 +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_The default property must be an array property +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_Virtual constructors are only supported in class object model +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_No default property available +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_The class can't have a published section, use the {$M+} switch +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_Forward declaration of class $1 must be resolved here to use the class as ancestor +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_Local operators not supported +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_Procedure directive $1 not allowed in interface section +% This procedure directive is not allowed in the \var{interface} section of + +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_Procedure directive $1 not allowed in implementation section +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_Procedure directive $1 not allowed in procvar declaration +% This procedure directive cannot be part of a procedural or function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_Function is already declared Public/Forward $1 +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_Can't use both EXPORT and EXTERNAL +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_NAME keyword expected +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 not yet supported inside inline procedure/function +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_Inlining disabled +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_Writing Browser log $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_may be pointer dereference is missing +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_Selected assembler reader not supported +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not + +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_Procedure directive $1 has conflicts with other directives +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_Calling convention doesn't match forward +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_Register calling (fastcall) not supported +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_Property can't have a default value +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_The default value of a property must be constant +% The value of a \var{default} declared property must be known at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_Symbol can't be published, can be only a class +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_That kind of property can't be published +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_Empty import name specified +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_An import name is required +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_Function internal name changed after use of function +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_Division by zero +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Invalid floating point operation +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_Upper bound of range is less than lower bound +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_string "$1" is longer than $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_string length is larger than array of char length +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Illegal expression after message directive +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_Message handlers can take only one call by ref. parameter +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_Duplicate message label: $1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_Self can be only an explicit parameter in message handlers +% The self parameter can be passed only explicitly in a method which +% is declared as message method handler. +parser_e_threadvars_only_sg=03147_E_Threadvars can be only static or global +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_Direct assembler not supported for binary output format +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_Don't load OBJPAS unit manual, use {$mode objfpc} or {$mode delphi} instead +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_OVERRIDE can't be used in objects +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +parser_e_cant_use_inittable_here=03151_E_Data types which requires initialization/finalization can't be used in variant records +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_Resourcestrings can be only static or global +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_Exit with argument can't be used here +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_The type of the storage symbol must be boolean +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_This symbol isn't allowed as storage symbol +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_Only class which are compiled in $M+ mode can be published +% In the published section of a class can be only class as fields used which +% are compiled in \var{\{\$M+\}} or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_Procedure directive expected +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_The value for a property index must be of an ordinal type +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_Procedure name to short to be exported +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_No DEFFILE entry can be generated for unit global vars +parser_e_dlltool_unit_var_problem2=03161_E_Compile without -WD option +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Type mismatch +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Incompatible types: got "$1" expected "$2" +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_Type mismatch between $1 and $2 +% The types are not equal +type_e_type_id_expected=04003_E_Type identifier expected +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_Variable identifier expected +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_Integer expression expected, but got "$1" +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_Boolean expression expected, but got "$1" +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_Ordinal expression expected +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_pointer type expected, but got "$1" +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_class type expected, but got "$1" +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_Variable or type indentifier expected +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_Can't evaluate constant expression +% No longer in use. +type_e_set_element_are_not_comp=04012_E_Set elements are not compatible +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_Operation not implemented for sets +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_Automatic type conversion from floating type to COMP which is an integer type +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_use DIV instead to get an integer result +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_string types doesn't match, because of $V+ mode +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_succ or pred on enums with assignments not possible +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_Can't read or write variables of this type +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_Can't use readln or writeln on typed file +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_Can't use read or write on untyped file. +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_Type conflict between set elements +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_lo/hi(dword/qword) returns the upper/lower word/dword +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword/int64/qword} +% which returns the lower/upper word/dword of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type cast the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_Integer or real expression expected +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Wrong type $1 in array constructor +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Incompatible type for arg no. $1: Got $2, expected $3 +% You are trying to pass an invalid type for the specified parameter. +type_e_no_method_and_procedure_not_compatible=04026_E_Method (variable) and Procedure (variable) are not compatible +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_Illegal constant passed to internal math function +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_Can't get the address of constants +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +type_e_argument_cant_be_assigned=04029_E_Argument can't be assigned to +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_Can't assign local procedure/function to procedure variable +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_Can't assign values to an address +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_Can't assign values to const variable +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_Identifier not found $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_Internal Error in SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_Duplicate identifier $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_Identifier already defined in $1 at line $2 +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_Unknown identifier $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_Forward declaration not solved $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_Identifier type already defined as type +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_Error in type definition +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_Type identifier not defined +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_Forward type not resolved $1 +% A symbol was forward defined, but no declaration was encountered. +sym_e_only_static_in_static=05010_E_Only static variables can be used in static methods or outside methods +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Invalid call to tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_record or class type expected +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_Instances of classes or objects with an abstract method are not allowed +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_Label not defined $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_Label used but not defined $1 +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Illegal label declaration +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO and LABEL are not supported (use switch -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_Label not found +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_identifier isn't a label +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_label already defined +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_illegal type declaration of set elements +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_Forward class definition not resolved $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_Unit $1 not used in $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_Parameter $1 not used +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_Local variable $1 not used +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_Value parameter $1 is assigned but never used +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_Local variable $1 is assigned but never used +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_Local $1 $2 is not used +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Private field $1.$2 is never used +sym_n_private_identifier_only_set=05030_N_Private field $1.$2 is assigned but never used +sym_n_private_method_not_used=05031_N_Private method $1.$2 never used + + +sym_e_set_expected=05032_E_Set type expected +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_Function result does not seem to be set +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_Type $1 is not aligned correctly in current record for C +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_Unknown record field identifier $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_Local variable $1 does not seem to be initialized +sym_n_uninitialized_variable=05037_W_Variable $1 does not seem to be initialized +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_identifier idents no member $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_Found declaration: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +sym_e_segment_too_large=05040_E_Data segment too large (max. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK not allowed +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE not allowed +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_Expression too complicated - FPU stack overflow +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Illegal expression +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Invalid integer expression +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_Illegal qualifier +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_High range limit < low range limit +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Illegal counter variable +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_Can't determine which overloaded function to call +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_Parameter list size exceeds 65535 bytes +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Illegal type conversion +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_Conversion between ordinals and pointers is not portable across platforms +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_File types must be var parameters +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_The use of a far pointer isn't allowed there +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_illegal call by reference parameters +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_EXPORT declared functions can't be called +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_Possible illegal call of constructor or destructor (doesn't match to this context) +% No longer in use. +cg_n_inefficient_code=06017_N_Inefficient code +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_unreachable code +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_procedure call with stackframe ESP/SP +% The compiler encountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_Abstract methods can't be called directly +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_Internal Error in getfloatreg(), allocation failure +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_Unknown float type +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() base defined twice +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_Extended cg68k not supported +% The \var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_32-bit unsigned not supported in MC68000 mode +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_Internal Error in secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_Register $1 weight $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_Stack limit excedeed in local routine +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_Stack frame is omitted +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_Range check for 64 bit integers is not supported on this target +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_Object or class methods can't be inline. +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_Procvar calls can't be inline. +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_No code for inline procedure stored +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_Direct call of interrupt procedure $1 is not possible +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Element zero of an ansi/wide- or longstring can't be accessed, use (set)length instead +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_Include and exclude not implemented in this case +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_Constructors or destructors can not be called inside a 'with' clause +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_Cannot call message handler method directly +% A message method handler method can't be called directly if it contains an +% explicit self argument +cg_e_goto_inout_of_exception_block=06039_E_Jump in or outside of an exception block +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +cg_e_control_flow_outside_finally=06040_E_Control flow statements aren't allowed in a finally block +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +% \end{description} +# EndOfTeX + +# +# Assembler reader +# +asmr_d_start_reading=07000_D_Starting $1 styled assembler parsing +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_Finished $1 styled assembler parsing +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_Non-label pattern contains @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_Override operator not supported +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_Error building record offset +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET used without identifier +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE used without identifier +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_Cannot use local variable or parameters here +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_need to use OFFSET here +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_need to use $ here +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_Cannot use multiple relocatable symbols +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_Relocatable symbol can only be added +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Invalid constant expression +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_Relocatable symbol is not allowed +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Invalid reference syntax +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_You can not reach $1 from that code +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_Local symbols/labels aren't allowed as references +% You can't use local symbols/labels as references +asmr_e_wrong_base_index=07017_E_Invalid base and index register usage +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_Possible error in object field handling +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Wrong scale factor specified +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_Multiple index register usage +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Invalid operand type +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Invalid string as opcode operand: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE and @DATA not supported +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_Null label references are not allowed +asmr_e_expr_zero_divide=07025_E_Divide by zero in asm evaluator +asmr_e_expr_illegal=07026_E_Illegal expression +asmr_e_escape_seq_ignored=07027_E_escape sequence ignored: $1 +asmr_e_invalid_symbol_ref=07028_E_Invalid symbol reference +asmr_w_fwait_emu_prob=07029_W_Fwait can cause emulation problems with emu387 +asmr_w_fadd_to_faddp=07030_W_FADD without operand translated into FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER instruction is not supported by Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_Calling an overload function in assembler +asmr_e_unsupported_symbol_type=07033_E_Unsupported symbol type for operand +asmr_e_constant_out_of_bounds=07034_E_Constant value out of bounds +asmr_e_error_converting_decimal=07035_E_Error converting decimal $1 +asmr_e_error_converting_octal=07036_E_Error converting octal $1 +asmr_e_error_converting_binary=07037_E_Error converting binary $1 +asmr_e_error_converting_hexadecimal=07038_E_Error converting hexadecimal $1 +asmr_h_direct_global_to_mangled=07039_H_$1 translated to $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 is associated to an overloaded function +asmr_e_cannot_use_SELF_outside_a_method=07041_E_Cannot use SELF outside a method +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_Cannot use OLDEBP outside a nested procedure +asmr_e_void_function=07043_W_Procedures can't return any value in asm code +asmr_e_SEG_not_supported=07044_E_SEG not supported +asmr_e_size_suffix_and_dest_dont_match=07045_E_Size suffix and destination or source size do not match +asmr_w_size_suffix_and_dest_dont_match=07046_W_Size suffix and destination or source size do not match +asmr_e_syntax_error=07047_E_Assembler syntax error +asmr_e_invalid_opcode_and_operand=07048_E_Invalid combination of opcode and operands +asmr_e_syn_operand=07049_E_Assemler syntax error in operand +asmr_e_syn_constant=07050_E_Assemler syntax error in constant +asmr_e_invalid_string_expression=07051_E_Invalid String expression +asmr_w_const32bit_for_address=07052_bit constant created for address +asmr_e_unknown_opcode=07053_E_Unrecognized opcode $1 +asmr_e_invalid_or_missing_opcode=07054_E_Invalid or missing opcode +asmr_e_invalid_prefix_and_opcode=07055_E_Invalid combination of prefix and opcode: $1 +asmr_e_invalid_override_and_opcode=07056_E_Invalid combination of override and opcode: $1 +asmr_e_too_many_operands=07057_E_Too many operands on line +asmr_w_near_ignored=07058_W_NEAR ignored +asmr_w_far_ignored=07059_W_FAR ignored +asmr_e_dup_local_sym=07060_E_Duplicate local symbol $1 +asmr_e_unknown_local_sym=07061_E_Undefined local symbol $1 +asmr_e_unknown_label_identifier=07062_E_Unknown label identifier $1 +asmr_e_invalid_register=07063_E_Invalid register name +asmr_e_invalid_fpu_register=07064_E_Invalid floating point register name +asmr_e_nor_not_supported=07065_E_NOR not supported +asmr_w_modulo_not_supported=07066_W_Modulo not supported +asmr_e_invalid_float_const=07067_E_Invalid floating point constant $1 +asmr_e_invalid_float_expr=07068_E_Invalid floating point expression +asmr_e_wrong_sym_type=07069_E_Wrong symbol type +asmr_e_cannot_index_relative_var=07070_E_Cannot index a local var or parameter with a register +asmr_e_invalid_seg_override=07071_E_Invalid segment override expression +asmr_w_id_supposed_external=07072_W_Identifier $1 supposed external +asmr_e_string_not_allowed_as_const=07073_E_Strings not allowed as constants +asmr_e_no_var_type_specified=07074_No type of variable specified +asmr_w_assembler_code_not_returned_to_text=07075_E_assembler code not returned to text section +asmr_e_not_directive_or_local_symbol=07076_E_Not a directive or local symbol $1 +asmr_w_using_defined_as_local=07077_E_Using a defined name as a local label +asmr_e_dollar_without_identifier=07078_E_Dollar token is used without an identifier +asmr_w_32bit_const_for_address=07079_W_32bit constant created for address +asmr_n_align_is_target_specific=07080_N_.align is target specific, use .balign or .p2align +asmr_e_cannot_access_field_directly_for_parameters=07081_E_Can't access fields directly for parameters +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_Can't access fields of objects/classes directly +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_Too many assembler files +asmw_f_assembler_output_not_supported=08001_F_Selected assembler output not supported +asmw_f_comp_not_supported=08002_F_Comp not supported +asmw_f_direct_not_supported=08003_F_Direct not support for binary writers +asmw_e_alloc_data_only_in_bss=08004_E_Allocating of data is only allowed in bss section +asmw_f_no_binary_writer_selected=08005_F_No binary writer selected +asmw_e_opcode_not_in_table=08006_E_Asm: Opcode $1 not in table +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 invalid combination of opcode and operands +asmw_e_16bit_not_supported=08008_E_Asm: 16 Bit references not supported +asmw_e_invalid_effective_address=08009_E_Asm: Invalid effective address +asmw_e_immediate_or_reference_expected=08010_E_Asm: Immediate or reference expected +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 value exceeds bounds $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: Short jump is out of range $1 +asmw_e_undefined_label=08013_E_Asm: Undefined label $1 + + +# +# Executing linker/assembler +# +# BeginOfTeX +% +% \section{Errors of assembling/linking stage} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +exec_w_source_os_redefined=09000_W_Source operating system redefined +exec_i_assembling_pipe=09001_I_Assembling (pipe) $1 +exec_d_cant_create_asmfile=09002_E_Can't create assember file: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_Can't create object file: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_Can't create archive file: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_Assembler $1 not found, switching to external assembling +exec_t_using_assembler=09006_T_Using assembler: $1 +exec_w_error_while_assembling=09007_W_Error while assembling exitcode $1 +exec_w_cant_call_assembler=09008_W_Can't call the assembler, error $1 switching to external assembling +exec_i_assembling=09009_I_Assembling $1 +exec_i_assembling_smart=09010_I_Assembling smartlink $1 +exec_w_objfile_not_found=09011_W_Object $1 not found, Linking may fail ! +exec_w_libfile_not_found=09012_W_Library $1 not found, Linking may fail ! +exec_w_error_while_linking=09013_W_Error while linking +exec_w_cant_call_linker=09014_W_Can't call the linker, switching to external linking +exec_i_linking=09015_I_Linking $1 +exec_w_util_not_found=09016_W_Util $1 not found, switching to external linking +exec_t_using_util=09017_T_Using util $1 +exec_e_exe_not_supported=09018_E_Creation of Executables not supported +exec_e_dll_not_supported=09019_E_Creation of Dynamic/Shared Libraries not supported +exec_i_closing_script=09020_I_Closing script $1 +exec_w_res_not_found=09021_W_resource compiler not found, switching to external mode +exec_i_compilingresource=09022_I_Compiling resource $1 +%\end{description} +# EndOfTeX + +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_Can't post process executable $1 +execinfo_f_cant_open_executable=09024_F_Can't open executable $1 +execinfo_x_codesize=09025_X_Size of Code: $1 bytes +execinfo_x_initdatasize=09026_X_Size of initialized data: $1 bytes +execinfo_x_uninitdatasize=09027_X_Size of uninitialized data: $1 bytes +execinfo_x_stackreserve=09028_X_Stack space reserved: $1 bytes +execinfo_x_stackcommit=09029_X_Stack space commited: $1 bytes + +# +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_Unitsearch: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_PPU Loading $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU Name: $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU Flags: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU Crc: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU Time: $1 +% When you use the \var{-vu} flag, the time the unit was compiled is shown. +unit_u_ppu_file_too_short=10006_U_PPU File too short +% The ppufile is too short, not all declarations are present. +unit_u_ppu_invalid_header=10007_U_PPU Invalid Header (no PPU at the begin) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_PPU Invalid Version $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU is compiled for an other processor +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU is compiled for an other target +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU Source: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_Writing $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_Can't Write PPU-File +% An error occurred when writing the unit file. +unit_f_ppu_read_error=10014_F_Error reading PPU-File +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_read_unexpected_end=10015_F_unexpected end of PPU-File +% Unexpected end of file. +unit_f_ppu_invalid_entry=10016_F_Invalid PPU-File entry: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU Dbx count problem +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Illegal unit name: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_Too much units +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_Circular unit reference between $1 and $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_Can't compile unit $1, no sources available +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_Can't find unit $1 +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_Unit $1 was not found but $2 exists +unit_f_unit_name_error=10024_F_Unit $1 searched but $2 found +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_Compiling the system unit requires the -Us switch +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_There were $1 errors compiling module, stopping +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_Load from $1 ($2) unit $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_Recompiling $1, checksum changed for $2 +unit_u_recompile_source_found_alone=10029_U_Recompiling $1, source found only +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_Recompiling unit, static lib is older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_Recompiling unit, shared lib is older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_Recompiling unit, obj and asm are older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the assembler or +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_Recompiling unit, obj is older than asm +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_Parsing interface of $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_Parsing implementation of $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_Second load for unit $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU Check file $1 time $2 +% When you use the \var{-vu} flag, the compiler show the filename and +% date and time of the file which a recompile depends on +% \end{description} +# EndOfTeX + +# +# Options +# +option_usage=11000_$1 [options] [options] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_Only one source file supported +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_DEF file can be created only for OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_nested response files are not supported +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_F_No source file name in command line +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_No option inside $1 config file +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Illegal parameter: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? writes help pages +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_Too many config files nested +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_Unable to open file $1 +% The option file cannot be found. +option_reading_further_from=11010_N_Reading further options from $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_Target is already set to: $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_Shared libs not supported on DOS platform, reverting to static +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_too many IF(N)DEFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_too many ENDIFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_open conditional at the end of the file +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_Debug information generation is not supported by this executable +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_Try recompiling with -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_E_You are using the obsolete switch $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_E_You are using the obsolete switch $1, please use $2 +% this warns you when you use a switch that is not supported anymore. You +% must now use the second switch instead. +% It is recommended that you change the switch to overcome problems in the +% future, when the switch meaning may change. +option_switch_bin_to_src_assembler=11020_N_Switching assembler to default source writing assembler +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_Assembler output selected "$1" is not compatible with "$2" +option_asm_forced=11022_W_"$1" assembler use forced +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +%\end{description} +# EndOfTeX + +# +# Logo (option -l) +# +option_logo=11023_[ +Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET +Copyright (c) 1993-2000 by Florian Klaempfl +] + +# +# Info (option -i) +# +option_info=11024_[ +Free Pascal Compiler version $FPCVER + +Compiler Date : $FPCDATE +Compiler Target: $FPCTARGET + +This program comes under the GNU General Public Licence +For more information read COPYING.FPC + +Report bugs,suggestions etc to: + bugrep@freepascal.org +] + +# +# Help pages (option -? and -h) +# +option_help_pages=11025_[ +**0*_put + after a boolean switch option to enable it, - to disable it +**1a_the compiler doesn't delete the generated assembler file +**2al_list sourcecode lines in assembler file +**2ar_list register allocation/release info in assembler file +**2at_list temp allocation/release info in assembler file +**1b_generate browser info +**2bl_generate local symbol info +**1B_build all modules +**1C_code generation options: +**2CD_create also dynamic library (not supported) +**2Ch_ bytes heap (between 1023 and 67107840) +**2Ci_IO-checking +**2Cn_omit linking stage +**2Co_check overflow of integer operations +**2Cr_range checking +**2Cs_set stack size to +**2Ct_stack checking +**2CX_create also smartlinked library +**1d_defines the symbol +*O1D_generate a DEF file +*O2Dd_set description to +*O2Dw_PM application +**1e_set path to executable +**1E_same as -Cn +**1F_set file names and paths: +**2FD_sets the directory where to search for compiler utilities +**2Fe_redirect error output to +**2FE_set exe/unit output path to +**2Fi_adds to include path +**2Fl_adds to library path +*L2FL_uses as dynamic linker +**2Fo_adds to object path +**2Fr_load error message file +**2Fu_adds to unit path +**2FU_set unit output path to , overrides -FE +*g1g_generate debugger information: +*g2gg_use gsym +*g2gd_use dbx +*g2gh_use heap trace unit (for memory leak debugging) +*g2gl_use line info unit to show more info for backtraces +*g2gc_generate checks for pointers +**1i_information +**2iD_return compiler date +**2iV_return compiler version +**2iSO_return compiler OS +**2iSP_return compiler processor +**2iTO_return target OS +**2iTP_return target processor +**1I_adds to include path +**1k_Pass to the linker +**1l_write logo +**1n_don't read the default config file +**1o_change the name of the executable produced to +**1pg_generate profile code for gprof (defines FPC_PROFILE) +*L1P_use pipes instead of creating temporary assembler files +**1S_syntax options: +**2S2_switch some Delphi 2 extensions on +**2Sc_supports operators like C (*=,+=,/= and -=) +**2sa_include assertion code. +**2Sd_tries to be Delphi compatible +**2Se_compiler stops after the errors (default is 1) +**2Sg_allow LABEL and GOTO +**2Sh_Use ansistrings +**2Si_support C++ styled INLINE +**2Sm_support macros like C (global) +**2So_tries to be TP/BP 7.0 compatible +**2Sp_tries to be gpc compatible +**2Ss_constructor name must be init (destructor must be done) +**2St_allow static keyword in objects +**1s_don't call assembler and linker (only with -a) +**1u_undefines the symbol +**1U_unit options: +**2Un_don't check the unit name +**2Us_compile a system unit +**1v_Be verbose. is a combination of the following letters: +**2*_e : Show errors (default) d : Show debug info +**2*_w : Show warnings u : Show unit info +**2*_n : Show notes t : Show tried/used files +**2*_h : Show hints m : Show defined macros +**2*_i : Show general info p : Show compiled procedures +**2*_l : Show linenumbers c : Show conditionals +**2*_a : Show everything 0 : Show nothing (except errors) +**2*_b : Show all procedure r : Rhide/GCC compatibility mode +**2*_ declarations if an error x : Executable info (Win32 only) +**2*_ occurs +**1X_executable options: +*L2Xc_link with the c library +**2Xs_strip all symbols from executable +**2XD_try to link dynamic (defines FPC_LINK_DYNAMIC) +**2XS_try to link static (default) (defines FPC_LINK_STATIC) +**2XX_try to link smart (defines FPC_LINK_SMART) +**0*_Processor specific options: +3*1A_output format: +3*2Aas_assemble using GNU AS +3*2Aasaout_assemble using GNU AS for aout (Go32v1) +3*2Anasmcoff_coff (Go32v2) file using Nasm +3*2Anasmelf_elf32 (Linux) file using Nasm +3*2Anasmobj_obj file using Nasm +3*2Amasm_obj file using Masm (Microsoft) +3*2Atasm_obj file using Tasm (Borland) +3*2Acoff_coff (Go32v2) using internal writer +3*2Apecoff_pecoff (Win32) using internal writer +3*1R_assembler reading style: +3*2Ratt_read AT&T style assembler +3*2Rintel_read Intel style assembler +3*2Rdirect_copy assembler text directly to assembler file +3*1O_optimizations: +3*2Og_generate smaller code +3*2OG_generate faster code (default) +3*2Or_keep certain variables in registers +3*2Ou_enable uncertain optimizations (see docs) +3*2O1_level 1 optimizations (quick optimizations) +3*2O2_level 2 optimizations (-O1 + slower optimizations) +3*2O3_level 3 optimizations (same as -O2u) +3*2Op_target processor: +3*3Op1_set target processor to 386/486 +3*3Op2_set target processor to Pentium/PentiumMMX (tm) +3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm) +3*1T_Target operating system: +3*2TGO32V1_version 1 of DJ Delorie DOS extender +3*2TGO32V2_version 2 of DJ Delorie DOS extender +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +3*1W_Win32 target options +3*2WB_Set Image base to Hexadecimal value +3*2WC_Specify console type application +3*2WD_Use DEFFILE to export functions of DLL or EXE +3*2WG_Specify graphic type application +3*2WN_Do not generate relocation code (necessary for debugging) +3*2WR_Generate relocation code +6*1A_output format +6*2Aas_Unix o-file using GNU AS +6*2Agas_GNU Motorola assembler +6*2Amit_MIT Syntax (old GAS) +6*2Amot_Standard Motorola assembler +6*1O_optimizations: +6*2Oa_turn on the optimizer +6*2Og_generate smaller code +6*2OG_generate faster code (default) +6*2Ox_optimize maximum (still BUGGY!!!) +6*2O2_set target processor to a MC68020+ +6*1R_assembler reading style: +6*2RMOT_read motorola style assembler +6*1T_Target operating system: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_shows this help +**1h_shows this help without waiting +] + +# +# The End... +# diff --git a/befpc/compiler/errores.msg b/befpc/compiler/errores.msg new file mode 100644 index 0000000..2a09eb2 --- /dev/null +++ b/befpc/compiler/errores.msg @@ -0,0 +1,1910 @@ +# +# $Id: errores.msg,v 1.1.1.1 2001-07-23 17:16:05 memson Exp $ +# This file is part of the Free Pascal Compiler +# Copyright (c) 1998-2000 by the Free Pascal Development team +# +# English (default) Language File for Free Pascal +# +# 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. +# +# +# The constants are build in the following order: +# __ +# +# is the part of the compiler the message is used +# asmr_ assembler parsing +# asmw_ assembler writing/binary writers +# unit_ unit handling +# scan_ scanner +# parser_ parser +# type_ type checking +# general_ general info +# exec_ calls to assembler, linker, binder +# +# the type of the message it should normally used for +# f_ fatal error +# e_ error +# w_ warning +# n_ note +# h_ hint +# i_ info +# l_ linenumber +# u_ used +# t_ tried +# m_ macro +# p_ procedure +# c_ conditional +# d_ debug message +# b_ display overloaded procedures +# x_ executable informations +# + +# +# General +# +# BeginOfTeX +% \section{General compiler messages} +% This section gives the compiler messages which are not fatal, but which +% display useful information. The number of such messages can be +% controlled with the various verbosity level \var{-v} switches. +% \begin{description} +general_t_compilername=01000_T_Compilador: $1 +% When the \var{-vt} switch is used, this line tells you what compiler +% is used. +general_d_sourceos=01001_D_OS de origen: $1 +% When the \var{-vd} switch is used, this line tells you what the source +% operating system is. +general_i_targetos=01002_I_OS de destino: $1 +% When the \var{-vd} switch is used, this line tells you what the target +% operating system is. +general_t_exepath=01003_T_Usando el path para ejecutables: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's binaries. +general_t_unitpath=01004_T_Usando el path para unidades: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for compiled units. You can set this path with the \var{-Fu} +general_t_includepath=01005_T_Usando el path para incluidos: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's include files (files used in \var{\{\$I xxx\}} statements). +% You can set this path with the \var{-I} option. +general_t_librarypath=01006_T_Usando el path para librerias: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for the libraries. You can set this path with the \var{-Fl} option. +general_t_objectpath=01007_T_Usando el path para objetos: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for object files you link in (files used in \var{\{\$L xxx\}} statements). +% You can set this path with the \var{-Fo} option. +general_i_abslines_compiled=01008_I_$1 Lneas compiladas, $2 seg +% When the \var{-vi} switch is used, the compiler reports the number +% of lines compiled, and the time it took to compile them (real time, +% not program time). +general_f_no_memory_left=01009_F_No queda memoria disponible +% The compiler doesn't have enough memory to compile your program. There are +% several remedies for this: +% \begin{itemize} +% \item If you're using the build option of the compiler, try compiling the +% different units manually. +% \item If you're compiling a huge program, split it up in units, and compile +% these separately. +% \item If the previous two don't work, recompile the compiler with a bigger +% heap (you can use the \var{-Ch} option for this, \seeo{Ch}) +% \end{itemize} +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +general_i_writingresourcefile=01010_I_Writing Resource String Table file: $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_Writing Resource String Table file: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +scan_f_end_of_file=02000_F_Inesperado fin de fichero +% this typically happens in one of the following cases : +% \begin{itemize} +% \item The source file ends before the final \var{end.} statement. This +% happens mostly when the \var{begin} and \var{end} statements aren't +% balanced; +% \item An include file ends in the middle of a statement. +% \item A comment wasn't closed. +% \end{itemize} +scan_f_string_exceeds_line=02001_F_La cadena excede la lnea +% You forgot probably to include the closing ' in a string, so it occupies +% multiple lines. +scan_f_illegal_char=02002_F_Caracter ilegal +% An illegal character was encountered in the input file. +scan_f_syn_expected=02003_F_Error de sintaxis $1 esperado pero $2 encontrado +% This indicates that the compiler expected a different token than +% the one you typed. It can occur almost everywhere where you make a +% mistake against the pascal language. +scan_t_start_include_file=02004_T_Empezando a leer el fichero aadido $1 +% When you provide the \var{-vt} switch, the compiler tells you +% when it starts reading an included file. +scan_w_comment_level=02005_W_Nivel de comentario $1 encontrado +% When the \var{-vw} switch is used, then the compiler warns you if +% it finds nested comments. Nested comments are not allowed in Turbo Pascal +% and can be a possible source of errors. +scan_n_far_directive_ignored=02006_N_Directiva $F (FAR) ignorada +% The \var{FAR} directive is a 16-bit construction which is recorgnised +% but ignored by the compiler, since it produces 32 bit code. +scan_n_stack_check_global_under_linux=02007_N_El testeo de Stack es global bajo linux +% Stack checking with the \var{-Cs} switch is ignored under \linux, since +% \linux does this for you. Only displayed when \var{-vn} is used. +scan_n_ignored_switch=02008_N_Conmutador de compilador ignorado $1 +% With \var{-vn} on, the compiler warns if it ignores a switch +scan_w_illegal_switch=02009_W_Conmutador de compilador ilegal $1 +% You included a compiler switch (i.e. \var{\{\$... \}}) which the compiler +% doesn't know. +scan_w_switch_is_global=02010_W_Este conmutador de compilador tiene un efecto global +% When \var{-vw} is used, the compiler warns if a switch is global. +scan_e_illegal_char_const=02011_E_Constante de caracter ilegal +% This happens when you specify a character with its ASCII code, as in +% \var{\#96}, but the number is either illegal, or out of range. The range +% is 1-255. +scan_f_cannot_open_input=02012_F_No se puede abrir el fichero $1 +% \fpc cannot find the program or unit source file you specified on the +% command line. +scan_f_cannot_open_includefile=02013_F_No se puede abrir el fichero incluido $1 +% \fpc cannot find the source file you specified in a \var{\{\$include ..\}} +% statement. +scan_e_too_much_endifs=02014_E_Demasiados $ENDIFs o $ELSEs +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_w_only_pack_records=02015_W_Los campos de los Records pueden ser alinieados solo a 1,2,4 o 16 bytes +% You are specifying the \var{\{\$PACKRECORDS n\} } with an illegal value for +% \var{n}. Only 1,2,4 or 16 are valid in this case. +scan_w_only_pack_enum=02016_W_Los enumerados solo pueden ser salvados en 1,2 o 4 bytes +% You are specifying the \var{\{\$PACKENUM n\}} with an illegal value for +% \var{n}. Only 1,2 or 4 are valid in this case. +scan_e_endif_expected=02017_E_$1 esperado para $2 definido en la lnea $3 +% Your conditional compilation statements are unbalanced. +scan_e_preproc_syntax_error=02018_E_Error de sintaxis mientras se procesaba una expresin de compilacin condicional +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_e_error_in_preproc_expr=02019_E_Evaluando una expresin de compilacin condicional +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_w_macro_cut_after_255_chars=02020_W_Los contenidos de la macro son cortados despus del caracter 255 para evaluar la expresin +% The contents of macros cannot be longer than 255 characters. This is a +% safety in the compiler, to prevent buffer overflows. This is shown as a +% warning, i.e. when the \var{-vw} switch is used. +scan_e_endif_without_if=02021_E_ENDIF sin IF(N)DEF +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_f_user_defined=02022_F_El usuario definio: $1 +% A user defined fatal error occurred. see also the \progref +scan_e_user_defined=02023_E_El usuario definio: $1 +% A user defined error occurred. see also the \progref +scan_w_user_defined=02024_W_El usuario definio: $1 +% A user defined warning occurred. see also the \progref +scan_n_user_defined=02025_N_El usuario definio: $1 +% A user defined note was encountered. see also the \progref +scan_h_user_defined=02026_H_El usuario definio: $1 +% A user defined hint was encountered. see also the \progref +scan_i_user_defined=02027_I_El usuario definio: $1 +% User defined information was encountered. see also the \progref +scan_e_keyword_cant_be_a_macro=02028_E_Palabra clave redefinida como macro no tiene efecto +% You cannot redefine keywords with macros. +scan_f_macro_buffer_overflow=02029_F_Desbordamiento del buffer de macro mintras se lea o se expanda +% Your macro or it's result was too long for the compiler. +scan_w_macro_deep_ten=02030_W_La extension de macros excede una profundidad de 16. +% When expanding a macro macros have been nested to a level of 16. +% The compiler will expand no further, since this may be a sign that +% recursion is used. +scan_e_wrong_styled_switch=02031_E_conmutadores de compilador no estan permitidos en comentarios de estilo (* ... *) +% Compiler switches should always be between \var{\{ \}} comment delimiters. +scan_d_handling_switch=02032_D_Manejando el conmutador "$1" +% When you set debugging info on (\var{-vd}) the compiler tells you when it +% is evaluating conditional compile statements. +scan_c_endif_found=02033_C_ENDIF $1 encontrado +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifdef_found=02034_C_IFDEF $1 encontrado, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifopt_found=02035_C_IFOPT $1 encontrado, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_if_found=02036_C_IF $1 encontrado, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifndef_found=02037_C_IFNDEF $1 encontrado, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_else_found=02038_C_ELSE $1 encontrado, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_skipping_until=02039_C_Omitiendo hasta... +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements, and whether it is skipping or +% compiling parts. +scan_i_press_enter=02040_I_Presiona para continuar +% When the \var{-vi} switch is used, the compiler stops compilation +% and waits for the \var{Enter} key to be pressed when it encounters +% a \var{\{\$STOP\}} directive. +scan_w_unsupported_switch=02041_W_Conmutador $1 no soportado +% When warings are turned on (\var{-vw}) the compiler warns you about +% unsupported switches. This means that the switch is used in Delphi or +% Turbo Pascal, but not in \fpc +scan_w_illegal_directive=02042_W_Directiva ilegal del compilador $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unrecognised switches. For a list of recognised switches, \progref +scan_t_back_in=02043_T_Vuelve en $1 +% When you use (\var{-vt}) the compiler tells you when it has finished +% reading an include file. +scan_w_unsupported_app_type=02044_W_Tipo de aplicacin no soportada: $1 +% You get this warning, ff you specify an unknown application type +% with the directive \var{\{\$APPTYPE\}} +scan_w_app_type_not_support=02045_W_APPTYPE no es soportado por el OS de destino +% The \var{\{\$APPTYPE\}} directive is supported by win32 applications only. +scan_w_decription_not_support=02046_W_DESCRIPTION is only supported for OS2 and Win32 +% The \var{\{\$DESCRIPTION\}} directive is only supported for OS2 and Win32 targets. +scan_n_version_not_support=02047_N_VERSION is not supported by target OS. +% The \var{\{\$VERSION\}} directive is only supported by win32 target. +scan_n_only_exe_version=02048_N_VERSION only for exes or DLLs +% The \var{\{\$VERSION\}} directive is only used for executable or DLL sources. +scan_w_wrong_version_ignored=02049_W_Wrong format for VERSION directive $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_El estilo de asamblador especificado $1 no es soportado +% When you specify an assembler mode with the \var{\{\$ASMMODE xxx\}} +% the compiler didn't recognize the mode you specified. +scan_w_no_asm_reader_switch_inside_asm=02051_W_Conmutador de lector de ASM no esta permitido dentre de bloques asm $1 ser efectivo solo para el siguiente +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Modificador de conmutador errneo, usa ON/OFF o +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_Los ficheros de recursos no son soportados por este destino +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +% +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +scan_w_include_env_not_found=02054_W_Include environment $1 not found in environment +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_Illegal value for FPU register limit +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +scan_w_only_one_resourcefile_supported=02056_W_Only one resource file is supported for this target +% The target you are compiling for supports only one resource file. This is the +% case of OS/2 (EMX) currently. The first resource file found is used, the +% others are discarded. +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +parser_e_syntax_error=03000_E_Analizador - Error de sintaxis +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_Procedure tipo FAR ignorado +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_Procedure tipo NEAR ignorado +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_Procedure type INTERRUPT ignored for not i386 +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is ignored for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT procedure can't be nested +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_Procedure type $1 ignored +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_Not all declarations of $1 are declared with OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_No se especific un fichero DLL +% No longer in use. +parser_e_export_name_double=03008_E_Los nombre de funciones exportadas de DLL no pueden ser dobles $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_Los indices de funciones exportadas de DLL no pueden ser dobles $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Indice no vlido para la funcion exportada de DLL +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_Relocatable DLL or executable $1 debug info does not work, disabled. +parser_w_parser_win32_debug_needs_WN=03012_W_To allow debugging for win32 code you need to disable relocation with -WN option +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_El nombre del constructor tiene que ser INIT +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_El nombre del destructor tiene que ser DONE +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Parmetro abierto ilegal +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_Procedure tipo INLINE no soportado +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Los mtodos privados no deben ser virtuales +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_El constructor debera ser pblico +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_El destructor debera ser pblico +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_Una clase debera tener solo un destructor +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_Las definiciones de clases locales no estn permitidas +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_Las definiciones de clases annimas no estn permitidas +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_El objeto $1 no tiene VMT +parser_e_illegal_parameter_list=03024_E_Lista de parmetros ilegal +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Tipo de parmetro errneo especificado para el arg num. $1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Cantidad errnea de parmetros +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_el identificador sobrecargado $1 no es una funcin +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_funciones sobrecargadas tienen los mismos parmetros +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_la cabecera de la funcin no concuerda con la declaracin posterior $1 +% You declared a function with same parameters but +% different result type or function specifiers. +parser_e_header_different_var_names=03030_E_la cabecera de la funcion $1 no concuerda con la posterior declaracin : el nombre de la var. cambia $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_solo los valores mayores pueden ser incluidos en un tipo enumerado +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_ El nombre en Interface e implementation es diferente ! +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With no puede ser usado para variables en un segmento diferente +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_Anidado de funciones > 31 +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_error de testeo de rango mientras se evaluaban las constantes +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_error de testeo de rango mientras se evaluaban las constantes +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_etiqueta de case duplicada +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_Lmite superior del rango de case es menor less que el lmite inferior +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_constantes de tipo class o object no estn permitidas +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_el asignar variables de tipo function a funciones sobrecargadas no est permitido +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_la longitud de una cadena tiene que ser un valor entre 1 y 255 +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_usa la sintaxis estendida de DISPOSE y NEW para generar instancias de objetos +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_el uso de NEW o DISPOSE para punteros sin tipo no tiene sentido +parser_e_no_new_dispose_on_void_pointers=03044_E_el uso de NEW o DISPOSE no es posible con punteros sin tipo +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_identificador de clase esperado +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_identificador de tipo no permitido aqu +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_identificador de mtodo esperado +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_la cabecera de la funcion no concuerda con ningn mtodo de esta clase +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_procedure/function $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Constante ilegal de punto flotante +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL solo puede ser usado en constructores +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_Los destructores no pueden tener parmetros +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_Solo los mtodos de clases pueden ser referidos con referencias de clase +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_Solo los mtodos de la clase pueden ser accedidos por los mtodos de esa clase +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_Los tipos de una constante y CASE no concuerdan +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_El smbolo no puede ser exportado de una librera +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_Un mtodo heredado est oculto por $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_No hay un mtodo en una clase antepasada para ser substituido: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_No se suministro un miembro para acceder a propiedad +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_La directiva Stored prorperty no est implementada an +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_smbolo ilegal para el acceso a propiedad +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_No se puede acceder a un campo protegido de un objeto aqu +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_No se puede acceder a un campo privado de un objeto aqu +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_mtodo sobrecargado de un mtodo virtual debera ser virtual: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_mtodo sobrecargado de un mtodo no virtual debera ser no virtual: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_mtodos sobrecargados que son virtuales tienen que tener el mismo tipo para retorno: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_Las funciones declarados como EXPORT no pueden estar anidados +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_los mtodos no pueden ser EXPORTados +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_los llamadas por parmetros variables tienen que concordar exactamente +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_La clase no es un pariente de la clase actual +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF solo est permitido en mtodos +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_los mtodos solo pueden estar en otros mtodos llamados directamente con el tipo identificador de la clase +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Uso ilegal de ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_Error de testeo de rango en constructor de set o elemento de set duplicado +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_Puntero a objeto esperado +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_La expresin tiene que ser una llamada al constructor +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_La expresin tiene que ser una llamada al destructor +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Orden ilegal de elementos de record +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_El tipo de la expresin tiene que ser class o record +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_Funciones sin valores de retorno no pueden devolver ningun valor +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_constructores y destructores tienen que ser mtodos +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_El operador no esta sobrecargado +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_Impossible to overload assignment for equal types +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_Impossible operator overload +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_Re-incremento no es posible aqu +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_La sintaxis extendida de new o dispose no est permitida para una clase +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_Ensamblador incompatible con el valor de retorno de la funcin +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_La sobrecarga de funciones no esta activada +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_No es posible sobrecargar este operador (sobrecarga = en lugar de) +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_Operador comparativo tiene que devolver un valor booleano +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_Solo los mtodos virtuales pueden ser abstractos +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_Uso de caracterstica no soportada! +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_La mezcla de CLASSES y OBJECTS no est permitida +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_Directiva de procedure desconocida debe ser ignorada: $1 +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_absolute solo puede estar asociado a UNA variable +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_absolute solo puede ser asociado a un var o const +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_Solo una variable puede ser inicializada +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_Mtodos abstractos no deveran tener ninguna definicin (con el cuerpo de la funcin) +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_Esta funcin sobrecargada no puede ser local (tiene que ser exported) +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_Mtodos virtuales estn siendo usados sin un constructor en $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_Macro definida: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_Macro indefinida: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_Macro $1 puesta a $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_Compilando $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_Parsing interface of unit $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_Parsing implementation of $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_Compilando $1 por segunda vez +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_Propiedades de array no estn permitidas en este punto +% You cannot use array properties at that point.a +parser_e_no_property_found_to_override=03109_E_No se encontro la propiedad a sobreescribir +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_Solo una propiedad por defecto esta permitida, encontrada propiedad por defecto heredada en class $1 +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_La propiedad por defecto tiene que ser un array de propieada +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_Constructores virtuales son solo soportados en modelo class +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_No hay propiedad por defecto disponible +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_La clase no puede tener una seccin published, usa el conmutador {$M+} +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_Declaracin posterior de la clase $1 tiene que ser resuelta aqu para usar la clase como antepasado +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_Operadores locales no soportados +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_Directiva de procedure $1 no esta permitida en la seccin interface +% This procedure directive is not allowed in the \var{interface} section of +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_Directiva de procedure $1 no permitida en la seccin implementation +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_Directiva de procedure $1 no permitida en declaracin procvar +% This procedure directive cannot be part of a procedural of function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_La funcin esta actualmente declarada como Public/Forward $1 +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_No se pueden usar ambos EXPORT y EXTERNAL +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_palabra clave NAME esperada +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 no est soportado todava dentro de procedure/function inline +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_Inlining deshabilitado +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_Escribiendo Browser log $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_podra ser que falte la de-referencia del puntero +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_Lector del ensamblador seleccionado no soportado +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_Directiva de procedure $1 tiene conflictos con otras directivas +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_Convencion de llamada no concuerda con la posterior +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_Llamadas por registros (fastcall) no soportadas +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_Propiedad no puede tener un valor por defecto +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_El valor por defecto de una propiedad tiene que ser constante +% The value of a \var{default} declared property must be knwon at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_El smbolo no puede ser published, solo puede ser una clase +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_Este tipo de propiedad no puede ser published +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_Nombre de imporatacion vaco +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_Nombre de importacin especificado +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_Nombre interno de la funcin cambi despus de usar la funcin +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_Division por cero +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Operacion de punto flotante no vlida +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_Lmite superior del rango es menor que el lmite inferior +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_string "$1" is longer than $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_La longitud de la cadena es mayor que el array de carcteres +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Expresin ilegal despus de una directiva mensaje +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_Manejadores de mensajes solo pueden tomar una llamada por par. de referencia +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_Etiqueta de mensaje duplicada: $1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_Self solo puede ser un parmetro explicito en manejadores de mensajes +% The self parameter can be passed only explicit if it is a method which +% is declared as message method handler +parser_e_threadvars_only_sg=03147_E_Threadvars solo pueden ser estticas o globales +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_Ensamblador directo no soportado para formato binario de salida +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +% \end{description} +parser_w_no_objpas_use_mode=03149_W_No carges manuamente la unidad OBJPAS, usa {$mode objfpc} o {$mode delphi} +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_OVERRIDE no puede ser usado en objetos +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +parser_e_cant_use_inittable_here=03151_E_Data types which requires initialization/finalization can't be used in variant records +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_Resourcestrings can be only static or global +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_Exit with argument can't be used here +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_The type of the storage symbol must be boolean +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_This symbol isn't allowed as storage symbol +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_Only class which are compiled in $M+ mode can be published +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_Procedure directive expected +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_The value for a property index must be of an ordinal type +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_Procedure name to short to be exported +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_No DEFFILE entry can be generated for unit global vars +parser_e_dlltool_unit_var_problem2=03161_E_Compile without -WD option +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_desconcordancia de tipo +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Tipos incompatibles: cogi "$1" esperado "$2" +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_Desconcuerdo de tipos entre $1 y $2 +% The types are not equal +type_e_type_id_expected=04003_E_Identificador de tipo esperado +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_Identificador de variable esperado +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_espression entera esperada +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_Boolean expression expected, but got "$1" +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_Espresin ordinal esperada +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_tipo puntero esperado +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_tipo clase esperado +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_Identificador de variable o tipo esperado +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_No se puede evaluar la espresin constante +% No longer in use. +type_e_set_element_are_not_comp=04012_E_Elementos del Set no son compatibles +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_Operacin no implementada para sets +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_Conversion automtica de tipo de punto flotante a COMP el cual es un tipo entero +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_usa DIV para tener un resultado entero +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_tipos string no concuerdan, a cause del modo $V+ +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_succ o pred en enumeraciones con asignaciones no es posible +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_No se puede leer o escribir variables de este tipo +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_Can't use readln or writeln on typed file +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_Can't use read or write on untyped file. +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_Conflicto de tipos entre elementos del set +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_lo/hi(longint/dword) devuelve el word superior/inferior +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword} +% which returns the lower/upper word of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type case the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_Espresin entera o real esperada +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Tipo errneo en constructor de array +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Tipo incompatible para el arg. num. $1: Cogi $2, esperado $3 +% You are trying to pass an invalid type for the specified parameter. +% \end{description} +type_e_no_method_and_procedure_not_compatible=04026_E_Mtodo (variable) y Procedure (variable) no son compatibles +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_Illegal constant passed to internal math function +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_Can't get the address of constants +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +type_e_argument_cant_be_assigned=04029_E_Argument can't be assigned to +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_Can't assign local procedure/function to procedure variable +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_Can't assign values to an address +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_Can't assign values to const variable +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_Identificador no encontrado $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_Error interno en SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_Identificador duplicado $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_El identificador ya est definido en $1 en la lnea $2 +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_Identificador desconocido $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_Declaracin posterior no solucionada $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_Identificador de tipo ya est definido como un tipo +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_Error en definicin de tipo +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is errneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_Identificador de tipo no definido +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_Tipo posterior no resuelto $1 +% The compiler encountered an unknown type. +sym_e_only_static_in_static=05010_E_Solo las variables estticas pueden ser usadas en mtodos estticos o fuera de mtodos +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Llamada invlida a tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_tipo record o class esperado +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_Instancias de clases u objetos con un mtodo abstracto no estn permitidas +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_Etiqueta no definida $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_Label used but not defined $1 +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Declaracin de etiqueta ilegal +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO y LABEL no son soportados (usa conmutador -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_Etiqueta no encontrada +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_el identificador no es una etiqueta +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_la etiqueta no est definida todava +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_declaracin ilegal de tipo en elementos de set +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_Definicin posterior de clase no resuelta $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_Unit $1 not used in $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_Parmetro no usado $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_Variable local no usada $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_Value parameter $1 is assigned but never used +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_Local variable $1 is assigned but never used +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_Local $1 $2 is not used +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Private field $1.$2 is never used +sym_n_private_identifier_only_set=05030_N_Private field $1.$2 is assigned but never used +sym_n_private_method_not_used=05031_N_Private method $1.$2 never used + + +sym_e_set_expected=05032_E_Tipo set esperado +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_El resultado de la funcin no parece estar puesto +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_Type $1 is not aligned correctly in current record for C +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_Identificador de campo de record desconocido $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_La variable local $1 no parace ser inicializada +sym_n_uninitialized_variable=05037_W_Variable $1 does not seem to be initialized +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_identifier idents no member $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_declaracin encontrada: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +sym_e_segment_too_large=05040_E_Data segment too large (max. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK no est permitido +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE no est permitido +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_Espresin demasiado complicada - desboradamiento del stack de FPU +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_espresin ilegal +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Entero invlido +% You made an exression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_Qualificador ilegal +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_Lmite del rango superior < al lmite del rango inferior +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Variable de contador ilegal +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_No se puede determinar a cual funcin sobrecargada llamar +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_La lista de parmetros excede los 65535 bytes +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Conversin de tipos ilegal +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_Conversiones entre ordinales y punteros no son portables entre plataformas +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_Los tipos File tienen que ser parmetros variables +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_El uso de punteros lejanos (far) no est permitido ahi +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_llamada ilegal por parmetros de referencia +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_las funciones declaradas como EXPORT no pueden ser llamadas +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_Posible llamada ilegal de constructor o destructor (no concuerda con este contexto) +% No longer in use. +cg_n_inefficient_code=06017_N_cdigo ineficiente +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_este cdigo no se ejecutar nunca +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_llamada a procedure con stackframe ESP/SP +% The compiler enocountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_Los mtodos abstractos no pueden ser llamados directamente +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_Error interno en getfloatreg(), fallo de alojamiento +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_tipo flotante desconocido +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_base de SecondVecn() definida dos veces +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_El tipo Extended no es soportado en cg68k +% The var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_el entero sin signo de 32-bit no est soportado en modo MC68000 +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_Error interno en secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_Registro $1 peso $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_El lmite del Stack ha sido excedido in una rutina local +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try to put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_El frame del Stack es omitido +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_Range check for 64 bit integers is not supported on this target +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_Incapaz de "inline" mtodos del objeto +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_Incapaz de "inline" llamadas a procvar +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_No hay informacion de cdigo almacenada para "inline" procedure +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_Direct call of interrupt procedure $1 is not possible +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Elemento cero de un ansi/wide- o longstring no puede ser accedido, usa (set)length +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_Include or exclude not implemented in this case +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_Constructores o destructores no pueden ser llamados aqu dentro +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_No se puede llamar al mtodo manejador de mensaje directamente +% A message method handler method can't be called directly if it contains an +% explicit self argument +% \end{description} +# EndOfTeX + +# +# Assembler reader +# +cg_e_goto_inout_of_exception_block=06039_E_Jump in or outside of an exception block +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +cg_e_control_flow_outside_finally=06040_E_Control flow statements aren't allowed in a finally block +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX + +# +# Assembler reader +# +asmr_d_start_reading=07000_D_Empezado analizacin de ensamblador estilo $1 +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_Finalizado analizacin de ensamblador estilo $1 +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_Una directiva que no es una etiqueta contiene @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_Operador sobreescrito no soportado +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_Error construyendo desplazamiento de record +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET usado sin identificador +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE used without identifier +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_No se puede usar variable local o parmetro aqu +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_necesita usar OFFSET aqu +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_need to use $ here +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_No se pueden usar multiples smbolos realojables +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_Smbolo realojable solo puede ser aadido +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Espresin constante invlida +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_Smbolo realojable no permitido +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Sintaxis de referencia invlida +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_You can not reach $1 from that code +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_Local symbols/labels aren't allowed as references +% You can't use local symbols/labels as references +asmr_e_wrong_base_index=07017_E_Base invlida, uso de registro ndice +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_Possible error in object field handling +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Factor de escala errneo +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_Uso de multiples registros ndice +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Tipo del operando no vlido +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Cadena no vlida como operando opcode: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE y @DATA no soportados +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_Referencias a etiqueta nula no permitida +asmr_e_expr_zero_divide=07025_E_Divide by zero in asm evaluator +asmr_e_expr_illegal=07026_E_Illegal expression +asmr_e_escape_seq_ignored=07027_E_Sequencia de escape ignorada: $1 +asmr_e_invalid_symbol_ref=07028_E_smbolo de referencia no vlido +asmr_w_fwait_emu_prob=07029_W_Fwait puede causar problemas de emulacin con emu387 +asmr_w_fadd_to_faddp=07030_W_FADD without operand translated into FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER instruction is not supported by Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_Llamando una funcion sobrecargada en asm +asmr_e_unsupported_symbol_type=07033_E_Tipo de smbolo no soportado para operando +asmr_e_constant_out_of_bounds=07034_E_Valor constante fuera de lmites +asmr_e_error_converting_decimal=07035_E_Error convirtiendo decimal $1 +asmr_e_error_converting_octal=07036_E_Error convirtiendo octal $1 +asmr_e_error_converting_binary=07037_E_Error convirtiendo binario $1 +asmr_e_error_converting_hexadecimal=07038_E_Error convirtiendo hexadecimal $1 +asmr_h_direct_global_to_mangled=07039_H_$1 traducido a $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 esta asociado a una funcin sobrecargada +asmr_e_cannot_use_SELF_outside_a_method=07041_E_No se puede usar SELF fuera de un mtodo +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_No se puede usar OLDEBP fuera de un procedure anidado +asmr_e_void_function=07043_W_Procedures no pueden devolver ningn valor en cdigo asm +asmr_e_SEG_not_supported=07044_E_SEG no soportado +asmr_e_size_suffix_and_dest_dont_match=07045_E_Tamao de sufijo y destinacin o tamao del origen no concuerdan +asmr_w_size_suffix_and_dest_dont_match=07046_W_Tamao de sufijo y destinacin o tamao del origen no concuerdan +asmr_e_syntax_error=07047_E_Error de sintaxis de ensamblador +asmr_e_invalid_opcode_and_operand=07048_E_Combinacin no vlida de opcode y operandos +asmr_e_syn_operand=07049_E_Error de sintaxis de ensamblador en operando +asmr_e_syn_constant=07050_E_Error de sintaxis de ensamblador en constante +asmr_e_invalid_string_expression=07051_E_Espresin de cadena no vlida +asmr_w_const32bit_for_address=07052_W_Constante de 32bit creada para direccin +asmr_e_unknown_opcode=07053_E_Unrecognized opcode $1 +asmr_e_invalid_or_missing_opcode=07054_E_Invlido o falta opcode +asmr_e_invalid_prefix_and_opcode=07055_E_Combinacin no vlida de prefijo y opcode: $1 +asmr_e_invalid_override_and_opcode=07056_E_Combinacin no vlida de override y opcode: $1 +asmr_e_too_many_operands=07057_E_Demasiados operandos en la lnea +asmr_w_near_ignored=07058_W_NEAR ignorado +asmr_w_far_ignored=07059_W_FAR ignorado +asmr_e_dup_local_sym=07060_E_Smbolo local duplicado $1 +asmr_e_unknown_local_sym=07061_E_Smbolo local indefinido $1 +asmr_e_unknown_label_identifier=07062_E_Identificador de etiqueta desconocido $1 +asmr_e_invalid_register=07063_E_Invalid register name +asmr_e_invalid_fpu_register=07064_E_Nombre de registro de punto flotante no vlido +asmr_e_nor_not_supported=07065_E_NOR no soportado +asmr_w_modulo_not_supported=07066_W_Modulo no soportado +asmr_e_invalid_float_const=07067_E_Constante de punto flotante no vlida $1 +asmr_e_invalid_float_expr=07068_E_Espresin de punto flotante no vlida +asmr_e_wrong_sym_type=07069_E_Tipo de smbolo errneo +asmr_e_cannot_index_relative_var=07070_E_No se puede indexar una var. local o un parmetro con un registro +asmr_e_invalid_seg_override=07071_E_Espresin de segmento sobreescrito no vlida +asmr_w_id_supposed_external=07072_W_Identificador $1 supuesto externo +asmr_e_string_not_allowed_as_const=07073_E_Strings no permitidos como constantes +asmr_e_no_var_type_specified=07074_E_No hay tipo de variable especificado +asmr_w_assembler_code_not_returned_to_text=07075_E_Cdigo ensamblador no devuelto a seccin de texto +asmr_e_not_directive_or_local_symbol=07076_E_No es una directiva o un smbolo local $1 +asmr_w_using_defined_as_local=07077_E_Usando un nombre definido como una etiqueta local + +# +# Assembler/binary writers +# +asmr_e_dollar_without_identifier=07078_E_Dollar token is used without an identifier +asmr_w_32bit_const_for_address=07079_W_32bit constant created for address +asmr_n_align_is_target_specific=07080_N_.align is target specific, use .balign or .p2align +asmr_e_cannot_access_field_directly_for_parameters=07081_E_Can't access fields directly for parameters +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_Can't access fields of objects/classes directly +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_Demasiados archivos de ensamblador abiertos +asmw_f_assembler_output_not_supported=08001_F_Ensamblador de salida seleccionado no soportado +asmw_f_comp_not_supported=08002_F_Comp no soportado +asmw_f_direct_not_supported=08003_F_Direct no soportado por escritores binarios +asmw_e_alloc_data_only_in_bss=08004_E_El alojamiento de datos solo est permitido en seccin bss +asmw_f_no_binary_writer_selected=08005_F_No hay seleccionado un escritor binario +asmw_e_opcode_not_in_table=08006_E_Asm: Opcode $1 no esta en la tabla +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 combinacion invalida de opcode y operandos +asmw_e_16bit_not_supported=08008_E_Asm: Referencias de 16 Bit no soportadas +asmw_e_invalid_effective_address=08009_E_Asm: Direccion efectiva no valida +asmw_e_immediate_or_reference_expected=08010_E_Asm: Inmediato o referencia esperado +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 valor excede los lmites $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: Salto corto es fuera de rango $1 + + +# +# Executing linker/assembler +# +asmw_e_undefined_label=08013_E_Asm: Undefined label $1 + + +# +# Executing linker/assembler +# +# BeginOfTeX +% +% \section{Errors of assembling/linking stage} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +exec_w_source_os_redefined=09000_W_Sistema operativo de origen redefinido +exec_i_assembling_pipe=09001_I_Ensamblando (pipe) $1 +exec_d_cant_create_asmfile=09002_E_No se puede crear fichero ensamblador $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_Can't create object file: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_Can't create archive file: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_Ensamblador $1 no encontrado, cambiando a ensamblado externo +exec_t_using_assembler=09006_T_Usando ensamblador: $1 +exec_w_error_while_assembling=09007_W_Error mientras se ensamblaba cdigo de salida $1 +exec_w_cant_call_assembler=09008_W_No se puede llamar al ensamblador, error $1 cambiando a ensamblado externo +exec_i_assembling=09009_I_Ensamblando $1 +exec_i_assembling_smart=09010_I_Assembling smartlink $1 +exec_w_objfile_not_found=09011_W_Objeto $1 no encontrado, Enlace podra fallar ! +exec_w_libfile_not_found=09012_W_Librera $1 no encontrada, Enlace podra fallar ! +exec_w_error_while_linking=09013_W_Error mientras se enlazaba +exec_w_cant_call_linker=09014_W_No se puede llamar al enlazador, cambiando al enlazador externo +exec_i_linking=09015_I_Enlazando $1 +exec_w_util_not_found=09016_W_Util $1 not found, switching to external linking +exec_t_using_util=09017_T_Using util $1 +exec_e_exe_not_supported=09018_E_Creation of Executables not supported +exec_e_dll_not_supported=09019_E_Libreras dinamicas no soportadas +exec_i_closing_script=09020_I_Cerrando script $1 +exec_w_res_not_found=09021_W_compilador de resources no encontrado, cambiando a modo externo +exec_i_compilingresource=09022_I_Compilando resource $1 + +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_No se puede post-procesar el ejecutable $1 +execinfo_f_cant_open_executable=09024_F_No se puede abrir el ejecutable $1 +execinfo_x_codesize=09025_X_Tamao de Cdigo: $1 bytes +execinfo_x_initdatasize=09026_X_Tamao de datos inicializados: $1 bytes +execinfo_x_uninitdatasize=09027_X_Tamao de datos sin inicializar: $1 bytes +execinfo_x_stackreserve=09028_X_Espacio reservado para Stack: $1 bytes +execinfo_x_stackcommit=09029_X_Stack space commited: $1 bytes + +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_Buscando unidad: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_Cargando PPU $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU Nombre: $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU Banderas: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU Crc: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU Fecha: $1 +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_file_too_short=10006_U_Fichero PPU demasiado corto +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_invalid_header=10007_U_Cabecera PPU invlida (no est PPU al principio) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_Versin $1 de PPU no es vlida +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU est compilada para otro procesador +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU est compilada para otro destino +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_Fuente PPU: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_Escribiendo $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_No se puede escribir el fichero PPU +% An err +unit_f_ppu_read_error=10014_F_leyendo fichero PPU +% Unexpected end of file +unit_f_ppu_read_unexpected_end=10015_F_inexperado fin de fichero PPU +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_invalid_entry=10016_F_Entrada invlida en fichero PPU: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_Problema contando PPU Dbx +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Nombre de unidad ilegal: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_Demasiades unidades +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_Referencia circular entre unidades $1 y $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_No se puede compilar la unidad $1, no hay fuentes disponibles +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_Can't find unit $1 +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_Unit $1 was not found but $2 exists +unit_f_unit_name_error=10024_F_Unit $1 searched but $2 found +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_Compilar la unidad System requiere el conmutador -Us +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_Ha habido $1 errors compilando el modulo, parando +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_Cargado de $1 ($2) la unidad $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_Recompilando $1, checksum cambiado por $2 +unit_u_recompile_source_found_alone=10029_U_Recompilando $1, solo se encontr el fuente +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_Recompilando unidad, lib esttica es ms vieja que ppu +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_Recompilando unidad, lib compartida es ms vieja que ppu +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_Recompilando unidad, obj y asm son ms viejos que ppu +% When you use the \var{-vu} flag, the compiler warns if the assembler of +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_Recompilando unidad, obj es ms viejo que asm +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_Analizando interface de $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_Analizando implementation de $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_Segunda carga para la unidad $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_Chequeo de fichero PPU $1 fecha $2 +% When you use the \var{-vu} flag, the compiler show the filename and +% date and time of the file which a recompile depends on +% \end{description} +# EndOfTeX + +# +# Options +# +option_usage=11000_$1 [opciones] [opciones] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_Solo es soportado un fichero fuente +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_Fichero DEF solo puede ser creado para OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_Ficheros de respuesta anidados no son soportados +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_F_No hay fichero fuente en lnea de comandos +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_No option inside $1 config file +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Parmetro ilegal: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? escribe las pginas de ayuda +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_Demasiados ficheros de configuracion anidados +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_Imposible abrir fichero $1 +% The option file cannot be found. +option_reading_further_from=11010_N_Leyendo opciones adicionales de $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_Destino est ya puesto a: $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_Libreras compartidas no soportadas en la plataforma DOS, revocando a estticas +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_demasiados IF(N)DEFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_demasiados ENDIFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_condicional abierto al final del fichero +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_La generacin de informacin de depuracin no es soportada por este ejecutable +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_Prueba recompilando con -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_E_Estas usando el conmutador obsoleto $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_E_Ests usando el conmutador obsoleto $1, porfavor usa $2 +% this warns you when you use a switch that is not supported anymore. You +% must now use the second switch instead. +% It is recommended that you change the switch to overcome problems in the +% future, when the switch meaning may change. +option_switch_bin_to_src_assembler=11020_N_Cambindo a ensamblador de escritura de cdigo fuente por defecto +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_Assembler output selected "$1" is not compatible with "$2" +option_asm_forced=11022_W_"$1" assembler use forced +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +%\end{description} +# EndOfTeX + +# +# Logo (option -l) +# +option_logo=11023_[ +Free Pascal Compiler versin $FPCVER [$FPCDATE] para $FPCTARGET +Copyright (c) 1998-2000 por Florian Klaempfl +] + +# +# Info (option -i) +# +option_info=11024_[ +Free Pascal Compiler versin $FPCVER + +Fecha del compilador : $FPCDATE +Destino del compilador : $FPCTARGET + +Este programa viene bajo la Licencia Pblica General de GNU +Para ms informacin lea COPYING.FPC + +Comunicanos fallos, sugerencias, etc a: + bugrep@freepascal.org +] + +# +# Help pages (option -? and -h) +# +option_help_pages=11025_[ +**0*_pon + despus de un conmutador boleano para activarlo, - para desactivarlo +**1a_el compilador no borrar el fichero ensamblador generado +**2al_muestra las lneas de cdigo fuente en el fichero ensamblador +**2ar_mostrar alojamiento/desaloj. registro info. en fichero ensamblador +**2at_mostrar alojamiento/desaloj. temporal info. en fichero ensamblador +**1b_generar informacin de navegador +**2bl_generar informacion de smbolos locales +**1B_construir todos los mdulos +**1C_code generation options: +3*2CD_crear librera dinmica +**2Ch_ bytes de heap (entre 1023 y 67107840) +**2Ci_chequeo de E/S +**2Cn_omitir enlazado +**2Co_chequea el desbordamiento de operaciones con enteros +**2Cr_chequeo de rango +**2Cs_pone el tamao del stack a +**2Ct_chequeo del stack +3*2CS_crear librera esttica +3*2Cx_usar enlaze-inteligente +**1d_define el smbolo +*O1D_genera un fichero DEF +*O2Dd_pone la descripcin a +*O2Dw_aplicacion PM +**1e_pone el path a ejecutables +**1E_igual a -Cn +**1F_pone nombres de ficheros y paths +**2FD_pone el directorio donde buscar para utilidades del compilador +**2Fe_redirecciona la salida de errores a +**2FE_pone el path de destino de ejecutable/unidad a +**2Fi_aade al path de incluidos +**2Fl_aade al path de librerias +*L2FL_usa como enlazador dinmico +**2Fo_aade al path de objetos +**2Fr_carga fichero de mensages de error +**2Fu_aade al path de unidades +**2FU_pone el path de destino de unidades a , anula -FE +*g1g_genera informacin de depuracin +*g2gg_usa gsym +*g2gd_usa dbx +*g2gh_usa la unidad de trazado del heap +*g2gc_generate checks for pointers +**1i_informacin +**2iD_devuelve la fecha del compilador +**2iV_devuelve la versin del compilador +**2iSO_devuelve el OS de origen +**2iSP_devuelve el procesador de origen +**2iTO_devuelve el OS de destino +**2iTP_devuelve el procesador de destino +**1I_aade al path de aadidos +**1k_Pasa al enlazador +**1l_escribe logotipo +**1n_no lee el fichero de configuracin por defecto +**1o_cambia el nombre del ejecutable producido a +**1pg_genera cdigo de perfil para gprof +*L1P_usa pipes en vez de crear ficheros ensamblador temporales +**1S_opciones de sintaxis +**2S2_habilita algunas extensiones de Delphi 2 +**2Sc_soportar operadores tipo C (*=,+=,/= y -=) +**2Sd_intenta ser compatible con Delphi +**2Se_el compilador se para despus del primer error +**2Sg_permite LABEL y GOTO +**2Sh_Usar cadenas ansi (ansistrings) +**2Si_soportar INLINE estilo C++ +**2Sm_soportar macros tipo C (globales) +**2So_intenta ser compatible con TP/BP 7.0 +**2Sp_intenta ser compatible con gpc +**2Ss_nombre del constructor tiene que ser init (destructor tiene que ser done) +**2St_permite la palabra clave static en objetos +**1s_no llama al ensamblador ni al enlazador (solo con -a) +**1u_indefine el smbolo +**1U_opciones de unidad +**2Un_no testea el nombre de unidad +**2Us_compila una unidad de sistema +**1v_Ser explicativo. es una combinacin de las siguientes letras : +**2*_e : muestra errores (defecto) d : muestra info de depuracin +**2*_w : muestra advertencias u : muestra info de unidades +**2*_n : muestra notas t : muestra ficheros inten./usados +**2*_h : muestra trucos m : muestra macros definidas +**2*_i : muestra informacin general p : muestra procedures compilados +**2*_l : muestra nmero de lnea c : muestra condicionales +**2*_a : muestra todo 0 : no muestra nada (excepto errores) +**2*_b : muestra toda la declaracin r : modo compatible con Rhide/GCC +**2*_ del procedure si ocurre x : info. de ejecutable (solo Win32) +**2*_ un error +**1X_opciones del ejecutable +*L2Xc_enlaza con la librera c +**2XD_enlaza con libreras dinmicass (define FPC_LINK_DYNAMIC) +**2Xs_elimina todos los smbolos del ejecutable +**2XS_enlaza con libreras estticas (define FPC_LINK_STATIC) +**0*_Opciones especficas del procesador: +3*1A_formato de salida +3*2Aas_fichero coff usando GNU AS +3*2Aasaout_fichero coff usando GNU AS for aout (Go32v1) +3*2Anasmcoff_coff (Go32v2) file using Nasm +3*2Anasmelf_elf32 (Linux) file using Nasm +3*2Anasmobj_obj file using Nasm +3*2Amasm_obj usando Masm (Microsoft) +3*2Atasm_obj usando Tasm (Borland) +3*2Acoff_coff (Go32v2) using internal writer +3*2Apecoff_pecoff (Win32) using internal writer +3*1R_tipo de lectura de ensamblador +3*2Ratt_lee ensamblador estilo AT&T +3*2Rintel_lee ensamblador estilo Intel +3*2Rdirect_copiar texto ensamblador directamente al fichero ensamblador +3*1O_optimizaciones +3*2Og_generar cdigo ms pequeo +3*2OG_generar cdigo ms rpido (defecto) +3*2Or_mantener ciertas variables en registros (todaba con fallos!!!) +3*2Ou_habilita las optimizaciones inciertas (mira la documentacin) +3*2O1_nivel 1 de optimizacin (optimizaciones rpidas) +3*2O2_nivel 2 de optimizacin (-O1 + optimizaciones lentas) +3*2O3_nivel 3 de optimizacin (igual que -O2u) +3*2Op_procesador de destino +3*3Op1_pone el procesador de destino en 386/486 +3*3Op2_pone el procesador de destino en Pentium/PentiumMMX (tm) +3*3Op3_pone el procesador de destino en PPro/PII/c6x86/K6 (tm) +3*1T_Sistema operativo de destino +3*2TGO32V1_versin 1 del extensor del DOS de DJ Delorie +3*2TGO32V2_versin 2 del extensor del DOS de DJ Delorie +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +6*1A_formato de salida +6*2Aas_Unix o-file usando GNU AS +6*2Agas_Ensamblador GNU Motorola +6*2Amit_Sintaxis MIT (antiguo GAS) +6*2Amot_Ensamblador estandard de Motorola +6*1O_optimizaciones +6*2Oa_enchega el optimizador +6*2Og_generar el cdigo ms pequeo +6*2OG_generar el cdigo ms rpido (defecto) +6*2Ox_optimizar al mximo (todaba con fallos!!!) +6*2O2_pone el procesador de destino para un MC68020+ +6*1R_estilo de lectura de ensamblador +6*2RMOT_lee el estilo de ensamblador de motorola +6*1T_Sistema operativo de destino +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_muestra esta ayuda +6*1R_assembler reading style: +6*2RMOT_read motorola style assembler +6*1T_Target operating system: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_shows this help +**1h_muestra esta ayuda sin esperar +] + +# +# The End... +# diff --git a/befpc/compiler/errorf.msg b/befpc/compiler/errorf.msg new file mode 100644 index 0000000..7ed0b6f --- /dev/null +++ b/befpc/compiler/errorf.msg @@ -0,0 +1,1896 @@ +# +# $Id: errorf.msg,v 1.1.1.1 2001-07-23 17:16:08 memson Exp $ +# This file is part of the Free Pascal Compiler +# Copyright (c) 1998-2000 by the Free Pascal Development team +# +# French (cp850) Language File for Free Pascal +# +# 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. +# +# +# The constants are build in the following order: +# __ +# +# is the part of the compiler the message is used +# asmr_ assembler parsing +# asmw_ assembler writing/binary writers +# unit_ unit handling +# scan_ scanner +# parser_ parser +# type_ type checking +# general_ general info +# exec_ calls to assembler, linker, binder +# +# the type of the message it should normally used for +# f_ fatal error +# e_ error +# w_ warning +# n_ note +# h_ hint +# i_ info +# l_ linenumber +# u_ used +# t_ tried +# m_ macro +# p_ procedure +# c_ conditional +# d_ debug message +# b_ display overloaded procedures +# x_ executable informations +# + +# +# General +# +# BeginOfTeX +% \section{General compiler messages} +% This section gives the compiler messages which are not fatal, but which +% display useful information. The number of such messages can be +% controlled with the various verbosity level \var{-v} switches. +% \begin{description} +general_t_compilername=01000_T_Compilateur : $1 +% When the \var{-vt} switch is used, this line tells you what compiler +% is used. +general_d_sourceos=01001_D_Systme d'exploitation source : $1 +% When the \var{-vd} switch is used, this line tells you what the source +% operating system is. +general_i_targetos=01002_I_Systme d'exploitation cible : $1 +% When the \var{-vd} switch is used, this line tells you what the target +% operating system is. +general_t_exepath=01003_T_Rpertoire pour fichiers executables : $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's binaries. +general_t_unitpath=01004_T_Rpertoire de recherche d'units : $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for compiled units. You can set this path with the \var{-Fu} +general_t_includepath=01005_T_Rpertoire pour recherche de fichiers inclus : $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's include files (files used in \var{\{\$I xxx\}} statements). +% You can set this path with the \var{-I} option. +general_t_librarypath=01006_T_Rpertoire pour librairies : $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for the libraries. You can set this path with the \var{-Fl} option. +general_t_objectpath=01007_T_Rpertoire pour fichiers objets : $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for object files you link in (files used in \var{\{\$L xxx\}} statements). +% You can set this path with the \var{-Fo} option. +general_i_abslines_compiled=01008_I_$1 lignes compiles, $2 secondes +% When the \var{-vi} switch is used, the compiler reports the number +% of lines compiled, and the time it took to compile them (real time, +% not program time). +general_f_no_memory_left=01009_F_Plus de mmoire disponible +% The compiler doesn't have enough memory to compile your program. There are +% several remedies for this: +% \begin{itemize} +% \item If you're using the build option of the compiler, try compiling the +% different units manually. +% \item If you're compiling a huge program, split it up in units, and compile +% these separately. +% \item If the previous two don't work, recompile the compiler with a bigger +% heap (you can use the \var{-Ch} option for this, \seeo{Ch}) +% \end{itemize} +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +general_i_writingresourcefile=01010_I_Ecriture du fichier Resource : $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_Ecriture du fichier Resource String Table : $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +scan_f_end_of_file=02000_F_Fin de fichier inattendue +% this typically happens in on of the following cases : +% \begin{itemize} +% \item The source file ends befor then final \var{end.} statement. This +% happens mostly when the \var{begin} and \var{end} statements aren't +% balanced; +% \item An include file ends in the middle of a statement. +% \item A comment wasn't closed. +% \end{itemize} +scan_f_string_exceeds_line=02001_F_String au-del de la fin de ligne +% You forgot probably to include the closing ' in a string, so it occupies +% multiple lines. +scan_f_illegal_char=02002_F_caractre illgal +% An illegal character was encountered in the input file. +scan_f_syn_expected=02003_F_Erreur de syntaxe, $1 attendu mais $2 trouv +% This indicates that the compiler expected a different token than +% the one you typed. It can occur almost everywhere where you make a +% mistake against the pascal language. +scan_t_start_include_file=02004_T_Dbut de lecture du fichier inclus $1 +% When you provide the \var{-vt} switch, the compiler tells you +% when it starts reading an included file. +scan_w_comment_level=02005_W_Commentaire de niveau $1 +% When the \var{-vw} switch is used, then the compiler warns you if +% it finds nested comments. Nested comments are not allowed in Turbo Pascal +% and can be a possible source of errors. +scan_n_far_directive_ignored=02006_N_$F directive (FAR) ignore +% The \var{FAR} directive is a 16-bit construction which is recorgnised +% but ignored by the compiler, since it produces 32 bit code. +scan_n_stack_check_global_under_linux=02007_N_Le controle de la gestion de la pile est global sous Linux +% Stack checking with the \var{-Cs} switch is ignored under \linux, since +% \linux does this for you. Only displayed when \var{-vn} is used. +scan_n_ignored_switch=02008_N_Switch "$1" ignor +% With \var{-vn} on, the compiler warns if it ignores a switch +scan_w_illegal_switch=02009_W_Switch "$1" illgal +% You included a compiler switch (i.e. \var{\{\$... \}}) which the compiler +% doesn't know. +scan_w_switch_is_global=02010_W_Ce switch a un effet global +% When \var{-vw} is used, the compiler warns if a switch is global. +scan_e_illegal_char_const=02011_E_Constante de type char illgale +% This happens when you specify a character with its ASCII code, as in +% \var{\#96}, but the number is either illegal, or out of range. The range +% is 1-255. +scan_f_cannot_open_input=02012_F_Impossible d'ouvrir le fichier $1 +% \fpc cannot find the program or unit source file you specified on the +% command line. +scan_f_cannot_open_includefile=02013_F_Impossible d'ouvrir le fichier inclus $1 +% \fpc cannot find the source file you specified in a \var{\{\$include \}} +% stateent. +scan_e_too_much_endifs=02014_E_Trop de $ENDIFs ou de $ELSEs +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_w_only_pack_records=02015_W_L'alignement des Records peut uniquement tre de 1,2,4,8 ou 16 bytes +% You are specifying the \var{\{\$PACKRECORDS n\} } with an illegal value for +% \var{n}. Only 1,2,4 or 16 are valid in this case. +scan_w_only_pack_enum=02016_W_Les numerations peuvent seulement tre sauvegards en 1,2 ou 4 bytes +% You are specifying the \var{\{\$PACKENUM n\}} with an illegal value for +% \var{n}. Only 1,2 or 4 are valid in this case. +scan_e_endif_expected=02017_E_$1 attendu pour $2 dfini la ligne $3 +% Your conditional compilation statements are unbalanced. +scan_e_preproc_syntax_error=02018_E_Erreur de syntaxe pendant l'interprtation d'une directive de compilation +% There is an error in the expression following the \var{\{\$if \}} compiler +% directive. +scan_e_error_in_preproc_expr=02019_E_Erreur d'valuation d'une directive de compilation +% There is an error in the expression following the \var{\{\$if \}} compiler +% directive. +scan_w_macro_cut_after_255_chars=02020_W_Le contenu d'une macro est tronqu 255 caractres +% The contents of macros cannot be longer than 255 characters. This is a +% safety in the compiler, to prevent buffer overflows. This is shown as a +% warning, i.e. when the \var{-vw} switch is used. +scan_e_endif_without_if=02021_E_ENDIF sans IF(N)DEF +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_f_user_defined=02022_F_Dfini par l'utilisateur : $1 +% A user defined fatal error occurred. see also the \progref +scan_e_user_defined=02023_E_Dfini par l'utilisateur : $1 +% A user defined error occurred. see also the \progref +scan_w_user_defined=02024_W_Dfini par l'utilisateur : $1 +% A user defined warning occurred. see also the \progref +scan_n_user_defined=02025_N_Dfini par l'utilisateur : $1 +% A user defined note was encountered. see also the \progref +scan_h_user_defined=02026_H_Dfini par l'utilisateur : $1 +% A user defined hint was encountered. see also the \progref +scan_i_user_defined=02027_I_Dfini par l'utilisateur : $1 +% User defined information was encountered. see also the \progref +scan_e_keyword_cant_be_a_macro=02028_E_Impossible de redefinir un mot rserv +% You cannot redefine keywords with macros. +scan_f_macro_buffer_overflow=02029_F_Dbordement du buffer de la macro en lecture ou expansion +% Your macro or it's result was too long for the compiler. +scan_w_macro_deep_ten=02030_W_L'expansion des macros dpasse un niveau de 16. +% When expanding a macro macros have been nested to a level of 16. +% The compiler will expand no further, since this may be a sign that +% recursion is used. +scan_e_wrong_styled_switch=02031_E_Les directives de compilation entre (* ... *) ne sont pas acceptes +% Compiler switches should always be between \var{\{ \}} comment delimiters. +scan_d_handling_switch=02032_D_Interprtation switch "$1" +% When you set debugging info on (\var{-vd}) the compiler tells you when it +% is evaluating conditional compile statements. +scan_c_endif_found=02033_C_ENDIF $1 trouv +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifdef_found=02034_C_IFDEF $1 trouv, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifopt_found=02035_C_IFOPT $1 trouv, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_if_found=02036_C_IF $1 trouv, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifndef_found=02037_C_IFNDEF $1 trouv, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_else_found=02038_C_ELSE $1 trouv, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_skipping_until=02039_C_Passant jusqu'... +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements, and whether it is skipping or +% compiling parts. +scan_i_press_enter=02040_I_Appuyez sur pour continuer +% When the \var{-vi} switch is used, the compiler stops compilation +% and waits for the \var{Enter} key to be pressed when it encounters +% a \var{\{\$STOP\}} directive. +scan_w_unsupported_switch=02041_W_Switch non support $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unsupported switches. This means that the switch is used in Delphi or +% Turbo Pascal, but not in \fpc +scan_w_illegal_directive=02042_W_directive de compilation illgale $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unrecognised switches. For a list of recognised switches, \progref +scan_t_back_in=02043_T_De retour dans $1 +% When you use (\var{-vt}) the compiler tells you when it has finished +% reading an include file. +scan_w_unsupported_app_type=02044_W_Type d'application non supporte : $1 +% You get this warning, ff you specify an unknown application type +% with the directive $APPTYPE +scan_w_app_type_not_support=02045_W_$APPTYPE non support par OS cible +% The $APPTYPE directive is supported by win32 applications only +scan_w_decription_not_support=02046_W_DESCRIPTION est support seulement pour OS2 et Win32 +% The \var{\{\$DESCRIPTION\}} directive is only supported for OS2 and Win32 targets. +scan_n_version_not_support=02047_N_VERSION non support par OS cible +% The \var{\{\$VERSION\}} directive is only supported by win32 target. +scan_n_only_exe_version=02048_N_VERSION seulement pour exes ou DLLs +% The \var{\{\$VERSION\}} directive is only used for executable or DLL sources. +scan_w_wrong_version_ignored=02049_W_Mauvais format de la directive VERSION $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_Style assembleur non support $1 +% When you specify an assembler mode with the \var{\{\$ASMMODE xxx\}} +% the compiler didn't recognize the mode you specified. +scan_w_no_asm_reader_switch_inside_asm=02051_W_Changement de type d'interprteur ASM l'intrieur de code assembleur, $1 sera effectif seulement pour le prochain +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Mauvais argument de switch, utilisez ON/OFF ou +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_Fichiers ressource non support pour cette cible +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +scan_w_include_env_not_found=02054_W_Include pour variable d'environment $1 non trouv +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_Valeur invalide pour nombre limite de variables en registre FPU +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +scan_w_only_one_resourcefile_supported=02056_W_Un fichier ressource est seulement support pour cette cible +% Only one resource file can be supported for this target - this is the case of +% OS/2 (EMX) currently. The first one found is used, the others are discarded. +% +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +parser_e_syntax_error=03000_E_Parseur - Erreur de syntaxe +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_Directive pour procdure FAR ignor +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_Directive pour procdure NEAR ignor +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_Directive pour procdure INTERRUPT ignor +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is igonred for other processors. +parser_e_dont_nest_interrupt=03004_E_Une procdure de type INTERRUPT ne peut tre locale +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_Procedure type $1 ignored +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_Not all declarations of $1 are declared with OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_Pas de fichier DLL spcifi +% No longer in use. +parser_e_export_name_double=03008_E_Nom de fonction exporte doubl $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_Index de fonction exporte doubl $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Index non valide pour fonction exporte +% DLL function index must be in the range 1..$FFFF +parser_w_parser_reloc_no_debug=03011_W_Les DLL ou EXE relogeables sont incompatibles avec les informations de dbogage, dbogage dsactiv. +parser_w_parser_win32_debug_needs_WN=03012_W_Pour permettre le dbogage de code win32, utilisez l'option -WN +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_Le nom du constructeur doit tre INIT +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_Le nom du destructeur doit tre DONE +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Paramtre ouvert non valide +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_Directive de fonction INLINE non supporte +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Les mthodes prives ne devraient pas tre virutelles +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_Le constructeur devrait tre public +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_Le destructeur devrait tre public +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_Les classes ne devraient avoir qu'un selu destructeur +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_Les Dfinitions locales de classes ne sont pas autorises +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_Les dfinitions de classes anonymes sont interdites +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_L'object $1 n'a pas de table de mthodes virtuelles (VMT) +parser_e_illegal_parameter_list=03024_E_Liste de paramtres illgale +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Mauvais type pour paramtre #$1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Mauvais nombre de paramtres spcifi +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_L'identificateur surcharg $1 n'est pas une fonction +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_Les fonctions surcharges ont les mmes paramtres +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_L'entte de la fonction ne correspond pas la dclaration $1 +% You declared a function with same parameters but +% different result type or function specifiers. +parser_e_header_different_var_names=03030_E_L'entte de la fonction $1 ne correspond pas la dclaration : le nom de variable change $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_Les valeurs d'une numration doivent tre en ordre ascendant +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Les noms d'interface et d'implementation sont diffrents $1 => $2 +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With ne peut tre utilis pour des variables dans un autre segment +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_Niveau d'inbrication de fonctions > 31 +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_Erreur d'intervalle dans l'valuation d'une constante +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_Erreur d'intervalle dans l'valuation d'une constante +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_Valeur en double dans une instruction CASE +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_Valeur max infrieure la valeur min dans CASE +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_Les constantes types de classes sont interdites +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_Impossible d'assigner une variable fonctionelle une fonction surcharge +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_La longueur d'une STRING doit tre situe entre 1 et 255 +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_Utilisez la syntaxe tendue de NEW et DISPOSE pour les objets +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_L'usage de NEW ou DISPOSE pour des pointeurs non typs est sans signification meaningless +parser_e_no_new_dispose_on_void_pointers=03044_E_L'usage de NEW ou DISPOSE pour des pointeurs non typs est sans signification meaningless +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \vat{delphi} modes. +parser_e_class_id_expected=03045_E_Identificateur de classe attendu +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_Identificateur de type interdit ici +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_Identificateur de mthode attendu +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_La fonction ne correspond aucune mthode de cette classe +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_procdure/fonction $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Constante relle illgale +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL peut uniquement tre utilis dans un constructeur +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_Les destructeurs ne peuvent avoir de paramtres +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_Seules des mthodes de classes peuvent tre rfr avec des rfrences de classes +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_Seuls des mthodes de classes peuvent tre appels dans une mthode de classe +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_La constante et le type de CASE ne conserpodnet pas +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_Le symbole ne peut tre export d'une librairie +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_Une mthode hrite est cache par $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_Il n'y a pas de mthode dans l'anctre que l'on peut surcharger : $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_Il manque un champ pour spcifier l'accss la property +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_Directive de property Stored non implemente +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Symbole illgal pour accs la property +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_Impossible d'accder un champ "protected" d'un object ici +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_Impossible d'accder un champ "private" d'un object ici +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_Mthode surchargeant une mthode virtuelle devrait tre virtuelle : $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_Mthode surchargeant une mthode non virtuelle devrait tre non virtuelle : $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_Mthodes virtuelles surcharges doivent avoir le mme type rsultat : $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_Des fonctions dclares comme EXPORT ne peuvent tre locales +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_Les mthodes ne peuvent pas tre EXPORTes +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_Un appel avec paramtre par variable doivent tre du type exact de la dclaration +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_Cette classe n'est pas un paarent de la classe actuelle +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF est seulement possible dans les mthodes +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_Les mthodes ne peuvent tre appels avec un type qu' l'intrieur d'une mthode +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Utilisation non valide de ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_Erreur d'intervalle ou lment dupliqu dans un constructeur d'ensemble +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_Pointeur d'object attendu +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_Expression doit tre un appel un constructeur +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_Expression doit tre un appel un destructeur +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Mauvais ordre des lments d'un record +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_L'expression doit tre de type record ou objet +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_Les procdures ne peuvent retourner une valeur +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_Les constructeurs et destructeurs doivent tre des mthodes +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_Operator n'est pas surcharg +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_Impossible de surcharger l'assignement pour des types gaux +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_Impossible operator overload +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_Re-raise impossible ici +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_La syntaxe tendue de new ou dispose n'est pas valide pour une classe +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_Directive "Assembler" incompatible avec le type de la fonction +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_L'overloading de procdure est dsactiv +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_Impossible de redfinir cet oprateur +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_Un opratuer de comparaison doit retourner une valeur boolenne +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_Seule une mthode virtuelle peut tre abstraite +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_Utilisation d'une caractristique non supporte ! +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_Il est interdit de mlanger des objets et des classes +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_Directive de procdure non reconnue a due tre ignore : $1 +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_absolute put seulement tre associ une seule variable +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_absolute peut seulement tre associ une variable ou une constante +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_Seule UNE variable peut tre initialise +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_Les mthodes "Abstract" ne peuvent pas avoir d'implementation +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_Cette fonction surcharge ne peut tre locale (doit tre exporte) +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_Des mthodes virtuelles sont utilises sans constructeur pour $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_Macro dfinie : $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_Macro non dfinie : $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_Macro $1 pour valeur $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_Compilation de $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_Lecture de l'interface de l'unit $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_Lecture de l'implementation de $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_Compilation de $1 pour la seconde fois +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_Les proprits vecteurs ne sont pas acceptes ici +% You cannot use array properties at that point. +parser_e_no_property_found_to_override=03109_E_Aucune proprit trouve pour override +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_Seule une proprit pardfaut autorise, il y en a une dans la classe $1 +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_La proprit par dfaut doit tre une proprit vecteur +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_Les constructeurs virtuels sont seulement possible pour les classes +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_Pas de proprit par dfaut +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_PUBLISHED non autoris ici pour des classes, utilisez {$M+} +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_La dclaration anticipe de la classe $1 doit tre rsolue ici pour pouvoir treparent +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_Les oprateurs ne peuvent tre locaux +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_La directive de procdure $1 n'est pas autorise en interface +% This procedure directive is not allowed in the \var{interface} section of +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_La directive de procdure $1 n'est pas autorise en implmentation +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_La directive de procdure n'est pas valide pour une variable +% This procedure directive cannot be part of a procedural of function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_La fonction $1 est dj dclare comme publique ou forward +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_EXPORT et EXTERNAL sont incompatibles +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_Le mot rserv NAME est requis ici +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 n'est pas support pour des fonctions INLINE +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_Inlining dsactiv +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_Ecriture du Browser log $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_le drfrencement du pointeur semble manquer +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_Lecteur de code assembleur non support +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_La directive de procdure $1 est en conflit avec d'autres directives +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_La convention d'appel ne correspond pas la fonction prdfinie +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_Appel avec registres (fastcall) non support +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_Cette proprit ne peut avoir de valeur par dfaut +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_La valeur par dfaut d'une proprit doit tre une constante +% The value of a \var{default} declared property must be knwon at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_Ce symbole n'est pas une classe et ne peut donc pas tre PUBLISHED +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_Ce genre de proprit ne peut tre PUBLISHED +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_Nom d'importation vide +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_Empty import name specified +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_Le nom interne de la fonction chang aprs son usage +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_Division par zro +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Opration en virgule flottatne invalide +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_Limite suprieure infrieure la limite infrieure d'un intervalle +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_String "$1" est plus long que $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_longueur du String suprieure la longueur du CHAR ARRAY +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Expression invalide aprs directive MESSAGE +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_MESSAGE handler peuvent seulement accepter un paramtre par rfrence +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_Duplicate message label: %1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_SELF ne peut tre un paramtre explicite que dans les MESSAGE handlers +% The self parameter can be passed only explicit if it is a method which +% is declared as message method handler +parser_e_threadvars_only_sg=03147_E_THREADVARS peuvent seulement tre statiques ou globaux +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_Assembleur direct non support pour la sortie binaire +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_Ne chargez pas l'unit OBJPAS manuellement, utilisez {$mode objfpc} ou {$mode delphi} +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the {$mode objfpc} or {$mode delphi} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_OVERRIDE nepeut tre utilis pour des objets +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +parser_e_cant_use_inittable_here=03151_E_Les types de donnes ncessitant des initialisations ne peuvent faire partie de RECORD variables +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_RESOURCESTRINGS doivent tre statiques ou globaux +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_Exit avec un argument ne peut tre utilis ici +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_Le type du symbole STORED doit tre un boolen +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_Ce symbole n'est pas admis comme symbole STORED +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_Selues les classes compiles en mode $M+ peuvent tre PUBLISHED +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_Directive de procdure attendue +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_Le type d'un index de proprit doit tre un type ordinal +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_Nom de procdure trop court pour tre exprot +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_Impossible de crer une entre DEFFILE pour des variables globales d'units +parser_e_dlltool_unit_var_problem2=03161_E_Compilez sans l'option -WD +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Incompatibilit de types +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Incompatible types: got $1 expected $2 +% There is no conversion possible between the two types +type_e_not_equal_types=04002_E_Incompatibilit de types entre $1 et $2 +% The types are not equal +type_e_type_id_expected=04003_E_Identificateur de type attendu +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_Identificateur de variable attendu +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_Integer expression expected +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_Expression boolenne attendue, mais "$1" obtenu +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_Expression ordinale attendue +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_Type pointeur attendu +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_Type classe attendu +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_Identificateur de variable ou de type attendu +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_Impossible d'valuer l'expression constante +% No longer in use. +type_e_set_element_are_not_comp=04012_E_Elements d'ensembles non compatibles +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_Opration non permise pour des ensembles +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_Conversion automatique de rel vers COMP qui est un type entier +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_Utilisez DIV pour obtenir un rsultat entier +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_Types string incompatibles, cause du mode $V+ +% When compiling in \var{\{\$V+ \}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_succ ou pred impossible pour des numrations avec valeurs fixes +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_Impossible de lire ou d'crire des variables de ce type +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_Impossible d'utiliser READLN ou WRITELN pour un ficher typ +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_Impossible d'utiliser READ ou WRITE pour un FILE non typ +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_Confit de type pour des lments d'un ensemble +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_lo/hi(longint/dword) retourne le word bas/haut +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword} +% which returns the lower/upper word of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type case the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_Expression entire ou relle attendue +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Mauvais type dans array constructor +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Type incompatible type pour arg #$1: $2 au lieu de $3 +% You are trying to pass an invalid type for the specified parameter. +% \end{description} +type_e_no_method_and_procedure_not_compatible=04026_E_Method (variable) et Procedure (variable) sont incompatibles +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_Constante invalide passe une fonction mathmatique interne +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_Impossible d'obtenir l'adresse d'une constante +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +type_e_argument_cant_be_assigned=04029_E_Impossible d'assigner une valeur l'argument +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_Impossible d'assigner une fonction ou procdure locale une variable de procdure +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_Can't assign values to an address +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_Can't assign values to const variable +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_Identificateur non trouv $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_Internal Error in SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_Duplicate identifier $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_Identifier already defined in $1 at line $2 +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_Unknown identifier $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_Forward declaration not solved $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_Identifier type already defined as type +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_Error in type definition +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_Type identifier not defined +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_Forward type not resolved $1 +% The compiler encountered an unknown type. +sym_e_only_static_in_static=05010_E_Only static variables can be used in static methods or outside methods +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Invalid call to tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_record or class type expected +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_Instances of classes or objects with an abstract method are not allowed +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_Label not defined $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_Label used but not defined $1 +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Illegal label declaration +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO und LABEL are not supported (use switch -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_Label not found +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_identifier isn't a label +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_label already defined +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_illegal type declaration of set elements +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_Forward class definition not resolved $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_Unit $1 not used in $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_Parameter not used $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_Local variable not used $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_Value parameter $1 is assigned but never used +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_Local variable $1 is assigned but never used +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_Local $1 $2 is not used +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Private field $1.$2 is never used +sym_n_private_identifier_only_set=05030_N_Private field $1.$2 is assigned but never used +sym_n_private_method_not_used=05031_N_Private method $1.$2 never used + +sym_e_set_expected=05032_E_Set type expected +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_Function result does not seem to be set +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_Type $1 is not aligned correctly in current record for C +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_Unknown record field identifier $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_Local variable $1 does not seem to be initialized +% This message is displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the right-hand side of an +% assigment) +sym_n_uninitialized_variable=05037_W_Variable $1 does not seem to be initialized +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_identifier idents no member $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_Found declaration: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +sym_e_segment_too_large=05040_E_Data segment too large (max. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK not allowed +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE not allowed +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_Expression too complicated - FPU stack overflow +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Illegal expression +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Invalid integer expression +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_Illegal qualifier +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_High range limit < low range limit +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Illegal counter variable +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_Can't determine which overloaded function to call +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_Parameter list size exceeds 65535 bytes +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Illegal type conversion +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_Conversion between ordinals and pointers is not portable across platforms +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_File types must be var parameters +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_The use of a far pointer isn't allowed there +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_illegal call by reference parameters +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_EXPORT declared functions can't be called +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_Possible illegal call of constructor or destructor (doesn't match to this context) +% No longer in use. +cg_n_inefficient_code=06017_N_Inefficient code +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_unreachable code +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_procedure call with stackframe ESP/SP +% The compiler encountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_Abstract methods can't be called directly +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_Internal Error in getfloatreg(), allocation failure +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_Unknown float type +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() base defined twice +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_Extended cg68k not supported +% The var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_32-bit unsigned not supported in MC68000 mode +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_Internal Error in secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_Register $1 weight $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_Stack limit excedeed in local routine +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_Stack frame is omitted +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_Range check for 64 bit integers is not supported on this target +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_Object or class methods can't be inline. +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_Procvar calls can't be inline. +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_No code for inline procedure stored +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_Direct call of interrupt procedure $1 is not possible +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Element zero of an ansi/wide- or longstring can't be accessed, use (set)length instead +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_Include and exclude not implemented in this case +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_Constructors or destructors can not be called inside a 'with' clause +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_Cannot call message handler method directly +% A message method handler method can't be called directly if it contains an +% explicit self argument +% \end{description} +# EndOfTeX +# +# Assembler reader +# +cg_e_goto_inout_of_exception_block=06039_E_Jump in or outside of an exception block +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +cg_e_control_flow_outside_finally=06040_E_Control flow statements aren't allowed in a finally block +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX +asmr_d_start_reading=07000_D_Starting $1 styled assembler parsing +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_Finished $1 styled assembler parsing +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_Non-label pattern contains @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_Override operator not supported +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_Error building record offset +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET used without identifier +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE utilis sans identificateur +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_Cannot use local variable or parameters here +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_need to use OFFSET here +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_need to use $ here +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_Cannot use multiple relocatable symbols +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_Relocatable symbol can only be added +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Invalid constant expression +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_Relocatable symbol is not allowed +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Invalid reference syntax +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_Impossible d'atteindre $1 depuis ce code +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_Local symboles/labels ne sont pas autoriss +% You can't use local symbols/labels as references +asmr_e_wrong_base_index=07017_E_Invalid base and index register usage +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_Erreur possible dans l'utilisation d'un champ d'un object +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Wrong scale factor specified +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_Multiple index register usage +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Invalid operand type +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Invalid string as opcode operand: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE and @DATA not supported +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_Null label references are not allowed +asmr_e_expr_zero_divide=07025_E_Divide by zero in asm evaluator +asmr_e_expr_illegal=07026_E_Illegal expression +asmr_e_escape_seq_ignored=07027_E_escape sequence ignored: $1 +asmr_e_invalid_symbol_ref=07028_E_Invalid symbol reference +asmr_w_fwait_emu_prob=07029_W_Fwait can cause emulation problems with emu387 +asmr_w_fadd_to_faddp=07030_W_FADD without operand translated into FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER instruction is not supported by Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_Calling an overload function in assembler +asmr_e_unsupported_symbol_type=07033_E_Unsupported symbol type for operand +asmr_e_constant_out_of_bounds=07034_E_Constant value out of bounds +asmr_e_error_converting_decimal=07035_E_Error converting decimal $1 +asmr_e_error_converting_octal=07036_E_Error converting octal $1 +asmr_e_error_converting_binary=07037_E_Error converting binary $1 +asmr_e_error_converting_hexadecimal=07038_E_Error converting hexadecimal $1 +asmr_h_direct_global_to_mangled=07039_H_$1 translated to $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 is associated to an overloaded function +asmr_e_cannot_use_SELF_outside_a_method=07041_E_Cannot use SELF outside a method +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_Cannot use OLDEBP outside a nested procedure +asmr_e_void_function=07043_W_Functions with void return value can't return any value in asm code +asmr_e_SEG_not_supported=07044_E_SEG not supported +asmr_e_size_suffix_and_dest_dont_match=07045_E_Size suffix and destination or source size do not match +asmr_w_size_suffix_and_dest_dont_match=07046_W_Size suffix and destination or source size do not match +asmr_e_syntax_error=07047_E_Assembler syntax error +asmr_e_invalid_opcode_and_operand=07048_E_Invalid combination of opcode and operands +asmr_e_syn_operand=07049_E_Assemler syntax error in operand +asmr_e_syn_constant=07050_E_Assemler syntax error in constant +asmr_e_invalid_string_expression=07051_E_Invalid String expression +asmr_w_const32bit_for_address=07052_bit constant created for address +asmr_e_unknown_opcode=07053_E_Instruction non reconnue $1 +asmr_e_invalid_or_missing_opcode=07054_E_Invalid or missing opcode +asmr_e_invalid_prefix_and_opcode=07055_E_Invalid combination of prefix and opcode: $1 +asmr_e_invalid_override_and_opcode=07056_E_Invalid combination of override and opcode: $1 +asmr_e_too_many_operands=07057_E_Too many operands on line +asmr_w_near_ignored=07058_W_NEAR ignored +asmr_w_far_ignored=07059_W_FAR ignored +asmr_e_dup_local_sym=07060_E_Duplicate local symbol $1 +asmr_e_unknown_local_sym=07061_E_Undefined local symbol $1 +asmr_e_unknown_label_identifier=07062_E_Unknown label identifier $1 +asmr_e_invalid_register=07063_E_Invalid register name +asmr_e_invalid_fpu_register=07064_E_Invalid floating point register name +asmr_e_nor_not_supported=07065_E_NOR not supported +asmr_w_modulo_not_supported=07066_W_Modulo not supported +asmr_e_invalid_float_const=07067_E_Invalid floating point constant $1 +asmr_e_invalid_float_expr=07068_E_Invalid floating point expression +asmr_e_wrong_sym_type=07069_E_Wrong symbol type +asmr_e_cannot_index_relative_var=07070_E_Cannot index a local var or parameter with a register +asmr_e_invalid_seg_override=07071_E_Invalid segment override expression +asmr_w_id_supposed_external=07072_W_Identifier $1 supposed external +asmr_e_string_not_allowed_as_const=07073_E_Strings not allowed as constants +asmr_e_no_var_type_specified=07074_No type of variable specified +asmr_w_assembler_code_not_returned_to_text=07075_E_assembler code not returned to text section +asmr_e_not_directive_or_local_symbol=07076_E_Not a directive or local symbol $1 +asmr_w_using_defined_as_local=07077_E_Using a defined name as a local label +# +# Assembler/binary writers +# +asmr_e_dollar_without_identifier=07078_E_Dollar utilis sans identificateur +asmr_w_32bit_const_for_address=07079_W_32bit constante cre pour une addresse +asmr_n_align_is_target_specific=07080_N_.align dpend de la cible, utilisez .balign ou .p2align +asmr_e_cannot_access_field_directly_for_parameters=07081_E_Impossible d'accder directement aux champs pour des paramtres +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_Impossible d'accder aux champs d'objectsou de classes directement +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_Too many assembler files +asmw_f_assembler_output_not_supported=08001_F_Selected assembler output not supported +asmw_f_comp_not_supported=08002_F_Comp not supported +asmw_f_direct_not_supported=08003_F_Direct not support for binary writers +asmw_e_alloc_data_only_in_bss=08004_E_Allocating of data is only allowed in bss section +asmw_f_no_binary_writer_selected=08005_F_No binary writer selected +asmw_e_opcode_not_in_table=08006_E_Asm: Opcode $1 not in table +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 invalid combination of opcode and operands +asmw_e_16bit_not_supported=08008_E_Asm: 16 Bit references not supported +asmw_e_invalid_effective_address=08009_E_Asm: Invalid effective address +asmw_e_immediate_or_reference_expected=08010_E_Asm: Immediate or reference expected +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 value exceeds bounds $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: Short jump is out of range $1 +# +# Executing linker/assembler +# +asmw_e_undefined_label=08013_E_Asm: Label $1 non dfini + +# +# Executing linker/assembler +# +# BeginOfTeX +% +% \section{Errors of assembling/linking stage} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +exec_w_source_os_redefined=09000_W_Source operating system redefined +exec_i_assembling_pipe=09001_I_Assembling (pipe) $1 +exec_d_cant_create_asmfile=09002_E_Can't create assember file $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_Impossible de crer le fichier object : $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_Impossible de crer le fichier archive : $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_Assembler $1 not found, switching to external assembling +exec_t_using_assembler=09006_T_Using assembler: $1 +exec_w_error_while_assembling=09007_W_Error while assembling exitcode $1 +exec_w_cant_call_assembler=09008_W_Can't call the assembler, error $1 switching to external assembling +exec_i_assembling=09009_I_Assembling $1 +exec_i_assembling_smart=09010_I_Assemblage smartlink $1 +exec_w_objfile_not_found=09011_W_Object $1 not found, Linking may fail ! +exec_w_libfile_not_found=09012_W_Library $1 not found, Linking may fail ! +exec_w_error_while_linking=09013_W_Error while linking +exec_w_cant_call_linker=09014_W_Can't call the linker, switching to external linking +exec_i_linking=09015_I_Linking $1 +exec_w_util_not_found=09016_W_Utilitaire $1 non trouv, force la liaison externe +exec_t_using_util=09017_T_Utilitaire $1 trouv +exec_e_exe_not_supported=09018_E_Cration d'executables impossible +exec_e_dll_not_supported=09019_E_Dynamic Libraries not supported +exec_i_closing_script=09020_I_Closing script $1 +exec_w_res_not_found=09021_W_resource compiler not found, switching to external mode +exec_i_compilingresource=09022_I_Compiling resource $1 +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_Can't post process executable $1 +execinfo_f_cant_open_executable=09024_F_Can't open executable $1 +execinfo_x_codesize=09025_X_Size of Code: $1 bytes +execinfo_x_initdatasize=09026_X_Size of initialized data: $1 bytes +execinfo_x_uninitdatasize=09027_X_Size of uninitialized data: $1 bytes +execinfo_x_stackreserve=09028_X_Stack space reserved: $1 bytes +execinfo_x_stackcommit=09029_X_Stack space commited: $1 bytes +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_Unitsearch: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_PPU Loading $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU Name: $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU Flags: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU Crc: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU Time: $1 +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_file_too_short=10006_U_PPU File too short +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_invalid_header=10007_U_PPU Invalid Header (no PPU at the begin) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_PPU Invalid Version $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU is compiled for an other processor +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU is compiled for an other target +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU Source: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_Writing $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_Can't Write PPU-File +% An err +unit_f_ppu_read_error=10014_F_reading PPU-File +% Unexpected end of file +unit_f_ppu_read_unexpected_end=10015_F_unexpected end of PPU-File +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_invalid_entry=10016_F_Invalid PPU-File entry: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU Dbx count problem +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Illegal unit name: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_Too much units +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_Circular unit reference between $1 and $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_Can't compile unit $1, no sources available +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_Impossible de trouver l'unit $1 +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_Unit $1 non trouv mais $2 existe +unit_f_unit_name_error=10024_F_Unit $1 cherch mais $2 trouv +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_Compiling the system unit requires the -Us switch +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_There were $1 errors compiling module, stopping +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_Load from $1 ($2) unit $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_Recompiling $1, checksum changed for $2 +unit_u_recompile_source_found_alone=10029_U_Recompiling $1, source found only +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_Recompiling unit, static lib is older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_Recompiling unit, shared lib is older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_Recompiling unit, obj and asm are older than ppufile +% When you use the \var{-vu} flag, the compiler warns if the assembler of +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_Recompiling unit, obj is older than asm +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_Parsing interface of $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_Parsing implementation of $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_Second load for unit $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU Check file $1 time $2 +% When you use the \var{-vu} flag, the compiler show the filename and +% date and time of the file which a recompile depends on +% \end{description} +# EndOfTeX + +# +# Options +# +option_usage=11000_$1 [options] [options] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_Only one source file supported +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_DEF file can be created only for OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_nested response files are not supported +% you cannot nest response files with the \var {@file} command-line option. +option_no_source_found=11004_F_No source file name in command line +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_Aucune option trouve dans le fichier de configuration $1 +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Illegal parameter: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? writes help pages +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_Too many config files nested +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_Unable to open file $1 +% The option file cannot be found. +option_reading_further_from=11010_N_Reading further options from $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_Target is already set to: $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_Shared libs not supported on DOS platform, reverting to static +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_too many IF(N)DEFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_too many ENDIFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_open conditional at the end of the file +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_Debug information generation is not supported by this executable +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_Try recompiling with -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_W_You are using the obsolete switch $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_W_You are using the obsolete switch $1, please use $2 +% this warns you when you use a switch that is not supported anymore. You +% must now use the second switch instead. +% It is recommended that you change the switch to overcome problems in the +% future, when the switch meaning may change. +option_switch_bin_to_src_assembler=11020_N_Switching assembler to default source writing assembler +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_Assembler output selected "$1" is not compatible with "$2" +option_asm_forced=11022_W_"$1" assembler use forced +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +%\end{description} +# EndOfTeX + +# +# Logo (option -l) +# +option_logo=11023_[ +Compilatuer Free Pascal version $FPCVER [$FPCDATE] pour $FPCTARGET +Copyright (c) 1998-2000 by Florian Klaempfl +] + +# +# Info (option -i) +# +option_info=11024_[ +Compilatuer Free Pascal version $FPCVER + +Date du compilateur : $FPCDATE +Cible du compilateur : $FPCTARGET +# the next lines are NOT translated on purpose !!! + +This program comes under the GNU General Public Licence +For more information read COPYING.FPC + +Report bugs,suggestions etc to: + bugrep@freepascal.org +] + +# +# Help pages (option -? and -h) +# +option_help_pages=11025_[ +**0*_mettre + aprs un boolen pour activer l'option, - pour la dsactiver +**1a_conserve les fichiers assembleurs crs pendant la compilation +**2al_liste le code source dans les fichiers assembleur +**2ar_liste les allocations de registres dans les fichiers assembleur +**2at_liste les allocations de donnes temporaire dans la pile +**1b_gnre les informations pour le browser +**2bl_gnre les informations locales galement +**1B_recompile toutes les units +**1C_options de gnration de code : +3*2CD_crerune librairie dynamique +**2Ch_ taille du tas en bytes (entre 1023 et 67107840) +**2Ci_IO-checking +**2Cn_pas de linking +**2Co_gnre des tests d'overflow pour les oprations sur les entiers +**2Cr_Controle d'intervalles +**2Cs_spcifie comme taille de la pile +**2Ct_test de dbordement de pile +3*2CS_crer une librairie statique +3*2Cx_utiliser le smartlinking +**1d_dfinit le symbole +*O1D_gnre un fichier DEF +*O2Dd_assigne la description +*O2Dw_application en mode protg +**1e_dfinit le chemin vers l'excutable +**1E_comme -Cn +**1F_dfinit des chemins et noms de fichiers : +**2FD_dfinit le rpertoire o chercher les utilitaires de compilation +**2Fe_redirige les erreurs vers le fichier +**2FE_rpertoire pour les exe/units : +**2Fi_ajoute la liste des rpertoires pour fichiers inclus +**2Fl_ajoute la liste des rpertoires pour librairies +*L2FL_utilises comme lieur dynamique +**2Fo_ajoute la liste des rpertoires pour fichiers objets +**2Fr_charge le fichier erreur +**2Fu_ajoute la liste des rpertoires pour units +**2FU_dfinit le rpertoire d'criture des units , en dpit de -FE +*g1g_gnre des informations de dbogage : +*g2gg_utilise gsym +*g2gd_utilise dbx +*g2gh_use l'unit de tracage du tas +*g2gc_generate checks for pointers +**1i_information +**2iD_donne la date du compilateur +**2iV_donne la version du compilateur +**2iSO_donne l'OS du compilateur +**2iSP_donne le processeur du compilateur +**2iTO_donne l'OS cible +**2iTP_donne le processeur cible +**1I_ajoute la liste des rpertoires pour fichiers inclus +**1k_transmet au linker +**1l_crit le logo +**1n_ne pas lire le fichier de configuration par dfaut +**1o_change le nom de l'executable en +**1pg_gnre du code pour profiler avec gprof +*L1P_utilise des pipes au lieu de crer des fichiers temporaires +**1S_options de syntaxe : +**2S2_autorise quelques extensions Delphi 2 +**2Sc_autorise les operateurs type C (*=,+=,/= et -=) +**2Sd_essaye d'tre compatible avec Delphi +**2Se_stoppe la compilation la premire erreur +**2Sg_autorise LABEL et GOTO +**2Sh_Utilise les ansistrings +**2Si_supporte les INLINE type C++ +**2Sm_support des macros comme C (global) +**2So_essaye d'tre compatible avec TP/BP 7.0 +**2Sp_essaye d'tre compatible avec GPC +**2Ss_les constructeurs doivent s'appeler init (et les destructeurs done) +**2St_autorise "static" dans les objects +**1s_n'appelle pas l'assembleur ni le linker +**1u_rend le symbole non dfini +**1U_options d'units : +**2Un_ne pas vrifier le nom de l'unit +**2Us_compiler en temps qu'unit systme +**1v_donne des informations. est une combination des lettres suivantes : +**2*_e : montre les erreurs (dfaut) d : informations de dboggage +**2*_w : montre les avertissements u : montre les info sur les units +**2*_n : montre les notes t : montre les fichiers essays/utiliss +**2*_h : montre les suggestions m : montre les macros dfinies +**2*_i : montre des infos gnrales p : montre les procdures compiles +**2*_l : montre les numros de lignes c : montre les conditionniels +**2*_a : montre tout 0 : ne montre rien (sauf les erreurs) +**2*_b : montre toutes les procdures r : mode compatibilit Rhide/GCC +**2*_ quand une erreur survient x : infos Executable (Win32 seulement) +**2*_ +**1X_options pour executable : +*L2Xc_lien avec librairie C +**2XD_lien avec la librarie dynamique (dfinit FPC_LINK_DYNAMIC) +**2Xs_enlve tous les symboles de l'executable +**2XS_lien avec les librairies statiques (dfinit FPC_LINK_STATIC) +**0*_options spcifiques au processeur : +3*1A_format de sortie : +3*2Aas_fichier objet gnr par GNU AS +3*2Aasaout_fichier objet gnr par GNU AS pour aout (Go32v1) +3*2Anasmcoff_fichier COFF (Go32v2) avec Nasm +3*2Anasmelf_fichier ELF32 (Linux) avec Nasm +3*2Anasmobj_fichier OBJ avec Nasm +3*2Amasm_fichier OBJ avec Masm (Mircosoft) +3*2Atasm_fichier OBJ avec Tasm (Borland) +3*2Acoff_coff (Go32v2) using internal writer +3*2Apecoff_pecoff (Win32) using internal writer +3*1R_type lecture assembleur : +3*2Ratt_lit l'assembleur AT&T +3*2Rintel_lit l'assembleur Intel +3*2Rdirect_copie le texte assembleur directement dans le fichier assembleur +3*1O_optimisations : +3*2Og_gnre du code compact +3*2OG_gnre du code rapide (defaut) +3*2Or_garde certaines variables dans des registres (toujours BUGGY!!!) +3*2Ou_autorise les optimisations incertaines (voir docs) +3*2O1_optimisations niveau 1 (optimisations rapides) +3*2O2_optimisations niveau 2 (-O1 + optimisations plus lentes) +3*2O3_optimisations niveau 3 (comme -O2u) +3*2Op_processeur cible : +3*3Op1_dfinit 386/486 comme processeur cible +3*3Op2_dfinit Pentium/PentiumMMX (tm) comme processeur cycle +3*3Op3_dfinit PPro/PII/c6x86/K6 (tm) comme processeur cycle +3*1T_systme d'explioitation cible : +3*2TGO32V1_version 1 de l'extension DOS de DJ Delorie +3*2TGO32V2_version 2 de l'extension DOS de DJ Delorie +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bits +6*1A_output format +6*2Aas_Unix o-file using GNU AS +6*2Agas_GNU Motorola assembler +6*2Amit_MIT Syntax (old GAS) +6*2Amot_Standard Motorola assembler +6*1O_optimizations: +6*2Oa_turn on the optimizer +6*2Og_generate smaller code +6*2OG_generate faster code (default) +6*2Ox_optimize maximum (still BUGGY!!!) +6*2O2_set target processor to a MC68020+ +6*1R_styles d'assembleur : +6*2RMOT_lire l'assembleur type motorola +6*1T_Systme d'exploitation cible : +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_affiche cette aide +6*1R_version de l'assembleur lu +6*2RMOT_read motorola style assembler +6*1T_Target operating system: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_shows this help +**1h_affiche cette aide sans attente +] + +# +# The End... +# diff --git a/befpc/compiler/errorn.msg b/befpc/compiler/errorn.msg new file mode 100644 index 0000000..be8e21b --- /dev/null +++ b/befpc/compiler/errorn.msg @@ -0,0 +1,1935 @@ +# +# $Id: errorn.msg,v 1.1.1.1 2001-07-23 17:16:13 memson Exp $ +# This file is part of the Free Pascal Compiler +# Copyright (c) 1998-2000 by the Free Pascal Development team +# +# Dutch Language File for Free Pascal +# +# 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. +# +# +# The constants are build in the following order: +# __ +# +# is the part of the compiler the message is used +# asmr_ assembler parsing +# asmw_ assembler writing/binary writers +# unit_ unit handling +# scan_ scanner +# parser_ parser +# type_ type checking +# general_ general info +# exec_ calls to assembler, linker, binder +# +# the type of the message it should normally used for +# f_ fatal error +# e_ error +# w_ warning +# n_ note +# h_ hint +# i_ info +# l_ linenumber +# u_ used +# t_ tried +# m_ macro +# p_ procedure +# c_ conditional +# d_ debug message +# b_ display overloaded procedures +# x_ executable informations +# + +# +# Enkele punten om bij het vertalen in het achterhoofd te houden: +# +# - "Methoden" wordt vaak foutief als "methodes" geschreven. +# - "Typen" wordt vaak foutief als "types" geschreven. +# - "Illegal" wordt niet met "illegaal" vertaald, maar met "ongeldig". +# Illegaal betekent onwettig in het Nederlands. +# - Zo wordt "execute" niet met "executeren" vertaalt maar met "uitvoeren". +# Programma, hebt u nog een laatste wens voordat de trekker wordt +# overgehaald? +# - In het Nederlands schrijft men woorden vaker aan elkaar dan in het +# Engels: "compiler switch" (2 woorden ) wordt "compileroptie" (1 woord). +# Let ook op voorvoegingen: "Interface and implementation names" wordt: +# "Interface- en implementatienamen" (streepje!) +# - Pas op met het vernederlandsen van Engelse woorden. Bijvoorbeeld +# "symbool". Voor deze categorie woorden bestaat geen goede +# vertaling. Iedereen die zo'n vernederlandsing ziet krijgt echter gelijk +# een pijnscheut in zijn taalknobbel. Soms helpt een woordenboek, anders +# is het beter om de engelse term te laten staan. Wat improvisatie helpt +# soms ook, "symbool" is niet precies hetzelfde maar kan in dit geval +# prima als vertaling gebruikt worden. + +# +# General +# +# BeginOfTeX +% \section{General compiler messages} +% This section gives the compiler messages which are not fatal, but which +% display useful information. The number of such messages can be +% controlled with the various verbosity level \var{-v} switches. +% \begin{description} +general_t_compilername=01000_T_Gebruikte compiler: $1 +% When the \var{-vt} switch is used, this line tells you what compiler +% is used. +general_d_sourceos=01001_D_Bronsysteem: $1 +% When the \var{-vd} switch is used, this line tells you what the source +% operating system is. +general_i_targetos=01002_I_Doelsysteem: $1 +% When the \var{-vd} switch is used, this line tells you what the target +% operating system is. +general_t_exepath=01003_T_Programmalocatie: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's binaries. +general_t_unitpath=01004_U_Locatie units: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for compiled units. You can set this path with the \var{-Fu} +general_t_includepath=01005_T_Locatie includes: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for it's include files (files used in \var{\{\$I xxx\}} statements). +% You can set this path with the \var{-I} option. +general_t_librarypath=01006_T_Locatie bibliotheken: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for the libraries. You can set this path with the \var{-Fl} option. +general_t_objectpath=01007_T_Locatie objectbestanden: $1 +% When the \var{-vt} switch is used, this line tells you where the compiler +% looks for object files you link in (files used in \var{\{\$L xxx\}} statements). +% You can set this path with the \var{-Fo} option. +general_i_abslines_compiled=01008_I_$1 Regels gecompileerd, $2 sec. +% When the \var{-vi} switch is used, the compiler reports the number +% of lines compiled, and the time it took to compile them (real time, +% not program time). +general_f_no_memory_left=01009_F_Geen geheugen meer vrij +% The compiler doesn't have enough memory to compile your program. There are +% several remedies for this: +% \begin{itemize} +% \item If you're using the build option of the compiler, try compiling the +% different units manually. +% \item If you're compiling a huge program, split it up in units, and compile +% these separately. +% \item If the previous two don't work, recompile the compiler with a bigger +% heap (you can use the \var{-Ch} option for this, \seeo{Ch}) +% \end{itemize} +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +general_i_writingresourcefile=01010_I_Schrijven van resource string tabel bestand: $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_Schrijven van resource string tabel bestand: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} +# +# Scanner +# +% \section{Scanner messages.} +% This section lists the messages that the scanner emits. The scanner takes +% care of the lexical structure of the pascal file, i.e. it tries to find +% reserved words, strings, etc. It also takes care of directives and +% conditional compiling handling. +% \begin{description} +scan_f_end_of_file=02000_F_Onverwacht einde van bestand +% this typically happens in one of the following cases : +% \begin{itemize} +% \item The source file ends before the final \var{end.} statement. This +% happens mostly when the \var{begin} and \var{end} statements aren't +% balanced; +% \item An include file ends in the middle of a statement. +% \item A comment wasn't closed. +% \end{itemize} +scan_f_string_exceeds_line=02001_F_String langer dan regel +% You forgot probably to include the closing ' in a string, so it occupies +% multiple lines. +scan_f_illegal_char=02002_F_ongeldig teken +% An illegal character was encountered in the input file. +scan_f_syn_expected=02003_F_Taalfout: $2 verwacht in kolom $1 +% This indicates that the compiler expected a different token than +% the one you typed. It can occur almost everywhere where you make a +% mistake against the pascal language. +scan_t_start_include_file=02004_T_Ingevoegd bestand $1 word geopend +% When you provide the \var{-vt} switch, the compiler tells you +% when it starts reading an included file. +scan_w_comment_level=02005_W_Commentaar van niveau $1 gevonden +% When the \var{-vw} switch is used, then the compiler warns you if +% it finds nested comments. Nested comments are not allowed in Turbo Pascal +% and can be a possible source of errors. +scan_n_far_directive_ignored=02006_N_$F directive (FAR) genegeerd +% The \var{FAR} directive is a 16-bit construction which is recorgnised +% but ignored by the compiler, since it produces 32 bit code. +scan_n_stack_check_global_under_linux=02007_N_Stapeloverloop test is globaal onder linux +% Stack checking with the \var{-Cs} switch is ignored under \linux, since +% \linux does this for you. Only displayed when \var{-vn} is used. +scan_n_ignored_switch=02008_N_Genegeerde compileroptie $1 +% With \var{-vn} on, the compiler warns if it ignores a switch +scan_w_illegal_switch=02009_W_Foutieve compileroptie $1 +% You included a compiler switch (i.e. \var{\{\$... \}}) which the compiler +% doesn't know. +scan_w_switch_is_global=02010_W_Deze compileroptie heeft ook een globaal effect +% When \var{-vw} is used, the compiler warns if a switch is global. +scan_e_illegal_char_const=02011_E_Foutieve constante voor een karakter +% This happens when you specify a character with its ASCII code, as in +% \var{\#96}, but the number is either illegal, or out of range. The range +% is 1-255. +scan_f_cannot_open_input=02012_F_Kan bestand niet openen +% \fpc cannot find the program or unit source file you specified on the +% command line. +scan_f_cannot_open_includefile=02013_F_Kan ingevoerd bestand niet openen $1 +% \fpc cannot find the source file you specified in a \var{\{\$include ..\}} +% statement. +scan_e_too_much_endifs=02014_E_Te veel $ENDIFs of $ELSEs +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_w_only_pack_records=02015_W_Record velden kunnen op 1,2 of 4 bytes uitgelijnd worden. +% You are specifying the \var{\{\$PACKRECORDS n\} } with an illegal value for +% \var{n}. Only 1,2,4 or 16 are valid in this case. +scan_w_only_pack_enum=02016_W_Enumeraties kunnen alleen worden bewaard in 1,2 of 4 bytes +% You are specifying the \var{\{\$PACKENUM n\}} with an illegal value for +% \var{n}. Only 1,2 or 4 are valid in this case. +scan_e_endif_expected=02017_E_$ENDIF verwacht voor $1 op $2 $3 +% Your conditional compilation statements are unbalanced. +scan_e_preproc_syntax_error=02018_E_Taalfout bij het compileren van een conditionele compilatie uitdrukking +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_e_error_in_preproc_expr=02019_E_Evalueren van een conditionele compilatie uitdrukking +% There is an error in the expression following the \var{\{\$if ..\}} compiler +% directive. +scan_w_macro_cut_after_255_chars=02020_W_Macro inhoud is afgekapt op 255 karakters voor evaluatie +% The contents of macros cannot be longer than 255 characters. This is a +% safety in the compiler, to prevent buffer overflows. This is shown as a +% warning, i.e. when the \var{-vw} switch is used. +scan_e_endif_without_if=02021_E_ENDIF zonder IF(N)DEF +% Your \var{\{\$IFDEF ..\}} and {\{\$ENDIF\}} statements aren't balanced. +scan_f_user_defined=02022_F_Gebruiker definitie: $1 +% A user defined fatal error occurred. see also the \progref +scan_e_user_defined=02023_E_Gebruiker definitie: $1 +% A user defined error occurred. see also the \progref +scan_w_user_defined=02024_W_Gebruiker definitie: $1 +% A user defined warning occurred. see also the \progref +scan_n_user_defined=02025_N_Gebruiker definitie: $1 +% A user defined note was encountered. see also the \progref +scan_h_user_defined=02026_H_Gebruiker definitie: $1 +% A user defined hint was encountered. see also the \progref +scan_i_user_defined=02027_I_Gebruiker definitie: $1 +% User defined information was encountered. see also the \progref +scan_e_keyword_cant_be_a_macro=02028_E_Sleutelwoord herdefinieren als macro heeft geen effect +% You cannot redefine keywords with macros. +scan_f_macro_buffer_overflow=02029_F_Macro buffer overflow bij lezen of expansie van macro +% Your macro or it's result was too long for the compiler. +scan_w_macro_deep_ten=02030_W_Expansie van macro meer dan 16 niveaus diep, waarschijnlijk een recursieve macro +% When expanding a macro macros have been nested to a level of 16. +% The compiler will expand no further, since this may be a sign that +% recursion is used. +scan_e_wrong_styled_switch=02031_E_Compileroptie is niet toegestaan in (* ... *) commentaar +% Compiler switches should always be between \var{\{ \}} comment delimiters. +scan_d_handling_switch=02032_D_Behandel schakelaar "$1" +% When you set debugging info on (\var{-vd}) the compiler tells you when it +% is evaluating conditional compile statements. +scan_c_endif_found=02033_C_ENDIF $1 gevonden +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifdef_found=02034_C_IFDEF $1 gevonden, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifopt_found=02035_C_IFOPT $1 gevonden, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_if_found=02036_C_IF $1 gevonden, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_ifndef_found=02037_C_IFNDEF $1 gevonden, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_else_found=02038_C_ELSE $1 gevonden, $2 +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements. +scan_c_skipping_until=02039_C_Negeer tot... +% When you turn on conditional messages(\var{-vc}), the compiler tells you +% where it encounters conditional statements, and whether it is skipping or +% compiling parts. +scan_i_press_enter=02040_I_Druk om verder te gaan +% When the \var{-vi} switch is used, the compiler stops compilation +% and waits for the \var{Enter} key to be pressed when it encounters +% a \var{\{\$STOP\}} directive. +scan_w_unsupported_switch=02041_W_Niet ondersteunde optie $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unsupported switches. This means that the switch is used in Delphi or +% Turbo Pascal, but not in \fpc +scan_w_illegal_directive=02042_W_Ongeldige compiler optie $1 +% When warings are turned on (\var{-vw}) the compiler warns you about +% unrecognised switches. For a list of recognised switches, \progref +scan_t_back_in=02043_T_Terug in $1 +% When you use (\var{-vt}) the compiler tells you when it has finished +% reading an include file. +%%% scan_w_unsupported_app_type=W_Applicatie type niet ondersteund: $1 +%%% % You get this warning, ff you specify an unknown application type +%%% % with the directive \var{\{\$APPTYPE\}} +scan_w_unsupported_app_type=02044_W_Niet ondersteund programmatype: $1 +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_w_app_type_not_support=02045_W_$APPTYPE niet ondersteund op doelsysteem +% The \var{\{\$APPTYPE\}} directive is supported by win32 applications only. +scan_w_decription_not_support=02046_W_DESCRIPTION is slechts toegestaan onder OS2 en Win32 +% The \var{\{\$DESCRIPTION\}} directive is only supported for OS2 and Win32 targets. +scan_n_version_not_support=02047_N_VERSION is niet ondersteund door het doel OS. +% The \var{\{\$VERSION\}} directive is only supported by win32 target. +scan_n_only_exe_version=02048_N_VERSION kan alleen voor executables of bibliotheken +% The \var{\{\$VERSION\}} directive is only used for executable or DLL sources. +scan_w_wrong_version_ignored=02049_W_verkeerd formaat voor VERSION directive $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_Niet ondersteunde assembler soort gegeven $1 +% When you specify an assembler mode with the \var{\{\$ASMMODE xxx\}} +% the compiler didn't recognize the mode you specified. +scan_w_no_asm_reader_switch_inside_asm=02051_W_ASM lezer-optie is niet mogelijk in een asm instructie, $1 ingesteld voor volgende blok +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Verkeerde optiewaarde, gebruik ON/OFF of +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_Resource bestanden worden niet ondersteund op doel OS +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +% +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +scan_w_include_env_not_found=02054_W_Include omgevingsvariabele $1 niet gevonden in omgeving +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_Ongeldige waarde voor FPU register limiet +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +scan_w_only_one_resourcefile_supported=02056_W_Only one resource file is supported for this target +% The target you are compiling for supports only one resource file. This is the +% case of OS/2 (EMX) currently. The first resource file found is used, the +% others are discarded. +% \end{description} +# +# Parser +# +% \section{Parser messages} +% This section lists all parser messages. The parser takes care of the +% semantics of you language, i.e. it determines if your pascal constructs +% are correct. +% \begin{description} +parser_e_syntax_error=03000_E_Parser - Taalfout +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_Procedure type FAR genegeerd +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_Procedure type NEAR genegeerd +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_Procedure type INTERRUPT genegeerd +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is igonred for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT procedures kunnen niet genest worden +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_Procedure type $1 ignored +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_Not all declarations of $1 are declared with OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_Geen DLL bestand opgegeven +% No longer in use. +parser_e_export_name_double=03008_E_Dubbel geexporteerde functie naam $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_Dubbel geexporteerde functie index $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Ongeldige index for geexporteerde functie +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_Relocatable bibliotheek of applicatie $1 debug informatie niet ondersteund. +parser_w_parser_win32_debug_needs_WN=03012_W_Om win32 code te debuggen moet relocatie afgezet worden door de -WN optie +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_Constructornaam moet INIT zijn +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_Destructornaam moet DONE zijn +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Foutieve open parameter +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_Procedure type INLINE wordt niet ondersteund +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Private methoden zijn niet VIRTUAL +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_E_Constructor mag niet private or protected zijn +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_E_Destructor mag niet private or protected zijn +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_Klasse heeft slechts 1 destructor +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_Lokale klassedefinities zijn niet toegestaan +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_Anonieme klassedefinities zijn niet toegestaan +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_Het object $1 heeft geen VMT +parser_e_illegal_parameter_list=03024_E_Foutieve parameterlijst +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Foutief parametertype meegegeven voor arg #$1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Onjuist aantal parameters meegegeven +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_Overroepen symbool is geen procedure of functie +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_Overroepen procedures hebben identieke parameterlijst +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_Declaratie komt niet overeen met eerdere declaratie: $1 +% You declared a function with same parameters but +% different result type or function specifiers. +parser_e_header_different_var_names=03030_E_Procedurehoofding $1 komt niet overeen met eerdere declaratie: variabelenaam veranderd $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_Waarden in opsommingstypes moeten steeds stijgen +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Interface- en implementatienamen zijn verschillend +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With kan niet gebruikt worden voor variabelen in verschillende segmenten +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_Procedure meer dan 31 keer genest +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_Bereikfout bij evalueren constanten +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_Bereikscontrolefout bij evalueren constantes. +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_Dubbel case-element +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_Bovengrens van casebereik is lager dan ondergrens +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_Getypeerde constanten van klassen zijn niet toegestaan +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_Procedurele variabelen van overroepen procedures zijn niet toegestaan +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_Stringlengte moet tussen 1 en 255 liggen +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_Gebruik de uitgebreide syntax van DISPOSE en NEW om nieuwe instanties van klassen te genereren +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_Het gebruik van NEW of DISPOSE voor pointers zonder type is zinloos +parser_e_no_new_dispose_on_void_pointers=03044_E_Het gebruik van NEW of DISPOSE is niet mogelijk voor pointers zonder type +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_Klasse verwacht +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_Typesymbool is hier niet toegestaan +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_Methode verwacht +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_Proceduredeclaratie komt niet overeen met een methode van deze klasse +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_Procedure/functie $1 ($2) op regel $3 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Foutieve vlottende-komma constante +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL mag alleen in constructors gebruikt worden +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_Destructors hebben geen parameters +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_Alleen klassemethoden kunnen gerefereerd worden via een klasse +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_Alleen klassemethoden zijn toegankelijk in klassen +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_Type van constante komt niet overeen met dat van de case uitrukking +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_Het symbool kan niet uitgevoerd worden uit een bibliotheek +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_E_Een virtuele methode moet met OVERRIDE overroepen worden: $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_Er is geen geerfde methode die overroepen kan worden: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_Er is geen lid om de eigenschap te bereiken +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_Stored prorperty directive is not yet implemented +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Ongeldig symbool voor eigenschap toegang +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_Kan niet in beschermd veld van een object schrijven +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_Kan niet in prive-veld van een object schrijven +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_Alle overroepen methoden moeten virtueel zijn als 1 virtueel is: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_Overroepen methode van een niet virtuele methode moet niet-virtueel zijn: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_Virtuele overladen methodes moeten dezelfde resultaat-type hebben: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_Als EXPORT gedeclareerde procedures kunnen niet genest worden +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_Methoden kunnen niet geexporteerd worden. +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_Typen van referentieparameters moeten exact overeenkomen. +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_Deze klasse is geen ouderklasse van de huidige klasse +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF is alleen toegelaten in methoden. +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_Methoden kunnen alleen in andere methoden worden aangeroepen met type symbool +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Ongeldig gebruik van ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_Bereikfout in setconstructor of dubbel setelement +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_Pointer naar klasse verwacht +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_Uitdrukking moet een constructoraanroep zijn. +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_Uitdrukking moet een destructoraanroep zijn +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Ongeldige volgorde van record leden +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_Type van uitdrukking moet class of record type zijn +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_Procedures kunnen geen resultaat teruggeven +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_Constructors en destructors moeten methoden zijn +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_Operator is niet hergedefineerd +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_Het is niet toegestaan de assignatie operator te overladen voor gelijke types +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_Onmogelijk overladen van operator +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_Re-raise is hier niet mogelijk +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_De uitgebreide syntax van NEW of DISPOSE is niet toegestaan voor klassen +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_Assembler stemt niet overeen met type van functieresultaat +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_Procedure overroepen is afgezet +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_Deze operator kan niet overroepen worden. +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_Vergelijkingsoperator moet een boolean type als resultaat hebben. +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_Enkel virtuele methoden kunnen abstract zijn +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_Gebruik van niet ondersteunde optie ! +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_CLASSES and OBJECTS kunnen niet gemengd worden. +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_Onbekende proceduredirective is genegeerd: $1 +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_Absolute kan maar aan een variabele verbonden worden. +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_Absolute kan slechts aan variabelen of constanten verbonden worden. +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_Slechts 1 variabele kan geinitialiseerd worden. +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_Abtracte methoden kunnen niet gedefineerd worden +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_Deze overroepen procedure kan niet lokaal zijn (moet geexporteerd worden) +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_Gebruik van virtuele methoden zonder constructor +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_Macro gedefinieerd: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_Macro opgeheven: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_Macro $1 wordt $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_Compilatie van $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_Parsen van de interface van unit $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_Parsen van de implementatie van unit $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_Compilatie van $1 voor de tweede keer. +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_Array eigenschappen zijn hier niet toegestaan. +% You cannot use array properties at that point.a +parser_e_no_property_found_to_override=03109_E_Geen eigenschap gevonden om te herdefinieren +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_Slechts 1 standaardeigenschap is toegestaan, geerfde standaardeigenschap in kind gevonden. +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_Standaardeigenschappen moeten van type array zijn. +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_Virtuele constructors worden alleen ondersteunt in het klassemodel +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_Geen standaardeigenschap gevonden +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_De klasse kan geen gepubliceerde sectie hebben, gebruik {$M+} +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_Declaratie van klasse $1 moet worden opgelost om de klasse als ouder te gebruiken +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_Lokale operatoren worden niet ondersteund +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_Procedure directive $1 niet toegestaan in interface sectie +% This procedure directive is not allowed in the \var{interface} section of +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_Procedure directive $1 niet toegestaan in implementation sectie +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_Procedure directive $1 niet toegestaan in procvar declaratie +% This procedure directive cannot be part of a procedural of function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_Functie is al publiek/forward gedeclareerd $1 +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_Kan niet zowel EXPORT als EXTERNAL gebruiken +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_NAME sleutelwoord verwacht +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 wordt niet ondersteund voor inline procedure/functie +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_Inlining uitgeschakeld +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_Schrijven van browser logfile $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_misschien is het een pointer, ^ wordt dan gemist +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_Geselecteerde assemblerlezer wordt niet ondersteund +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_Procedure directive $1 geeft conflicten met andere directives +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_Aanroep conventie klopt niet met voorwaartse +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_Registeraanroep (fastcall) wordt niet ondersteund +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_Eigenschap kan geen standaard waarde hebben +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_De standaard waarde van een eigenschap moet een constante zijn +% The value of a \var{default} declared property must be knwon at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_Symbool kan niet worden gepubliceerd, alleen mogelijk voor een klasse +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_Dit soort eigenschappen kunnen niet worden gepubliceerd +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_Lege importnaam opgegeven. +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_Lege importnaam opgegeven +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_Interne functienaam gewijzigd na declaratie. +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_Deling door nul +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Ongeldige vlottende-komma bewerking. +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_Bovengrens van bereik is lager dan ondergrens +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_string "$1" is langer dan $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_Stringlengte moet tussen 1 en 255 liggen +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Ongeldige uitdrukking achter message optie +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_Message handlers aanvaarden slechts 1 variabele parameter +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_Dubbel message label: %1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_Self kan alleen een explicite parameter zijn bij string message handlers +% The self parameter can be passed only explicit if it is a method which +% is declared as message method handler +parser_e_threadvars_only_sg=03147_E_Thread variabelen kunnen alleen globaal of statisch zijn +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_Directe assembler wordt niet ondersteund door interne assembler. +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_Laad de OBJPAS unit niet manueel, gebruik {$mode objfpc} of {$mode delphi}. +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_OVERRIDE kan niet gebruikt worden in objecten +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +parser_e_cant_use_inittable_here=03151_E_Data typen die initializatie/finalizatie vereisen zijn niet toegestaan in variabele records. +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +parser_e_resourcestring_only_sg=03152_E_Resourcestrings kunnen alleen statisch of globaal zijn. +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_Exit met argument is hier niet toegestaan +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_De stored directive verwacht een boolean argument. +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_Dit symbool is niet toegestaan achter het stored sleutelwoord. +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_Alleen klassen gecompileerd in $M+ modus kunnen een published sectie hebben. +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_Procedure directive verwacht. +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_De waarde voor een property index moet een ordinale waarde zijn. +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_Procedure naam te kort om te exporteren. +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_Kan geen DEFFILE item genereren voor globale variabelen. +parser_e_dlltool_unit_var_problem2=03161_E_Compileer zonder -WD optie +% \end{description} +# +# Type Checking +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Typen stemmen niet overeen +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Incompatibele typen: kreeg $1, verwachtte $2 +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_Typen komen niet overeen $1 en $2 +% The types are not equal +type_e_type_id_expected=04003_E_Typesymbool verwacht +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_Variabelesymbool verwacht +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_Integerexpressie verwacht +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_Boolean waarde verwacht, kreeg echter "$1" +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_Ordinale expressie verwacht +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_Pointertype verwacht +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_Klassetype verwacht +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_Variabele- of typesymbool verwacht +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_Kan constante expressie niet evalueren +% No longer in use. +type_e_set_element_are_not_comp=04012_E_Elementen van set zijn niet compatible +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_Bewerking niet ondersteund voor sets +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_Typeconversie van vlottende-komma type naar COMP, wat een integer type is. +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_Gebruik DIV voor gehele getallen om geheel resultaat te krijgen +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_String typen stemmen niet overeen wegens de $V+ modus +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_SUCC of PRED op enumeratie types met toekenningen zijn niet mogelijk +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_Kan dit type variabelen niet lezen of schrijven +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_Kan geen readln of writeln op getypeerde bestanden doen. +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_Kan geen read of write doen op ongetypeerde bestanden. +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_Type conflict tussen set elementen. +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_lo/hi(longint/dword) geeft hoog/laag (ipv byte) woord terug. +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword} +% which returns the lower/upper word of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type case the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_Integer of vlottende komma uitdrukking verwacht +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Verkeerd type in array constructor +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Incompatibel type voor argument #$1: kreeg $2, verwachtte $3 +% You are trying to pass an invalid type for the specified parameter. +type_e_no_method_and_procedure_not_compatible=04026_E_Methode (variabele) en Procedure (variable) zijn niet compatible +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_Ongeldige constante opgegeven aan interne wiskundige functie +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_Een constante heeft geen adres +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +type_e_argument_cant_be_assigned=04029_E_Kan geen waarde toekennen aan argument +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_Kan geen lokale procedure toekennen aan procedure variabele +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_Kan geen waarde toekennen aan een adres +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_Kan geen waarde toekennen aan constante +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_Symbool niet gevonden $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_Interne fout in SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_Dubbel symbool $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_Symbool reeds gedefinieerd in $1 op lijn $2 +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_Onbekende symbool $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_Voorwaartse declaratie niet opgelost $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_Typesymbool reeds gedefineerd als type +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_Fout in type definitie +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_Typesymbool niet gedefinieerd +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_Forward declaratie niet opgelost $1 +% The compiler encountered an unknown type. +sym_e_only_static_in_static=05010_E_Alleen statische variabelen kunnen gebruikt worden in statische methoden +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Ongeldige aanroep van tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_Record- of klassetype verwacht +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_U kunt geen vertegenwoordiger van een klasse met abstracte methoden instantieren +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_Label niet gedefineerd $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_Label gebruikt maar niet gedefinieerd +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Label foutief gedefineerd +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO en LABEL zijn afgezet (gebruik -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_Label niet gevonden +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_Symbool is geen label +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_Label is al gedefineerd +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_Type declaratie van set elementen is foutief +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_Voorwaartse definitie van klasse niet opgelost $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_Unit $1 wordt niet gebruikt in $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_Parameter niet gebruikt $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_Lokale variabele niet gebruikt $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_Waarde parameter $1 is gedeclareerd maar niet gebruikt. +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_Lokale variabele $1 gedeclareerd maar niet gebruikt. +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_Lokaal $1 $2 is niet gebruikt +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Privaat veld $1.$2 wordt niet gebruikt +sym_n_private_identifier_only_set=05030_N_Privaat veld $1.$2 gedeclareerd maar niet gebruikt. +sym_n_private_method_not_used=05031_N_Private methode $1.$2 wordt nooit gebruikt. + + +sym_e_set_expected=05032_E_Set type verwacht +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_Resultaat van functie lijkt niet te zijn toegekend +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_Type $1 is not aligned correctly in current record for C +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_Onbekend record lid $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_N_Locale variabele $1 lijkt niet geinitialiseerd te zijn +sym_n_uninitialized_variable=05037_W_Variabele $1 lijkt niet geinitialiseerd te zijn +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_Geen lid met de naam $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_Declaratie gevonden: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +sym_e_segment_too_large=05040_E_Data segment te groot (max. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK niet toegelaten +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE niet toegelaten +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_Uitdrukking te ingewikkeld - overloop van wiskundige processor +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Foutieve uitdrukking +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Foutieve gehele uitdruking +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_Ongeldige constructie +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_Bovengrens is kleiner dan ondergrens +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Ongeldige lusteller +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_Weet niet welke overroepen procedure moet worden aangeroepen +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_Parameters gebruiken meer dan 64 kilobyte +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Foute typeconversie +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_Conversie tussen ordinale en pointertypen is niet overdraagbaar naar andere processoren +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_File variabelen moeten altijd var parameters zijn +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_U kunt daar geen far pointer gebruiken +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_Ongeldige aanroep met referentie parameters +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_Procedures die als EXPORT gedeclareerd staan kunnen niet aangeroepen worden +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_Mogelijke ongeldige aanroep van constructor of destructor +% No longer in use. +cg_n_inefficient_code=06017_N_Inefficiente code +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_Deze code wordt nooit uitgevoerd +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_Procedure aanroep met stackframe ESP/SP +% The compiler encountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_Abstracte methoden kunnen niet direct aangeroepen worden +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_Interne fout in getfloatreg(), allocatie faling +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_Onbekend vlottende-komma type +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() basis tweemaal gedefinieerd. +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_Extended cg68k niet ondersteund +% The var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_32-bit unsigned niet ondersteund in MC68000 modus +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_Interne fout in secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_Register $1 gewicht $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_Stacklimiet overschreden in lokale routine +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_Stackframe wordt niet gemaakt +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_bereik check voor 64 bit integer is niet ondersteund op dit platform +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_Kan inline niet gebruiken voor object methoden +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_Kan inline niet gebruiken voor procvar aanroepen +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_Geen code voor inline procedure opgeslagen +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_Directe oproep van interrupt procedure $1 is niet mogelijk +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Element nul van een ansi/wide- of longstring is niet toegankelijk, gebruik (set)length. +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_Include en exclude niet ondersteund in dit geval +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_Constructors of destructors kunnen niet aangeroepen worden binnen een 'with' clausule +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_Een message handler methode kan niet direct aangeroepen worden. +% A message method handler method can't be called directly if it contains an +% explicit self argument +% \end{description} +# EndOfTeX +# +# Assembler reader +# +cg_e_goto_inout_of_exception_block=06039_E_Sprong in of uit een exception blok +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +cg_e_control_flow_outside_finally=06040_E_Control flow statements niet toegestaan in een finally blok +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX +asmr_d_start_reading=07000_D_Begonnen met verwerken van $1 assembler +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_Gedaan met verwerken van $1 assembler +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_Patroon dat geen label is bevat "@" +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_De "override" operator wordt niet ondersteund +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_Fout bij berekenen offset in record +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET gebruikt zonder symbool +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE gebruikt zonder identifier +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_Kan hier geen lokale variabele of parameter gebruiken +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_OFFSET moet hier gebruikt worden +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_Gebruik van $ is hier verplicht +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_Kan niet meerdere verplaatsbare symbolen gebruiken +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_Een verplaatsbaar symbool kan enkel toegevoegd worden +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Ongeldige constante uitdrukking +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_Verplaatsbaar symbool niet toegelaten +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Ongeldige geheugenlocatie schrijfwijze +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_$1 niet bereikbaar vanuit deze code +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_Lokale symbolen/labels niet toegestaan als referenties +% You can't use local symbols/labels as references +asmr_e_wrong_base_index=07017_E_Ongeldig gebruik van basis en index register +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_Mogelijke fout in behandeling velden van object. +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Ongeldige schaalfactor +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_Meervoudig indexregister gebruik +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Ongeldig operandus type +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Ongeldige tekenreeks als instructie operandus: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE en @DATA worden niet ondersteund +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_Null label verwijzingen zijn niet toegelaten +asmr_e_expr_zero_divide=07025_E_Deling door nul in assembler evaluator +asmr_e_expr_illegal=07026_E_Ongeldige uitdrukking +asmr_e_escape_seq_ignored=07027_E_Expliciete reeks genegeerd: $1 +asmr_e_invalid_symbol_ref=07028_E_Ongeldige symboolverwijzing +asmr_w_fwait_emu_prob=07029_W_Fwait kan emulatieproblemen met emu387 veroorzaken +asmr_w_fadd_to_faddp=07030_W_FADD zonder operand vertaald naar FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER instructie wordt niet ondersteund door de Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_Een overroepen functie wordt aangeroepen vanuit de assembler code +asmr_e_unsupported_symbol_type=07033_E_Niet ondersteund symbool type voor operandus +asmr_e_constant_out_of_bounds=07034_E_Constante waarde valt buiten bereik +asmr_e_error_converting_decimal=07035_E_Fout bij omzetten van decimaal getal $1 +asmr_e_error_converting_octal=07036_E_Fout bij omzetten van octaal getal $1 +asmr_e_error_converting_binary=07037_E_Fout bij omzetten van binair getal $1 +asmr_e_error_converting_hexadecimal=07038_E_Fout bij omzetten van hexadecimaal getal $1 +asmr_h_direct_global_to_mangled=07039_H_$1 vertaald naar $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 is geassocieerd met een overroepen functie +asmr_e_cannot_use_SELF_outside_a_method=07041_E_Kan SELF niet buiten een methode gebruiken +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_Kan OLDEBP niet buiten een genestelde procedure gebruiken +asmr_e_void_function=07043_W_Functies met een ongedefinieerde teruggeefwaarde kunnen geen waarde teruggeven +asmr_e_SEG_not_supported=07044_E_SEG not supported +asmr_e_size_suffix_and_dest_dont_match=07045_E_Grootte-achtervoegsel en doel- of brongrootte komen niet overeen +asmr_w_size_suffix_and_dest_dont_match=07046_W_Grootte-achtervoegsel en doel- of brongrootte komen niet overeen +asmr_e_syntax_error=07047_E_Assembler taalfout +asmr_e_invalid_opcode_and_operand=07048_E_Ongeldige combinatie van instructie en operandi +asmr_e_syn_operand=07049_E_Assemler taalfout in operandum +asmr_e_syn_constant=07050_E_Assemler taalfout in constante +asmr_e_invalid_string_expression=07051_E_Ongeldige String uitdrukking +asmr_w_const32bit_for_address=07052_ bits constante gemaakt voor adres +asmr_e_unknown_opcode=07053_E_Ongekende opcode $1 +asmr_e_invalid_or_missing_opcode=07054_E_Ongeldige of ontbrekende instructie +asmr_e_invalid_prefix_and_opcode=07055_E_Ongeldige combinatie van voorvoegsel en instructie: $1 +asmr_e_invalid_override_and_opcode=07056_E_Ongeldige combinatie van segment overroeping en instructie: $1 +asmr_e_too_many_operands=07057_E_Te veel operandi op een lijn +asmr_w_near_ignored=07058_W_NEAR genegeerd +asmr_w_far_ignored=07059_W_FAR genegeerd +asmr_e_dup_local_sym=07060_E_Dubbel lokaal symbool $1 +asmr_e_unknown_local_sym=07061_E_Niet gedefinieerd lokaal symbool $1 +asmr_e_unknown_label_identifier=07062_E_Onbekende labelnaam $1 +asmr_e_invalid_register=07063_E_Ongeldige register naam +asmr_e_invalid_fpu_register=07064_E_Ongeldig vlottende-komma registernaam +asmr_e_nor_not_supported=07065_E_NOR wordt niet ondersteund +asmr_w_modulo_not_supported=07066_W_Modulo wordt niet ondersteund +asmr_e_invalid_float_const=07067_E_Ongeldige vlottende-komma constante $1 +asmr_e_invalid_float_expr=07068_E_Ongeldige vlottende-komma uitdrukking +asmr_e_wrong_sym_type=07069_E_Verkeerd symbool type +asmr_e_cannot_index_relative_var=07070_E_Een lokale variabele of parameter kan niet geindedxeerd worden met een register +asmr_e_invalid_seg_override=07071_E_Ongeldige segment overroeping +asmr_w_id_supposed_external=07072_W_Symbool $1 wordt verondersteld extern te zijn +asmr_e_string_not_allowed_as_const=07073_E_Strings zijn niet toegelaten als constante +asmr_e_no_var_type_specified=07074_Geen type van de variabele gegeven +asmr_w_assembler_code_not_returned_to_text=07075_E_De assembler code stopt niet in een '.text' gedeelte +asmr_e_not_directive_or_local_symbol=07076_E_Geen aanwijzing of lokaal symbool $1 +asmr_w_using_defined_as_local=07077_E_Een gedfinieerde naam wordt gebruikt als assembler label + +# +# Assembler/binary writers +# +asmr_e_dollar_without_identifier=07078_E_Dollar teken gebruikt zonder identifier +asmr_w_32bit_const_for_address=07079_W_32bit constante aangemaakt voor adres +asmr_n_align_is_target_specific=07080_N_.align is doel specifiek, gebruik .balign of .p2align +asmr_e_cannot_access_field_directly_for_parameters=07081_E_Kan velden niet direct gebruiken voor parameters. +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_Kan velden van objecten/klassen niet direct aanspreken +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_Te veel assembler bestanden +asmw_f_assembler_output_not_supported=08001_F_De geselecteerde assembler modus wordt hier niet ondersteund +asmw_f_comp_not_supported=08002_F_Het COMP type wordt hier niet ondersteund +asmw_f_direct_not_supported=08003_F_Directe assembler modus wordt niet ondersteund door de binaire assemblerschrijver +asmw_e_alloc_data_only_in_bss=08004_E_Ruimte voor gegevens reserveren mag enkel in een bss gedeelte +asmw_f_no_binary_writer_selected=08005_F_Binaire assemblerschrijver geselecteerd +asmw_e_opcode_not_in_table=08006_E_Asm: Opcode $1 not gevonden in interne tabel +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 Ongeldige combinatie van instructie en operandi +asmw_e_16bit_not_supported=08008_E_Asm: 16 Bit geheugenlocaties worden niet ondersteund +asmw_e_invalid_effective_address=08009_E_Asm: Ongeldig direct adres +asmw_e_immediate_or_reference_expected=08010_E_Asm: Constante of geheugenadres verwacht +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 value exceeds bounds $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: Korte spronginstructie gaat te ver $1 + +# +# Executing linker/assembler +# +asmw_e_undefined_label=08013_E_Asm: Ongedefinieerd label $1 + + +# +# Executing linker/assembler +# +# BeginOfTeX +% +% \section{Errors of assembling/linking stage} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +exec_w_source_os_redefined=09000_W_Bronbesturingssysteem geherdefinieerd +exec_i_assembling_pipe=09001_I_Assembleren (pijp) van $1 +exec_d_cant_create_asmfile=09002_E_Kan geen assembler bestand $1 niet maken +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_Kan geen object bestand openen: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_kan geen archief bestand openen: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_Assembler $1 niet gevonden, overschakeling naar externe assemblage +exec_t_using_assembler=09006_T_Gebruikte assembler: $1 +exec_w_error_while_assembling=09007_W_Fout bij assembleren +exec_w_cant_call_assembler=09008_W_Kan assembleerder niet oproepen, overschakeling naar externe assemblage +exec_i_assembling=09009_I_Assembleren van $1 +exec_i_assembling_smart=09010_I_Assembleren slim-link $1 +exec_w_objfile_not_found=09011_E_Bestand $1 niet gevonden, linken kan foutlopen ! +exec_w_libfile_not_found=09012_E_Bibliotheek $1 niet gevonden, linken kan foutlopen ! +exec_w_error_while_linking=09013_W_Fout tijdens linken +exec_w_cant_call_linker=09014_W_Kan linker niet oproepen, overschakeling naar extern linken +exec_i_linking=09015_I_Linken van $1 +exec_w_util_not_found=09016_W_Tool $1 niet gevonden, schakel over op exter linken. +exec_t_using_util=09017_T_Gebruik tool $1 +exec_e_exe_not_supported=09018_E_Creatie van executable bestanden niet ondersteund. +exec_e_dll_not_supported=09019_E_Dynamische bibliotheken niet ondersteund +exec_i_closing_script=09020_I_Afsluiten batch $1 +exec_w_res_not_found=09021_W_resource compiler niet gevonden, ga over op externe modus +exec_i_compilingresource=09022_I_Compileer resource $1 +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_Kan applicatie niet nabehandelen $1 +execinfo_f_cant_open_executable=09024_F_Kan applicatie niet openen $1 +execinfo_x_codesize=09025_X_Grootte van de code: $1 bytes +execinfo_x_initdatasize=09026_X_Grootte van geinitialiseerde data: $1 bytes +execinfo_x_uninitdatasize=09027_X_Grootte van niet-geinitialiseerde data: $1 bytes +execinfo_x_stackreserve=09028_X_Gereserveerde Stack ruimte: $1 bytes +execinfo_x_stackcommit=09029_X_Toegewezen Stack ruimte: $1 bytes +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_Unit zoeken: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_U_PPU Laden $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU Naam: $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_D_PPU Vlaggen: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_D_PPU CRC: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_D_PPU Tijd: $1 +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_file_too_short=10006_D_PPU bestand te kort +% When you use the \var{-vu} flag, the unit time is shown. +unit_u_ppu_invalid_header=10007_D_PPU Ongeldige kop (geen PPU aan het begin) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_D_PPU Ongeldige versie $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU is gecompileerd voor een andere processor +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU is gecompileerd voor een ander doelsysteem +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU bron: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_Schrijven van $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_Kan PPU bestand niet schrijven +% An err +unit_f_ppu_read_error=10014_F_Lezen van PPU bestand +% Unexpected end of file +unit_f_ppu_read_unexpected_end=10015_F_Onverwacht einde van PPU-bestand +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_invalid_entry=10016_F_Ongeldig PPU bestand post: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU Dbx aantal probleem +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Ongeldige unitnaam: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_Te veel units +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_Uses statement veroorzaakt vicieuze cirkel +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_Kan unit $1 niet compileren, geen broncode beschikbaar +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_Kan unit $1 niet vinden +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_Unit $1 niet gevonden maar $2 bestaat +unit_f_unit_name_error=10024_F_Unit $1 gezocht maar $2 gevonden +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_De systeemunit compileren vereist de -Us schakelaar +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_Er waren fouten $1 bij het compileren van een module, compilatie gestopt. +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_Laden van $1 ($2) unit $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_Hercompileer $1, checksum voor $2 veranderd +unit_u_recompile_source_found_alone=10029_U_herkompileer $1, alleen bron gevonden +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_Hercompileer unit, statische bibliotheek ouder dan ppu-bestand +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_Hercompileer unit, dynamische bibliotheek ouder dan ppu-bestand +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_Hercompileer unit, object en asm zijn ouder dan ppu-bestand +% When you use the \var{-vu} flag, the compiler warns if the assembler of +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_Hercompileer unit, object is ouder dan assembler +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_Parsen van interface van $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_Parsen van implementatie van $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_Tweede maal unit $1 laden +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU Controleren van bestand $1 tijd $2 +% When you use the \var{-vu} flag, the compiler show the filename and +% date and time of the file which a recompile depends on +% \end{description} +# EndOfTeX +# +# Options +# +option_usage=11000_$1 [opties] [opties] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_Maar een (1) bronbestand wordt ondersteunt +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_Een DEF file kan alleen worden gemaakt voor OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_Geneste optie bestanden niet ondersteund +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_Geen bronbestand op de commando-lijn +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_geen opties in configuratie bestand $1 +% The compiler didn't find any option in that config file. +option_illegal_para=11006_Ongeldige parameter: $1 +% You specified an unknown option. +option_help_pages_para=11007_-? druk hulp af +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_Te veel geneste instellingsbestanden +% You can only nest up to 16 config files. +option_unable_open_file=11009_Kan bestand $1 niet openen +% The option file cannot be found. +option_reading_further_from=11010_Meer instellingen worden gelezen van $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_Doel is reeds ingesteld op: $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_Shared bibliotheken niet onderteund onder DOS, val terug op statisch +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_Te veel IF(N)DEFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_Te veel ENDIFs +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_Open voorwaardelijke aan eind van bestand +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_Debug informatie generatie is niet ondersteund door deze applicatie +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_Hercompileer de compiler-applicatie met -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_W_U gebruikt een in onbruik geraakte schakeloptie $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_W_U gebruikt een in onbruik geraakte schakeloptie $1, gebruik $2 a.u.b. +% this warns you when you use a switch that is not supported anymore. You +% must now use the second switch instead. +% It is recommended that you change the switch to overcome problems in the +% future, when the switch meaning may change. +option_switch_bin_to_src_assembler=11020_N_De assembler wordt veranderd in de standaard assembler schrijver +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_Geselecteerde assembler "$1" is niet verenigbaar met "$2" +option_asm_forced=11022_W_Gebruik van "$1" assembler opgelegd +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +%\end{description} +# EndOfTeX + +# +# Logo (option -l) +# +option_logo=11023_[ +Free Pascal Compiler versie $FPCVER [$FPCDATE] voor $FPCTARGET +Copyright (c) 1998-2000 door Florian Klaempfl en anderen +] + +# +# Info (option -i) +# +option_info=11024_[ +Free Pascal Compiler versie $FPCVER + +Compiler datum: $FPCDATE +Compiler doelsysteem: $FPCTARGET + +Dit programma wordt verspreid onder de GNU General Public Licence +Voor meer informatie, lees COPYING.FPC. Hiervan is helaas geen +Nederlandse vertaling beschikbaar. + + bugrep@freepascal.org +] + +# +# Help pages (option -? and -h) +# +option_help_pages=11025_[ +**0*_+ schakelt optie aan, - af +**1a_De compiler verwijdert gegenereerd assembler bestand niet +**2al_Toon broncode lijnen in assembler bestand +**2ar_Toon register allocatie/release informatie in assembler bestand +**2at_Toon tijdelijke allocatie/release informatie in assembler bestand +**1b_genereer browser info +**2bl_genereer info voor lokale symbolen info +**1B_Bouw alle modules +**1C_Code generatie opties +3*2CD_Creeer dynamische bibliotheek +**2Ch_ bytes heap (tussen 1023 en 67107840) +**2Ci_IO-checking +**2Cn_Laat linken achterwege +**2Co_Controleer overflow van integer operaties +**2Cr_Bereik controle +**2Cs_Stel stack grootte in op +**2Ct_Stack controle +3*2CS_Creer dynamische bibliotheek +3*2Cx_Gebruik slim linken +**1d_definieer het symbool +*O1D_genereer een DEF bestand +*O2Dd_Zet beschrijving op +*O2Dw_PM applicatie +**1e_Zet pad naar applicaties +**1E_Zelfde als -Cn +**1F_Zet bestandsnamen en paden +**2Fe_Zend foutboodschappen naar bestand +*L2Fg_Zelfde als -Fl +**2Fi_Voegt toe aan invoegpad +**2Fl_Voegt toe aan bibliotheek pad +*L2FL_Gebruik als dynamische linker +**2Fo_Voeg toe aan object pad +**2Fr_Gebruik foutboodschappen in bestand +**2Fu_Voeg toe aan unit pad +**2FU_Schrijf units in folder , (primeert op -FE) +*g1g_genereer debug informatie +*g2gg_gebruik gsym +*g2gd_gebruik dbx +*g2gh_laad heaptrc unit automatisch +*g2gl_Gebruik lijn informatie unit voor meer informatie in backtraces +*g2gc_genereer meer controlers voor wijzers +**1i_informatie +**2iD_Toon compiler datum +**2iV_Toon compiler versie +**2iSO_Toon compiler OS +**2iSP_Toon compiler processor +**2iTO_Toon doel OS +**2iTP_Toon doel processor +**1I_Voeg toe aan invoegpad +**1k_Geef door aan de linker +**1l_Druk logo af +**1n_Standaard configuratie bestand niet lezen +**1o_Stel de naam van het applicatiebestand in op +**1pg_genereer profile code voor gprof +*L1P_Gebruik pipes in plaats van tijdelijke assembler bestanden +**1S_Syntax instellingen +**2S2_Stel Delphi 2 uitbreidingen in +**2Sc_Ondersteun operatoren als in C (*=,+=,/= en -=) +**2sa_Voeg assertion code toe +**2S2_Tracht Delphi compatibel te zijn +**2Se_Compiler stopt na fouten (standaard 1) +**2Sg_Laat LABEL en GOTO toe +**2Sh_Gebruik ansistrings +**2Si_Ondersteun C++ stijl INLINE +**2Sm_Ondersteun macros zoals in C (globaal) +**2So_Probeer TP/BP 7.0 compatibel te zijn +**2Sp_Probeer to be gpc compatibel te zijn +**2Ss_Constructor naam moet init zijn (destructor moet done zijn) +**2St_Sta static sleutelwoord toe in objecten +**1s_Roep assembler en linker niet op (slechts met -a) +**1u_Verwijdert symbooldefinitie +**1U_unit opties +**2Un_Unit naam niet nagaan +**2Us_Compileer een systeemunit +**1v_Wees uitvoerig. is een combinatie van volgende letters: +**2*_e : Toon fouten (standaard) d : Toon debug informatie +**2*_w : Toon waarschuwingen u : Toon gebruikte bestanden +**2*_n : Toon notas t : Toon geteste bestanden +**2*_h : Toon hints m : Toon gedefinieerde macros +**2*_i : Toon algemene informatie p : Toon gecompileerde routines +**2*_l : Toon regelnummers c : Toon voorwaardelijken +**2*_a : Toon alles 0 : Toon alleen fouten +**2*_b : Toon alle procedures r : Rhide/GCC compatibiliteit modus +**2*_ declaraties indien een x : Executable informatie (alleen Win32) +**2*_ fout optreedt +**1X_applicatie instellingen +*L2Xc_link met de C bibliotheek +**2Xs_verwijder alle symbolen uit applicatie +**2XD_link met dynamische bibliotheken (definieert FPC_LINK_DYNAMIC) +**2XS_link met statische bibliotheken (definieert FPC_LINK_STATIC) +**2XS_link slim (definieert FPC_LINK_STATIC_SMART) +**0*_Processor specifieke instellingen: +3*1A_Output formaat +3*2Aas_assembleer met GNU AS +3*2Aasaout_assembleer met GNU AS voor aout (Go32v1) +3*2Anasmcoff_Coff (Go32v2) bestand met Nasm +3*2Anasmelf_elf32 (linux) bestand met Nasm +3*2Anasmobj_obj bestand met Nasm +3*2Amasm_obj bestand met Masm (Microsoft) +3*2Atasm_obj bestand met Tasm (Borland) +3*2Acoff_coff (Go32v2) met interne assembler +3*2Apecoff_pecoff (Win32) met interne assembler +3*1R_assembler lezer stijl: +3*2Ratt_Lees AT&T stijl assembler +3*2Rintel_Lees Intel stijl assembler +3*2Rdirect_Kopieer assembler dadelijk naar assembler bestand +3*1O_optimalizaties +3*2Og_Genereer kleinere code +3*2OG_Genereerd snellere code (standaard) +3*2Or_Houd zekere variabelen in registers (Nog steeds BUGGY!!!) +3*2Ou_Probeer onzekere optimalizaties (zie documentatie) +3*2O1_Niveau 1 optimalizaties (snelle optimizaties) +3*2O2_Niveau 2 optimalizaties (-O1 + tragere optimizaties) +3*2O3_Niveau 3 optimalizaties (Zelfde als -O2u) +3*2Op_Doel processor +3*3Op1_Stel doel processor in op 386/486 +3*3Op2_Stel doel processor in op Pentium/PentiumMMX (tm) +3*3Op3_Stel doel processor in op PPro/PII/c6x86/K6 (tm) +6*1T_Doel besturingssysteem: +3*2TGO32V1_version 1 of DJ Delorie DOS extender +3*2TGO32V2_version 2 of DJ Delorie DOS extender +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +3*1W_Win32 Doel opties +3*2WB_Stel Image base in op (hexadecimale) waarde +3*2WC_Maak een console applicatie +3*2WD_Gebruik DEFFILE om functies van bibliotheek of applicatie te exporteren +3*2WG_Maak een grafische applicatie +3*2WN_Genereer geen relocatie code (nodig voor debuggen) +3*2WR_Genereer relocatie code +6*1A_output formaat +6*2Aas_Unix o-bestand met GNU AS +6*2Agas_GNU Motorola assembler +6*2Amit_MIT Syntax (oude GAS) +6*2Amot_Standaard Motorola assembler +6*1O_optimizaties +6*2Oa_Gebruik de optimizaties +6*2Og_Genereer kleinere code +6*2OG_Genereer snellere code (standaard) +6*2Ox_Optimizeer maximaal (nog steeds BUGGY!!!) +6*2O2_Stel doelprocessor in op MC68020+ +6*1R_assembler reading style: +6*2RMOT_read motorola style assembler +6*1T_Target operating system: +6*2TAMIGA_Commodore Amiga +6*2TATARI_Atari ST/STe/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_Toont deze hulp +**1h_Toont deze hulp zonder wachten +] + +# +# The End... +# diff --git a/befpc/compiler/errorr.msg b/befpc/compiler/errorr.msg new file mode 100644 index 0000000..6ed125d --- /dev/null +++ b/befpc/compiler/errorr.msg @@ -0,0 +1,1855 @@ +# +# $Id: errorr.msg 1.95 2000/06/28 14:51:48 Michail A.Baikov +# 䠩 - ணࠬ த Free Pascal Compiler +# Copyright (c) 1998-2000 by Free Pascal Development Team +# +# y᪨ 䠩 몠 Free Pascal Compiler +# +# . 䠩 COPYING.FPC, 祭 y ⠢y, +# ᥬ ᠬ ⭮⥫쭮 ᪮ ࠢ. +# +# ணࠬ p , 㤥 y- +# , ! ࠭㥬, ணࠬ +# ᮮ⢥ ᢮ 楫! +# +# +# ⠭ - 祭, ᫥y饬 : +# __ +# +# ࠧ ᮮ饭 , ᯮy ࠬ, +# 䨪樨 ⨯ 訡: +# asmr_ ᨭ⠪᪨ ᥬ (ᨭ⠪᪨ ) +# asmw_ ᨭ⠪᪨ ᥬ (⥭ ) +# unit_ ࠡ⪠ +# scan_ ᪠ +# parser_ ᨭ⠪᪨ +# type_ ஫ ᮮ⢥⢨ ⨯ +# general_ ଠ +# exec_ 맮 ᥬ, 騪, । +# +# ⨯ ᮮ饭, ᯮ짮 +# f_ ⠫쭠 訡 +# e_ 訡 +# w_ ।० +# n_ ਬ砭 +# h_ ᪠ +# i_ ଠ +# l_ p p +# u_ ᯮ㥬 +# t_ p뢠 +# m_ ப +# p_ 楤 +# c_ ᫮ ࠦ +# d_ ᮮ饭 ⫠ +# b_ ⮡ࠦ "overload" 楤 (ppy p楤yp) +# x_ ଠ ᯮ +# + +# +# 饥 +# +# BeginOfTeX +% \section{騥 ᮮ饭 } +% ࠧ ᮮ饭 , ⠫, +% ⮡ࠦ ଠ. ᫮ ⠪ ᮮ饭 +% ࠢ塞 ࠧ묨 p yp \var{-v} p. +% \begin {ᠭ} +general_t_compilername=01000_T_p: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% ᯮ. +general_d_sourceos=01001_D_ OS: $1 +% \var{-vd} ᯮ, ப, ᮮ頥 , +% 樮 ⥬, ᮧ 䠩. +general_i_targetos=01002_I_ OS: $1 +% \var{-vd} ᯮ, ப, ᮮ頥 , +% 樮 ⥬ ᮧ 䠩 +general_t_exepath=01003_T_ᯮy y p 䠩: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% p 䠩. +general_t_unitpath=01004_T_ᯮy 㫥: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% 㥬 㫨. ⠭ +% p \var{-Fu} \var{-Up} 樨. +general_t_includepath=01005_T_ᯮy y 砥 䠩: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% 䠩 祭 (䠩, ᯮ㥬 \var{\{\$I xxx\}} +% p). ⠭ p \var{-I} . +general_t_librarypath=01006_T_ᯮy y ⥪: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% ⥪. ⠭ p +% \var{-Fl} . +general_t_objectpath=01007_T_ᯮy y ꥪ 䠩: $1 +% \var{-vt} ᯮ, ப, ᮮ頥 , +% ꥪ 䠩, 뢠 (䠩, +% ᯮ \var{\{\$L xxx \}} p). +% ⠭ p \var{-Fo} . +general_i_abslines_compiled=01008_I_$1 ᪮p, $2 ᥪ. +% \var{-vi} ᯮ, , ᮮ頥 ᫮ +% ᪮p ப, ६, ஥ p ⮣. +% (ॠ쭮 ६, ணࠬpy ६). +general_f_no_memory_left=01009_F_H ᢮ +% 筮 , ⮡ ஢ ணࠬ. +% ᪮쪮 p権 p襭 ⮣ p: +% \begin{itemsize} +% \item ᫨ ᯮ ନ , ஡ +% ஢ ࠧ 㫨 . +% \item ᫨ , ஬y ணࠬy, ࠧ 㫨, +% ⤥쭮. +% \item ᫨ ।騥 y ࠡ, ࠭᫨y +% 訬 pp y ( ᯮ짮 \var{-Ch} ⮣, \seeo{Ch}) +% \end {itemsize} +% \end {ᠭ} +general_i_writingresourcefile=01010_I_뢠 䠩-⠡y p pypᮢ: $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_訡 p 䠩-⠡ p pypᮢ: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} + + +# +# +# +% \section {饭 ᪠.} +% ࠧ ᮮ饭, p 뤠 ᪠. +% ᪮ 䠩 Free Pascal, py 室 +% १ࢨ஢ ᫮, ப, .. ⠪ ४⨢ +% ᫮ ࠦ 騥 py pp p. +% \begin {ᠭ} +scan_f_end_of_file=02000_F_H 䠩 +% 筮 砥 ᫥ : +% \begin{itemsize} +% \item 室 䠩 稢 ᫥ \var{end} p. +% 砥 筮, \var{begin} \var{end} p +% ᡠ஢ ( ⢮); +% \item 砥 䠩 稢 । p. +% \item ਩ (䨣yp ᪮ ) +% \end{itemsize} +scan_f_string_exceeds_line=02001_F_H p +% , , 뫨 ⨥ ' p, ⠪ p +% ᪮쪮 (p). +scan_f_illegal_char=02002_F_p饭 ᨬ +% p ⮫y 饭 ᨬ 室 䠩. +scan_f_syn_expected=02003_F_py ᨭ⠪᪠ 訡: $1 +% 㪠뢠, pyy ᥬ ( થ) 祬 +% , ⠫. ந室 , +% 몠 ᪠. +scan_t_start_include_file=02004_T_H稭 ⥭ 砥 䠩 $1 +% ᯥ稢 \var{-vt} , , ᮮ頥 +% 稭 砥 䠩. +scan_w_comment_level=02005_W_H $1 yp p +% \var{-vw} ᯮ, ।० , +% ᫨ 室 ਨ. ਨ +% Turbo Pascal 筨 訡. +scan_n_far_directive_ignored=02006_N_$F ४⨢ (FAR) +% \var{FAR} ४⨢ 16-ࠧ來 ,  +% p, 㥬 ஬, ⠪ ந +% 32 ࠧ來 . +scan_n_stack_check_global_under_linux=02007_N_Linux pp ⥪ ⮬᪨ +% ஢ઠ ⥪ \var{-Cs} \linux, ⠪ +% \linux . ⮡p ⮫쪮, \var{-vn} ᯮ. +scan_n_ignored_switch=02008_N_ppy ஬ $1 +% 祭 \var{-vn}, ।०, ᫨ +scan_w_illegal_switch=02009_W_H p $1 +% 稫 ( \var{\{\$... \}}) +% . +scan_w_switch_is_global=02010_W_ y +% \var{-vw} ᯮ, ।०, ᫨ . +scan_e_illegal_char_const=02011_E_H ᨬ ⠭ +% 砥, । ᨬ ASCII, ᪮ +% \var{\#96},  饭, . +% - 1-255. +scan_f_cannot_open_input=02012_F_H y p 䠩 $1 +% \fpc ணࠬ 室 䠩 , +% । ப. +scan_f_cannot_open_includefile=02013_F_H y p 砥 䠩 $1 +% \fpc 室 䠩, p । \var{\{\$include \}} +% p. +scan_e_too_much_endifs=02014_E_誮 $ENDIF $ELSE p⨢ +% \var{\{\$IFDEF.. \}} {\{\$ENDIF} \}} p -. +scan_w_only_pack_records=02015_W_Record y ࠢ ⮫쪮 1,2,4 16 ⠬ +% । \var{\{\$PACKRECORDS n\} } 饭 祭 +% \var{n}. 쪮 1,2,4 16 ⨬ ⮬ 砥. +scan_w_only_pack_enum=02016_W_p᫥ y ࠭ ⮫쪮 1,2 4 +% । \var{\{\$PACKENUM n \}} 饭 祭 +% \var {n}. 쪮 1,2 4 ⨬ ⮬ 砥. +scan_e_endif_expected=02017_E_$1 $2 । ப $3 +% ᫮ ⢥ত ࠭樨 ᡠ஢. +scan_e_preproc_syntax_error=02018_E_⠪᪠ 訡 ࠦ p +% ᫮ ࠦ 訡 ᫥ \var{\{\$if \}} ४⨢ . +scan_e_error_in_preproc_expr=02019_E_訡 p ࠦ ppp ஢ +% ᫮ ࠦ 訡 ᫥ \var{\{\$if \}} ४⨢ . +scan_w_macro_cut_after_255_chars=02020_W_ p p, p ᮪p饭 255 ᨬ +% ࠦ ᮤঠ騥 ப 祬 255 ᨬ. +%  ᭮ , ।頥 +% ९. 뢠 ।०, +% \var{-vw} ᯮy. +scan_e_endif_without_if=02021_E_ENDIF IF{N}DEF +% \var{\{\$IFDEF.. \}} {\ {\$ENDIF \}} ⢥ত ᡠ஢. +scan_f_user_defined=02022_F_짮⥫ । $1 +% p諠 ।塞 짮⥫ ⠫쭠 訡. . ⠪ \progref +scan_e_user_defined=02023_E_짮⥫ p $1 +% p諠 ।塞 짮⥫ 訡. . ⠪ \progref +scan_w_user_defined=02024_W_짮⥫ p $1 +% p諮 ।塞 짮⥫ ।०. . ⠪ \progref +scan_n_user_defined=02025_N_짮⥫ p $1 +% ⮫y ।塞 짮⥫ ਬ砭. . ⠪ \progref +scan_h_user_defined=02026_H_짮⥫ p $1 +% ⮫y ।塞 짮⥫ ᪠. . ⠪ \progref +scan_i_user_defined=02027_I_짮⥫ p $1 +% ⮫y ।塞 짮⥫ ᪠. . ⠪ \progref +scan_e_keyword_cant_be_a_macro=02028_E_祢 ᫮ ८।, ᪮ ப 䥪 +% ८। 祢 ᫮ ப. +scan_f_macro_buffer_overflow=02029_F_yp pᮢ ९ ⥭ ७ ப +% p १, ᫨誮 . +scan_w_macro_deep_ten=02030_W_p ப ॢ蠥 yp ( 16). +% ७ ப 뫮 ᯮ짮 16 yp . +% pp p, ⠪ , +% ᯮy ४ +scan_e_wrong_styled_switch=02031_E_p⥫ p ᯮ짮 (* *) ⨫ p. +% ४⥫ ᥣ \var{\{\ }} ࠧ⥫ﬨ . +scan_d_handling_switch=02032_D_pp塞 "$1" +% 砥 ଠ ⫠ (\var{-vd}), ᮮ頥 +% , 業 ᫮ ࠦ, 饥 . +scan_c_endif_found=02033_C_ENDIF $1 +% 砥 ᫮ ᮮ饭 (\var{-vc}), ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_ifdef_found=02034_C_IFDEF $1 , $2 +% 砥 ᫮ ᮮ饭 (\var{-vc}), , ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_ifopt_found=02035_C_IFOPT $1 , $2 +% 砥 ᫮ ᮮ饭 (\var{-vc}), , ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_if_found=02036_C_IF $1 , $2 +% 砥 ᫮ ᮮ饭 (\var{-vc}), , ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_ifndef_found=02037_C_IFNDEF $1 , $2 +% 砥 ᫮ ᮮ饭 (\var {-vc}), , ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_else_found=02038_C_ELSE $1 , $2 +% 砥 ᫮ ᮮ饭 (\var{-vc}), , ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ. +scan_c_skipping_until=02039_C_py᪠ ... +% 砥 ᫮ ᮮ饭 (\var{-vc}), ᮮ頥 +% ⠫ ᫮묨 ⢥তﬨ, ய᪠ . +scan_i_press_enter=02040_I_H , ⮡ த +% ᯮy \var{-vi} , ⠭ +% ࠭樨 \var{enter} y, 㤥 , +% ⮫ p⨢ \var {\{\$STOP\}}. +scan_w_unsupported_switch=02041_W_Hp $1 +% pyp 祭 (\var{-vw}), ।० +% ⭮⥫쭮 ন 祩. 砥 , ᯮ +% Delphi Turbo Pascal, \fpc +scan_w_illegal_directive=02042_W_Hp쭠 ४⨢ $1 +% pyp 祭 (\var{-vw}), ।० +% ⭮⥫쭮 ਧ p⨢. ᯨ᪠ ᯮ p⨢, . \progref +scan_t_back_in=02043_T_p頥 $1 +% ᯮ (\var{-vt}) , ᮮ頥 , +% 稫 砥 䠩. +scan_w_unsupported_app_type=02044_W_Hp ⨯ p: $1 +% 砥 ।०, । ⨯ +% ਫ ४⨢ $APPTYPE +scan_w_app_type_not_support=02045_W_$APPTYPE ন ⥬ p py 䠩 +% $APPTYPE ४⨢ ᯥ稢 ⮫쪮 win32 ਫﬨ. +scan_w_decription_not_support=02046_W_ DESCRIPTION ন ⥬ p py 䠩 +% \var{\{\$DESCRIPTION\}} ন ⮫쪮 ⥬ OS/2 Win32. +scan_n_version_not_support=02047_N_ VERSION ন ⥬ p py 䠩 +% \var{\{\$VERSION\}} ন ⮫쪮 Win32 ⥬. +scan_n_only_exe_version=02048_N_ VERSION ᯮ ⮫쪮 .EXE .DLL 室. +% \var{\{\$VERSION\}} ᯮ ⮫쪮 .EXE .DLL 室. +scan_w_wrong_version_ignored=02049_W_ ଠ ⥣ VERSION ४⨢ $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_Hp ⨫ ᥬp $1 +% । ० ᥬ \var{\{\$ASMMODE xxx\}} +% ᯮ ०, ⠬ y. +% \end {ᠭ} +scan_w_no_asm_reader_switch_inside_asm=02051_W_ ᥬp: yp py ᥬp, $1 y 䥪⨢ ⮫쪮 ᫥y騩 p +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Hp p ४⥫, ᯮ ON/OFF +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_ pypᮢ ন ⥬ p py 䠩 +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +scan_w_include_env_not_found=02054_W_砥 p py $1 py ⥬ +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_୮ 祭 ࠭ ॣ ᮯ +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +scan_w_only_one_resourcefile_supported=02056_W_ ⮩ ⥬ ন ⮫쪮 䠩 ᮢ +% The target you are compiling for supports only one resource file. This is the +% case of OS/2 (EMX) currently. The first resource file found is used, the +% others are discarded. +% \end{description} + +# +# ⠪᪨ +# +% \section {ᮮ饭 ᨭ⠪᪮ } +% ࠧ ᮮ饭 ᨭ⠪᪮ . +% ⠪᪨ ᥬ⨪ 몠, +% ।, ࠢ ᪠. +% \begin {ᠭ} +parser_e_syntax_error=03000_E_⠪᪠ 訡 () +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_p楤yp ⨯ FAR - ppy +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_p楤yp ⨯ NEAR - ppy +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_楤 ⨯ INTERRUPT i386 ஢ +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is ignored for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT 楤 +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_楤 ⨯ $1 +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_ । $1 । OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_DLL-䠩 y +% No longer in use. +parser_e_export_name_double=03008_E_ y樨 ᯮppy $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_ y樨 ᯮppy $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Hp y ᯮppy y樨 +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_६頥 DLL/EXE 䠩 $1 ⫠ ଠ ᮤন, ⪫祭. +parser_w_parser_win32_debug_needs_WN=03012_W_ প ⫠ Win32-, 室 ⪫ ६饭 樥 -WN +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_pyp INIT +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_pyp DONE +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Hp쭮 p 'p pp' +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_p楤yp ⨯ INLINE p +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Private ⮤ y py묨 +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_pyp public +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_pyp public +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_ ⮫쪮 pyp +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_p ᮢ p +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_p ᮢ p +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_ꥪ $1  ⠡楩 VMT +parser_e_illegal_parameter_list=03024_E_Hp ᯨ᮪ pp +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Hp쭮 p ⨯ pp py $1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Hp쭮 p ⢮ pp +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_ॣ㦥 䨪p $1  y樥 +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_ॣ㦥 y樨 - ᯨ᮪ pp +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_ y樨 ᮮ⢥y py饬y p forward $1 +% You declared a function with same parameters but +% different result type or function modifiers. +parser_e_header_different_var_names=03030_E_ y樨 $1 ᮮ⢥y py饬y p forward : p $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_祭 ⨯ ᫥ 騬 +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Interface Implementation p $1 => $2 +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With ᯮ짮 p p 室 p ᥣ +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_⢮ y樨 ᫨誮 ( 31) +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_訡 室 y⨬ p p ⠭ +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_訡 室 y⨬ p p ⠭ +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_p ⪠ CASE +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_p p 祬 +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_p ⠭ ᮢ p +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_६ ॣ㦥 㭪権 p +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_ p 1 .. 255 +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_ᯮ짮 pp ᨭ⠪ NEW DISPOSE ⠭権 ꥪ⮢ +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_ᯮ짮 NEW DISPOSE ⨯p y⥫, ᫥ +parser_e_no_new_dispose_on_void_pointers=03044_E_ᯮ짮 NEW DISPOSE ⨯p y⥫, p +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_ 䨪p +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_䨪p ⨯ y⥭ +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_ 䨪p ⮤ +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_ y樨 ᮤp ⮤ ꥪ +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_p楤yp/y $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Hp ⠭ 饩 ⮩ +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL ᯮ짮 ⮫쪮 pyp +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_pyp y pp +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_쪮 ⮤ 뫠 +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_쪮 ⮤ ⮤ +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_ ⠭ ⨯ p CASE ᮢ +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_ ᯮ஢ ⥪ +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_᫥ ⮤ p $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_ ⮤ ।, 㦭 pp: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_ ᯥ稢 饭 ᢮⢠ +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_࠭ ४⨢ ᢮ , p +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Hp ᨬ 㯠 ᢮y +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_H protected ꥪ +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_H private ꥪ +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_ॣ㦥 ⮤ py ⮤, ⮦ py묨: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_ॣ㦥 ⮤ H 㠫쭮 ⮤ ⮦ H 㠫: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_ॣ㦥 ⮤,  㠫묨, ᠬ ⨯ py: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_EXPORT y樨 y 묨 +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_⮤ y ᯮpp +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_맮 ६묨 ࠬࠬ ᮮ⢥⢮ 筮 +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_  த⥫᪨ ᮬ ⥪饣 +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF pp蠥 ⮫쪮 ⮤ +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_⮤ y 뢠 ⮫쪮 py ⮤ py 䨪p ⨯ +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Hp쭮 ᯮ짮 ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_訡 ஢ન ਭ +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_ y⥫ ꥪ +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_p 뢠 pyp +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_p 뢠 pyp +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Hp p冷 ⮢ ⨯ RECORD +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_ p CLASS RECORD +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_p楤yp y p 祭 +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_pyp pyp ⮤ +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_pp ppy +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_ॣ㦥 뢠 묨 ⨯ +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_ॣ㧪 +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_RERAISE +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_p ᨭ⠪ NEW DISPOSE y⨬ +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_ᥬp ᮢ⨬ ⨯, p p頥 y +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_p楤yp ॣ㧪 ⪫祭 +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_ ८ࠧ ॣ㦥 +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_ࠢ⥫ 㫥 祭 +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_쪮 㠫 ⮤ ࠪ +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_ᯮ짮 ন ᮡ +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_訢 +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_⭠ ४⨢ 楤, $1 y +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_ABSOLUTE 易 ⮫쪮 H p +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_ABSOLUTE 易 ⮫쪮 p ⠭⮩ +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_쪮 H p 樠p +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_ࠪ ⮤ । ( ⥫) +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_ ॣ㦥 㭪 쭮, ᯮ஢ +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_㠫 ⮤ ᯮ $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_p p: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_p p: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_p $1 y⠭ $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_p $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_㥬 䥩 y $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_㥬 ॠ樮 y $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_୮ ஢ $1 +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_⢠ ᨢ ⮩ 窥 p +% You cannot use array properties at that point in the source. +parser_e_no_property_found_to_override=03109_E_H ᢮ pp +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_쪮 -㬮砭 ᢮⢮ pp蠥, y᫥, y砭, ᢮⢮ $1 +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_ -㬮砭 ᢮⢮ ᢮⢮ ᨢ +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_py pyp p ⮫쪮 ᮢ ꥪ +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_H ᢮ +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_ PUBLISHED ࠧ, ᯮy {$M+} +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_FORWARD p $1 ॠ , ⮡ ᯮ짮 । +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_ pp p +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_p楤yp p⨢ $1 pp襭 䥩᭮ +% This procedure directive is not allowed in the \var{interface} section of + +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_p楤yp p⨢ $1 pp襭 ॠ樮 +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_p楤yp p⨢ $1 pp襭 PROCVAR p +% This procedure directive cannot be part of a procedural or function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_㭪 $1 㦥  PUBLIC FORWARD +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_H ᯮ짮 EXPORT EXTERNAL +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_ 祢 ᫮ NAME +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 p yp INLINE p楤yp/y樨 +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_祭 INLINE ⪫祭 +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_뢠 pyp $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_ yy p묥 y⥫ +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_p ⨫ ⥭ ᥬp p +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not + +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_p楤yp p⨢ $1 䫨y py p⨢ +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_襭 맮 p楤yp/y樨 ᮮ⢥ yy FORWARD +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_맮 pp ("FAST CALL") p +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_⢮ 祭 y砭 +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_祭 y砭 y ᢮⢠ ⠭⮩ +% The value of a \var{default} declared property must be known at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_ PUBLISHED, ⮫쪮 +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_ ᢮⢠ PUBLISHED +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_ y +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_ॡ +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_७ 㭪樨, ᫥ ᯮ짮 㭪樨 +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_ +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Hp쭠 p 饩 ⮩ +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_p p , 祬 p +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_ப "$1" 祬 $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_ப , 祬 ᨢ ᨬ +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Hp p ᫥ p⨢ ᮮ饭 +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_p稪 ᮮ饭 y p ⮫쪮 p 뫮筮 pp +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_p p ⪨ ᮮ饭: $1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_SELF ⮫쪮  ࠬ ࠡ稪 ᮮ饭 +% The self parameter can be passed only explicitly in a method which +% is declared as message method handler. +parser_e_threadvars_only_sg=03147_E_p p y ⮫쪮 ᪨ 묨 +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_אַ ⨫ ᥬp p p⮬ 室 䠩 +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_H py OBJPAS y, ᯮy {$mode objfpc} {$mode delphi} ⮣ +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_pp ᯮ짮 ꥪ +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +parser_e_cant_use_inittable_here=03151_E_ , p py INITILIZATION/FINALIZATION ᯮ짮 p +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_ப ⮫쪮 ᪨ 묨 +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_楤 Exit 㬥⮬ ⨬ +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_ ࠭塞 ᨬ boolean +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_ ⨯ ᨬ p ⮬ ᢮⢥ +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_쪮 , p py $M+ p published +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_ p楤yp p⨢ +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_祭 ᢮⢠ 筮 ⨯ +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_ p楤yp ᫨誮 p⪮ ᯮp +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_ DEFFILE ᮧ ६ +parser_e_dlltool_unit_var_problem2=03161_E_஢ -WD 樨 +% \end{description} + +# +# pp ⨯ +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Hp ⨯ +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_Hᮢ⨬ ⨯: y稫 $1, $2 +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_Hᮮ⢥⢨ ⨯ y $1 $2 +% The types are not equal +type_e_type_id_expected=04003_E_ ࠦ ⨯ TYPE +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_ ࠦ ⨯ VAR +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_ p ⨯ INTEGER +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_ ࠦ ⨯ BOOLEAN, 稫 "$1" +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_ p ⠪- ⨯ +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_ ⨯ POINTER, 稫 "$1" +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_ ⨯ CLASS, 稫 "$1" +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_ p 䨪p +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_H p 祭 ⠭ +% No longer in use. +type_e_set_element_are_not_comp=04012_E_⠭ ⮢ ᨢ +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_p p p 祭 +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_⮬᪮ pp ⨯ REAL COMP, p  ᫮ ⨯ INTEGER +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_ᯮy DIV ⮣, y祭 楫᫥ py +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_p ⨯ p - $V+ p +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_SUCC PRED p᫥ 祭ﬨ +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_H p py ⮣ ⨯ +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_ ᯮ짮 Readln Writeln ⨯஢ 䠩 +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_ ᯮ짮 Read Write ⨯஢ 䠩 +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_訡 ⨯ y ⠬ p +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_LO/HI (LONGINT/DWORD) p p襥/襥 ᫮ +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword/int64/qword} +% which returns the lower/upper word/dword of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type cast the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_ p ⨯ INTEGER REAL +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Hp ⨯ ᨢ pyp +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_Hᮢ⨬ ⨯ py +% You are trying to pass an invalid type for the specified parameter. +type_e_no_method_and_procedure_not_compatible=04026_E_⮤ (p) p楤yp (p) ᮢ⨬ +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_p饭 ⠭, 뫠 p yp ⥬᪮ y樨 +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_H y y p ⠭ +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +type_e_argument_cant_be_assigned=04029_E_㬥 易 +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_ 易 楤/㭪 楤୮ ६ +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_H y 易 祭 py +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_H y 易 祭 ⠭ +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} + +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_䨪p $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_yp 訡 SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_ 䨪p $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_䨪p y p $1 (p $2) +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_H 䨪p $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_FORWARD $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_䨪p y p ⨯ +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_訡 p ⨯ +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_ 䨪p p +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_FORWARD ⨯ $1 +% A symbol was forward defined, but no declaration was encountered. +sym_e_only_static_in_static=05010_E_쪮 ᪨ ६ ᯮ짮 ᪨ 譨 ⮤ +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Hp 맮 tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_ ⨯ RECORD CLASS +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_p ᮢ ꥪ⮢ p ⮤ p +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_⪠ p $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_⪠ $1 ᯮ, । +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Hp । ⪨ +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO LABEL p (ᯮy -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_⪠ +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_ 䨪p ⪠ +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_p p ⪨ +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_p  ⨯ ⮢ +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_FORWARD p py $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_ $1 ᯮ $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_pp ᯮy $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_쭠 p ᯮy $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_祭 ࠬ $1 易 祬-, ᯮ +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_쭠 ६ $1 易 祬-, ᯮ +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_ ᨬ $1 $2 ᯮ +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Private $1.$2 ᯮ +sym_n_private_identifier_only_set=05030_N_Private $1.$2 易 祬-, ᯮ +sym_n_private_method_not_used=05031_N_Private ⮤ $1.$2 ᯮ + + +sym_e_set_expected=05032_E_ y⠭ ⨯ +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_y y樨 y⠭ +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_ $1 ४⭮ ஢ ⥪饩 C 몠 +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_H⭮ $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_쭠 p $1 樠p +sym_n_uninitialized_variable=05037_W_p $1 樠p +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_䨪p y뢠 $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_H p: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +sym_e_segment_too_large=05040_E_ ᫨誮 让 (. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} + + +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK pp襭 +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE pp襭 +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_p ᫨誮 ᫮ - p ⥪ FPU +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Hp쭮 p +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Hp쭮 楫᫥ p +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_H⢨⥫ ᯥ䨪p +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_p孨 p p. +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Hp ६-稪 +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_ ।, 'ॣ㦠' 㭪, ⮡ 맢 +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_p ᯨ᪠ pp pᨫ y⨬ p 65535 (64kb) +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Hp쭮 pp ⨯ +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_p y ORDINAL POINTER - ⢨ প +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_ ⨯ p묨 +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_ᯮ짮 FAR y⥫ p +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_Hp 맮 pp 뫪 +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_ᯮ짮 EXPORT p, y 뢠 +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_ p 맮 pyp pyp ( ᮮ⢥y ⥪y饬y ⥪y) +% No longer in use. +cg_n_inefficient_code=06017_N_H䥪⨢ +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_H⨦ +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_맮 p楤yp STACKFRAME ESP/SP +% The compiler encountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_p ⮤ y 뢠 py +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_yp 訡 getfloatreg(), pp p! +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_H ⨯ 饩 ⮩ +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() p +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_p cg68k p +% The \var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_ 32- ᫠ p MC680x0 p +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_yp 訡 secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_p $1 $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_ ⥪ 쭮 pp p +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_STACK FRAME y饭 +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_஢ઠ 64- ᥫ ন ⮩ ଥ +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_ ꥪ ᯮ짮 INLINE +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_ 맮 PROCVAR ᯮ짮 INLINE +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_H INLINE +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_אַ 맮 楤-뢠 $1 +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Hy p y, ᯮy ⮣ SETLENGTH LENGTH +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_祭 ᪫祭 p CASE +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_pyp pyp y 뢠 yp 'WITH' p +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_H 뢠 ⮤ p稪 ᮡ⨩ p⢥ +% A message method handler method can't be called directly if it contains an +% explicit self argument +cg_e_goto_inout_of_exception_block=06039_E_室 ஭ exception +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +cg_e_control_flow_outside_finally=06040_E_஫騥 ࠦ (break,continue exit) finally - ⨬ +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX + +# +# Assembler reader +# +asmr_d_start_reading=07000_D_H稭 $1 ⨫ ᥬp +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_ ⥭ $1 ⨫ ᥬp +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_-, ⪠, ᮤp @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_pp pp p +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_訡 p ᬥ饭 +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET ᯮy 䨪p +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE ᯮy 䨪p +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_H y ᯮ짮 p pp +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_ 室 ᯮ짮 OFFSET +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_ 室 ᯮ짮 ('$') +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_H y ᯮ짮 ⢥ p頥 ᨬ +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_p頥 ᨬ ⮫쪮 +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Hp쭮 p ⠭ +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_p頥 ᨬ pp襭 +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Hp ᨭ⠪ 뫪 +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_ $1 ⮣ +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_ ᨬ ⪨ ᯮ짮 뫪 +% ᯮ짮 ᨬ ⪨ 뫪 +asmr_e_wrong_base_index=07017_E_Hp ᯮ짮 pp +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_ 訡 ࠢ ꥪ +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Hp ⠡ 䠪p (?樥 ? :-&) +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_⢥ ᯮ짮 pp +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Hp ⨯ p +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Hp p, p p樨: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE @DATA p +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_y 뫪 ⮪ pp襭 +asmr_e_expr_zero_divide=07025_E_ ࠦ +asmr_e_expr_illegal=07026_E_୮ ࠦ +asmr_e_escape_seq_ignored=07027_E_Esc-᫥⥫쭮 ppy: $1 +asmr_e_invalid_symbol_ref=07028_E_Hp 뫪 ᨬ +asmr_w_fwait_emu_prob=07029_W_FWAIT 맢 p y樨 EMU387 +asmr_w_fadd_to_faddp=07030_W_FADD ࠭ ࠭᫨ FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER ন Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_맮 ppy y樨 ᥬp +asmr_e_unsupported_symbol_type=07033_E_H p ⨯ ᨬ p +asmr_e_constant_out_of_bounds=07034_E_ﭭ 祭 p +asmr_e_error_converting_decimal=07035_E_訡 p pp 筮 ᫠ $1 +asmr_e_error_converting_octal=07036_E_訡 p pp ᬥp筮 ᫠ $1 +asmr_e_error_converting_binary=07037_E_訡 p pp 筮 ᫠ $1 +asmr_e_error_converting_hexadecimal=07038_E_訡 p pp ⭠p筮 ᫠ $1 +asmr_h_direct_global_to_mangled=07039_H_$1 pp $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 易 ppy y樥 +asmr_e_cannot_use_SELF_outside_a_method=07041_E_H y ᯮ짮 SELF ⮤ +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_H y ᯮ짮 __OLDEBP p楤yp +asmr_e_void_function=07043_W_y p p ' p 祭' p +asmr_e_SEG_not_supported=07044_E_SEG p +asmr_e_size_suffix_and_dest_dont_match=07045_E_y䨪 pp p 室 pp ᮮ⢥y +asmr_w_size_suffix_and_dest_dont_match=07046_W_y䨪 pp p 室 pp ᮮ⢥y +asmr_e_syntax_error=07047_E_⠪᪠ 訡 ᥬ஢ +asmr_e_invalid_opcode_and_operand=07048_E_Hp p樨 p +asmr_e_syn_operand=07049_E_⠪᪠ 訡 p ᥬ஢ +asmr_e_syn_constant=07050_E_⠪᪠ 訡 ⠭ ᥬ஢ +asmr_e_invalid_string_expression=07051_E_Hp p p +asmr_w_const32bit_for_address=07052_-pp來 ⠭ ᮧ p +asmr_e_unknown_opcode=07053_E_ $1 +asmr_e_invalid_or_missing_opcode=07054_E_Hp py饭 +asmr_e_invalid_prefix_and_opcode=07055_E_Hp p䨪 : $1 +asmr_e_invalid_override_and_opcode=07056_E_Hp pp : $1 +asmr_e_too_many_operands=07057_E_誮 p p +asmr_w_near_ignored=07058_W_४⨢ NEAR pp +asmr_w_far_ignored=07059_W_४⨢ FAR pp +asmr_e_dup_local_sym=07060_E_p p 쭮 ᨬ $1 +asmr_e_unknown_local_sym=07061_E_H ᨬ $1 +asmr_e_unknown_label_identifier=07062_E_H⭠ ⪠ 䨪p $1 +asmr_e_invalid_register=07063_E_ࠢ쭮 ॣ +asmr_e_invalid_fpu_register=07064_E_Hp쭮 pp p樨 饩 ⮩ +asmr_e_nor_not_supported=07065_E_NOR p +asmr_w_modulo_not_supported=07066_W_MODULO p +asmr_e_invalid_float_const=07067_E_Hp ⠭ ( ): $1 +asmr_e_invalid_float_expr=07068_E_Hp p ( p) +asmr_e_wrong_sym_type=07069_E_Hp ⨯ ᨬ +asmr_e_cannot_index_relative_var=07070_E_H y p y py pp pp +asmr_e_invalid_seg_override=07071_E_Hp p pp ᥣ +asmr_w_id_supposed_external=07072_W_䨪p $1, p 譨 +asmr_e_string_not_allowed_as_const=07073_E_H ᯮ짮 p ⠭ +asmr_e_no_var_type_specified=07074_ p y +asmr_w_assembler_code_not_returned_to_text=07075_E_ᥬp᪨ p頥 TEXT ᥣ +asmr_e_not_directive_or_local_symbol=07076_E_$1 p⨢ ᨬ +asmr_w_using_defined_as_local=07077_E_ᯮ짮 p 쭠 ⪠ +asmr_e_dollar_without_identifier=07078_E_ '$' ᯮy 䨪p +asmr_w_32bit_const_for_address=07079_W_32-⭠ ⠭ ᮧ p +asmr_n_align_is_target_specific=07080_N_.ALIGN ᯮy ᯥ樠쭮 y p, ᯮy .BALIGN .P2ALIGN +asmr_e_cannot_access_field_directly_for_parameters=07081_E_H y pp py, ᯮy pp +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_H y ꥪ⮢/ᮢ py, ᯮy pp +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. + +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_誮 䠩 ᥬp +asmw_f_assembler_output_not_supported=08001_F_p ⨯ ᥬp p +asmw_f_comp_not_supported=08002_F_COMP p +asmw_f_direct_not_supported=08003_F_אַ ᥬp p +asmw_e_alloc_data_only_in_bss=08004_E_p ⮫쪮 BSS ᥪ樨 +asmw_f_no_binary_writer_selected=08005_F_ ࠭ ⨫ ᥬ஢ +asmw_e_opcode_not_in_table=08006_E_Asm: $1 ᯨ᪥ +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 p p +asmw_e_16bit_not_supported=08008_E_Asm: 16- 뫪 p +asmw_e_invalid_effective_address=08009_E_Asm: Hp 䥪⨢(?) p +asmw_e_immediate_or_reference_expected=08010_E_Asm: IMMEDIATE 뫪 +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 祭 諮 p $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: SHORT JUMP 襫 p $1 +asmw_e_undefined_label=08013_E_Asm: । ⪠ $1 + +# +# Executing linker/assembler +# +exec_w_source_os_redefined=09000_W_室 p樮 ⥬ pp +exec_i_assembling_pipe=09001_I_ᥬpy (pipe) $1 +exec_d_cant_create_asmfile=09002_E_H y ᮧ 䠩 ᬥp: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_ ᮧ ꥪ 䠩: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_ ᮧ 娢 䠩: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_ᥬp $1 , ᯮy 譨 ᥬp +exec_t_using_assembler=09006_T_ᯮy ᥬp: $1 +exec_w_error_while_assembling=09007_W_訡 p ᥬp $1 +exec_w_cant_call_assembler=09008_W_H y 맢 ᥬp, 訡 $1. ᯮy 譨 ᥬp +exec_i_assembling=09009_I_ᥬp $1 +exec_i_assembling_smart=09010_I_⥫y쭮 ᥬp $1 +exec_w_objfile_not_found=09011_W_ꥪ 䠩 $1 , y筮 ! +exec_w_libfile_not_found=09012_W_⥪ $1 , y筮 ! +exec_w_error_while_linking=09013_W_訡 p +exec_w_cant_call_linker=09014_W_H y 맢 騪, ᯮy 譨 騪 +exec_i_linking=09015_I_ $1 +exec_w_util_not_found=09016_W_⨫ $1 , p砥 y +exec_t_using_util=09017_T_ᯮ㥬 ⨫ $1 +exec_e_exe_not_supported=09018_E_ ᯮ塞 䠩 p +exec_e_dll_not_supported=09019_E_ ᪨ ⥪ (DLL) p +exec_i_closing_script=09020_I_p뢠 p $1 +exec_w_res_not_found=09021_W_p pypᮢ , p砥 譨 ᮢ +exec_i_compilingresource=09022_I_py pyp $1 + +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_H ᯮ ᯮ塞 y $1 +execinfo_f_cant_open_executable=09024_F_H y p ᯮ塞 y $1 +execinfo_x_codesize=09025_X_p : $1 +execinfo_x_initdatasize=09026_X_p 樠py饩 : $1 +execinfo_x_uninitdatasize=09027_X_p -樠py饩 : $1 +execinfo_x_stackreserve=09028_X_ppp ⥪: $1 +execinfo_x_stackcommit=09029_X_ᯮ짮 ⥪: $1 + +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_ y: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_PPU py $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU : $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU 䫠: $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU CRC: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU p: $1 +% When you use the \var{-vu} flag, the time the unit was compiled is shown. +unit_u_ppu_file_too_short=10006_U_PPU 䠩 ᫨誮 p⪨ +% The ppufile is too short, not all declarations are present. +unit_u_ppu_invalid_header=10007_U_Hp PPU ( PPU ⪨ 砫) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_Hp p PPU 䠩 $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU 䠩 ⪮p py pp +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU 䠩 ⪮p py OS +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU 筨: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_뢠 $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_H y PPU-䠩 +% An error occurred when writing the unit file. +unit_f_ppu_read_error=10014_F_⠥ PPU-䠩 +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_read_unexpected_end=10015_F_ y PPU-䠩 +% Unexpected end of file. +unit_f_ppu_invalid_entry=10016_F_Hp 室 PPU-䠩: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU DBX COUNT p +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Hp y: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_誮 y +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_py 뫪 y y $1 $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_H y ⪮p y $1. H y 室. +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_H y PPU 䠩 $1. +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_ $1 , $2 +unit_f_unit_name_error=10024_F_ $1 ᪠, 諨 $2 +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_py p ⥬ y. ᯮy -Us +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_py $1 訡 p p y, ⠭ +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_py $1 ($2) y $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_pp $1, p쭠 y y $2 +unit_u_recompile_source_found_alone=10029_U_pp $1, ⠪ ⮫쪮 室 +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_pp y, ⠪ ⥪ (static) p 祬 ppu-䠩 +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_pp y, ⠪ ⥪ (shared) p 祬 ppu-䠩 +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_pp y, ⠪ .as .obj 䠩 p 祬 ppu-䠩 +% When you use the \var{-vu} flag, the compiler warns if the assembler or +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_pp y, ⠪ .obj 䠩 p 祬 .as 䠩 +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_㥬 p䥩 $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_㥬 p樮 $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_p py y $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU pp 䠩 $1 p $2 + +# +# Options +# +option_usage=11000_$1 [樨] <䠩> [樨] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_p ⮫쪮 䠩 樨 +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_DEF 䠩 ᮧ ⮫쪮 OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_ 䠩 ⢥ p +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_F_ 䠩 樨 p 㦥 +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_ $1 䨣樮 䠩 㦥 +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Hp pp: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? 뢥 p +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_誮 䨣yp樮 䠩 +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_H y p 䠩 $1 +% The option file cannot be found. +option_reading_further_from=11010_N_⥭ 쭥 pp $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_TARGET y⠭ : $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_SHARED ⥪ p GO32* p, STATIC +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_誮 $IFDEF $IFNDEF +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_誮 $ENDIF +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_p⨥ y᫮ p 䠩 +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_p p樨 ⫠ p ⮬ ᯮ塞 䠩 +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_py ⪮p 樥 -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_E_ ᯮy yp訩 $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_E_ ᯮy yp訩 $1, y ᯮy $2 +% ।० , ᯮ , +% ন. ᯮ짮 ன ⮣. +% , , ⮡ ८ ஡ 饬, +% , y py 祭. +option_switch_bin_to_src_assembler=11020_N_p砥 ᥬp ᥬp y砭 +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_ ࠭ ⨫ ᥬ "$1" ᮢ⨬ "$2" +option_asm_forced=11022_W_ ᮦ, ᯮ㥬 ⨫ ᥬ "$1" +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +% + +# +# ( -l) +# +option_logo=11023_[ +Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET [Russian Edition] +Copyright (c) 1998-2000 by Florian Klaempfl +] + +# +# p ( -i) +# +option_info=11024_[ +Free Pascal Compiler version $FPCVER + +Compiler Date : $FPCDATE +Compiler Target: $FPCTARGET + +This program comes under the GNU General Public Licence +For more information read COPYING.FPC + +Report bugs, suggestions and etc to: + bugrep@freepascal.org, russia@freepascal.org +] + +# +# ࠭ ࠢ ( -? -h) +# +# : Hyp ! +# +option_help_pages=11025_[ +**0*_ '+', ⮡ , '-' ⮡ ⪫ +**1a_ y 㤠 ᣥ஢ ᥬ᪨ 䠩 +**2al_뢮 p ப ᥬp 䠩 +**2ar_뢮 p ᯨ᪥ /᢮ pp ᥬp᪨ 䠩 +**2at_뢮 p ᯨ᪥ /᢮ p p ᥬp᪨ 䠩 +**1b_pp p pyp +**2bl_pp p ᨬ +**1B_pp y +**1C_樨 pp +3*2CD_ᮧ y ⥪y +**2Ch_ y ( 1023 67107840) +**2Ci_pp -뢮 +**2Cn_ 䠩 +**2Co_pp ९ 楫᫥ +**2Cr_pp +**2Cs_y⠭ pp ⥪ +**2Ct_஢ઠ ⥪ +3*2CS_ᮧ y ⥪y +3*2Cx_ᯮ짮 ⥫yy y y +**1d_p ᨬ +*O1D_ᮧ DEF-䠩 +*O2Dd_y⠭ ᠭ +*O2Dw_PM ਫ +**1e_y⠭ y ᯮ塞 䠩 +**1E_⮦, -Cn +**1F_y⠭ 䠩 +**2FD_y⠭ y ⠫, ᪠ ⨫ +**2Fe_pp 뢮 訡 +**2FE_y⠭ y exe/unit 䠩 +**2Fi_ , y 砥 䠩 +**2Fl_ , y ⥪ +*L2FL_ᯮ짮 ᪨ 騪 +**2Fo_ y ꥪ 䠩 +**2Fr_py 䠩 ᮮ饭 訡 +**2Fu_ 㫥 +**2FU_y⠭ y y , ⬥ -FE +*g1g_ᮧ ଠ ⫠稪 +*g2gg_ᯮ짮 GSYM +*g2gd_ᯮ짮 DBX +*g2gh_ᯮ짮 y ᫥ 祩 +*g2gc_஢ ஢ન 㪠⥫ +**1i_p +**2iD_p頥 y p +**2iV_p頥 p +**2iSO_p頥 ⨯ OS, p ᮧ pp +**2iSP_p頥 ⨯ pp, p 뫠 ᮧ pp +**2iTO_p頥 ⨯ OS, p 뫠 ᮧ pp +**2iTP_p頥 ⨯ pp, p 뫠 ᮧ pp +**1I_ y 砥 䠩 +**1k_p室 騪y +**1l_뢠 ppy ⨯ +**1n_H 䠩 䨣樨 +**1o_ ணࠬ, +**1pg_p 䨫饣 GPROF +*L1P_ᯮ짮 ६ 䠩 ᥬ +**1S_ᨭ⠪᪨ 樨 +**2S2_ 祭 p pp Delphi 2 +**2Sc_p , 宦 pp C (*=,+=,/= -=) +**2sa_ ஫騩 +**2Sd_p Delphi-ᮢ⨬ +**2Se_p ⠭ ᫥ 訡 ( 㬮砭 ᫥ 1 訡) +**2Sg_p LABEL GOTO +**2Sh_ᯮ짮 ANSI p +**2Si_p ⨫ INLINE 몠 C++ +**2Sm_p ப C ( 쭮!) +**2So_p TP/BP 7.0 ᮢ⨬ +**2Sp_p GPC ᮢ⨬ +**2Ss_pyp init (pyp - done) +**2St_p ᪨ 祢 ᫮ ꥪ +**1s_ 뢠 ᥬ 騪 p p (⮫쪮 -a) +**1u_y p ᨬ +**1U_樨 y +**2Un_ pp ᮮ⢥⢨ y 䠩 y +**2Us_᪮p y (system) +**1v_p ᫥y ᨬ: +**2*_e : 訡 ( 㬮砭) d: ଠ ⫠ +**2*_w : ।० u: ଠ +**2*_n : ਬ砭 t: ஡/ᯮ짮 䠩 +**2*_h : ᪠ m: । ப +**2*_i : ଠ p: 㥬 楤 +**2*_l : Hp c: ᫮ ࠦ +**2*_a : 뢠 0: H祣 ᮮ, p 訡 +**2*_b : p楤ypy, r: Rhide/GCC ० ᮢ⨬ +**2*_ ᫨ 訡 p室 x: ଠ 䠩 (⮫쪮 Win32) +**2*_ +**1X_樨 믮 +*L2Xc_ ⥪ 몠 C +**2Xs_ ᨬ pp +**2XD_. . . (. FPC_LINK_DYNAMIC) +**2XS_. . . (. FPC_LINK_STATIC) +**2XX_. "⥫y쭮" (. FPC_LINK_SMART) +**0*_樨 ᯥ pp: +3*1A_ଠ 뢮 +3*2Aas_䠩, ᯮ騩 GNU +3*2Aasaout_䠩, ᯮ騩 GNU for aout (Go32v1) +3*2Anasmcoff_coff 䠩, ᯮ騩 Nasm +3*2Anasmelf_elf32 (linux) 䠩, ᯮ騩 Nasm +3*2Anasmobj_obj 䠩, ᯮ騩 Nasm +3*2Amasm_obj ᯮy騩 Masm (Microsoft) +3*2Atasm_obj ᯮy騩 Tasm (Borland) +3*2Acoff_coff (Go32v2) ᯮ ஥ ᥬ +3*2Apecoff_pecoff (Win32) ᯮ ஥ ᥬ +3*1R_⨫ ⥭ ᥬp +3*2Ratt_ ᥬ ⨫ AT&T +3*2Rintel_ ᥬ ⨫ Intel +3*2Rdirect_⥪ ᥬ p ।⢥ ᥬy +3*1O_⨯ ⨬権 +3*2Og_pp 訩 +3*2OG_pp p ( y砭) +3*2Or_p ६ ॣp ( 訡!) +3*2Ou_ । ⨬樨 (. 㬥) +3*2O1_yp 1 ⨬樨 ( ⨬樨) +3*2O2_yp 2 ⨬樨 (-O1 + ⨬樨) +3*2O3_yp 3 ⨬樨 ( ᠬ -O2u) +3*2Op_⨯ , p p室 : +3*3Op1_ 386/486 +3*3Op2_ Pentium/PentiumMMX +3*3Op3_ Pentium PRO/Pentium II/Cyrix 6X86/AMD K6 +3*1T_⨯ 樮 ⥬, p p室 : +3*2TGO32V1_version 1 (DJ Delorie ⥫ DOS) +3*2TGO32V2_version 2 (DJ Delorie ⥫ DOS) +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +3*1W_Win32 樨 +3*1WB_ ⠭ Image ⭠筮 祭 +3*1WC_ ।, 㤥 ᮫쭮 ਫ +3*1WD_ ᯮ짮 DEFFILE ᯮ஢ 㭪権 DLL EXE +3*1WG_ ।, 㤥 GUI ਫ +3*1WN_ ஢ ६頥 (室 ⫠) +3*1WR_ ஢ ६頥 +6*1A_ଠ ᥬp +6*2Ao_Unix o-䠩, ᯮ騩 GNU +6*2Agas_GNU ᥬ Motorola +6*2Amit_MIT ᨭ⠪ ( GAS) +6*2Amot_⠭p ᥬp Motorola +6*1O_⨬樨 +6*2Oa_ ⨬ +6*2Og_pp 訩 +6*2OG_pp p ( 㬮砭) +6*2Ox_ᨬ쭠 ⨬ ( 訡!) +6*2O2_ MC68020+ +6*1R_⨫ ⥭ ᥬp +6*2RMOT_ Motorola-ᥬp +6*1T_樮 ⥬ p py 䠩 +6*2TAMIGA_Commodore Commodore +6*2TATARI_Atari ST/STE/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_ y ࠢy +**1h_ y ࠢy, +] + +# +# The End +# diff --git a/befpc/compiler/errorrw.msg b/befpc/compiler/errorrw.msg new file mode 100644 index 0000000..39cef4d --- /dev/null +++ b/befpc/compiler/errorrw.msg @@ -0,0 +1,1855 @@ +# +# $Id: errorr2.msg 1.95 2000/07/06 11:41:24 Michail A.Baikov +# - Free Pascal Compiler +# Copyright (c) 1998-2000 by Free Pascal Development Team +# +# y Free Pascal Compiler +# +# . COPYING.FPC, y y, +# . +# +# p , y- +# , ! , +# ! +# +# +# - , y : +# __ +# +# , y , +# : +# asmr_ ( ) +# asmw_ ( ) +# unit_ +# scan_ +# parser_ +# type_ +# general_ +# exec_ , , +# +# , +# f_ +# e_ +# w_ +# n_ +# h_ +# i_ +# l_ p p +# u_ +# t_ p +# m_ +# p_ +# c_ +# d_ +# b_ "overload" (ppy pyp) +# x_ +# + +# +# +# +# BeginOfTeX +% \section{ } +% , , +% . +% p yp \var{-v} p. +% \begin {} +general_t_compilername=01000_T_p: $1 +% \var{-vt} , , , +% . +general_d_sourceos=01001_D_ OS: $1 +% \var{-vd} , , , +% , . +general_i_targetos=01002_I_ OS: $1 +% \var{-vd} , , , +% +general_t_exepath=01003_T_y y p : $1 +% \var{-vt} , , , +% p . +general_t_unitpath=01004_T_y : $1 +% \var{-vt} , , , +% . +% p \var{-Fu} \var{-Up} . +general_t_includepath=01005_T_y y : $1 +% \var{-vt} , , , +% (, \var{\{\$I xxx\}} +% p). p \var{-I} . +general_t_librarypath=01006_T_y y : $1 +% \var{-vt} , , , +% . p +% \var{-Fl} . +general_t_objectpath=01007_T_y y : $1 +% \var{-vt} , , , +% , (, +% \var{\{\$L xxx \}} p). +% p \var{-Fo} . +general_i_abslines_compiled=01008_I_$1 p, $2 . +% \var{-vi} , , +% p , , p . +% ( , py ). +general_f_no_memory_left=01009_F_H +% , . +% p p p: +% \begin{itemsize} +% \item , +% . +% \item , y y, , +% . +% \item y , y +% pp y ( \var{-Ch} , \seeo{Ch}) +% \end {itemsize} +% \end {} +general_i_writingresourcefile=01010_I_ -y p pyp: $1 +% This message is shown when the compiler writes the Resource String Table +% file containing all the resource strings for a program. +general_e_errorwritingresourcefile=01011_E_ p - p pyp: $1 +% This message is shown when the compiler encountered an error when writing +% the Resource String Table file +% \end{description} + + +# +# +# +% \section { .} +% , p . +% Free Pascal, py +% , , .. +% py pp p. +% \begin {} +scan_f_end_of_file=02000_F_H +% : +% \begin{itemsize} +% \item \var{end} p. +% , \var{begin} \var{end} p +% ( ); +% \item p. +% \item (yp ) +% \end{itemsize} +scan_f_string_exceeds_line=02001_F_H p +% , , ' p, p +% (p). +scan_f_illegal_char=02002_F_p +% p y . +scan_f_syn_expected=02003_F_py : $1 +% , pyy ( ) +% , . , +% . +scan_t_start_include_file=02004_T_H $1 +% \var{-vt} , , +% . +scan_w_comment_level=02005_W_H $1 yp p +% \var{-vw} , , +% . +% Turbo Pascal . +scan_n_far_directive_ignored=02006_N_$F (FAR) +% \var{FAR} 16- , +% p, , +% 32 . +scan_n_stack_check_global_under_linux=02007_N_Linux pp +% \var{-Cs} \linux, +% \linux . p , \var{-vn} . +scan_n_ignored_switch=02008_N_ppy $1 +% \var{-vn}, , +scan_w_illegal_switch=02009_W_H p $1 +% ( \var{\{\$... \}}) +% . +scan_w_switch_is_global=02010_W_ y +% \var{-vw} , , . +scan_e_illegal_char_const=02011_E_H +% , ASCII, +% \var{\#96}, , . +% - 1-255. +scan_f_cannot_open_input=02012_F_H y p $1 +% \fpc , +% . +scan_f_cannot_open_includefile=02013_F_H y p $1 +% \fpc , p \var{\{\$include \}} +% p. +scan_e_too_much_endifs=02014_E_ $ENDIF $ELSE p +% \var{\{\$IFDEF.. \}} {\{\$ENDIF} \}} p -. +scan_w_only_pack_records=02015_W_Record y 1,2,4 16 +% \var{\{\$PACKRECORDS n\} } +% \var{n}. 1,2,4 16 . +scan_w_only_pack_enum=02016_W_p y 1,2 4 +% \var{\{\$PACKENUM n \}} +% \var {n}. 1,2 4 . +scan_e_endif_expected=02017_E_$1 $2 $3 +% . +scan_e_preproc_syntax_error=02018_E_ p +% \var{\{\$if \}} . +scan_e_error_in_preproc_expr=02019_E_ p ppp +% \var{\{\$if \}} . +scan_w_macro_cut_after_255_chars=02020_W_ p p, p p 255 +% 255 . +% , +% . , +% \var{-vw} y. +scan_e_endif_without_if=02021_E_ENDIF IF{N}DEF +% \var{\{\$IFDEF.. \}} {\ {\$ENDIF \}} . +scan_f_user_defined=02022_F_ $1 +% p . . \progref +scan_e_user_defined=02023_E_ p $1 +% p . . \progref +scan_w_user_defined=02024_W_ p $1 +% p . . \progref +scan_n_user_defined=02025_N_ p $1 +% y . . \progref +scan_h_user_defined=02026_H_ p $1 +% y . . \progref +scan_i_user_defined=02027_I_ p $1 +% y . . \progref +scan_e_keyword_cant_be_a_macro=02028_E_ , +% . +scan_f_macro_buffer_overflow=02029_F_yp p +% p , . +scan_w_macro_deep_ten=02030_W_p yp ( 16). +% 16 yp . +% pp p, , +% y +scan_e_wrong_styled_switch=02031_E_p p (* *) p. +% \var{\{\ }} . +scan_d_handling_switch=02032_D_pp "$1" +% (\var{-vd}), +% , , . +scan_c_endif_found=02033_C_ENDIF $1 +% (\var{-vc}), +% . +scan_c_ifdef_found=02034_C_IFDEF $1 , $2 +% (\var{-vc}), , +% . +scan_c_ifopt_found=02035_C_IFOPT $1 , $2 +% (\var{-vc}), , +% . +scan_c_if_found=02036_C_IF $1 , $2 +% (\var{-vc}), , +% . +scan_c_ifndef_found=02037_C_IFNDEF $1 , $2 +% (\var {-vc}), , +% . +scan_c_else_found=02038_C_ELSE $1 , $2 +% (\var{-vc}), , +% . +scan_c_skipping_until=02039_C_py ... +% (\var{-vc}), +% , . +scan_i_press_enter=02040_I_H , +% y \var{-vi} , +% \var{enter} y, , +% p \var {\{\$STOP\}}. +scan_w_unsupported_switch=02041_W_Hp $1 +% pyp (\var{-vw}), +% . , +% Delphi Turbo Pascal, \fpc +scan_w_illegal_directive=02042_W_Hp $1 +% pyp (\var{-vw}), +% p. p, . \progref +scan_t_back_in=02043_T_p $1 +% (\var{-vt}) , , +% . +scan_w_unsupported_app_type=02044_W_Hp p: $1 +% , +% $APPTYPE +scan_w_app_type_not_support=02045_W_$APPTYPE p py +% $APPTYPE win32 . +scan_w_decription_not_support=02046_W_ DESCRIPTION p py +% \var{\{\$DESCRIPTION\}} OS/2 Win32. +scan_n_version_not_support=02047_N_ VERSION p py +% \var{\{\$VERSION\}} Win32 . +scan_n_only_exe_version=02048_N_ VERSION .EXE .DLL . +% \var{\{\$VERSION\}} .EXE .DLL . +scan_w_wrong_version_ignored=02049_W_ VERSION $1 +% The \var{\{\$VERSION\}} directive format is major_version.minor_version +% where major_version and minor_version are words. +scan_w_unsupported_asmmode_specifier=02050_W_Hp p $1 +% \var{\{\$ASMMODE xxx\}} +% , y. +% \end {} +scan_w_no_asm_reader_switch_inside_asm=02051_W_ p: yp py p, $1 y y p +% It is not possible to switch from one assembler reader to another +% inside an assmebler block. The new reader will be used for next +% assembler statement only. +scan_e_wrong_switch_toggle=02052_E_Hp p , ON/OFF +/- +% You need to use ON or OFF or a + or - to toggle the switch +scan_e_resourcefiles_not_supported=02053_E_ pyp p py +% The target you are compiling for doesn't support Resource files. The +% only target which can use resource files is Win32 +scan_w_include_env_not_found=02054_W_ p py $1 py +% The included environment variable can't be found in the environment, it'll +% be replaced by an empty string instead. +scan_e_invalid_maxfpureg_value=02055_E_ +% Valid values for this directive are 0..8 and NORMAL/DEFAULT +scan_w_only_one_resourcefile_supported=02056_W_ +% The target you are compiling for supports only one resource file. This is the +% case of OS/2 (EMX) currently. The first resource file found is used, the +% others are discarded. +% \end{description} + +# +# +# +% \section { } +% . +% , +% , . +% \begin {} +parser_e_syntax_error=03000_E_ () +% An error against the Turbo Pascal language was encountered. This happens +% typically when an illegal character is found in the sources file. +parser_w_proc_far_ignored=03001_W_pyp FAR - ppy +% This is a warning. \var{FAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_near_ignored=03002_W_pyp NEAR - ppy +% This is a warning. \var{NEAR} is a construct for 8 or 16 bit programs. Since +% the compile generates 32 bit programs, it ignores this directive. +parser_w_proc_interrupt_ignored=03003_W_ INTERRUPT i386 +% This is a warning. \var{INTERRUPT} is a i386 specific construct +% and is ignored for other processors. +parser_e_dont_nest_interrupt=03004_E_INTERRUPT +% An \VAR{INTERRUPT} procedure must be global. +parser_w_proc_directive_ignored=03005_W_ $1 +% This is a warning. \var{REGISTER},\var{REINTRODUCE} is ignored by FPC programs for now. +% This is introduced first for Delphi compatibility. +parser_e_no_overload_for_all_procs=03006_E_ $1 OVERLOAD +% When you want to use overloading using the \var{OVERLOAD} directive, then +% all declarations need to have \var{OVERLOAD} specified. +parser_e_no_dll_file_specified=03007_E_DLL- y +% No longer in use. +parser_e_export_name_double=03008_E_ y ppy $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_ordinal_double=03009_E_ y ppy $1 +% Exported function names inside a specific DLL must all be different +parser_e_export_invalid_index=03010_E_Hp y ppy y +% DLL function index must be in the range \var{1..\$FFFF} +parser_w_parser_reloc_no_debug=03011_W_ DLL/EXE $1 , . +parser_w_parser_win32_debug_needs_WN=03012_W_ Win32-, -WN +% Stabs info is wrong for relocatable DLL or EXES use -WN +% if you want to debug win32 executables. +parser_e_constructorname_must_be_init=03013_E_pyp INIT +% You are declaring a constructor with a name which isn't \var{init}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_destructorname_must_be_done=03014_E_pyp DONE +% You are declaring a constructor with a name which isn't \var{done}, and the +% \var{-Ss} switch is in effect. See the \var{-Ss} switch (\seeo{Ss}). +parser_e_illegal_open_parameter=03015_E_Hp p 'p pp' +% You are trying to use the wrong type for an open parameter. +parser_e_proc_inline_not_supported=03016_E_pyp INLINE p +% You tried to compile a program with C++ style inlining, and forgot to +% specify the \var{-Si} option (\seeo{Si}). The compiler doesn't support C++ +% styled inlining by default. +parser_w_priv_meth_not_virtual=03017_W_Private y py +% You declared a method in the private part of a object (class) as +% \var{virtual}. This is not allowed. Private methods cannot be overridden +% anyway. +parser_w_constructor_should_be_public=03018_W_pyp public +% Constructors must be in the 'public' part of an object (class) declaration. +parser_w_destructor_should_be_public=03019_W_pyp public +% Destructors must be in the 'public' part of an object (class) declaration. +parser_n_only_one_destructor=03020_N_ pyp +% You can declare only one destructor for a class. +parser_e_no_local_objects=03021_E_p p +% Classes must be defined globally. They cannot be defined inside a +% procedure or function +parser_f_no_anonym_objects=03022_F_p p +% An invalid object (class) declaration was encountered, i.e. an +% object or class without methods that isn't derived from another object or +% class. For example: +% \begin{verbatim} +% Type o = object +% a : longint; +% end; +% \end{verbatim} +% will trigger this error. +parser_object_has_no_vmt=03023_E_ $1 VMT +parser_e_illegal_parameter_list=03024_E_Hp pp +% You are calling a function with parameters that are of a different type than +% the declared parameters of the function. +parser_e_wrong_parameter_type=03025_E_Hp p pp py $1 +% There is an error in the parameter list of the function or procedure. +% The compiler cannot determine the error more accurate than this. +parser_e_wrong_parameter_size=03026_E_Hp p pp +% There is an error in the parameter list of the function or procedure, +% the number of parameters is not correct. +parser_e_overloaded_no_procedure=03027_E_ p $1 y +% The compiler encountered a symbol with the same name as an overloaded +% function, but it isn't a function it can overload. +parser_e_overloaded_have_same_parameters=03028_E_ y - pp +% You're declaring overloaded functions, but with the same parameter list. +% Overloaded function must have at least 1 different parameter in their +% declaration. +parser_e_header_dont_match_forward=03029_E_ y y pyy p forward $1 +% You declared a function with same parameters but +% different result type or function modifiers. +parser_e_header_different_var_names=03030_E_ y $1 y pyy p forward : p $2 => $3 +% You declared the function in the \var{interface} part, or with the +% \var{forward} directive, but define it with a different parameter list. +parser_n_duplicate_enum=03031_N_ +% \fpc allows enumeration constructions as in C. Given the following +% declaration two declarations: +% \begin{verbatim} +% type a = (A_A,A_B,A_E:=6,A_UAS:=200); +% type a = (A_A,A_B,A_E:=6,A_UAS:=4); +% \end{verbatim} +% The second declaration would produce an error. \var{A\_UAS} needs to have a +% value higher than \var{A\_E}, i.e. at least 7. +parser_n_interface_name_diff_implementation_name=03032_N_Interface Implementation p $1 => $2 +% This note warns you if the implementation and interface names of a +% functions are different, but they have the same mangled name. This +% is important when using overloaded functions (but should produce no error). +parser_e_no_with_for_variable_in_other_segments=03033_E_With p p p +% With stores a variable locally on the stack, +% but this is not possible if the variable belongs to another segment. +parser_e_too_much_lexlevel=03034_E_ y ( 31) +% You can nest function definitions only 31 times. +parser_e_range_check_error=03035_E_ y p p +% The constants are out of their allowed range. +parser_w_range_check_error=03036_W_ y p p +% The constants are out of their allowed range. +parser_e_double_caselabel=03037_E_p CASE +% You are specifying the same label 2 times in a \var{case} statement. +parser_e_case_lower_less_than_upper_bound=03038_E_p p +% The upper bound of a \var{case} label is less than the lower bound and this +% is useless +parser_e_type_const_not_possible=03039_E_p p +% You cannot declare a constant of type class or object. +parser_e_no_overloaded_procvars=03040_E_ p +% You are trying to assign an overloaded function to a procedural variable. +% This isn't allowed. +parser_e_invalid_string_size=03041_E_ p 1 .. 255 +% The length of a string in Pascal is limited to 255 characters. You are +% trying to declare a string with length lower than 1 or greater than 255 +% (This is not true for \var{Longstrings} and \var{AnsiStrings}. +parser_w_use_extended_syntax_for_objects=03042_W_ pp NEW DISPOSE +% If you have a pointer \var{a} to a class type, then the statement +% \var{new(a)} will not initialize the class (i.e. the constructor isn't +% called), although space will be allocated. you should issue the +% \var{new(a,init)} statement. This will allocate space, and call the +% constructor of the class. +parser_w_no_new_dispose_on_void_pointers=03043_W_ NEW DISPOSE p y, +parser_e_no_new_dispose_on_void_pointers=03044_E_ NEW DISPOSE p y, p +% You cannot use \var{new(p)} or \var{dispose(p)} if \var{p} is an untyped pointer +% because no size is associated to an untyped pointer. +% Accepted for compatibility in \var{tp} and \var{delphi} modes. +parser_e_class_id_expected=03045_E_ p +% This happens when the compiler scans a procedure declaration that contains +% a dot, +% i.e., a object or class method, but the type in front of the dot is not +% a known type. +parser_e_no_type_not_allowed_here=03046_E_p y +% You cannot use a type inside an expression. +parser_e_methode_id_expected=03047_E_ p +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_e_header_dont_match_any_member=03048_E_ y p +% This identifier is not a method. +% This happens when the compiler scans a procedure declaration that contains +% a dot, i.e., a object or class method, but the procedure name is not a +% procedure of this type. +parser_p_procedure_start=03049_P_pyp/y $1 +% When using the \var{-vp} switch, the compiler tells you when it starts +% processing a procedure or function implementation. +parser_e_error_in_real=03050_E_Hp +% The compiler expects a floating point expression, and gets something else. +parser_e_fail_only_in_constructor=03051_E_FAIL pyp +% You are using the \var{FAIL} instruction outside a constructor method. +parser_e_no_paras_for_destructor=03052_E_pyp y pp +% You are declaring a destructor with a parameter list. Destructor methods +% cannot have parameters. +parser_e_only_class_methods_via_class_ref=03053_E_ +% This error occurs in a situation like the following: +% \begin{verbatim} +% Type : +% Tclass = Class of Tobject; +% +% Var C : TClass; +% +% begin +% ... +% C.free +% \end{verbatim} +% \var{Free} is not a class method and hence cannot be called with a class +% reference. +parser_e_only_class_methods=03054_E_ +% This is related to the previous error. You cannot call a method of an object +% from a inside a class method. The following code would produce this error: +% \begin{verbatim} +% class procedure tobject.x; +% +% begin +% free +% \end{verbatim} +% Because free is a normal method of a class it cannot be called from a class +% method. +parser_e_case_mismatch=03055_E_ p CASE +% One of the labels is not of the same type as the case variable. +parser_e_illegal_symbol_exported=03056_E_ +% You can only export procedures and functions when you write a library. You +% cannot export variables or constants. +parser_w_should_use_override=03057_W_ p $1 +% A method that is declared \var{virtual} in a parent class, should be +% overridden in the descendent class with the \var{override} directive. If you +% don't specify the \var{override} directive, you will hide the parent method; +% you will not override it. +parser_e_nothing_to_be_overridden=03058_E_ , pp: $1 +% You try to \var{override} a virtual method of a parent class that doesn't +% exist. +parser_e_no_procedure_to_access_property=03059_E_ +% You specified no \var{read} directive for a property. +parser_w_stored_not_implemented=03060_W_ , p +% The \var{stored} directive is not yet implemented +parser_e_ill_property_access_sym=03061_E_Hp y +% There is an error in the \var{read} or \var{write} directives for an array +% property. When you declare an array property, you can only access it with +% procedures and functions. The following code woud cause such an error. +% \begin{verbatim} +% tmyobject = class +% i : integer; +% property x [i : integer]: integer read I write i; +% \end{verbatim} +% +parser_e_cant_access_protected_member=03062_E_H protected +% Fields that are declared in a \var{protected} section of an object or class +% declaration cannot be accessed outside the module wher the object is +% defined, or outside descendent object methods. +parser_e_cant_access_private_member=03063_E_H private +% Fields that are declared in a \var{private} section of an object or class +% declaration cannot be accessed outside the module where the class is +% defined. +parser_w_overloaded_are_not_both_virtual=03064_W_ py , py: $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_w_overloaded_are_not_both_non_virtual=03065_W_ H H : $1 +% If you declare overloaded methods in a class, then they should either all be +% virtual, or none. You shouldn't mix them. +parser_e_overloaded_methodes_not_same_ret=03066_E_ , , py: $1 +% If you declare virtual overloaded methods in a class definition, they must +% have the same return type. +parser_e_dont_nest_export=03067_E_EXPORT y y +% You cannot declare a function or procedure within a function or procedure +% that was declared as an export procedure. +parser_e_methods_dont_be_export=03068_E_ y pp +% You cannot declare a procedure that is a method for an object as +% \var{export}ed. That is, your methods cannot be called from a C program. +parser_e_call_by_ref_without_typeconv=03069_E_ +% When calling a function declared with \var{var} parameters, the variables in +% the function call must be of exactly the same type. There is no automatic +% type conversion. +parser_e_no_super_class=03070_E_ +% When calling inherited methods, you are trying to call a method of a strange +% class. You can only call an inherited method of a parent class. +parser_e_self_not_in_method=03071_E_SELF pp +% You are trying to use the \var{self} parameter outside an object's method. +% Only methods get passed the \var{self} parameters. +parser_e_generic_methods_only_in_methods=03072_E_ y py py p +% A construction like \var{sometype.somemethod} is only allowed in a method. +parser_e_illegal_colon_qualifier=03073_E_Hp ':' +% You are using the format \var{:} (colon) 2 times on an expression that +% is not a real expression. +parser_e_illegal_set_expr=03074_E_ +% The declaration of a set contains an error. Either one of the elements is +% outside the range of the set type, either two of the elements are in fact +% the same. +parser_e_pointer_to_class_expected=03075_E_ y +% You specified an illegal type in a \var{New} statement. +% The extended synax of \var{New} needs an object as a parameter. +parser_e_expr_have_to_be_constructor_call=03076_E_p pyp +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the object you are trying to create. The procedure you specified +% is not a constructor. +parser_e_expr_have_to_be_destructor_call=03077_E_p pyp +% When using the extended syntax of \var{dispose}, you must specify the +% destructor method of the object you are trying to dispose of. +% The procedure you specified is not a destructor. +parser_e_invalid_record_const=03078_E_Hp p RECORD +% When declaring a constant record, you specified the fields in the wrong +% order. +parser_e_false_with_expr=03079_E_ p CLASS RECORD +% A \var{with} statement needs an argument that is of the type \var{record} +% or \var{class}. You are using \var{with} on an expression that is not of +% this type. +parser_e_void_function=03080_E_pyp y p +% In \fpc, you can specify a return value for a function when using +% the \var{exit} statement. This error occurs when you try to do this with a +% procedure. Procedures cannot return a value. +parser_e_constructors_always_objects=03081_E_pyp pyp +% You're declaring a procedure as destructor or constructor, when the +% procedure isn't a class method. +parser_e_operator_not_overloaded=03082_E_pp ppy +% You're trying to use an overloaded operator when it isn't overloaded for +% this type. +parser_e_no_such_assignment=03083_E_ +% You can not overload assignment for types +% that the compiler considers as equal. +parser_e_overload_impossible=03084_E_ +% The combination of operator, arguments and return type are +% incompatible. +parser_e_no_reraise_possible=03085_E_RERAISE +% You are trying to raise an exception where it isn't allowed. You can only +% raise exceptions in an \var{except} block. +parser_e_no_new_or_dispose_for_classes=03086_E_p NEW DISPOSE y +% You cannot generate an instance of a class with the extended syntax of +% \var{new}. The constructor must be used for that. For the same reason, you +% cannot call \var{Dispose} to de-allocate an instance of a class, the +% destructor must be used for that. +parser_e_asm_incomp_with_function_return=03087_E_p , p p y +% You're trying to implement a \var{assembler} function, but the return type +% of the function doesn't allow that. +parser_e_procedure_overloading_is_off=03088_E_pyp +% When using the \var{-So} switch, procedure overloading is switched off. +% Turbo Pascal does not support function overloading. +parser_e_overload_operator_failed=03089_E_ +% You are trying to overload an operator which cannot be overloaded. +% The following operators can be overloaded : +% \begin{verbatim} +% +, -, *, /, =, >, <, <=, >=, is, as, in, **, := +% \end{verbatim} +parser_e_comparative_operator_return_boolean=03090_E_ +% When overloading the \var{=} operator, the function must return a boolean +% value. +parser_e_only_virtual_methods_abstract=03091_E_ +% You are declaring a method as abstract, when it isn't declared to be +% virtual. +parser_f_unsupported_feature=03092_F_ +% You're trying to force the compiler into doing something it cannot do yet. +parser_e_mix_of_classes_and_objects=03093_E_ +% You cannot derive \var{objects} and \var{classes} intertwined . That is, +% a class cannot have an object as parent and vice versa. +parser_w_unknown_proc_directive_ignored=03094_W_ , $1 y +% The procedure direcive you secified is unknown. Recognised procedure +% directives are \var{cdecl}, \var{stdcall}, \var{popstack}, \var{pascal} +% \var{register}, \var{export}. +parser_e_absolute_only_one_var=03095_E_ABSOLUTE H p +% You cannot specify more than one variable before the \var{absolute} directive. +% Thus, the following construct will provide this error: +% \begin{verbatim} +% Var Z : Longint; +% X,Y : Longint absolute Z; +% \end{verbatim} +% \item [ absolute can only be associated a var or const ] +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_absolute_only_to_var_or_const=03096_E_ABSOLUTE p +% The address of a \var{absolute} directive can only point to a variable or +% constant. Therefore, the following code will produce this error: +% \begin{verbatim} +% Procedure X; +% +% var p : longint absolute x; +% \end{verbatim} +% +parser_e_initialized_only_one_var=03097_E_ H p p +% You cannot specify more than one variable with a initial value +% in Delphi syntax. +parser_e_abstract_no_definition=03098_E_ ( ) +% Abstract methods can only be declared, you cannot implement them. They +% should be overridden by a descendant class. +parser_e_overloaded_must_be_all_global=03099_E_ , +% You are defining a overloaded function in the implementation part of a unit, +% but there is no corresponding declaration in the interface part of the unit. +parser_w_virtual_without_constructor=03100_W_ $1 +% If you declare objects or classes that contain virtual methods, you need +% to have a constructor and destructor to initialize them. The compiler +% encountered an object or class with virtual methods that doesn't have +% a constructor/destructor pair. +parser_m_macro_defined=03101_M_p p: $1 +% When \var{-vm} is used, the compiler tells you when it defines macros. +parser_m_macro_undefined=03102_M_p p: $1 +% When \var{-vm} is used, the compiler tells you when it undefines macros. +parser_m_macro_set_to=03103_M_p $1 y $2 +% When \var{-vm} is used, the compiler tells you what values macros get. +parser_i_compiling=03104_I_p $1 +% When you turn on information messages (\var{-vi}), the compiler tells you +% what units it is recompiling. +parser_u_parsing_interface=03105_U_ y $1 +% This tells you that the reading of the interface +% of the current unit starts +parser_u_parsing_implementation=03106_U_ y $1 +% This tells you that the code reading of the implementation +% of the current unit, library or program starts +parser_d_compiling_second_time=03107_D_ $1 +% When you request debug messages (\var{-vd}) the compiler tells you what +% units it recompiles for the second time. +parser_e_no_paras_allowed=03108_E_ p +% You cannot use array properties at that point in the source. +parser_e_no_property_found_to_override=03109_E_H pp +% You want to overrride a property of a parent class, when there is, in fact, +% no such property in the parent class. +parser_e_only_one_default_property=03110_E_ - pp, y, y, $1 +% You specified a property as \var{Default}, but a parent class already has a +% default property, and a class can have only one default property. +parser_e_property_need_paras=03111_E_ - +% Only array properties of classes can be made \var{default} properties. +parser_e_constructor_cannot_be_not_virtual=03112_E_py pyp p +% You cannot have virtual constructors in objects. You can only have them +% in classes. +parser_e_no_default_property_available=03113_E_H +% You try to access a default property of a class, but this class (or one of +% it's ancestors) doesn't have a default property. +parser_e_cant_have_published=03114_E_ PUBLISHED , y {$M+} +% If you want a \var{published} section in a class definition, you must +% use the \var{\{\$M+\}} switch, whch turns on generation of type +% information. +parser_e_forward_declaration_must_be_resolved=03115_E_FORWARD p $1 , +% To be able to use an object as an ancestor object, it must be defined +% first. This error occurs in the following situation: +% \begin{verbatim} +% Type ParentClas = Class; +% ChildClass = Class(ParentClass) +% ... +% end; +% \end{verbatim} +% Where \var{ParentClass} is declared but not defined. +parser_e_no_local_operator=03116_E_ pp p +% You cannot overload locally, i.e. inside procedures or function +% definitions. +parser_e_proc_dir_not_allowed_in_interface=03117_E_pyp p $1 pp +% This procedure directive is not allowed in the \var{interface} section of + +% a unit. You can only use it in the \var{implementation} section. +parser_e_proc_dir_not_allowed_in_implementation=03118_E_pyp p $1 pp +% This procedure directive is not defined in the \var{implementation} section of +% a unit. You can only use it in the \var{interface} section. +parser_e_proc_dir_not_allowed_in_procvar=03119_E_pyp p $1 pp PROCVAR p +% This procedure directive cannot be part of a procedural or function +% type declaration. +parser_e_function_already_declared_public_forward=03120_E_ $1 PUBLIC FORWARD +% You will get this error if a function is defined as \var{forward} twice. +% Or it is once in the \var{interface} section, and once as a \var{forward} +% declaration in the \var{implmentation} section. +parser_e_not_external_and_export=03121_E_H EXPORT EXTERNAL +% These two procedure directives are mutually exclusive +parser_e_name_keyword_expected=03122_E_ NAME +% The definition of an external variable needs a \var{name} clause. +parser_w_not_supported_for_inline=03123_W_$1 p yp INLINE pyp/y +% Inline procedures don't support this declaration. +parser_w_inlining_disabled=03124_W_ INLINE +% Inlining of procedures is disabled. +parser_i_writing_browser_log=03125_I_ pyp $1 +% When information messages are on, the compiler warns you when it +% writes the browser log (generated with the \var{\{\$Y+ \}} switch). +parser_h_maybe_deref_caret_missing=03126_H_ yy p y +% The compiler thinks that a pointer may need a dereference. +parser_f_assembler_reader_not_supported=03127_F_p p p +% The selected assembler reader (with \var{\{\$ASMMODE xxx\}} is not + +% supported. The compiler can be compiled with or without support for a +% particular assembler reader. +parser_e_proc_dir_conflict=03128_E_pyp p $1 y py p +% You specified a procedure directive that conflicts with other directives. +% for instance \var{cdecl} and \var{pascal} are mutually exclusive. +parser_e_call_convention_dont_match_forward=03129_E_ pyp/y yy FORWARD +% This error happens when you declare a function or procedure with +% e.g. \var{cdecl;} but omit this directive in the implementation, or vice +% versa. The calling convention is part of the function declaration, and +% must be repeated in the function definition. +parser_e_register_calling_not_supported=03130_E_ pp ("FAST CALL") p +% The \var{register} calling convention, i.e., arguments are passed in +% registers instead of on the stack is not supported. Arguments are always +% passed on the stack. +parser_e_property_cant_have_a_default_value=03131_E_ y +% Set properties or indexed properties cannot have a default value. +parser_e_property_default_value_must_const=03132_E_ y y +% The value of a \var{default} declared property must be known at compile +% time. The value you specified is only known at run time. This happens +% .e.g. if you specify a variable name as a default value. +parser_e_cant_publish_that=03133_E_ PUBLISHED, +% Only class type variables can be in a \var{published} section of a class +% if they are not declared as a property. +parser_e_cant_publish_that_property=03134_E_ PUBLISHED +% Properties in a \var{published} section cannot be array properties. +% they must be moved to public sections. Properties in a \var{published} +% section must be an ordinal type, a real type, strings or sets. +parser_w_empty_import_name=03135_W_ y +% Both index and name for the import are 0 or empty +parser_e_empty_import_name=03136_W_ +% Some targets need a name for the imported procedure or a cdecl specifier +parser_e_used_proc_name_changed=03137_E_ , +% This is an internal error; please report any occurrences of this error +% to the \fpc team. +parser_e_division_by_zero=03138_E_ +% There is a divsion by zero encounted +parser_e_invalid_float_operation=03139_E_Hp p +% An operation on two real type values produced an overflow or a division +% by zero. +parser_e_array_lower_less_than_upper_bound=03140_E_p p , p +% The upper bound of a \var{case} label is less than the lower bound and this +% is not possible +parser_w_string_too_long=03141_W_ "$1" $2 +% The size of the constant string is larger than the size you specified in +% string type definition +parser_e_string_larger_array=03142_E_ , +% The size of the constant string is larger than the size you specified in +% the array[x..y] of char definition +parser_e_ill_msg_expr=03143_E_Hp p p +% \fpc supports only integer or string values as message constants +parser_e_ill_msg_param=03144_E_p y p p pp +% A method declared with the \var{message}-directive as message handler +% can take only one parameter which must be declared as call by reference +% Parameters are declared as call by reference using the \var{var}-directive +parser_e_duplicate_message_label=03145_E_p p : $1 +% A label for a message is used twice in one object/class +parser_e_self_in_non_message_handler=03146_E_SELF +% The self parameter can be passed only explicitly in a method which +% is declared as message method handler. +parser_e_threadvars_only_sg=03147_E_p p y +% Threadvars must be static or global, you can't declare a thread +% local to a procedure. Local variables are always local to a thread, +% because every thread has it's own stack and local variables +% are stored on the stack +parser_f_direct_assembler_not_allowed=03148_F_ p p p +% You can't use direct assembler when using a binary writer, choose an +% other outputformat or use an other assembler reader +parser_w_no_objpas_use_mode=03149_W_H py OBJPAS y, y {$mode objfpc} {$mode delphi} +% You're trying to load the ObjPas unit manual from a uses clause. This is +% not a good idea to do, you can better use the \var{\{\$mode objfpc\}} or +% \var{\{\$mode delphi\}} +% directives which load the unit automaticly +parser_e_no_object_override=03150_E_pp +% Override isn't support for objects, use VIRTUAL instead to override +% a method of an anchestor object +parser_e_cant_use_inittable_here=03151_E_ , p py INITILIZATION/FINALIZATION p +% Some data type (e.g. \var{ansistring}) needs initialization/finalization +% code which is implicitly generated by the compiler. Such data types +% can't be used in the variant part of a record. +parser_e_resourcestring_only_sg=03152_E_ +% Resourcestring can not be declared local, only global or using the static +% directive. +parser_e_exit_with_argument_not__possible=03153_E_ Exit +% an exit statement with an argument for the return value can't be used here, this +% can happen e.g. in \var{try..except} or \var{try..finally} blocks +parser_e_stored_property_must_be_boolean=03154_E_ boolean +% If you specify a storage symbol in a property declaration, it must be of +% the type boolean +parser_e_ill_property_storage_sym=03155_E_ p +% You can't use this type of symbol as storage specifier in property +% declaration. You can use only methods with the result type boolean, +% boolean class fields or boolean constants +parser_e_only_publishable_classes_can__be_published=03156_E_ , p py $M+ p published +% In the published section of a class can be only class as fields used which +% are compiled in $M+ or which are derived from such a class. Normally +% such a class should be derived from TPersitent +parser_e_proc_directive_expected=03157_E_ pyp p +% When declaring a procedure in a const block you used a ; after the +% procedure declaration after which a procedure directive must follow. +% Correct declarations are: +% \begin{verbatim} +% const +% p : procedure;stdcall=nil; +% p : procedure stdcall=nil; +% \end{verbatim} +parser_e_invalid_property_index_value=03158_E_ +% The value you use to index a property must be of an ordinal type, for +% example an integer or enumerated type. +parser_e_procname_to_short_for_export=03159_E_ pyp p p +% The length of the procedure/function name must be at least 2 characters +% long. This is because of a bug in dlltool which doesn't parse the .def +% file correct with a name of length 1. +parser_e_dlltool_unit_var_problem=03160_E_ DEFFILE +parser_e_dlltool_unit_var_problem2=03161_E_ -WD +% \end{description} + +# +# pp +# +% \section{Type checking errors} +% This section lists all errors that can occur when type checking is +% performed. +% \begin{description} +type_e_mismatch=04000_E_Hp +% This can happen in many cases: +% \begin{itemize} +% \item The variable you're assigning to is of a different type than the +% expression in the assignment. +% \item You are calling a function or procedure with parameters that are +% incompatible with the parameters in the function or procedure definition. +% \end{itemize} +type_e_incompatible_types=04001_E_H : y $1, $2 +% There is no conversion possible between the two types +% Another possiblity is that they are declared in different +% declarations: +% \begin{verbatim} +% Var +% A1 : Array[1..10] Of Integer; +% A2 : Array[1..10] Of Integer; +% +% Begin +% A1:=A2; { This statement gives also this error, it +% is due the strict type checking of pascal } +% End. +% \end{verbatim} +type_e_not_equal_types=04002_E_H y $1 $2 +% The types are not equal +type_e_type_id_expected=04003_E_ TYPE +% The identifier is not a type, or you forgot to supply a type identifier. +type_e_variable_id_expected=04004_E_ VAR +% This happens when you pass a constant to a \var{Inc} var or \var{Dec} +% procedure. You can only pass variables as arguments to these functions. +type_e_integer_expr_expected=04005_E_ p INTEGER +% The compiler expects an expression of type integer, but gets a different +% type. +type_e_boolean_expr_expected=04006_E_ BOOLEAN, "$1" +% The expression must be a boolean type, it should be return true or +% false. +type_e_ordinal_expr_expected=04007_E_ p - +% The expression must be of ordinal type, i.e., maximum a \var{Longint}. +% This happens, for instance, when you specify a second argument +% to \var{Inc} or \var{Dec} that doesn't evaluate to an ordinal value. +type_e_pointer_type_expected=04008_E_ POINTER, "$1" +% The variable or expression isn't of the type \var{pointer}. This +% happens when you pass a variable that isn't a pointer to \var{New} +% or \var{Dispose}. +type_e_class_type_expected=04009_E_ CLASS, "$1" +% The variable of expression isn't of the type \var{class}. This happens +% typically when +% \begin{enumerate} +% \item The parent class in a class declaration isn't a class. +% \item An exception handler (\var{On}) contains a type identifier that +% isn't a class. +% \end{enumerate} +type_e_varid_or_typeid_expected=04010_E_ p p +% The argument to the \var{High} or \var{Low} function is not a variable +% nor a type identifier. +type_e_cant_eval_constant_expr=04011_E_H p +% No longer in use. +type_e_set_element_are_not_comp=04012_E_ +% You are trying to make an operation on two sets, when the set element types +% are not the same. The base type of a set must be the same when taking the +% union +type_e_set_operation_unknown=04013_E_p p p +% several binary operations are not defined for sets +% like div mod ** (also >= <= for now) +type_w_convert_real_2_comp=04014_W_ pp REAL COMP, p INTEGER +% An implicit type conversion from a real type to a \var{comp} is +% encountered. Since \var{Comp} is a 64 bit integer type, this may indicate +% an error. +type_h_use_div_for_int=04015_H_y DIV , y py +% When hints are on, then an integer division with the '/' operator will +% procuce this message, because the result will then be of type real +type_e_strict_var_string_violation=04016_E_p p - $V+ p +% When compiling in \var{\{\$V+\}} mode, the string you pass as a parameter +% should be of the exact same type as the declared parameter of the procedure. +type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_SUCC PRED p +% When you declared an enumeration type which has assignments in it, as in C, +% like in the following: +% \begin{verbatim} +% Tenum = (a,b,e:=5); +% \end{verbatim} +% you cannot use the \var{Succ} or \var{Pred} functions on them. +type_e_cant_read_write_type=04018_E_H p py +% You are trying to \var{read} or \var{write} a variable from or to a +% file of type text, which doesn't support that. Only integer types, +% booleans, reals, pchars and strings can be read from/written to a text file. +type_e_no_readln_writeln_for_typed_file=04019_E_ Readln Writeln +% \var{readln} and \var{writeln} are only allowed for text files. +type_e_no_read_write_for_untyped_file=04020_E_ Read Write +% \var{read} and \var{write} are only allowed for text or typed files. +type_e_typeconflict_in_set=04021_E_ y p +% There is at least one set element which is of the wrong type, i.e. not of +% the set type. +type_w_maybe_wrong_hi_lo=04022_W_LO/HI (LONGINT/DWORD) p p/ +% \fpc supports an overloaded version of \var{lo/hi} for \var{longint/dword/int64/qword} +% which returns the lower/upper word/dword of the argument. TP always uses +% a 16 bit \var{lo/hi} which returns always bits 0..7 for \var{lo} and the +% bits 8..15 for \var{hi}. If you want the TP behavior you have +% to type cast the argument to \var{word/integer} +type_e_integer_or_real_expr_expected=04023_E_ p INTEGER REAL +% The first argument to \var{str} must a real or integer type. +type_e_wrong_type_in_array_constructor=04024_E_Hp pyp +% You are trying to use a type in an array constructor which is not +% allowed. +type_e_wrong_parameter_type=04025_E_H py +% You are trying to pass an invalid type for the specified parameter. +type_e_no_method_and_procedure_not_compatible=04026_E_ (p) pyp (p) +% You can't assign a method to a procedure variable or a procedure to a +% method pointer. +type_e_wrong_math_argument=04027_E_p , p yp y +% The constant argument passed to a ln or sqrt function is out of +% the definition range of these functions. +type_e_no_addr_of_constant=04028_E_H y y p +% It's not possible to get the address of a constant, because they +% aren't stored in memory, you can try making it a typed constant. +type_e_argument_cant_be_assigned=04029_E_ +% Only expressions which can be on the left side of an +% assignment can be passed as call by reference argument +% Remark: Properties can be only +% used on the left side of an assignment, but they can't be used as arguments +type_e_cannot_local_proc_to_procvar=04030_E_ / +% It's not allowed to assign a local procedure/function to a +% procedure variable, because the calling of local procedure/function is +% different. You can only assign local procedure/function to a void pointer. +type_e_no_assign_to_addr=04031_E_H y py +% It's not allowed to assign a value to an address of a variable,constant, +% procedure or function. You can try compiling with -So if the identifier +% is a procedure variable. +type_e_no_assign_to_const=04032_E_H y +% It's not allowed to assign a value to a variable which is declared +% as a const. This is normally a parameter declared as const, to allow +% changing make the parameter value or var. +% \end{description} + +# +# Symtable +# +% \section{Symbol handling} +% This section lists all the messages that concern the handling of symbols. +% This means all things that have to do with procedure and variable names. +% \begin{description} +sym_e_id_not_found=05000_E_p $1 +% The compiler doesn't know this symbol. Usually happens when you misspel +% the name of a variable or procedure, or when you forgot to declare a +% variable. +sym_f_internal_error_in_symtablestack=05001_F_yp SymTableStack() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_e_duplicate_id=05002_E_ p $1 +% The identifier was already declared in the current scope. +sym_h_duplicate_id_where=05003_H_p y p $1 (p $2) +% The identifier was already declared in a previous scope. +sym_e_unknown_id=05004_E_H p $1 +% The identifier encountered hasn't been declared, or is used outside the +% scope where it's defined. +sym_e_forward_not_resolved=05005_E_FORWARD $1 +% This can happen in two cases: +% \begin{itemize} +% \item This happens when you declare a function (in the \var{interface} part, or +% with a \var{forward} directive, but do not implement it. +% \item You reference a type which isn't declared in the current \var{type} +% block. +% \end{itemize} +sym_f_id_already_typed=05006_F_p y p +% You are trying to redefine a type. +sym_e_error_in_type_def=05007_E_ p +% There is an error in your definition of a new array type: +% \item One of the range delimiters in an array declaration is erroneous. +% For example, \var{Array [1..1.25]} will trigger this error. +sym_e_type_id_not_defined=05008_E_ p p +% The type identifier has not been defined yet. +sym_e_forward_type_not_resolved=05009_E_FORWARD $1 +% A symbol was forward defined, but no declaration was encountered. +sym_e_only_static_in_static=05010_E_ +% A static method of an object can only access static variables. +sym_e_invalid_call_tvarsymmangledname=05011_E_Hp tvarsym.mangledname() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +sym_f_type_must_be_rec_or_class=05012_F_ RECORD CLASS +% The variable or expression isn't of the type \var{record} or \var{class}. +sym_e_no_instance_of_abstract_object=05013_E_p p p +% You are trying to generate an instance of a class which has an abstract +% method that wasn't overridden. +sym_w_label_not_defined=05014_W_ p $1 +% A label was declared, but not defined. +sym_e_label_used_and_not_defined=05015_E_ $1 , +% A label was declared and used, but not defined. +sym_e_ill_label_decl=05016_E_Hp +% This error should never happen; it occurs if a label is defined outside a +% procedure or function. +sym_e_goto_and_label_not_supported=05017_E_GOTO LABEL p (y -Sg) +% You must compile a program which has \var{label}s and \var{goto} statements +% with the \var{-Sg} switch. By default, \var{label} and \var{goto} aren't +% supported. +sym_e_label_not_found=05018_E_ +% A \var{goto label} was encountered, but the label isn't declared. +sym_e_id_is_no_label_id=05019_E_ p +% The identifier specified after the \var{goto} isn't of type label. +sym_e_label_already_defined=05020_E_p p +% You are defining a label twice. You can define a label only once. +sym_e_ill_type_decl_set=05021_E_p +% The declaration of a set contains an invalid type definition. +sym_e_class_forward_not_resolved=05022_E_FORWARD p py $1 +% You declared a class, but you didn't implement it. +sym_n_unit_not_used=05023_H_ $1 $2 +% The unit referenced in the \var{uses} clause is not used. +sym_h_para_identifier_not_used=05024_H_pp y $1 +% This is a warning. The identifier was declared (locally or globally) but +% wasn't used (locally or globally). +sym_n_local_identifier_not_used=05025_N_ p y $1 +% You have declared, but not used a variable in a procedure or function +% implementation. +sym_h_para_identifier_only_set=05026_H_ $1 -, +% This is a warning. The identifier was declared (locally or globally) +% set but not used (locally or globally). +sym_n_local_identifier_only_set=05027_N_ $1 -, +% The variable in a procedure or function +% implementation is declared, set but never used. +sym_h_local_symbol_not_used=05028_H_ $1 $2 +% A local symbol is never used. +sym_n_private_identifier_not_used=05029_N_Private $1.$2 +sym_n_private_identifier_only_set=05030_N_Private $1.$2 -, +sym_n_private_method_not_used=05031_N_Private $1.$2 + + +sym_e_set_expected=05032_E_ y +% The variable or expression isn't of type \var{set}. This happens in an +% \var{in} statement. +sym_w_function_result_not_set=05033_W_y y y +% You can get this warning if the compiler thinks that a function return +% value is not set. This will not be displayed for assembler procedures, +% or procedures that contain assembler blocks. +sym_w_wrong_C_pack=05034_W_ $1 C +% Arrays with sizes not multiples of 4 will be wrongly aligned +% for C structures. +sym_e_illegal_field=05035_E_H $1 +% The field doesn't exist in the record definition. +sym_n_uninitialized_local_variable=05036_W_ p $1 p +sym_n_uninitialized_variable=05037_W_p $1 p +% These messages are displayed if the compiler thinks that a variable will +% be used (i.e. appears in the right-hand-side of an expression) when it +% wasn't initialized first (i.e. appeared in the left-hand side of an +% assigment) +sym_e_id_no_member=05038_E_p y $1 +% When using the extended syntax of \var{new}, you must specify the constructor +% method of the class you are trying to create. The procedure you specified +% does not exist. +sym_b_param_list=05039_B_H p: $1 +% You get this when you use the \var{-vb} switch. In case an overloaded +% procedure is not found, then all candidate overloaded procedures are +% listed, with their parameter lists. +sym_e_segment_too_large=05040_E_ (. 2GB) +% You get this when you declare an array whose size exceeds the 2GB limit. +% \end{description} + + +# +# Codegenerator +# +% \section{Code generator messages} +% This section lists all messages that can be displayed if the code +% generator encounters an error condition. +% \begin{description} +cg_e_break_not_allowed=06000_E_BREAK pp +% You're trying to use \var{break} outside a loop construction. +cg_e_continue_not_allowed=06001_E_CONTINUE pp +% You're trying to use \var{continue} outside a loop construction. +cg_e_too_complex_expr=06002_E_p - p FPU +% Your expression is too long for the compiler. You should try dividing the +% construct over multiple assignments. +cg_e_illegal_expression=06003_E_Hp p +% This can occur under many circumstances. Mostly when trying to evaluate +% constant expressions. +cg_e_invalid_integer=06004_E_Hp p +% You made an expression which isn't an integer, and the compiler expects the +% result to be an integer. +cg_e_invalid_qualifier=06005_E_H p +% One of the following is happening : +% \begin{itemize} +% \item You're trying to access a field of a variable that is not a record. +% \item You're indexing a variable that is not an array. +% \item You're dereferencing a variable that is not a pointer. +% \end{itemize} +cg_e_upper_lower_than_lower=06006_E_p p p. +% You are declaring a subrange, and the lower limit is higher than the high +% limit of the range. +cg_e_illegal_count_var=06007_E_Hp - +% The type of a \var{for} loop variable must be an ordinal type. +% Loop variables cannot be reals or strings. +cg_e_cant_choose_overload_function=06008_E_ , '' , +% You're calling overloaded functions with a parameter that doesn't correspond +% to any of the declared function parameter lists. e.g. when you have declared +% a function with parameters \var{word} and \var{longint}, and then you call +% it with a parameter which is of type \var{integer}. +cg_e_parasize_too_big=06009_E_p pp p y p 65535 (64kb) +% The I386 processor limits the parameter list to 65535 bytes (the \var{RET} +% instruction causes this) +cg_e_illegal_type_conversion=06010_E_Hp pp +% When doing a type-cast, you must take care that the sizes of the variable and +% the destination type are the same. +cg_d_pointer_to_longint_conv_not_portable=06011_D_p y ORDINAL POINTER - +% If you typecast a pointer to a longint, this code will not compile +% on a machine using 64bit for pointer storage. +cg_e_file_must_call_by_reference=06012_E_ p +% You cannot specify files as value parameters, i.e. they must always be +% declared \var{var} parameters. +cg_e_cant_use_far_pointer_there=06013_E_ FAR y p +% Free Pascal doesn't support far pointers, so you cannot take the address of +% an expression which has a far reference as a result. The \var{mem} construct +% has a far reference as a result, so the following code will produce this +% error: +% \begin{verbatim} +% var p : pointer; +% ... +% p:=@mem[a000:000]; +% \end{verbatim} +cg_e_var_must_be_reference=06014_E_Hp pp +% You are trying to pass a constant or an expression to a procedure that +% requires a \var{var} parameter. Only variables can be passed as a \var{var} +% parameter. +cg_e_dont_call_exported_direct=06015_E_ EXPORT p, y +% No longer in use. +cg_w_member_cd_call_from_method=06016_W_ p pyp pyp ( y yy y) +% No longer in use. +cg_n_inefficient_code=06017_N_H +% You construction seems dubious to the compiler. +cg_w_unreachable_code=06018_W_H +% You specified a loop which will never be executed. Example: +% \begin{verbatim} +% while false do +% begin +% {.. code ...} +% end; +% \end{verbatim} +cg_e_stackframe_with_esp=06019_E_ pyp STACKFRAME ESP/SP +% The compiler encountered a procedure or function call inside a +% procedure that uses a \var{ESP/SP} stackframe. Normally, when a call is +% done the procedure needs a \var{EBP} stackframe. +cg_e_cant_call_abstract_method=06020_E_p y py +% You cannot call an abstract method directy, instead you must call a +% overriding child method, because an abstract method isn't implemented. +cg_f_internal_error_in_getfloatreg=06021_F_yp getfloatreg(), pp p! +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_unknown_float_type=06022_F_H +% The compiler cannot determine the kind of float that occurs in an expression. +cg_f_secondvecn_base_defined_twice=06023_F_SecondVecn() p +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_f_extended_cg68k_not_supported=06024_F_p cg68k p +% The \var{extended} type is not supported on the m68k platform. +cg_f_32bit_not_supported_in_68000=06025_F_ 32- p MC680x0 p +% The cardinal is not supported on the m68k platform. +cg_f_internal_error_in_secondinline=06026_F_yp secondinline() +% An internal error occurred in the compiler; If you encounter such an error, +% please contact the developers and try to provide an exact description of +% the circumstances in which the error occurs. +cg_d_register_weight=06027_D_p $1 $2 $3 +% Debugging message. Shown when the compiler considers a variable for +% keeping in the registers. +cg_e_stacklimit_in_local_routine=06028_E_ pp p +% Your code requires a too big stack. Some operating systems pose limits +% on the stack size. You should use less variables or try ro put large +% variables on the heap. +cg_d_stackframe_omited=06029_D_STACK FRAME y +% Some procedure/functions do not need a complete stack-frame, so it is omitted. +% This message will be displayed when the {-vd} switch is used. +cg_w_64bit_range_check_not_supported=06030_W_ 64- +% 64 bit range check is not yet implemented for 32 bit processors. +cg_e_unable_inline_object_methods=06031_E_ INLINE +% You cannot have inlined object methods. +cg_e_unable_inline_procvar=06032_E_ PROCVAR INLINE +% A procedure with a procedural variable call cannot be inlined. +cg_e_no_code_for_inline_stored=06033_E_H INLINE +% The compiler couldn't store code for the inline procedure. +cg_e_no_call_to_interrupt=06034_E_ - $1 +% You can not call an interrupt procedure directly from FPC code +cg_e_can_access_element_zero=06035_E_Hy p y, y SETLENGTH LENGTH +% You should use \var{setlength} to set the length of an ansi/wide/longstring +% and \var{length} to get the length of such kinf of string +cg_e_include_not_implemented=06036_E_ p CASE +% \var{include} and \var{exclude} are only partially +% implemented for \var{i386} processors +% and not at all for \var{m68k} processors. +cg_e_cannot_call_cons_dest_inside_with=06037_E_pyp pyp y yp 'WITH' p +% Inside a \var{With} clause you cannot call a constructor or destructor for the +% object you have in the \var{with} clause. +cg_e_cannot_call_message_direct=06038_E_H p p +% A message method handler method can't be called directly if it contains an +% explicit self argument +cg_e_goto_inout_of_exception_block=06039_E_ exception +% It isn't allowed to jump in or outside of an exception block like \var{try..finally..end;}: +% \begin{verbatim} +% label 1; +% +% ... +% +% try +% if not(final) then +% goto 1; // this line will cause an error +% finally +% ... +% end; +% 1: +% ... +% \end{verbatim} +% \end{description} +cg_e_control_flow_outside_finally=06040_E_ (break,continue exit) finally - +% It isn't allowed to use the control flow statements \var{break}, +% \var{continue} and \var{exit} +% inside a finally statement. The following example shows the problem: +% \begin{verbatim} +% ... +% try +% p; +% finally +% ... +% exit; // This exit ISN'T allowed +% end; +% ... +% +% \end{verbatim} +% If the procedure \var{p} raises an exception the finally block is +% executed. If the execution reaches the exit, it's unclear what to do: +% exiting the procedure or searching for another exception handler +# EndOfTeX + +# +# Assembler reader +# +asmr_d_start_reading=07000_D_H $1 p +% This informs you that an assembler block is being parsed +asmr_d_finish_reading=07001_D_ $1 p +% This informs you that an assembler block has finished. +asmr_e_none_label_contain_at=07002_E_-, , p @ +% A identifier which isn't a label can't contain a @. +asmr_w_override_op_not_supported=07003_W_pp pp p +% The Override operator is not supported +asmr_e_building_record_offset=07004_E_ p +% There has an error occured while building the offset of a record/object +% structure, this can happend when there is no field specified at all or +% an unknown field identifier is used. +asmr_e_offset_without_identifier=07005_E_OFFSET y p +% You can only use OFFSET with an identifier. Other syntaxes aren't +% supported +asmr_e_type_without_identifier=07006_E_TYPE y p +% You can only use TYPE with an identifier. Other syntaxes aren't +% supported +asmr_e_no_local_or_para_allowed=07007_E_H y p pp +% You can't use a local variable or parameter here, mostly because the +% addressing of locals and parameters is done using the %ebp register so the +% address can't be get directly. +asmr_e_need_offset=07008_E_ OFFSET +% You need to use OFFSET here to get the address of the identifier. +asmr_e_need_dollar=07009_E_ ('$') +% You need to use $ here to get the address of the identifier. +asmr_e_cant_have_multiple_relocatable_symbols=07010_E_H y p +% You can't have more than one relocatable symbol (variable/typed constant) +% in one argument. +asmr_e_only_add_relocatable_symbol=07011_E_p +% Relocatable symbols (variable/typed constant) can't be used with other +% operators. Only addition is allowed. +asmr_e_invalid_constant_expression=07012_E_Hp p +% There is an error in the constant expression. +asmr_e_relocatable_symbol_not_allowed=07013_E_p pp +% You can't use a relocatable symbol (variable/typed constant) here. +asmr_e_invalid_reference_syntax=07014_E_Hp +% There is an error in the reference. +asmr_e_local_para_unreachable=07015_E_ $1 +% You can not read directly the value of local or para +% of a higher level in assembler code (except for +% local assembler code without parameter nor locals). +asmr_e_local_label_not_allowed_as_ref=07016_E_ +% +asmr_e_wrong_base_index=07017_E_Hp pp +% There is an error with the base and index register +asmr_w_possible_object_field_bug=07018_W_ +% Fields of objects or classes can be reached directly in normal or objfpc +% modes but TP and Delphi modes treat the field name as a simple offset. +asmr_e_wrong_scale_factor=07019_E_Hp p (? ? :-&) +% The scale factor given is wrong, only 1,2,4 and 8 are allowed +asmr_e_multiple_index=07020_E_ pp +% You are trying to use more than one index register +asmr_e_invalid_operand_type=07021_E_Hp p +% The operand type doesn't match with the opcode used +asmr_e_invalid_string_as_opcode_operand=07022_E_Hp p, p p: $1 +% The string specified as operand is not correct with this opcode +asmr_w_CODE_and_DATA_not_supported=07023_W_@CODE @DATA p +% @CODE and @DATA are unsupported and are ignored. +asmr_e_null_label_ref_not_allowed=07024_E_y pp +asmr_e_expr_zero_divide=07025_E_ +asmr_e_expr_illegal=07026_E_ +asmr_e_escape_seq_ignored=07027_E_Esc- ppy: $1 +asmr_e_invalid_symbol_ref=07028_E_Hp +asmr_w_fwait_emu_prob=07029_W_FWAIT p y EMU387 +asmr_w_fadd_to_faddp=07030_W_FADD FADDP +asmr_w_enter_not_supported_by_linux=07031_W_ENTER Linux kernel +% ENTER instruction can generate a stack page fault that is not +% caught correctly by the i386 Linux page handler. +asmr_w_calling_overload_func=07032_W_ ppy y p +asmr_e_unsupported_symbol_type=07033_E_H p p +asmr_e_constant_out_of_bounds=07034_E_ p +asmr_e_error_converting_decimal=07035_E_ p pp $1 +asmr_e_error_converting_octal=07036_E_ p pp p $1 +asmr_e_error_converting_binary=07037_E_ p pp $1 +asmr_e_error_converting_hexadecimal=07038_E_ p pp p $1 +asmr_h_direct_global_to_mangled=07039_H_$1 pp $2 +asmr_w_direct_global_is_overloaded_func=07040_W_$1 ppy y +asmr_e_cannot_use_SELF_outside_a_method=07041_E_H y SELF +asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042_E_H y __OLDEBP pyp +asmr_e_void_function=07043_W_y p p ' p ' p +asmr_e_SEG_not_supported=07044_E_SEG p +asmr_e_size_suffix_and_dest_dont_match=07045_E_y pp p pp y +asmr_w_size_suffix_and_dest_dont_match=07046_W_y pp p pp y +asmr_e_syntax_error=07047_E_ +asmr_e_invalid_opcode_and_operand=07048_E_Hp p p +asmr_e_syn_operand=07049_E_ p +asmr_e_syn_constant=07050_E_ +asmr_e_invalid_string_expression=07051_E_Hp p p +asmr_w_const32bit_for_address=07052_-pp p +asmr_e_unknown_opcode=07053_E_ $1 +asmr_e_invalid_or_missing_opcode=07054_E_Hp py +asmr_e_invalid_prefix_and_opcode=07055_E_Hp p : $1 +asmr_e_invalid_override_and_opcode=07056_E_Hp pp : $1 +asmr_e_too_many_operands=07057_E_ p p +asmr_w_near_ignored=07058_W_ NEAR pp +asmr_w_far_ignored=07059_W_ FAR pp +asmr_e_dup_local_sym=07060_E_p p $1 +asmr_e_unknown_local_sym=07061_E_H $1 +asmr_e_unknown_label_identifier=07062_E_H p $1 +asmr_e_invalid_register=07063_E_ +asmr_e_invalid_fpu_register=07064_E_Hp pp p +asmr_e_nor_not_supported=07065_E_NOR p +asmr_w_modulo_not_supported=07066_W_MODULO p +asmr_e_invalid_float_const=07067_E_Hp ( ): $1 +asmr_e_invalid_float_expr=07068_E_Hp p ( p) +asmr_e_wrong_sym_type=07069_E_Hp +asmr_e_cannot_index_relative_var=07070_E_H y p y py pp pp +asmr_e_invalid_seg_override=07071_E_Hp p pp +asmr_w_id_supposed_external=07072_W_p $1, p +asmr_e_string_not_allowed_as_const=07073_E_H p +asmr_e_no_var_type_specified=07074_ p y +asmr_w_assembler_code_not_returned_to_text=07075_E_p p TEXT +asmr_e_not_directive_or_local_symbol=07076_E_$1 p +asmr_w_using_defined_as_local=07077_E_ p +asmr_e_dollar_without_identifier=07078_E_ '$' y p +asmr_w_32bit_const_for_address=07079_W_32- p +asmr_n_align_is_target_specific=07080_N_.ALIGN y y p, y .BALIGN .P2ALIGN +asmr_e_cannot_access_field_directly_for_parameters=07081_E_H y pp py, y pp +% You should load the parameter first into a register and then access the +% fields using that register. +asmr_e_cannot_access_object_field_directly=07082_E_H y / py, y pp +% You should load the self pointer first into a register and then access the +% fields using the register as base. By default the self pointer is available +% in the esi register on i386. + +# +# Assembler/binary writers +# +asmw_f_too_many_asm_files=08000_F_ p +asmw_f_assembler_output_not_supported=08001_F_p p p +asmw_f_comp_not_supported=08002_F_COMP p +asmw_f_direct_not_supported=08003_F_ p p +asmw_e_alloc_data_only_in_bss=08004_E_p BSS +asmw_f_no_binary_writer_selected=08005_F_ +asmw_e_opcode_not_in_table=08006_E_Asm: $1 +asmw_e_invalid_opcode_and_operands=08007_E_Asm: $1 p p +asmw_e_16bit_not_supported=08008_E_Asm: 16- p +asmw_e_invalid_effective_address=08009_E_Asm: Hp (?) p +asmw_e_immediate_or_reference_expected=08010_E_Asm: IMMEDIATE +asmw_e_value_exceeds_bounds=08011_E_Asm: $1 p $2 +asmw_e_short_jmp_out_of_range=08012_E_Asm: SHORT JUMP p $1 +asmw_e_undefined_label=08013_E_Asm: $1 + +# +# Executing linker/assembler +# +exec_w_source_os_redefined=09000_W_ p pp +exec_i_assembling_pipe=09001_I_py (pipe) $1 +exec_d_cant_create_asmfile=09002_E_H y p: $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_objectfile=09003_E_ : $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_e_cant_create_archivefile=09004_E_ : $1 +% The mentioned file can't be create. Check if you've +% permission to create this file +exec_w_assembler_not_found=09005_W_p $1 , y p +exec_t_using_assembler=09006_T_y p: $1 +exec_w_error_while_assembling=09007_W_ p p $1 +exec_w_cant_call_assembler=09008_W_H y p, $1. y p +exec_i_assembling=09009_I_p $1 +exec_i_assembling_smart=09010_I_y p $1 +exec_w_objfile_not_found=09011_W_ $1 , y ! +exec_w_libfile_not_found=09012_W_ $1 , y ! +exec_w_error_while_linking=09013_W_ p +exec_w_cant_call_linker=09014_W_H y , y +exec_i_linking=09015_I_ $1 +exec_w_util_not_found=09016_W_ $1 , p y +exec_t_using_util=09017_T_ $1 +exec_e_exe_not_supported=09018_E_ p +exec_e_dll_not_supported=09019_E_ (DLL) p +exec_i_closing_script=09020_I_p p $1 +exec_w_res_not_found=09021_W_p pyp , p +exec_i_compilingresource=09022_I_py pyp $1 + +# +# Executable information +# +execinfo_f_cant_process_executable=09023_F_H y $1 +execinfo_f_cant_open_executable=09024_F_H y p y $1 +execinfo_x_codesize=09025_X_p : $1 +execinfo_x_initdatasize=09026_X_p py : $1 +execinfo_x_uninitdatasize=09027_X_p -py : $1 +execinfo_x_stackreserve=09028_X_ppp : $1 +execinfo_x_stackcommit=09029_X_ : $1 + +# Unit loading +# +# BeginOfTeX +% \section{Unit loading messages.} +% This section lists all messages that can occur when the compiler is +% loading a unit from disk into memory. Many of these mesages are +% informational messages. +% \begin{description} +unit_t_unitsearch=10000_T_ y: $1 +% When you use the \var{-vt}, the compiler tells you where it tries to find +% unit files. +unit_t_ppu_loading=10001_T_PPU py $1 +% When the \var{-vt} switch is used, the compiler tells you +% what units it loads. +unit_u_ppu_name=10002_U_PPU : $1 +% When you use the \var{-vu} flag, the unit name is shown. +unit_u_ppu_flags=10003_U_PPU : $1 +% When you use the \var{-vu} flag, the unit flags are shown. +unit_u_ppu_crc=10004_U_PPU CRC: $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_time=10005_U_PPU p: $1 +% When you use the \var{-vu} flag, the time the unit was compiled is shown. +unit_u_ppu_file_too_short=10006_U_PPU p +% The ppufile is too short, not all declarations are present. +unit_u_ppu_invalid_header=10007_U_Hp PPU ( PPU ) +% A unit file contains as the first three bytes the ascii codes of \var{PPU} +unit_u_ppu_invalid_version=10008_U_Hp p PPU $1 +% This unit file was compiled with a different version of the compiler, and +% cannot be read. +unit_u_ppu_invalid_processor=10009_U_PPU p py pp +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_invalid_target=10010_U_PPU p py OS +% This unit file was compiled for a different processor type, and +% cannot be read +unit_u_ppu_source=10011_U_PPU : $1 +% When you use the \var{-vu} flag, the unit CRC check is shown. +unit_u_ppu_write=10012_U_ $1 +% When you specify the \var{-vu} switch, the compiler will tell you where it +% writes the unit file. +unit_f_ppu_cannot_write=10013_F_H y PPU- +% An error occurred when writing the unit file. +unit_f_ppu_read_error=10014_F_ PPU- +% This means that the unit file was corrupted, and contains invalid +% information. Recompilation will be necessary. +unit_f_ppu_read_unexpected_end=10015_F_ y PPU- +% Unexpected end of file. +unit_f_ppu_invalid_entry=10016_F_Hp PPU-: $1 +% The unit the compiler is trying to read is corrupted, or generated with a +% newer version of the compiler. +unit_f_ppu_dbx_count_problem=10017_F_PPU DBX COUNT p +% There is an inconsistency in the debugging information of the unit. +unit_e_illegal_unit_name=10018_E_Hp y: $1 +% The name of the unit doesn't match the file name. +unit_f_too_much_units=10019_F_ y +% \fpc has a limit of 1024 units in a program. You can change this behavior +% by changing the \var{maxunits} constant in the \file{files.pas} file of the +% compiler, and recompiling the compiler. +unit_f_circular_unit_reference=10020_F_py y y $1 $2 +% Two units are using each other in the interface part. This is only allowed +% in the \var{implementation} part. At least one unit must contain the other one +% in the \var{implementation} section. +unit_f_cant_compile_unit=10021_F_H y p y $1. H y . +% A unit was found that needs to be recompiled, but no sources are +% available. +unit_f_cant_find_ppu=10022_F_H y PPU $1. +% You tried to use a unit of which the PPU file isn't found by the +% compiler. Check your config files for the unit pathes +unit_w_unit_name_error=10023_W_ $1 , $2 +unit_f_unit_name_error=10024_F_ $1 , $2 +% Dos truncation of 8 letters for unit PPU files +% may lead to problems when unit name is longer than 8 letters. +unit_w_switch_us_missed=10025_W_py p y. y -Us +% When recompiling the system unit (it needs special treatment), the +% \var{-Us} must be specified. +unit_f_errors_in_unit=10026_F_py $1 p p y, +% When the compiler encounters a fatal error or too many errors in a module +% then it stops with this message. +unit_u_load_unit=10027_U_py $1 ($2) y $3 +% When you use the \var{-vu} flag, which unit is loaded from which unit is +% shown. +unit_u_recompile_crc_change=10028_U_pp $1, p y y $2 +unit_u_recompile_source_found_alone=10029_U_pp $1, +% When you use the \var{-vu} flag, these messages tell you why the current +% unit is recompiled. +unit_u_recompile_staticlib_is_older=10030_U_pp y, (static) p ppu- +% When you use the \var{-vu} flag, the compiler warns if the static library +% of the unit are older than the unit file itself. +unit_u_recompile_sharedlib_is_older=10031_U_pp y, (shared) p ppu- +% When you use the \var{-vu} flag, the compiler warns if the shared library +% of the unit are older than the unit file itself. +unit_u_recompile_obj_and_asm_older=10032_U_pp y, .as .obj p ppu- +% When you use the \var{-vu} flag, the compiler warns if the assembler or +% object file of the unit are older than the unit file itself. +unit_u_recompile_obj_older_than_asm=10033_U_pp y, .obj p .as +% When you use the \var{-vu} flag, the compiler warns if the assembler +% file of the unit is older than the object file of the unit. +unit_u_start_parse_interface=10034_U_ p $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the interface part of the unit +unit_u_start_parse_implementation=10035_U_ p $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% parsing the implementation part of the unit +unit_u_second_load_unit=10036_U_p py y $1 +% When you use the \var{-vu} flag, the compiler warns that it starts +% recompiling a unit for the second time. This can happend with interdepend +% units. +unit_u_check_time=10037_U_PPU pp $1 p $2 + +# +# Options +# +option_usage=11000_$1 [] <> [] +# BeginOfTeX +% +% \section{Command-line handling errors} +% This section lists errors that occur when the compiler is processing the +% command line or handling the configuration files. +% \begin{description} +option_only_one_source_support=11001_W_p +% You can specify only one source file on the command line. The first +% one will be compiled, others will be ignored. This may indicate that +% you forgot a \var{'-'} sign. +option_def_only_for_os2=11002_W_DEF OS/2 +% This option can only be specified when you're compiling for OS/2 +option_no_nested_response_file=11003_E_ p +% you cannot nest response files with the \var{@file} command-line option. +option_no_source_found=11004_F_ p +% The compiler expects a source file name on the command line. +option_no_option_found=11005_N_ $1 +% The compiler didn't find any option in that config file. +option_illegal_para=11006_E_Hp pp: $1 +% You specified an unknown option. +option_help_pages_para=11007_H_-? p +% When an unknown option is given, this message is diplayed. +option_too_many_cfg_files=11008_F_ yp +% You can only nest up to 16 config files. +option_unable_open_file=11009_F_H y p $1 +% The option file cannot be found. +option_reading_further_from=11010_N_ pp $1 +% Displayed when you have notes turned on, and the compiler switches +% to another options file. +option_target_is_already_set=11011_W_TARGET y : $1 +% Displayed if more than one \var{-T} option is specified. +option_no_shared_lib_under_dos=11012_W_SHARED p GO32* p, STATIC +% If you specify \var{-CD} for the \dos platform, this message is displayed. +% The compiler supports only static libraries under \dos +option_too_many_ifdef=11013_F_ $IFDEF $IFNDEF +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_many_endif=11014_F_ $ENDIF +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_too_less_endif=11015_F_p y p +% the \var{\#IF(N)DEF} statements in the options file are not balanced with +% the \var{\#ENDIF} statements. +option_no_debug_support=11016_W_p p p +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_no_debug_support_recompile_fpc=11017_H_py p -dGDB +% It is possible to have a compiler executable that doesn't support +% the generation of debugging info. If you use such an executable with the +% \var{-g} switch, this warning will be displayed. +option_obsolete_switch=11018_E_ y yp $1 +% this warns you when you use a switch that is not needed/supported anymore. +% It is recommended that you remove the switch to overcome problems in the +% future, when the switch meaning may change. +option_obsolete_switch_use_new=11019_E_ y yp $1, y y $2 +% , , +% . . +% , , , +% , y py . +option_switch_bin_to_src_assembler=11020_N_p p p y +% this notifies you that the assembler has been changed because you used the +% -a switch which can't be used with a binary assembler writer. +option_incompatible_asm=11021_W_ "$1" "$2" +option_asm_forced=11022_W_ , "$1" +% The assembler output selected can not generate +% object files with the correct format. Therefore, the +% default assembler for this target is used instead. +% + +# +# ( -l) +# +option_logo=11023_[ +Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET [Russian Edition] +Copyright (c) 1998-2000 by Florian Klaempfl +] + +# +# p ( -i) +# +option_info=11024_[ +Free Pascal Compiler version $FPCVER + +Compiler Date : $FPCDATE +Compiler Target: $FPCTARGET + +This program comes under the GNU General Public Licence +For more information read COPYING.FPC + +Report bugs, suggestions and etc to: + bugrep@freepascal.org, russia@freepascal.org +] + +# +# ( -? -h) +# +# : Hyp ! +# +option_help_pages=11025_[ +**0*_ '+', , '-' +**1a_ y +**2al_ p p +**2ar_ p / pp p +**2at_ p / p p p +**1b_pp p pyp +**2bl_pp p +**1B_pp y +**1C_ pp +3*2CD_ y y +**2Ch_ y ( 1023 67107840) +**2Ci_pp - +**2Cn_ +**2Co_pp +**2Cr_pp +**2Cs_y pp +**2Ct_ +3*2CS_ y y +3*2Cx_ yy y y +**1d_p +*O1D_ DEF- +*O2Dd_y +*O2Dw_PM +**1e_y y +**1E_, -Cn +**1F_y +**2FD_y y , +**2Fe_pp +**2FE_y y exe/unit +**2Fi_ , y +**2Fl_ , y +*L2FL_ +**2Fo_ y +**2Fr_py +**2Fu_ +**2FU_y y y , -FE +*g1g_ +*g2gg_ GSYM +*g2gd_ DBX +*g2gh_ y +*g2gc_ +**1i_p +**2iD_p y p +**2iV_p p +**2iSO_p OS, p pp +**2iSP_p pp, p pp +**2iTO_p OS, p pp +**2iTP_p pp, p pp +**1I_ y +**1k_p y +**1l_ ppy +**1n_H +**1o_ , +**1pg_p GPROF +*L1P_ +**1S_ +**2S2_ p pp Delphi 2 +**2Sc_p , pp C (*=,+=,/= -=) +**2sa_ +**2Sd_p Delphi- +**2Se_p ( 1 ) +**2Sg_p LABEL GOTO +**2Sh_ ANSI p +**2Si_p INLINE C++ +**2Sm_p C ( !) +**2So_p TP/BP 7.0 +**2Sp_p GPC +**2Ss_pyp init (pyp - done) +**2St_p +**1s_ p p ( -a) +**1u_y p +**1U_ y +**2Un_ pp y y +**2Us_p y (system) +**1v_p y : +**2*_e : ( ) d: +**2*_w : u: +**2*_n : t: / +**2*_h : m: +**2*_i : p: +**2*_l : Hp c: +**2*_a : 0: H , p +**2*_b : pypy, r: Rhide/GCC +**2*_ p x: ( Win32) +**2*_ +**1X_ +*L2Xc_ C +**2Xs_ pp +**2XD_. . . (. FPC_LINK_DYNAMIC) +**2XS_. . . (. FPC_LINK_STATIC) +**2XX_. "y" (. FPC_LINK_SMART) +**0*_ pp: +3*1A_ +3*2Aas_, GNU +3*2Aasaout_, GNU for aout (Go32v1) +3*2Anasmcoff_coff , Nasm +3*2Anasmelf_elf32 (linux) , Nasm +3*2Anasmobj_obj , Nasm +3*2Amasm_obj y Masm (Microsoft) +3*2Atasm_obj y Tasm (Borland) +3*2Acoff_coff (Go32v2) +3*2Apecoff_pecoff (Win32) +3*1R_ p +3*2Ratt_ AT&T +3*2Rintel_ Intel +3*2Rdirect_ p y +3*1O_ +3*2Og_pp +3*2OG_pp p ( y) +3*2Or_p p ( !) +3*2Ou_ (. ) +3*2O1_yp 1 ( ) +3*2O2_yp 2 (-O1 + ) +3*2O3_yp 3 ( -O2u) +3*2Op_ , p p : +3*3Op1_ 386/486 +3*3Op2_ Pentium/PentiumMMX +3*3Op3_ Pentium PRO/Pentium II/Cyrix 6X86/AMD K6 +3*1T_ , p p : +3*2TGO32V1_version 1 (DJ Delorie DOS) +3*2TGO32V2_version 2 (DJ Delorie DOS) +3*2TLINUX_Linux +3*2TOS2_OS/2 2.x +3*2TWin32_Windows 32 Bit +3*1W_Win32 +3*1WB_ Image +3*1WC_ , +3*1WD_ DEFFILE DLL EXE +3*1WG_ , GUI +3*1WN_ ( ) +3*1WR_ +6*1A_ p +6*2Ao_Unix o-, GNU +6*2Agas_GNU Motorola +6*2Amit_MIT ( GAS) +6*2Amot_p p Motorola +6*1O_ +6*2Oa_ +6*2Og_pp +6*2OG_pp p ( ) +6*2Ox_ ( !) +6*2O2_ MC68020+ +6*1R_ p +6*2RMOT_ Motorola-p +6*1T_ p py +6*2TAMIGA_Commodore Commodore +6*2TATARI_Atari ST/STE/TT +6*2TMACOS_Macintosh m68k +6*2TLINUX_Linux-68k +**1*_ +**1?_ y y +**1h_ y y, +] + +# +# The End +# \ No newline at end of file diff --git a/befpc/compiler/export.pas b/befpc/compiler/export.pas new file mode 100644 index 0000000..52f5056 --- /dev/null +++ b/befpc/compiler/export.pas @@ -0,0 +1,250 @@ +{ + $Id: export.pas,v 1.1.1.1 2001-07-23 17:16:22 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an uniform export object + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit export; + +interface + +uses + cobjects{$IFDEF NEWST},objects{$ENDIF NEWST},symtable; + +const + { export options } + eo_resident = $1; + eo_index = $2; + eo_name = $4; + +type + pexported_item = ^texported_item; + texported_item = object(tlinkedlist_item) + sym : psym; + index : longint; + name : pstring; + options : word; + is_var : boolean; + constructor init; + destructor done;virtual; + end; + + pexportlib=^texportlib; + texportlib=object + private + notsupmsg : boolean; + procedure NotSupported; + public + constructor Init; + destructor Done; + procedure preparelib(const s : string);virtual; + procedure exportprocedure(hp : pexported_item);virtual; + procedure exportvar(hp : pexported_item);virtual; + procedure generatelib;virtual; + end; + +var + exportlib : pexportlib; + +procedure InitExport; +procedure DoneExport; + +implementation + +uses + systems,verbose,globals,files +{$ifdef i386} + {$ifndef NOTARGETLINUX} + ,t_linux + {$endif} + {$ifndef NOTARGETOS2} + ,t_os2 + {$endif} + {$ifndef NOTARGETWIN32} + ,t_win32 + {$endif} + {$ifndef NOTARGETBEOS} + ,t_beos + {$endif} + {$ifndef NOTARGETGO32V2} + ,t_go32v2 + {$endif} +{$endif} +{$ifdef m68k} + {$ifndef NOTARGETLINUX} + ,t_linux + {$endif} +{$endif} +{$ifdef powerpc} + {$ifndef NOTARGETLINUX} + ,t_linux + {$endif} +{$endif} +{$ifdef alpha} + {$ifndef NOTARGETLINUX} + ,t_linux + {$endif} +{$endif} + ; + +{**************************************************************************** + TImported_procedure +****************************************************************************} + +constructor texported_item.init; +begin + inherited init; + sym:=nil; + index:=-1; + name:=nil; + options:=0; + is_var:=false; +end; + + +destructor texported_item.done; +begin + stringdispose(name); + inherited done; +end; + + +{**************************************************************************** + TImportLib +****************************************************************************} + +constructor texportlib.Init; +begin + notsupmsg:=false; +end; + + +destructor texportlib.Done; +begin +end; + + +procedure texportlib.NotSupported; +begin + { show the message only once } + if not notsupmsg then + begin + Message(exec_e_dll_not_supported); + notsupmsg:=true; + end; +end; + + +procedure texportlib.preparelib(const s:string); +begin + NotSupported; +end; + + +procedure texportlib.exportprocedure(hp : pexported_item); +begin + NotSupported; +end; + + +procedure texportlib.exportvar(hp : pexported_item); +begin + NotSupported; +end; + + +procedure texportlib.generatelib; +begin + NotSupported; +end; + + +procedure DoneExport; +begin + if assigned(exportlib) then + dispose(exportlib,done); +end; + + +procedure InitExport; +begin + case target_info.target of +{$ifdef i386} + target_i386_Linux : + exportlib:=new(pexportliblinux,Init); + target_i386_Win32 : + exportlib:=new(pexportlibwin32,Init); + target_i386_BeOS : + exportlib:=new(pexportlibbeos,Init); +{ + target_i386_OS2 : + exportlib:=new(pexportlibos2,Init); +} +{$endif i386} +{$ifdef m68k} + target_m68k_Linux : + exportlib:=new(pexportlib,Init); +{$endif m68k} +{$ifdef alpha} + target_alpha_Linux : + exportlib:=new(pexportlib,Init); +{$endif alpha} +{$ifdef powerpc} + target_alpha_Linux : + exportlib:=new(pexportlib,Init); +{$endif powerpc} + else + exportlib:=new(pexportlib,Init); + end; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/02/28 17:23:56 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.11 2000/02/09 13:22:52 peter + * log truncated + + Revision 1.10 2000/01/12 10:34:29 peter + * only give unsupported error once + + Revision 1.9 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.8 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.7 1999/10/21 14:29:34 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + + Revision 1.6 1999/08/04 13:02:41 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.5 1999/08/03 17:09:34 florian + * the alpha compiler can be compiled now + +} diff --git a/befpc/compiler/files.pas b/befpc/compiler/files.pas new file mode 100644 index 0000000..e5d828e --- /dev/null +++ b/befpc/compiler/files.pas @@ -0,0 +1,1484 @@ +{ + $Id: files.pas,v 1.1.1.1 2001-07-23 17:16:24 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements an extended file management and the first loading + and searching of the modules (ppufiles) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit files; + +{$ifdef TP} + {$V+} +{$endif} + +{$ifdef TP} + {$define SHORTASMPREFIX} +{$endif} +{$ifdef go32v1} + {$define SHORTASMPREFIX} +{$endif} +{$ifdef go32v2} + {$define SHORTASMPREFIX} +{$endif} +{$ifdef OS2} + { Allthough OS/2 supports long filenames I play it safe and + use 8.3 filenames, because this allows the compiler to run + on a FAT partition. (DM) } + {$define SHORTASMPREFIX} +{$endif} + + + interface + + uses + globtype,cobjects,globals,ppu + {$IFDEF NEWST},objects{$ENDIF}; + + const +{$ifdef FPC} + maxunits = 1024; + InputFileBufSize=32*1024; + linebufincrease=512; +{$else} + maxunits = 128; + InputFileBufSize=1024; + linebufincrease=64; +{$endif} + + type + trecompile_reason = (rr_unknown,rr_noppu,rr_sourcenewer, + rr_build,rr_libolder,rr_objolder,rr_asmolder,rr_crcchanged); +{$ifdef FPC} + tlongintarr = array[0..1000000] of longint; +{$else} + tlongintarr = array[0..16000] of longint; +{$endif} + plongintarr = ^tlongintarr; + + pinputfile = ^tinputfile; + tinputfile = object + path,name : pstring; { path and filename } + next : pinputfile; { next file for reading } + + f : file; { current file handle } + is_macro, + endoffile, { still bytes left to read } + closed : boolean; { is the file closed } + + buf : pchar; { buffer } + bufstart, { buffer start position in the file } + bufsize, { amount of bytes in the buffer } + maxbufsize : longint; { size in memory for the buffer } + + saveinputpointer : pchar; { save fields for scanner variables } + savelastlinepos, + saveline_no : longint; + + linebuf : plongintarr; { line buffer to retrieve lines } + maxlinebuf : longint; + + ref_count : longint; { to handle the browser refs } + ref_index : longint; + ref_next : pinputfile; + + constructor init(const fn:string); + destructor done; + procedure setpos(l:longint); + procedure seekbuf(fpos:longint); + procedure readbuf; + function open:boolean; + procedure close; + procedure tempclose; + function tempopen:boolean; + procedure setmacro(p:pchar;len:longint); + procedure setline(line,linepos:longint); + function getlinestr(l:longint):string; + end; + + pfilemanager = ^tfilemanager; + tfilemanager = object + files : pinputfile; + last_ref_index : longint; + cacheindex : longint; + cacheinputfile : pinputfile; + constructor init; + destructor done; + procedure register_file(f : pinputfile); + procedure inverse_register_indexes; + function get_file(l:longint) : pinputfile; + function get_file_name(l :longint):string; + function get_file_path(l :longint):string; + end; + + {$IFDEF NEWST} + Plinkitem=^Tlinkitem; + Tlinkitem=object(Tobject) + data : pstring; + needlink : longint; + constructor init(const s:string;m:longint); + destructor done;virtual; + end; + {$ELSE} + plinkcontaineritem=^tlinkcontaineritem; + tlinkcontaineritem=object(tcontaineritem) + data : pstring; + needlink : longint; + constructor init(const s:string;m:longint); + destructor done;virtual; + end; + + plinkcontainer=^tlinkcontainer; + tlinkcontainer=object(tcontainer) + constructor Init; + procedure insert(const s : string;m:longint); + function get(var m:longint) : string; + function getusemask(mask:longint) : string; + function find(const s:string):boolean; + end; + {$ENDIF NEWST} + +{$ifndef NEWMAP} + tunitmap = array[0..maxunits-1] of pointer; + punitmap = ^tunitmap; + + pmodule = ^tmodule; + +{$else NEWMAP} + pmodule = ^tmodule; + + tunitmap = array[0..maxunits-1] of pmodule; + punitmap = ^tunitmap; +{$endif NEWMAP} + + tmodule = object(tlinkedlist_item) + ppufile : pppufile; { the PPU file } + crc, + interface_crc, + flags : longint; { the PPU flags } + + compiled, { unit is already compiled } + do_reload, { force reloading of the unit } + do_assemble, { only assemble the object, don't recompile } + do_compile, { need to compile the sources } + sources_avail, { if all sources are reachable } + sources_checked, { if there is already done a check for the sources } + is_unit, + in_compile, { is it being compiled ?? } + in_second_compile, { is this unit being compiled for the 2nd time? } + in_second_load, { is this unit PPU loaded a 2nd time? } + in_implementation, { processing the implementation part? } + in_global : boolean; { allow global settings } + recompile_reason : trecompile_reason; { the reason why the unit should be recompiled } + + islibrary : boolean; { if it is a library (win32 dll) } + map : punitmap; { mapping of all used units } + unitcount : word; { local unit counter } + unit_index : word; { global counter for browser } + globalsymtable, { pointer to the local/static symtable of this unit } + localsymtable : pointer; { pointer to the psymtable of this unit } + scanner : pointer; { scanner object used } + loaded_from : pmodule; + uses_imports : boolean; { Set if the module imports from DLL's.} + imports : plinkedlist; + _exports : plinkedlist; + + sourcefiles : pfilemanager; + resourcefiles : tstringcontainer; + + {$IFDEF NEWST} + linkunitofiles, + linkunitstaticlibs, + linkunitsharedlibs, + linkotherofiles, { objects,libs loaded from the source } + linkothersharedlibs, { using $L or $LINKLIB or import lib (for linux) } + linkotherstaticlibs : Tcollection; + {$ELSE} + linkunitofiles, + linkunitstaticlibs, + linkunitsharedlibs, + linkotherofiles, { objects,libs loaded from the source } + linkothersharedlibs, { using $L or $LINKLIB or import lib (for linux) } + linkotherstaticlibs : tlinkcontainer; + {$ENDIF NEWST} + + used_units : tlinkedlist; + dependent_units : tlinkedlist; + + localunitsearchpath, { local searchpaths } + localobjectsearchpath, + localincludesearchpath, + locallibrarysearchpath : TSearchPathList; + + path, { path where the module is find/created } + outputpath, { path where the .s / .o / exe are created } + modulename, { name of the module in uppercase } + objfilename, { fullname of the objectfile } + asmfilename, { fullname of the assemblerfile } + ppufilename, { fullname of the ppufile } + staticlibfilename, { fullname of the static libraryfile } + sharedlibfilename, { fullname of the shared libraryfile } + exefilename, { fullname of the exefile } + asmprefix, { prefix for the smartlink asmfiles } + mainsource : pstring; { name of the main sourcefile } +{$ifdef Test_Double_checksum} + crc_array : pointer; + crc_size : longint; + crc_array2 : pointer; + crc_size2 : longint; +{$endif def Test_Double_checksum} + constructor init(const s:string;_is_unit:boolean); + destructor done;virtual; + procedure reset; + procedure setfilename(const fn:string;allowoutput:boolean); + function openppu:boolean; + function search_unit(const n : string;onlysource:boolean):boolean; + end; + + pused_unit = ^tused_unit; + tused_unit = object(tlinkedlist_item) + unitid : word; + name : pstring; + checksum, + interface_checksum : longint; + loaded : boolean; + in_uses, + in_interface, + is_stab_written : boolean; + u : pmodule; + constructor init(_u : pmodule;intface:boolean); + constructor init_to_load(const n:string;c,intfc:longint;intface:boolean); + destructor done;virtual; + end; + + pdependent_unit = ^tdependent_unit; + tdependent_unit = object(tlinkedlist_item) + u : pmodule; + constructor init(_u : pmodule); + end; + + var + main_module : pmodule; { Main module of the program } + current_module : pmodule; { Current module which is compiled or loaded } + compiled_module : pmodule; { Current module which is compiled } + current_ppu : pppufile; { Current ppufile which is read } + global_unit_count : word; + usedunits : tlinkedlist; { Used units for this program } + loaded_units : tlinkedlist; { All loaded units } + SmartLinkOFiles : TStringContainer; { List of .o files which are generated, + used to delete them after linking } + + function get_source_file(moduleindex,fileindex : word) : pinputfile; + + +implementation + +uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + verbose,systems, + symtable,scanner{$IFDEF NEWST},symtablt{$ENDIF}; + +{**************************************************************************** + TINPUTFILE + ****************************************************************************} + + constructor tinputfile.init(const fn:string); + var + p:dirstr; + n:namestr; + e:extstr; + begin + FSplit(fn,p,n,e); + name:=stringdup(n+e); + path:=stringdup(p); + next:=nil; + { file info } + is_macro:=false; + endoffile:=false; + closed:=true; + buf:=nil; + bufstart:=0; + bufsize:=0; + maxbufsize:=InputFileBufSize; + { save fields } + saveinputpointer:=nil; + saveline_no:=0; + savelastlinepos:=0; + { indexing refs } + ref_next:=nil; + ref_count:=0; + ref_index:=0; + { line buffer } + linebuf:=nil; + maxlinebuf:=0; + end; + + + destructor tinputfile.done; + begin + if not closed then + close; + stringdispose(path); + stringdispose(name); + { free memory } + if assigned(linebuf) then + freemem(linebuf,maxlinebuf shl 2); + end; + + + procedure tinputfile.setpos(l:longint); + begin + bufstart:=l; + end; + + + procedure tinputfile.seekbuf(fpos:longint); + begin + if closed then + exit; + seek(f,fpos); + bufstart:=fpos; + bufsize:=0; + end; + + + procedure tinputfile.readbuf; + {$ifdef TP} + var + w : word; + {$endif} + begin + if is_macro then + endoffile:=true; + if closed then + exit; + inc(bufstart,bufsize); + {$ifdef VER70} + blockread(f,buf^,maxbufsize-1,w); + bufsize:=w; + {$else} + blockread(f,buf^,maxbufsize-1,bufsize); + {$endif} + buf[bufsize]:=#0; + endoffile:=eof(f); + end; + + + function tinputfile.open:boolean; + var + ofm : byte; + begin + open:=false; + if not closed then + Close; + ofm:=filemode; + filemode:=0; + Assign(f,path^+name^); + {$I-} + reset(f,1); + {$I+} + filemode:=ofm; + if ioresult<>0 then + exit; + { file } + endoffile:=false; + closed:=false; + Getmem(buf,MaxBufsize); + bufstart:=0; + bufsize:=0; + open:=true; + end; + + + procedure tinputfile.close; + begin + if is_macro then + begin + if assigned(buf) then + Freemem(buf,maxbufsize); + buf:=nil; + {is_macro:=false; + still needed for dispose in scanner PM } + closed:=true; + exit; + end; + if not closed then + begin + {$I-} + system.close(f); + {$I+} + if ioresult<>0 then; + closed:=true; + end; + if assigned(buf) then + begin + Freemem(buf,maxbufsize); + buf:=nil; + end; + bufstart:=0; + end; + + + procedure tinputfile.tempclose; + begin + if is_macro then + exit; + if not closed then + begin + {$I-} + system.close(f); + {$I+} + if ioresult<>0 then; + Freemem(buf,maxbufsize); + buf:=nil; + closed:=true; + end; + end; + + + function tinputfile.tempopen:boolean; + var + ofm : byte; + begin + tempopen:=false; + if is_macro then + begin + { seek buffer postion to bufstart } + if bufstart>0 then + begin + move(buf[bufstart],buf[0],bufsize-bufstart+1); + bufstart:=0; + end; + tempopen:=true; + exit; + end; + if not closed then + exit; + ofm:=filemode; + filemode:=0; + Assign(f,path^+name^); + {$I-} + reset(f,1); + {$I+} + filemode:=ofm; + if ioresult<>0 then + exit; + closed:=false; + { get new mem } + Getmem(buf,maxbufsize); + { restore state } + seek(f,BufStart); + bufsize:=0; + readbuf; + tempopen:=true; + end; + + + procedure tinputfile.setmacro(p:pchar;len:longint); + begin + { create new buffer } + getmem(buf,len+1); + move(p^,buf^,len); + buf[len]:=#0; + { reset } + bufstart:=0; + bufsize:=len; + maxbufsize:=len+1; + is_macro:=true; + endoffile:=true; + closed:=true; + end; + + + procedure tinputfile.setline(line,linepos:longint); + var + oldlinebuf : plongintarr; + begin + if line<1 then + exit; + while (line>=maxlinebuf) do + begin + oldlinebuf:=linebuf; + { create new linebuf and move old info } + getmem(linebuf,(maxlinebuf+linebufincrease) shl 2); + if assigned(oldlinebuf) then + begin + move(oldlinebuf^,linebuf^,maxlinebuf shl 2); + freemem(oldlinebuf,maxlinebuf shl 2); + end; + fillchar(linebuf^[maxlinebuf],linebufincrease shl 2,0); + inc(maxlinebuf,linebufincrease); + end; + linebuf^[line]:=linepos; + end; + + + function tinputfile.getlinestr(l:longint):string; + var + c : char; + i, + fpos : longint; + p : pchar; + begin + getlinestr:=''; + if lbufstart+bufsize) then + begin + seekbuf(fpos); + readbuf; + end; + { the begin is in the buf now simply read until #13,#10 } + i:=0; + p:=@buf[fpos-bufstart]; + repeat + c:=p^; + if c=#0 then + begin + if endoffile then + break; + readbuf; + p:=buf; + c:=p^; + end; + if c in [#10,#13] then + break; + inc(i); + getlinestr[i]:=c; + inc(longint(p)); + until (i=255); + {$ifndef TP} + {$ifopt H+} + setlength(getlinestr,i); + {$else} + getlinestr[0]:=chr(i); + {$endif} + {$else} + getlinestr[0]:=chr(i); + {$endif} + end; + end; + + +{**************************************************************************** + TFILEMANAGER + ****************************************************************************} + + constructor tfilemanager.init; + begin + files:=nil; + last_ref_index:=0; + cacheindex:=0; + cacheinputfile:=nil; + end; + + + destructor tfilemanager.done; + var + hp : pinputfile; + begin + hp:=files; + while assigned(hp) do + begin + files:=files^.ref_next; + dispose(hp,done); + hp:=files; + end; + last_ref_index:=0; + end; + + + procedure tfilemanager.register_file(f : pinputfile); + begin + { don't register macro's } + if f^.is_macro then + exit; + inc(last_ref_index); + f^.ref_next:=files; + f^.ref_index:=last_ref_index; + files:=f; + { update cache } + cacheindex:=last_ref_index; + cacheinputfile:=f; +{$ifdef FPC} + {$ifdef heaptrc} + writeln(stderr,f^.name^,' index ',current_module^.unit_index*100000+f^.ref_index); + {$endif heaptrc} +{$endif FPC} + end; + + + { this procedure is necessary after loading the + sources files from a PPU file PM } + procedure tfilemanager.inverse_register_indexes; + var + f : pinputfile; + begin + f:=files; + while assigned(f) do + begin + f^.ref_index:=last_ref_index-f^.ref_index+1; + f:=f^.ref_next; + end; + { reset cache } + cacheindex:=0; + cacheinputfile:=nil; + end; + + + + function tfilemanager.get_file(l :longint) : pinputfile; + var + ff : pinputfile; + begin + { check cache } + if (l=cacheindex) and assigned(cacheinputfile) then + begin + get_file:=cacheinputfile; + exit; + end; + ff:=files; + while assigned(ff) and (ff^.ref_index<>l) do + ff:=ff^.ref_next; + get_file:=ff; + end; + + + function tfilemanager.get_file_name(l :longint):string; + var + hp : pinputfile; + begin + hp:=get_file(l); + if assigned(hp) then + get_file_name:=hp^.name^ + else + get_file_name:=''; + end; + + + function tfilemanager.get_file_path(l :longint):string; + var + hp : pinputfile; + begin + hp:=get_file(l); + if assigned(hp) then + get_file_path:=hp^.path^ + else + get_file_path:=''; + end; + + + function get_source_file(moduleindex,fileindex : word) : pinputfile; + var + hp : pmodule; + f : pinputfile; + begin + hp:=pmodule(loaded_units.first); + while assigned(hp) and (hp^.unit_index<>moduleindex) do + hp:=pmodule(hp^.next); + get_source_file:=nil; + if not assigned(hp) then + exit; + f:=pinputfile(hp^.sourcefiles^.files); + while assigned(f) do + begin + if f^.ref_index=fileindex then + begin + get_source_file:=f; + exit; + end; + f:=pinputfile(f^.ref_next); + end; + end; + + +{**************************************************************************** + TLinkContainerItem + ****************************************************************************} + +{$IFDEF NEWST} +constructor TLinkItem.Init(const s:string;m:longint); +begin + inherited Init; + data:=stringdup(s); + needlink:=m; +end; + + +destructor TLinkItem.Done; +begin + stringdispose(data); +end; +{$ELSE} +constructor TLinkContainerItem.Init(const s:string;m:longint); +begin + inherited Init; + data:=stringdup(s); + needlink:=m; +end; + + +destructor TLinkContainerItem.Done; +begin + stringdispose(data); +end; +{$ENDIF NEWST} + + +{**************************************************************************** + TLinkContainer + ****************************************************************************} + + {$IFNDEF NEWST} + constructor TLinkContainer.Init; + begin + inherited init; + end; + + + procedure TLinkContainer.insert(const s : string;m:longint); + var + newnode : plinkcontaineritem; + begin + {if find(s) then + exit; } + new(newnode,init(s,m)); + inherited insert(newnode); + end; + + + function TLinkContainer.get(var m:longint) : string; + var + p : plinkcontaineritem; + begin + p:=plinkcontaineritem(inherited get); + if p=nil then + begin + get:=''; + m:=0; + exit; + end; + get:=p^.data^; + m:=p^.needlink; + dispose(p,done); + end; + + + function TLinkContainer.getusemask(mask:longint) : string; + var + p : plinkcontaineritem; + found : boolean; + begin + found:=false; + repeat + p:=plinkcontaineritem(inherited get); + if p=nil then + begin + getusemask:=''; + exit; + end; + getusemask:=p^.data^; + found:=(p^.needlink and mask)<>0; + dispose(p,done); + until found; + end; + + + function TLinkContainer.find(const s:string):boolean; + var + newnode : plinkcontaineritem; + begin + find:=false; + newnode:=plinkcontaineritem(root); + while assigned(newnode) do + begin + if newnode^.data^=s then + begin + find:=true; + exit; + end; + newnode:=plinkcontaineritem(newnode^.next); + end; + end; + {$ENDIF NEWST} + + + +{**************************************************************************** + TMODULE + ****************************************************************************} + + procedure tmodule.setfilename(const fn:string;allowoutput:boolean); + var + p : dirstr; + n : NameStr; + e : ExtStr; + begin + stringdispose(objfilename); + stringdispose(asmfilename); + stringdispose(ppufilename); + stringdispose(staticlibfilename); + stringdispose(sharedlibfilename); + stringdispose(exefilename); + stringdispose(outputpath); + stringdispose(path); + { Create names } + fsplit(fn,p,n,e); + n:=FixFileName(n); + { set path } + path:=stringdup(FixPath(p,false)); + { obj,asm,ppu names } + p:=path^; + if AllowOutput then + begin + if (OutputUnitDir<>'') then + p:=OutputUnitDir + else + if (OutputExeDir<>'') then + p:=OutputExeDir; + end; + outputpath:=stringdup(p); + objfilename:=stringdup(p+n+target_info.objext); + asmfilename:=stringdup(p+n+target_info.asmext); + ppufilename:=stringdup(p+n+target_info.unitext); + { lib and exe could be loaded with a file specified with -o } + if AllowOutput and (OutputFile<>'') and (compile_level=1) then + n:=OutputFile; + staticlibfilename:=stringdup(p+target_os.libprefix+n+target_os.staticlibext); + if target_info.target=target_i386_WIN32 then + sharedlibfilename:=stringdup(p+n+target_os.sharedlibext) + else + sharedlibfilename:=stringdup(p+target_os.libprefix+n+target_os.sharedlibext); + { output dir of exe can be specified separatly } + if AllowOutput and (OutputExeDir<>'') then + p:=OutputExeDir + else + p:=path^; + exefilename:=stringdup(p+n+target_info.exeext); + end; + + + function tmodule.openppu:boolean; + var + objfiletime, + ppufiletime, + asmfiletime : longint; + begin + openppu:=false; + Message1(unit_t_ppu_loading,ppufilename^); + { Get ppufile time (also check if the file exists) } + ppufiletime:=getnamedfiletime(ppufilename^); + if ppufiletime=-1 then + exit; + { Open the ppufile } + Message1(unit_u_ppu_name,ppufilename^); + ppufile:=new(pppufile,init(ppufilename^)); + ppufile^.change_endian:=source_os.endian<>target_os.endian; + if not ppufile^.open then + begin + dispose(ppufile,done); + Message(unit_u_ppu_file_too_short); + exit; + end; + { check for a valid PPU file } + if not ppufile^.CheckPPUId then + begin + dispose(ppufile,done); + Message(unit_u_ppu_invalid_header); + exit; + end; + { check for allowed PPU versions } + if not (ppufile^.GetPPUVersion = CurrentPPUVersion) then + begin + dispose(ppufile,done); + Message1(unit_u_ppu_invalid_version,tostr(ppufile^.GetPPUVersion)); + exit; + end; + { check the target processor } + if ttargetcpu(ppufile^.header.cpu)<>target_cpu then + begin + dispose(ppufile,done); + Message(unit_u_ppu_invalid_processor); + exit; + end; + { check target } + if ttarget(ppufile^.header.target)<>target_info.target then + begin + dispose(ppufile,done); + Message(unit_u_ppu_invalid_target); + exit; + end; + { Load values to be access easier } + flags:=ppufile^.header.flags; + crc:=ppufile^.header.checksum; + interface_crc:=ppufile^.header.interface_checksum; + { Show Debug info } + Message1(unit_u_ppu_time,filetimestring(ppufiletime)); + Message1(unit_u_ppu_flags,tostr(flags)); + Message1(unit_u_ppu_crc,tostr(ppufile^.header.checksum)); + Message1(unit_u_ppu_crc,tostr(ppufile^.header.interface_checksum)+' (intfc)'); + { check the object and assembler file to see if we need only to + assemble, only if it's not in a library } + do_compile:=false; + if (flags and uf_in_library)=0 then + begin + if (flags and uf_smart_linked)<>0 then + begin + objfiletime:=getnamedfiletime(staticlibfilename^); + Message2(unit_u_check_time,staticlibfilename^,filetimestring(objfiletime)); + if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then + begin + recompile_reason:=rr_libolder; + Message(unit_u_recompile_staticlib_is_older); + do_compile:=true; + exit; + end; + end; + if (flags and uf_static_linked)<>0 then + begin + { the objectfile should be newer than the ppu file } + objfiletime:=getnamedfiletime(objfilename^); + Message2(unit_u_check_time,objfilename^,filetimestring(objfiletime)); + if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then + begin + { check if assembler file is older than ppu file } + asmfileTime:=GetNamedFileTime(asmfilename^); + Message2(unit_u_check_time,asmfilename^,filetimestring(asmfiletime)); + if (asmfiletime<0) or (ppufiletime>asmfiletime) then + begin + Message(unit_u_recompile_obj_and_asm_older); + recompile_reason:=rr_objolder; + do_compile:=true; + exit; + end + else + begin + Message(unit_u_recompile_obj_older_than_asm); + if not(cs_asm_extern in aktglobalswitches) then + begin + do_compile:=true; + recompile_reason:=rr_asmolder; + exit; + end; + end; + end; + end; + end; + openppu:=true; + end; + + + function tmodule.search_unit(const n : string;onlysource:boolean):boolean; + var + singlepathstring, + filename : string; + + Function UnitExists(const ext:string):boolean; + begin + Message1(unit_t_unitsearch,Singlepathstring+filename+ext); + UnitExists:=FileExists(Singlepathstring+FileName+ext); + end; + + Function PPUSearchPath(const s:string):boolean; + var + found : boolean; + begin + Found:=false; + singlepathstring:=FixPath(s,false); + { Check for PPU file } + Found:=UnitExists(target_info.unitext); + if Found then + Begin + SetFileName(SinglePathString+FileName,false); + Found:=OpenPPU; + End; + PPUSearchPath:=Found; + end; + + Function SourceSearchPath(const s:string):boolean; + var + found : boolean; + ext : string[8]; + begin + Found:=false; + singlepathstring:=FixPath(s,false); + { Check for Sources } + ppufile:=nil; + do_compile:=true; + recompile_reason:=rr_noppu; + {Check for .pp file} + Found:=UnitExists(target_os.sourceext); + if Found then + Ext:=target_os.sourceext + else + begin + {Check for .pas} + Found:=UnitExists(target_os.pasext); + if Found then + Ext:=target_os.pasext; + end; + stringdispose(mainsource); + if Found then + begin + sources_avail:=true; + {Load Filenames when found} + mainsource:=StringDup(SinglePathString+FileName+Ext); + SetFileName(SinglePathString+FileName,false); + end + else + sources_avail:=false; + SourceSearchPath:=Found; + end; + + Function SearchPath(const s:string):boolean; + var + found : boolean; + begin + { First check for a ppu, then for the source } + found:=false; + if not onlysource then + found:=PPUSearchPath(s); + if not found then + found:=SourceSearchPath(s); + SearchPath:=found; + end; + + Function SearchPathList(list:TSearchPathList):boolean; + var + hp : PStringQueueItem; + found : boolean; + begin + found:=false; + hp:=list.First; + while assigned(hp) do + begin + found:=SearchPath(hp^.data^); + if found then + break; + hp:=hp^.next; + end; + SearchPathList:=found; + end; + + var + fnd : boolean; + begin + filename:=FixFileName(n); + { try to find unit + 1. look for ppu in cwd + 2. look for ppu in outputpath if set, this is tp7 compatible (PFV) + 3. look for source in cwd + 4. local unit pathlist + 5. global unit pathlist } + fnd:=false; + if not onlysource then + begin + fnd:=PPUSearchPath('.'); + if (not fnd) and (current_module^.outputpath^<>'') then + fnd:=PPUSearchPath(current_module^.outputpath^); + end; + if (not fnd) then + fnd:=SourceSearchPath('.'); + if (not fnd) then + fnd:=SearchPathList(current_module^.LocalUnitSearchPath); + if (not fnd) then + fnd:=SearchPathList(UnitSearchPath); + + { try to find a file with the first 8 chars of the modulename, like + dos } + if (not fnd) and (length(filename)>8) then + begin + filename:=copy(filename,1,8); + fnd:=SearchPath('.'); + if (not fnd) then + fnd:=SearchPathList(current_module^.LocalUnitSearchPath); + if not fnd then + fnd:=SearchPathList(UnitSearchPath); + end; + search_unit:=fnd; + end; + + + + procedure tmodule.reset; + var + pm : pdependent_unit; + begin + if assigned(scanner) then + pscannerfile(scanner)^.invalid:=true; + if assigned(globalsymtable) then + begin + dispose(punitsymtable(globalsymtable),done); + globalsymtable:=nil; + end; + if assigned(localsymtable) then + begin + dispose(punitsymtable(localsymtable),done); + localsymtable:=nil; + end; + if assigned(map) then + begin + dispose(map); + map:=nil; + end; + if assigned(ppufile) then + begin + dispose(ppufile,done); + ppufile:=nil; + end; + sourcefiles^.done; + sourcefiles^.init; + imports^.done; + imports^.init; + _exports^.done; + _exports^.init; + used_units.done; + used_units.init; + { all units that depend on this one must be recompiled ! } + pm:=pdependent_unit(dependent_units.first); + while assigned(pm) do + begin + if pm^.u^.in_second_compile then + Comment(v_debug,'No reload already in second compile: '+pm^.u^.modulename^) + else + begin + pm^.u^.do_reload:=true; + Comment(v_debug,'Reloading '+pm^.u^.modulename^+' needed because '+modulename^+' is reloaded'); + end; + pm:=pdependent_unit(pm^.next); + end; + dependent_units.done; + dependent_units.init; + resourcefiles.done; + resourcefiles.init; + linkunitofiles.done; + linkunitofiles.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkunitstaticlibs.done; + linkunitstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkunitsharedlibs.done; + linkunitsharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkotherofiles.done; + linkotherofiles.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkotherstaticlibs.done; + linkotherstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkothersharedlibs.done; + linkothersharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + uses_imports:=false; + do_assemble:=false; + do_compile:=false; + { sources_avail:=true; + should not be changed PM } + compiled:=false; + in_implementation:=false; + in_global:=true; + {loaded_from:=nil; + should not be changed PFV } + flags:=0; + crc:=0; + interface_crc:=0; + unitcount:=1; + recompile_reason:=rr_unknown; + end; + + + constructor tmodule.init(const s:string;_is_unit:boolean); + var + p : dirstr; + n : namestr; + e : extstr; + begin + FSplit(s,p,n,e); + { Programs have the name program to don't conflict with dup id's } + if _is_unit then +{$ifdef UNITALIASES} + modulename:=stringdup(GetUnitAlias(Upper(n))) +{$else} + modulename:=stringdup(Upper(n)) +{$endif} + else + modulename:=stringdup('PROGRAM'); + mainsource:=stringdup(s); + ppufilename:=nil; + objfilename:=nil; + asmfilename:=nil; + staticlibfilename:=nil; + sharedlibfilename:=nil; + exefilename:=nil; + { Dos has the famous 8.3 limit :( } +{$ifdef SHORTASMPREFIX} + asmprefix:=stringdup(FixFileName('as')); +{$else} + asmprefix:=stringdup(FixFileName(n)); +{$endif} + outputpath:=nil; + path:=nil; + setfilename(p+n,true); + localunitsearchpath.init; + localobjectsearchpath.init; + localincludesearchpath.init; + locallibrarysearchpath.init; + used_units.init; + dependent_units.init; + new(sourcefiles,init); + resourcefiles.init; + linkunitofiles.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkunitstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkunitsharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkotherofiles.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkotherstaticlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + linkothersharedlibs.init{$IFDEF NEWST}(8,4){$ENDIF}; + ppufile:=nil; + scanner:=nil; + map:=nil; + globalsymtable:=nil; + localsymtable:=nil; + loaded_from:=nil; + flags:=0; + crc:=0; + interface_crc:=0; + do_reload:=false; + unitcount:=1; + inc(global_unit_count); + unit_index:=global_unit_count; + do_assemble:=false; + do_compile:=false; + sources_avail:=true; + sources_checked:=false; + compiled:=false; + recompile_reason:=rr_unknown; + in_second_load:=false; + in_compile:=false; + in_second_compile:=false; + in_implementation:=false; + in_global:=true; + is_unit:=_is_unit; + islibrary:=false; + uses_imports:=false; + imports:=new(plinkedlist,init); + _exports:=new(plinkedlist,init); + { search the PPU file if it is an unit } + if is_unit then + begin + search_unit(modulename^,false); + { it the sources_available is changed then we know that + the sources aren't available } + if not sources_avail then + sources_checked:=true; + end; + end; + + + destructor tmodule.done; +{$ifdef MEMDEBUG} + var + d : tmemdebug; +{$endif} + begin + if assigned(map) then + dispose(map); + if assigned(ppufile) then + dispose(ppufile,done); + ppufile:=nil; + if assigned(imports) then + dispose(imports,done); + imports:=nil; + if assigned(_exports) then + dispose(_exports,done); + _exports:=nil; + if assigned(scanner) then + pscannerfile(scanner)^.invalid:=true; + if assigned(sourcefiles) then + dispose(sourcefiles,done); + sourcefiles:=nil; + used_units.done; + dependent_units.done; + resourcefiles.done; + linkunitofiles.done; + linkunitstaticlibs.done; + linkunitsharedlibs.done; + linkotherofiles.done; + linkotherstaticlibs.done; + linkothersharedlibs.done; + stringdispose(objfilename); + stringdispose(asmfilename); + stringdispose(ppufilename); + stringdispose(staticlibfilename); + stringdispose(sharedlibfilename); + stringdispose(exefilename); + stringdispose(outputpath); + stringdispose(path); + stringdispose(modulename); + stringdispose(mainsource); + stringdispose(asmprefix); + localunitsearchpath.done; + localobjectsearchpath.done; + localincludesearchpath.done; + locallibrarysearchpath.done; +{$ifdef MEMDEBUG} + d.init('symtable'); +{$endif} + if assigned(globalsymtable) then + dispose(punitsymtable(globalsymtable),done); + globalsymtable:=nil; + if assigned(localsymtable) then + dispose(punitsymtable(localsymtable),done); + localsymtable:=nil; +{$ifdef MEMDEBUG} + d.done; +{$endif} + inherited done; + end; + + +{**************************************************************************** + TUSED_UNIT + ****************************************************************************} + + constructor tused_unit.init(_u : pmodule;intface:boolean); + begin + u:=_u; + in_interface:=intface; + in_uses:=false; + is_stab_written:=false; + loaded:=true; + name:=stringdup(_u^.modulename^); + checksum:=_u^.crc; + interface_checksum:=_u^.interface_crc; + unitid:=0; + end; + + + constructor tused_unit.init_to_load(const n:string;c,intfc:longint;intface:boolean); + begin + u:=nil; + in_interface:=intface; + in_uses:=false; + is_stab_written:=false; + loaded:=false; + name:=stringdup(n); + checksum:=c; + interface_checksum:=intfc; + unitid:=0; + end; + + + destructor tused_unit.done; + begin + stringdispose(name); + inherited done; + end; + + +{**************************************************************************** + TDENPENDENT_UNIT + ****************************************************************************} + + constructor tdependent_unit.init(_u : pmodule); + begin + u:=_u; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.119 2000/07/03 21:08:54 pierre + * fix for bug 1025 + + Revision 1.118 2000/06/15 18:10:11 peter + * first look for ppu in cwd and outputpath and after that for source + in cwd + * fixpath() for not linux makes path now lowercase so comparing paths + with different cases (sometimes a drive letter could be + uppercased) gives the expected results + * sources_checked flag if there was already a full search for sources + which aren't found, so another scan isn't done when checking for the + sources only when recompile is needed + + Revision 1.117 2000/02/28 17:23:56 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.116 2000/02/24 18:41:38 peter + * removed warnings/notes + + Revision 1.115 2000/02/10 16:00:23 peter + * dont' check for ppl files as they aren't used atm. + + Revision 1.114 2000/02/09 13:22:52 peter + * log truncated + + Revision 1.113 2000/01/11 09:52:06 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.112 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.111 1999/12/08 01:01:11 peter + * fixed circular unit reference checking. loaded_from was reset after + reseting a unit, so no loaded_from info was available anymore. + + Revision 1.110 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.109 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.108 1999/11/06 14:34:20 peter + * truncated log to 20 revs + + Revision 1.107 1999/11/04 23:13:25 peter + * moved unit alias support into ifdef + + Revision 1.106 1999/11/04 10:54:02 peter + + -Ua= unit alias support + + Revision 1.105 1999/10/28 13:14:00 pierre + * allow doubles in TLinkContainer needed for double libraries + + Revision 1.104 1999/09/27 23:40:12 peter + * fixed macro within macro endless-loop + + Revision 1.103 1999/09/16 08:00:50 pierre + + compiled_module to avoid wrong file info when load PPU files + + Revision 1.102 1999/08/31 15:51:10 pierre + * in_second_compile cleaned up, in_compile and in_second_load added + + Revision 1.101 1999/08/27 10:43:20 pierre + + interface CRC check with ifdef Test_double_checksum added + + Revision 1.100 1999/08/24 13:14:01 peter + * MEMDEBUG to see the sizes of asmlist,asmsymbols,symtables + +} \ No newline at end of file diff --git a/befpc/compiler/fpc.pas b/befpc/compiler/fpc.pas new file mode 100644 index 0000000..7dc2675 --- /dev/null +++ b/befpc/compiler/fpc.pas @@ -0,0 +1,87 @@ +{ + $Id: fpc.pas,v 1.1.1.1 2001-07-23 17:16:24 memson Exp $ + Copyright (c) 2000 by Florian Klaempfl + + This file is the "loader" for the Free Pascal compiler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} +program fpc; + + uses +{$ifdef go32v2} + dpmiexcp, +{$endif go32v2} + dos; + + procedure error(const s : string); + + begin + writeln('Error: ',s); + halt(1); + end; + + var + ppccommandline,processorpostfix,processorstr : string; + i : longint; + + begin + ppccommandline:=''; +{$ifdef i386} + processorpostfix:='386'; +{$endif i386} +{$ifdef m68k} + processorpostfix:='386'; +{$endif m68k} +{$ifdef alpha} + processorpostfix:='alpha'; +{$endif alpha} +{$ifdef powerpc} + processorpostfix:='powerpc'; +{$endif powerpc} + for i:=1 to paramcount do + begin + if pos('-P',paramstr(i))=1 then + begin + processorstr:=copy(paramstr(i),3,length(paramstr(i))-2); + if processorstr='i386' then + processorpostfix:='386' + else if processorstr='m68k' then + processorpostfix:='68k' + else if processorstr='alpha' then + processorpostfix:='alpha' + else if processorstr='powerpc' then + processorpostfix:='ppc' + else error('Illegal processor type'); + end + else + ppccommandline:=ppccommandline+paramstr(i)+' '; + end; + + { ppcXXX is expected to be in the same directory } + swapvectors; + exec('ppc'+processorpostfix,ppccommandline); + swapvectors; + if doserror<>0 then + error('ppc'+processorpostfix+' can''t be executed'); + halt(dosexitcode); + end. +{ + $Log: not supported by cvs2svn $ + Revision 1.1 2000/07/07 17:07:20 florian + + initial revision + +} diff --git a/befpc/compiler/gdb.pas b/befpc/compiler/gdb.pas new file mode 100644 index 0000000..210b560 --- /dev/null +++ b/befpc/compiler/gdb.pas @@ -0,0 +1,272 @@ +{ + $Id: gdb.pas,v 1.1.1.1 2001-07-23 17:16:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This units contains special support for the GDB + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit gdb; + + interface + + uses + globtype,cpubase, + strings,cobjects,globals,aasm; + + {stab constants } +Const + N_GSYM = $20; + N_STSYM = 38; {initialized const } + N_LCSYM = 40; {non initialized variable} + N_Function = $24; {function or const } + N_TextLine = $44; + N_DataLine = $46; + N_BssLine = $48; + N_RSYM = $40; { register variable } + N_LSYM = $80; + N_PSYM = 160; + N_SourceFile = $64; + N_IncludeFile = $84; + N_BINCL = $82; + N_EINCL = $A2; + N_EXCL = $C2; + + type + pai_stabs = ^tai_stabs; + + tai_stabs = object(tai) + str : pchar; + constructor init(_str : pchar); + destructor done; virtual; + end; + + pai_stabn = ^tai_stabn; + + tai_stabn = object(tai) + str : pchar; + constructor init(_str : pchar); + destructor done; virtual; + end; + + { insert a cut to split into several smaller files } + pai_force_line = ^tai_force_line; + tai_force_line = object(tai) + constructor init; + end; + + pai_stab_function_name = ^tai_stab_function_name; + + tai_stab_function_name = object(tai) + str : pchar; + constructor init(_str : pchar); + destructor done; virtual; + end; + + const + DBX_counter : plongint = nil; + do_count_dbx : boolean = false; + +{$ifdef i386} + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", + "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB } + GDB_i386index : array[tregister] of shortint =(-1, + 0,1,2,3,4,5,6,7,0,1,2,3,4,5,7,0,1,2,3,0,1,2,3, + -1,10,12,13,14,15,11, + -1,-1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1, + -1,-1,-1,-1, + -1,-1,-1,-1,-1, + { I think, GDB doesn't know MMX (FK) } + -1,-1,-1,-1,-1,-1,-1,-1, + -1,-1,-1,-1,-1,-1,-1,-1 + ); +{$endif i386} + + implementation + + uses + verbose; +{ to use N_EXCL we have to count the character in the stabs for +N_BINCL to N_EINCL + Code comes from stabs.c for ld + if (type == N_BINCL) + ( + bfd_vma val; + int nest; + bfd_byte *incl_sym; + struct stab_link_includes_entry *incl_entry; + struct stab_link_includes_totals *t; + struct stab_excl_list *ne; + + val = 0; + nest = 0; + for (incl_sym = sym + STABSIZE; + incl_sym < symend; + incl_sym += STABSIZE) + ( + int incl_type; + + incl_type = incl_sym[TYPEOFF]; + if (incl_type == 0) + break; + else if (incl_type == N_EINCL) + ( + if (nest == 0) + break; + --nest; + ) + else if (incl_type == N_BINCL) + ++nest; + else if (nest == 0) + ( + const char *str; + + str = ((char *) stabstrbuf + + stroff + + bfd_get_32 (abfd, incl_sym + STRDXOFF)); + for (; *str != '\0'; str++) + ( + val += *str; + if *str == '(' + ( + Skip the file number. + ++str; + while (isdigit ((unsigned char) *str)) + ++str; + --str; + ) + ) + ) + ) } + + + procedure count_dbx(st : pchar); + var i : longint; + do_count : boolean; + begin + do_count := false; + if assigned(dbx_counter) then + begin +{$IfDef ExtDebugDbx } + Comment(V_Info,'Counting '+st); + Comment(V_Info,'count = '+tostr(dbx_counter^)); + Comment(V_Info,'addr = '+tostr(longint(dbx_counter))); +{$EndIf ExtDebugDbx } + i:=0; + while i<=strlen(st) do + begin + if st[i] = '"' then + if do_count then exit + else do_count := true + else + if do_count then + begin + dbx_counter^ := dbx_counter^+byte(st[i]); + { skip file number } + if st[i] = '(' then + begin + inc(i); + while st[i] in ['0'..'9'] do inc(i); + dec(i); + end; + end; + inc(i); + end; + end; + end; + + + constructor tai_stabs.init(_str : pchar); + + begin + inherited init; + typ:=ait_stabs; + str:=_str; + if do_count_dbx then + begin + count_dbx(str); + end; + end; + + destructor tai_stabs.done; + + begin + strdispose(str); + inherited done; + end; + + constructor tai_stabn.init(_str : pchar); + + begin + inherited init; + typ:=ait_stabn; + str:=_str; + end; + + destructor tai_stabn.done; + + begin + strdispose(str); + inherited done; + end; + + constructor tai_force_line.init; + + begin + inherited init; + typ:=ait_force_line; + end; + + constructor tai_stab_function_name.init(_str : pchar); + + begin + inherited init; + typ:=ait_stab_function_name; + str:=_str; + end; + + destructor tai_stab_function_name.done; + + begin + strdispose(str); + inherited done; + end; +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.17 2000/05/12 05:57:34 pierre + * * get it to compile with Delphi by Kovacs Attila Zoltan + + Revision 1.16 2000/05/11 09:40:11 pierre + * some DBX changes but it still does not work ! + + Revision 1.15 2000/02/09 13:22:52 peter + * log truncated + + Revision 1.14 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.13 1999/11/09 23:51:25 pierre + * some DBX work + + Revision 1.12 1999/08/04 00:23:01 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/gendef.pas b/befpc/compiler/gendef.pas new file mode 100644 index 0000000..4b9d8c5 --- /dev/null +++ b/befpc/compiler/gendef.pas @@ -0,0 +1,179 @@ +{ + $Id: gendef.pas,v 1.1.1.1 2001-07-23 17:16:25 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Generation of a .def file for needed for Os2/Win32 + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit gendef; +interface +uses cobjects; + +type + pdeffile=^tdeffile; + tdeffile=object + fname : string; + constructor init(const fn:string); + destructor done; + procedure addexport(const s:string); + procedure addimport(const s:string); + procedure writefile; + function empty : boolean; + private + is_empty : boolean; + WrittenOnDisk : boolean; + exportlist, + importlist : tstringcontainer; + end; +var + deffile : tdeffile; + + +implementation + +uses + systems,globtype,globals; + +{****************************************************************************** + TDefFile +******************************************************************************} + +constructor tdeffile.init(const fn:string); +begin + fname:=fn; + WrittenOnDisk:=false; + is_empty:=true; + importlist.init; + exportlist.init; +end; + + +destructor tdeffile.done; +var + f : file; +begin + if WrittenOnDisk and + not(cs_link_extern in aktglobalswitches) then + begin + assign(f,fname); + {$I-} + erase(f); + {$I+} + if ioresult<>0 then; + end; + importlist.done; + exportlist.done; +end; + + + +procedure tdeffile.addexport(const s:string); +begin + exportlist.insert(s); + is_empty:=false; +end; + + +procedure tdeffile.addimport(const s:string); +begin + importlist.insert(s); + is_empty:=false; +end; + +function tdeffile.empty : boolean; +begin + empty:=is_empty and (description=''); +end; + + + +procedure tdeffile.writefile; +var + t : text; +begin + If WrittenOnDisk then + Exit; +{ open file } + assign(t,fname); + {$I+} + rewrite(t); + {$I-} + if ioresult<>0 then + exit; +{$ifdef i386} + case target_info.target of + target_i386_Os2 : + begin + write(t,'NAME '+inputfile); + if usewindowapi then + write(t,' WINDOWAPI'); + writeln(t,''); + writeln(t,'PROTMODE'); + writeln(t,'DESCRIPTION '+''''+description+''''); + writeln(t,'DATA'#9'MULTIPLE'); + writeln(t,'STACKSIZE'#9+tostr(stacksize)); + writeln(t,'HEAPSIZE'#9+tostr(heapsize)); + end; + target_i386_win32 : + begin + if description<>'' then + writeln(t,'DESCRIPTION '+''''+description+''''); + if dllversion<>'' then + writeln(t,'VERSION '+dllversion); + end; + end; +{$endif} + +{write imports} + if not importlist.empty then + begin + writeln(t,''); + writeln(t,'IMPORTS'); + while not importlist.empty do + writeln(t,#9+importlist.get); + end; + +{write exports} + if not exportlist.empty then + begin + writeln(t,''); + writeln(t,'EXPORTS'); + while not exportlist.empty do + writeln(t,#9+exportlist.get); + end; + + close(t); + WrittenOnDisk:=true; +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.6 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.5 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.4 1999/12/20 23:23:28 pierre + + $description $version + +} diff --git a/befpc/compiler/globals.pas b/befpc/compiler/globals.pas new file mode 100644 index 0000000..e2e0f96 --- /dev/null +++ b/befpc/compiler/globals.pas @@ -0,0 +1,1773 @@ +{ + $Id: globals.pas,v 1.1.1.1 2001-07-23 17:16:26 memson Exp $ + Copyright (C) 1998-2000 by Florian Klaempfl + + This unit implements some support functions and global variables + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} + +{$ifdef tp} + {$E+,N+} +{$endif} + +{$ifdef linux} + {$define linux_or_beos} +{$endif} +{$ifdef beos} + {$define linux_or_beos} +{$endif} + + +unit globals; + + interface + + uses +{$ifdef win32} + windows, +{$endif} +{$ifdef linux} + linux, +{$endif} +{$ifdef beos} + beos, +{$endif} +{$ifdef Delphi} + sysutils, + dmisc, +{$else} + strings,dos, +{$endif} +{$ifdef TP} + objects, +{$endif} + globtype,version,tokens,systems,cobjects; + + const +{$ifdef linux} + DirSep = '/'; +{$else} + {$ifdef beos} + DirSep = '/'; + {$else} + {$ifdef amiga} + DirSep = '/'; + {$else} + DirSep = '\'; + {$endif} + {$endif} +{$endif} + +{$ifdef Splitheap} + testsplit : boolean = false; +{$endif Splitheap} + + delphimodeswitches : tmodeswitches= + [m_delphi,m_tp,m_all,m_class,m_objpas,m_result,m_string_pchar, + m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring]; + fpcmodeswitches : tmodeswitches= + [m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward, + m_cvar_support,m_initfinal,m_add_pointer]; + objfpcmodeswitches : tmodeswitches= + [m_objfpc,m_fpc,m_all,m_class,m_objpas,m_result,m_string_pchar,m_nested_comment, + m_repeat_forward,m_cvar_support,m_initfinal,m_add_pointer]; + tpmodeswitches : tmodeswitches= + [m_tp7,m_tp,m_all,m_tp_procvar]; + gpcmodeswitches : tmodeswitches= + [m_gpc,m_all]; + + type + TSearchPathList = object(TStringQueue) + procedure AddPath(s:string;addfirst:boolean); + procedure AddList(list:TSearchPathList;addfirst:boolean); + function FindFile(const f : string;var b : boolean) : string; + end; + + var + { specified inputfile } + inputdir : dirstr; + inputfile : namestr; + inputextension : extstr; + { specified outputfile with -o parameter } + outputfile : namestr; + { specified with -FE or -FU } + outputexedir : dirstr; + outputunitdir : dirstr; + + { things specified with parameters } + paralinkoptions, + paradynamiclinker : string; + parapreprocess : boolean; + + { directory where the utils can be found (options -FD) } + utilsdirectory : dirstr; + + { some flags for global compiler switches } + do_build, + do_make : boolean; + not_unit_proc : boolean; + { path for searching units, different paths can be seperated by ; } + exepath : dirstr; { Path to ppc } + librarysearchpath, + unitsearchpath, + objectsearchpath, + includesearchpath : TSearchPathList; + + { deffile } + usewindowapi : boolean; + description : string; + dllversion : string; + dllmajor,dllminor : word; + + { current position } + token, { current token being parsed } + idtoken : ttoken; { holds the token if the pattern is a known word } + tokenpos, { last postion of the read token } + aktfilepos : tfileposinfo; { current position } + + { type of currently parsed block } + { isn't full implemented (FK) } + block_type : tblock_type; + + in_args : boolean; { arguments must be checked especially } + parsing_para_level : longint; { parameter level, used to convert + proc calls to proc loads in firstcalln } + { Must_be_valid : boolean; should the variable already have a value + obsolete replace by set_varstate function } + compile_level : word; + make_ref : boolean; + resolving_forward : boolean; { used to add forward reference as second ref } + use_esp_stackframe : boolean; { to test for call with ESP as stack frame } + inlining_procedure : boolean; { are we inlining a procedure } + +{$ifdef TP} + use_big : boolean; +{$endif} + + { commandline values } + initdefines : tlinkedlist; + initglobalswitches : tglobalswitches; + initmoduleswitches : tmoduleswitches; + initlocalswitches : tlocalswitches; + initmodeswitches : tmodeswitches; + {$IFDEF testvarsets} + Initsetalloc, {0=fixed, 1 =var} + {$ENDIF} + initpackenum : longint; + initpackrecords : tpackrecords; + initoutputformat : tasm; + initoptprocessor, + initspecificoptprocessor : tprocessors; + initasmmode : tasmmode; + { current state values } + aktglobalswitches : tglobalswitches; + aktmoduleswitches : tmoduleswitches; + aktlocalswitches : tlocalswitches; + nextaktlocalswitches : tlocalswitches; + localswitcheschanged : boolean; + aktmodeswitches : tmodeswitches; + {$IFDEF testvarsets} + aktsetalloc, + {$ENDIF} + aktpackenum : longint; + aktmaxfpuregisters: longint; + aktpackrecords : tpackrecords; + aktoutputformat : tasm; + aktoptprocessor, + aktspecificoptprocessor : tprocessors; + aktasmmode : tasmmode; + + { Memory sizes } + heapsize, + maxheapsize, + stacksize : longint; + +{$Ifdef EXTDEBUG} + total_of_firstpass, + firstpass_several : longint; +{$ifdef FPC} + EntryMemUsed : longint; +{$endif FPC} + { parameter switches } + debugstop, + only_one_pass : boolean; +{$EndIf EXTDEBUG} + { windows application type } + apptype : tapptype; + + const + RelocSection : boolean = true; + RelocSectionSetExplicitly : boolean = false; + LinkTypeSetExplicitly : boolean = false; + DLLsource : boolean = false; + DLLImageBase : pstring = nil; + UseDeffileForExport : boolean = true; + ForceDeffileForExport : boolean = false; + + { used to set all registers used for each global function + this should dramatically decrease the number of + recompilations needed PM } + simplify_ppu : boolean = false; + + { should we allow non static members ? } + allow_only_static : boolean = false; + + Inside_asm_statement : boolean = false; + + { for error info in pp.pas } + const + parser_current_file : string = ''; + +{$ifdef debug} + { if the pointer don't point to the heap then write an error } + function assigned(p : pointer) : boolean; +{$endif} + function min(a,b : longint) : longint; + function max(a,b : longint) : longint; + function align(i,a:longint):longint; + function align_from_size(datasize:longint;length:longint):longint; + procedure Replace(var s:string;s1:string;const s2:string); + procedure ReplaceCase(var s:string;const s1,s2:string); + function upper(const s : string) : string; + function lower(const s : string) : string; + function trimspace(const s:string):string; + {$ifdef FPC} + function tostru(i:cardinal) : string; + {$else} + function tostru(i:longint) : string; + {$endif} + procedure uppervar(var s : string); + function hexstr(val : longint;cnt : byte) : string; + function tostr(i : longint) : string; + function tostr_with_plus(i : longint) : string; + procedure valint(S : string;var V : longint;var code : integer); + function is_number(const s : string) : boolean; + function ispowerof2(value : longint;var power : longint) : boolean; + { enable ansistring comparison } + function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint; + function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar; + function bstoslash(const s : string) : string; + procedure abstract; + + function getdatestr:string; + function gettimestr:string; + function filetimestring( t : longint) : string; + + procedure DefaultReplacements(var s:string); + function GetCurrentDir:string; + function path_absolute(const s : string) : boolean; + Function PathExists ( F : String) : Boolean; + Function FileExists ( Const F : String) : Boolean; + Function RemoveFile(const f:string):boolean; + Function RemoveDir(d:string):boolean; + Function GetFileTime ( Var F : File) : Longint; + Function GetNamedFileTime ( Const F : String) : Longint; + Function SplitPath(const s:string):string; + Function SplitFileName(const s:string):string; + Function SplitName(const s:string):string; + Function SplitExtension(Const HStr:String):String; + Function AddExtension(Const HStr,ext:String):String; + Function ForceExtension(Const HStr,ext:String):String; + Function FixPath(s:string;allowdot:boolean):string; + function FixFileName(const s:string):string; + procedure SplitBinCmd(const s:string;var bstr,cstr:string); + procedure SynchronizeFileTime(const fn1,fn2:string); + function FindFile(const f : string;path : string;var b : boolean) : string; + function FindExe(bin:string;var found:boolean):string; + function GetShortName(const n:string):string; + + Procedure Shell(const command:string); + function GetEnvPChar(const envname:string):pchar; + procedure FreeEnvPChar(p:pchar); + + procedure InitGlobals; + procedure DoneGlobals; + + +implementation + + uses + comphook; + + procedure abstract; + begin + do_internalerror(255); + end; + + + function ngraphsearchvalue(const s1,s2 : string) : double; + const + n = 3; + var + equals,i,j : longint; + hs : string; + begin + equals:=0; + { is the string long enough ? } + if min(length(s1),length(s2))-n+1<1 then + begin + ngraphsearchvalue:=0.0; + exit; + end; + for i:=1 to length(s1)-n+1 do + begin + hs:=copy(s1,i,n); + for j:=1 to length(s2)-n+1 do + if hs=copy(s2,j,n) then + inc(equals); + end; +{$ifdef fpc} + ngraphsearchvalue:=equals/double(max(length(s1),length(s2))-n+1); +{$else} + ngraphsearchvalue:=equals/(max(length(s1),length(s2))-n+1); +{$endif} + end; + + + function bstoslash(const s : string) : string; + { + return string s with all \ changed into / + } + var + i : longint; + begin + for i:=1to length(s) do + if s[i]='\' then + bstoslash[i]:='/' + else + bstoslash[i]:=s[i]; + {$ifndef TP} + {$ifopt H+} + setlength(bstoslash,length(s)); + {$else} + bstoslash[0]:=s[0]; + {$endif} + {$else} + bstoslash[0]:=s[0]; + {$endif} + end; + +{$ifdef debug} + + function assigned(p : pointer) : boolean; +{$ifndef FPC} + {$ifndef DPMI} + type + ptrrec = record + ofs,seg : word; + end; + var + lp : longint; + {$endif DPMI} +{$endif FPC} + begin +{$ifdef FPC} + { Assigned is used for procvar and + stack stored temp records !! PM } + (* if (p<>nil) {and + ((pheapptr))} then + do_internalerror(230); *) +{$else} + {$ifdef DPMI} + assigned:=(p<>nil); + exit; + {$else DPMI} + if p=nil then + lp:=0 + else + lp:=longint(ptrrec(p).seg)*16+longint(ptrrec(p).ofs); + if (lp<>0) and + ((lplongint(seg(heapptr^))*16+longint(ofs(heapptr^)))) then + do_internalerror(230); + {$endif DPMI} +{$endif FPC} + assigned:=(p<>nil); + end; +{$endif} + + + function min(a,b : longint) : longint; + { + return the minimal of a and b + } + begin + if a>b then + min:=b + else + min:=a; + end; + + + function max(a,b : longint) : longint; + { + return the maximum of a and b + } + begin + if a2 then + data_align:=4 + else if length>1 then + data_align:=2 + else + data_align:=1; + {$ENDIF} + {$IFDEF M68K} + data_align:=2; + {$ENDIF} + align_from_size:=(datasize+data_align-1) and not(data_align-1); + end; + + + function align(i,a:longint):longint; + { + return value aligned boundary + } + begin + align:=(i+a-1) and not(a-1); + end; + + + procedure Replace(var s:string;s1:string;const s2:string); + var + last, + i : longint; + begin + s1:=upper(s1); + last:=0; + repeat + i:=pos(s1,upper(s)); + if i=last then + i:=0; + if (i>0) then + begin + Delete(s,i,length(s1)); + Insert(s2,s,i); + last:=i; + end; + until (i=0); + end; + + + procedure ReplaceCase(var s:string;const s1,s2:string); + var + last, + i : longint; + begin + last:=0; + repeat + i:=pos(s1,s); + if i=last then + i:=0; + if (i>0) then + begin + Delete(s,i,length(s1)); + Insert(s2,s,i); + last:=i; + end; + until (i=0); + end; + + + function upper(const s : string) : string; + { + return uppercased string of s + } + var + i : longint; + begin + for i:=1 to length(s) do + 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 lower(const s : string) : string; + { + return lowercased string of s + } + var + i : longint; + begin + for i:=1 to length(s) do + if s[i] in ['A'..'Z'] then + lower[i]:=char(byte(s[i])+32) + else + lower[i]:=s[i]; + lower[0]:=s[0]; + end; + + + procedure uppervar(var s : string); + { + uppercase string s + } + var + i : longint; + begin + for i:=1 to length(s) do + if s[i] in ['a'..'z'] then + s[i]:=char(byte(s[i])-32); + end; + + function hexstr(val : longint;cnt : byte) : string; + const + HexTbl : array[0..15] of char='0123456789ABCDEF'; + var + i : longint; + begin + hexstr[0]:=char(cnt); + for i:=cnt downto 1 do + begin + hexstr[i]:=hextbl[val and $f]; + val:=val shr 4; + end; + end; + +{$ifdef FPC} + function tostru(i:cardinal):string; + { + return string of value i, but for cardinals + } + var + hs : string; + begin + str(i,hs); + tostru:=hs; + end; +{$else FPC} + function tostru(i:longint):string; + begin + tostru:=tostr(i); + end; +{$endif FPC} + + + function trimspace(const s:string):string; + { + return s with all leading and ending spaces and tabs removed + } + var + i,j : longint; + begin + i:=length(s); + while (i>0) and (s[i] in [#9,' ']) do + dec(i); + j:=1; + while (j=0 + } + var + hs : string; + begin + str(i,hs); + if i>=0 then + tostr_with_plus:='+'+hs + else + tostr_with_plus:=hs; + end; + + + procedure valint(S : string;var V : longint;var code : integer); + { + val() with support for octal, which is not supported under tp7 + } +{$ifndef FPC} + var + vs : longint; + c : byte; + begin + if s[1]='%' then + begin + vs:=0; + longint(v):=0; + for c:=2 to length(s) do + begin + if s[c]='0' then + vs:=vs shl 1 + else + if s[c]='1' then + vs:=vs shl 1+1 + else + begin + code:=c; + exit; + end; + end; + code:=0; + longint(v):=vs; + end + else + system.val(S,V,code); + end; +{$else not FPC} + begin + system.val(S,V,code); + end; +{$endif not FPC} + + + function is_number(const s : string) : boolean; + { + is string a correct number ? + } + var + w : integer; + l : longint; + begin + valint(s,l,w); + is_number:=(w=0); + end; + + + function ispowerof2(value : longint;var power : longint) : boolean; + { + return if value is a power of 2. And if correct return the power + } + var + hl : longint; + i : longint; + begin + hl:=1; + ispowerof2:=true; + for i:=0 to 31 do + begin + if hl=value then + begin + power:=i; + exit; + end; + hl:=hl shl 1; + end; + ispowerof2:=false; + end; + + + { enable ansistring comparison } + { 0 means equal } + { 1 means p1 > p2 } + { -1 means p1 < p2 } + function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint; + + var + i,j : longint; + begin + compareansistrings:=0; + j:=min(length1,length2); + i:=0; + while (ip2[i] then + begin + compareansistrings:=1; + exit; + end + else + if p1[i]length2 then + compareansistrings:=1 + else + if length10) and (s[1]='/') then + path_absolute:=true; +{$else linux_or_beos} + {$ifdef amiga} + if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then + path_absolute:=true; + {$else} + if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or + ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then + path_absolute:=true; + {$endif amiga} +{$endif linux_or_beos} + end; + +{$ifndef FPC} + Procedure FindClose(var Info : SearchRec); + Begin + End; +{$endif not FPC} + + + Function FileExists ( Const F : String) : Boolean; +{$ifndef delphi} + Var + Info : SearchRec; +{$endif} + begin +{$ifdef delphi} + FileExists:=sysutils.FileExists(f); +{$else} + {$ifdef beos} + FileExists:=beos.FExists(F); + {$else} + findfirst(F,readonly+archive+hidden,info); + FileExists:=(doserror=0); + findclose(Info); + {$endif} +{$endif delphi} + end; + + + Function PathExists ( F : String) : Boolean; +{$ifdef beos} + begin + PathExists:=beos.PExists(F); +{$else} + Var + Info : SearchRec; + begin + if F[Length(f)] in ['/','\'] then + Delete(f,length(f),1); + findfirst(F,readonly+archive+hidden+directory,info); + PathExists:=(doserror=0) and ((info.attr and directory)=directory); + findclose(Info); +{$endif} + end; + + + Function RemoveFile(const f:string):boolean; + var + g : file; + begin + assign(g,f); + {$I-} + erase(g); + {$I+} + RemoveFile:=(ioresult=0); + end; + + + Function RemoveDir(d:string):boolean; + begin + if d[length(d)]=DirSep then + Delete(d,length(d),1); + {$I-} + rmdir(d); + {$I+} + RemoveDir:=(ioresult=0); + end; + + + Function SplitPath(const s:string):string; + var + i : longint; + begin + i:=Length(s); + while (i>0) and not(s[i] in ['/','\']) do + dec(i); + SplitPath:=Copy(s,1,i); + end; + + + Function SplitFileName(const s:string):string; + var + p : dirstr; + n : namestr; + e : extstr; + begin + FSplit(s,p,n,e); + SplitFileName:=n+e; + end; + + + Function SplitName(const s:string):string; + var + i,j : longint; + begin + i:=Length(s); + j:=Length(s); + while (i>0) and not(s[i] in ['/','\']) do + dec(i); + while (j>0) and (s[j]<>'.') do + dec(j); + if j<=i then + j:=255; + SplitName:=Copy(s,i+1,j-(i+1)); + end; + + + Function SplitExtension(Const HStr:String):String; + var + j : longint; + begin + j:=length(Hstr); + while (j>0) and (Hstr[j]<>'.') do + begin + if hstr[j]=DirSep then + j:=0 + else + dec(j); + end; + if j=0 then + j:=254; + SplitExtension:=Copy(Hstr,j,255); + end; + + + Function AddExtension(Const HStr,ext:String):String; + begin + if (Ext<>'') and (SplitExtension(HStr)='') then + AddExtension:=Hstr+Ext + else + AddExtension:=Hstr; + end; + + + Function ForceExtension(Const HStr,ext:String):String; + var + j : longint; + begin + j:=length(Hstr); + while (j>0) and (Hstr[j]<>'.') do + dec(j); + if j=0 then + j:=255; + ForceExtension:=Copy(Hstr,1,j-1)+Ext; + end; + + + Function FixPath(s:string;allowdot:boolean):string; + var + i : longint; + begin + { Fix separator } + for i:=1 to length(s) do + if s[i] in ['/','\'] then + s[i]:=DirSep; + { Fix ending / } + if (length(s)>0) and (s[length(s)]<>DirSep) and + (s[length(s)]<>':') then + s:=s+DirSep; + { Remove ./ } + if (not allowdot) and (s='.'+DirSep) then + s:=''; + { return } +{$ifdef linux_or_beos} + FixPath:=s; +{$else} + FixPath:=Lower(s); +{$endif} + end; + + + function FixFileName(const s:string):string; + var + i : longint; + {$ifdef linux_or_beos} + NoPath : boolean; + {$endif linux_or_beos} + begin + {$ifdef linux_or_beos} + NoPath:=true; + {$endif linux_or_beos} + for i:=length(s) downto 1 do + begin + case s[i] of + {$ifdef linux_or_beos} + '/','\' : begin + FixFileName[i]:='/'; + NoPath:=false; {Skip lowercasing path: 'X11'<>'x11' } + end; + 'A'..'Z' : if NoPath then + FixFileName[i]:=char(byte(s[i])+32) + else + FixFileName[i]:=s[i]; + {$else} + '/' : FixFileName[i]:='\'; + 'A'..'Z' : FixFileName[i]:=char(byte(s[i])+32); + {$endif} + else + FixFileName[i]:=s[i]; + end; + end; + {$ifndef TP} + {$ifopt H+} + SetLength(FixFileName,length(s)); + {$else} + FixFileName[0]:=s[0]; + {$endif} + {$else} + FixFileName[0]:=s[0]; + {$endif} + end; + + + procedure SplitBinCmd(const s:string;var bstr,cstr:string); + var + i : longint; + begin + i:=pos(' ',s); + if i>0 then + begin + bstr:=Copy(s,1,i-1); + cstr:=Copy(s,i+1,length(s)-i); + end + else + begin + bstr:=''; + cstr:=''; + end; + end; + + + + procedure TSearchPathList.AddPath(s:string;addfirst:boolean); + var + j : longint; + hs,hsd, + CurrentDir, + CurrPath : string; + dir : searchrec; + {$IFDEF NEWST} + hp : PStringItem; + {$ELSE} + hp : PStringQueueItem; + {$ENDIF} + + procedure addcurrpath; + begin + if addfirst then + begin + Delete(currPath); + Insert(currPath); + end + else + begin + { Check if already in path, then we don't add it } + hp:=Find(currPath); + if not assigned(hp) then + Concat(currPath); + end; + end; + + begin + if s='' then + exit; + { Support default macro's } + DefaultReplacements(s); + { get current dir } + CurrentDir:=GetCurrentDir; + repeat + { get currpath } + if addfirst then + begin + j:=length(s); + while (j>0) and (s[j]<>';') do + dec(j); + CurrPath:=FixPath(Copy(s,j+1,length(s)-j),false); + if j=0 then + s:='' + else + System.Delete(s,j,length(s)-j+1); + end + else + begin + j:=Pos(';',s); + if j=0 then + j:=255; + CurrPath:=FixPath(Copy(s,1,j-1),false); + System.Delete(s,1,j); + end; + { fix pathname } + if CurrPath='' then + CurrPath:='.'+DirSep + else + begin + CurrPath:=FixPath(FExpand(CurrPath),false); + if (CurrentDir<>'') and (Copy(CurrPath,1,length(CurrentDir))=CurrentDir) then + CurrPath:='.'+DirSep+Copy(CurrPath,length(CurrentDir)+1,255); + end; + { wildcard adding ? } + if pos('*',currpath)>0 then + begin + if currpath[length(currpath)]=dirsep then + hs:=Copy(currpath,1,length(CurrPath)-1) + else + hs:=currpath; + hsd:=SplitPath(hs); + findfirst(hs,directory,dir); + while doserror=0 do + begin + if (dir.name<>'.') and + (dir.name<>'..') and + ((dir.attr and directory)<>0) then + begin + currpath:=hsd+dir.name+dirsep; + hp:=Find(currPath); + if not assigned(hp) then + AddCurrPath; + end; + findnext(dir); + end; + FindClose(dir); + end + else + begin + if PathExists(currpath) then + addcurrpath; + end; + until (s=''); + end; + + + procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean); + var + s : string; + hl : TSearchPathList; + {$IFDEF NEWST} + hp,hp2 : PStringItem; + {$ELSE} + hp,hp2 : PStringQueueItem; + {$ENDIF} + begin + if list.empty then + exit; + { create temp and reverse the list } + if addfirst then + begin + hl.Init; + hp:=list.first; + while assigned(hp) do + begin + hl.insert(hp^.data^); + hp:=hp^.next; + end; + while not hl.empty do + begin + s:=hl.Get; + Delete(s); + Insert(s); + end; + hl.done; + end + else + begin + hp:=list.first; + while assigned(hp) do + begin + hp2:=Find(hp^.data^); + { Check if already in path, then we don't add it } + if not assigned(hp2) then + Concat(hp^.data^); + hp:=hp^.next; + end; + end; + end; + + + function TSearchPathList.FindFile(const f : string;var b : boolean) : string; + Var + {$IFDEF NEWST} + p : PStringItem; + {$ELSE} + p : PStringQueueItem; + {$ENDIF} + begin + FindFile:=''; + b:=false; + p:=first; + while assigned(p) do + begin + If FileExists(p^.data^+f) then + begin + FindFile:=p^.data^; + b:=true; + exit; + end; + p:=p^.next; + end; + end; + + + Function GetFileTime ( Var F : File) : Longint; + Var + {$ifdef linux_or_beos} + Info : Stat; + {$endif} + L : longint; + begin + {$ifdef linux} + FStat (F,Info); + L:=Info.Mtime; + {$else} + GetFTime(f,l); + {$endif} + GetFileTime:=L; + end; + + + Function GetNamedFileTime (Const F : String) : Longint; + var + L : Longint; + {$ifndef linux_or_beos} + info : SearchRec; + {$else} + info : stat; + {$endif} + begin + l:=-1; + {$ifdef linux_or_beos} +{$ifdef linux} + if FStat (F,Info) then L:=info.mtime; +{$else} + GetFTime(f,L); +{$endif} + + {$else} +{$ifdef delphi} + dmisc.FindFirst (F,archive+readonly+hidden,info); +{$else delphi} + FindFirst (F,archive+readonly+hidden,info); +{$endif delphi} + if DosError=0 then + l:=info.time; + {$ifdef linux} + FindClose(info); + {$endif} + {$ifdef Win32} + FindClose(info); + {$endif} + {$endif} + GetNamedFileTime:=l; + end; + + + {Touch Assembler and object time to ppu time is there is a ppufilename} + procedure SynchronizeFileTime(const fn1,fn2:string); + var + f : file; + l : longint; + begin + Assign(f,fn1); + {$I-} + reset(f,1); + {$I+} + if ioresult=0 then + begin + getftime(f,l); + { just to be sure in case there are rounding errors } + setftime(f,l); + close(f); + assign(f,fn2); + {$I-} + reset(f,1); + {$I+} + if ioresult=0 then + begin + setftime(f,l); + close(f); + end; + end; + end; + + + function FindFile(const f : string;path : string;var b : boolean) : string; + Var + singlepathstring : string; + i : longint; + begin + {$ifdef linux_or_beos} + for i:=1 to length(path) do + if path[i]=':' then + path[i]:=';'; + {$endif} + b:=false; + FindFile:=''; + repeat + i:=pos(';',path); + if i=0 then + i:=256; + singlepathstring:=FixPath(copy(path,1,i-1),false); + delete(path,1,i); + If FileExists (singlepathstring+f) then + begin + FindFile:=singlepathstring; + b:=true; + exit; + end; + until path=''; + end; + + function FindExe(bin:string;var found:boolean):string; + begin + bin:=FixFileName(bin)+source_os.exeext; +{$ifdef delphi} + FindExe:=FindFile(bin,'.;'+exepath+';'+dmisc.getenv('PATH'),found)+bin; +{$else delphi} + FindExe:=FindFile(bin,'.;'+exepath+';'+dos.getenv('PATH'),found)+bin; +{$endif delphi} + end; + + + function GetShortName(const n:string):string; +{$ifdef win32} + var + hs,hs2 : string; + i : longint; +{$endif} +{$ifdef go32v2} + var + hs : string; +{$endif} + begin + GetShortName:=n; +{$ifdef win32} + hs:=n+#0; + i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2)); + if (i>0) and (i<=high(hs2)) then + begin + hs2[0]:=chr(strlen(@hs2[1])); + GetShortName:=hs2; + end; +{$endif} +{$ifdef go32v2} + hs:=n; + if Dos.GetShortName(hs) then + GetShortName:=hs; +{$endif} + end; + + + {**************************************************************************** + OS Dependent things + ****************************************************************************} + + function GetEnvPChar(const envname:string):pchar; + {$ifdef win32} + var + s : string; + i,len : longint; + hp,p,p2 : pchar; + {$endif} + begin + {$ifdef linux} + GetEnvPchar:=Linux.Getenv(envname); + {$define GETENVOK} + {$endif} + {$ifdef beos} + GetEnvPchar:=Beos.Getenv(envname); + {$define GETENVOK} + {$endif} + {$ifdef win32} + GetEnvPchar:=nil; + p:=GetEnvironmentStrings; + hp:=p; + while hp^<>#0 do + begin + s:=strpas(hp); + i:=pos('=',s); + len:=strlen(hp); + if upper(copy(s,1,i-1))=upper(envname) then + begin + GetMem(p2,len-length(envname)); + Move(hp[i],p2^,len-length(envname)); + GetEnvPchar:=p2; + break; + end; + { next string entry} + hp:=hp+len+1; + end; + FreeEnvironmentStrings(p); + {$define GETENVOK} + {$endif} + {$ifdef GETENVOK} + {$undef GETENVOK} + {$else} + GetEnvPchar:=StrPNew(Dos.Getenv(envname)); + {$endif} + end; + + + procedure FreeEnvPChar(p:pchar); + begin + {$ifndef linux_or_beos} + StrDispose(p); + {$endif} + end; + + Procedure Shell(const command:string); + { This is already defined in the linux.ppu for linux, need for the * + expansion under linux } + {$ifdef linux} + begin + Linux.Shell(command); + end; + {$else} + {$ifdef beos} + begin + Beos.Shell(command); + end; + {$else} + var + comspec : string; + begin + comspec:=getenv('COMSPEC'); + Exec(comspec,' /C '+command); + end; + {$endif} + {$endif} + + +{**************************************************************************** + Init +****************************************************************************} + + procedure get_exepath; + var + hs1 : namestr; + hs2 : extstr; + begin +{$ifdef delphi} + exepath:=dmisc.getenv('PPC_EXEC_PATH'); +{$else delphi} + exepath:=dos.getenv('PPC_EXEC_PATH'); +{$endif delphi} + if exepath='' then + fsplit(FixFileName(paramstr(0)),exepath,hs1,hs2); +{$ifndef VER0_99_15} + {$ifdef linux_or_beos} + if exepath='' then + fsearch(hs1,dos.getenv('PATH')); + {$endif} +{$endif} + exepath:=FixPath(exepath,false); + end; + + + + procedure DoneGlobals; + begin + initdefines.done; + if assigned(DLLImageBase) then + StringDispose(DLLImageBase); + RelocSection:=true; + RelocSectionSetExplicitly:=false; + DLLsource:=false; + UseDeffileForExport:=true; + librarysearchpath.Done; + unitsearchpath.Done; + objectsearchpath.Done; + includesearchpath.Done; + end; + + procedure InitGlobals; + begin + { set global switches } + do_build:=false; + do_make:=true; +{$ifdef tp} + use_big:=false; +{$endif tp} + compile_level:=0; + + { Output } + OutputFile:=''; + OutputExeDir:=''; + OutputUnitDir:=''; + + { Utils directory } + utilsdirectory:=''; + + { Search Paths } + librarysearchpath.Init; + unitsearchpath.Init; + includesearchpath.Init; + objectsearchpath.Init; + + { Def file } + usewindowapi:=false; + description:='Compiled by FPC '+version_string+' - '+target_cpu_string; + dllversion:=''; + + { Init values } + initmodeswitches:=fpcmodeswitches; + initlocalswitches:=[cs_check_io]; + initmoduleswitches:=[cs_extsyntax,cs_browser]; + initglobalswitches:=[cs_check_unit_name,cs_link_static]; +{$ifdef i386} + initoptprocessor:=Class386; + initspecificoptprocessor:=Class386; + initpackenum:=4; + {$IFDEF testvarsets} + initsetalloc:=0; + {$ENDIF} + initpackrecords:=packrecord_2; + initoutputformat:=target_asm.id; + initasmmode:=asmmode_i386_att; +{$else not i386} + {$ifdef m68k} + initoptprocessor:=MC68000; + include(initmoduleswitches,cs_fp_emulation); + initpackenum:=4; + {$IFDEF testvarsets} + initsetalloc:=0; + {$ENDIF} + initpackrecords:=packrecord_2; + initoutputformat:=as_m68k_as; + initasmmode:=asmmode_m68k_mot; + {$endif m68k} +{$endif i386} + initdefines.init; + + { memory sizes, will be overriden by parameter or default for target + in options or init_parser } + stacksize:=0; + heapsize:=0; + maxheapsize:=0; + + { compile state } + in_args:=false; + { must_be_valid:=true; obsolete PM } + not_unit_proc:=true; + + apptype:=at_cui; + end; + +begin + get_exepath; +{$ifdef EXTDEBUG} +{$ifdef FPC} + EntryMemUsed:=system.HeapSize-MemAvail; +{$endif FPC} +{$endif} +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.67 2000/06/19 19:57:19 pierre + * smart link is default on win32 + + Revision 1.66 2000/06/18 18:05:54 peter + * no binary value reading with % if not fpc mode + * extended illegal char message with the char itself (Delphi like) + + Revision 1.65 2000/06/15 18:10:11 peter + * first look for ppu in cwd and outputpath and after that for source + in cwd + * fixpath() for not linux makes path now lowercase so comparing paths + with different cases (sometimes a drive letter could be + uppercased) gives the expected results + * sources_checked flag if there was already a full search for sources + which aren't found, so another scan isn't done when checking for the + sources only when recompile is needed + + Revision 1.64 2000/06/11 07:00:21 peter + * fixed pchar->string conversion for delphi mode + + Revision 1.63 2000/05/12 08:58:51 pierre + * adapted to Delphi 3 + + Revision 1.62 2000/05/12 05:55:04 pierre + * * get it to compile with Delphi by Kovacs Attila Zoltan + + Revision 1.61 2000/05/11 09:37:25 pierre + * do not use upcase for strings, reported by Kovacs Attila Zoltan + + Revision 1.60 2000/05/04 20:46:17 peter + * ansistrings are now default on for delphi mode, as most ppl expect + this + + Revision 1.59 2000/05/03 14:36:57 pierre + * fix for tests/test/testrang.pp bug + + Revision 1.58 2000/04/14 12:27:57 pierre + * setfiletime to both files in synchronize + + Revision 1.57 2000/03/23 15:35:47 peter + * $VERSION is now version_string + + $FULLVERSION is now full_version_string + + Revision 1.56 2000/03/20 16:04:05 pierre + * probably a fix for bug 615 + + Revision 1.55 2000/03/08 15:39:45 daniel + + Added align_from_size function as suggested by Peter. + + Revision 1.54 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.53 2000/02/14 20:58:44 marco + * Basic structures for new sethandling implemented. + + Revision 1.52 2000/02/10 11:45:48 peter + * addpath fixed with list of paths when inserting at the beginning + * if exepath=currentdir then it's not inserted in path list + * searchpaths in ppc386.cfg are now added at the beginning of the + list instead of at the end. (commandline is not changed) + * check paths before inserting in list + + Revision 1.51 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.50 2000/01/26 14:31:03 marco + * $VERSION is now also substituted in -F paths (that have subst active) + + Revision 1.49 2000/01/23 21:29:14 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.48 2000/01/23 16:36:37 peter + * better auto RTL dir detection + + Revision 1.47 2000/01/20 00:23:03 pierre + * fix for GetShortName, now checks results from Win32 + + Revision 1.46 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.45 2000/01/07 00:08:09 peter + * tp7 fix + + Revision 1.44 2000/01/06 15:48:59 peter + * wildcard support for directory adding, this allows the use of units/* + in ppc386.cfg + + Revision 1.43 2000/01/04 15:15:50 florian + + added compiler switch $maxfpuregisters + + fixed a small problem in secondvecn + + Revision 1.42 1999/12/22 01:01:48 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.41 1999/12/20 23:23:28 pierre + + $description $version + + Revision 1.40 1999/12/20 21:42:34 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.39 1999/12/08 10:40:00 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.38 1999/12/06 18:21:03 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + + Revision 1.37 1999/12/02 17:34:34 peter + * preprocessor support. But it fails on the caret in type blocks + + Revision 1.36 1999/11/18 15:34:45 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.35 1999/11/17 17:04:59 pierre + * Notes/hints changes + + Revision 1.34 1999/11/15 17:42:41 pierre + * -g disables reloc section for win32 + + Revision 1.33 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.32 1999/11/09 23:34:46 pierre + + resolving_forward boolean used for references + + Revision 1.31 1999/11/09 13:00:38 peter + * define FPC_DELPHI,FPC_OBJFPC,FPC_TP,FPC_GPC + * initial support for ansistring default with modes + +} \ No newline at end of file diff --git a/befpc/compiler/globtype.pas b/befpc/compiler/globtype.pas new file mode 100644 index 0000000..057bd26 --- /dev/null +++ b/befpc/compiler/globtype.pas @@ -0,0 +1,274 @@ +{ + $Id: globtype.pas,v 1.1.1.1 2001-07-23 17:16:28 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Global types + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} +unit globtype; +interface + + const + maxidlen = 64; + + type + { System independent float names } +{$ifdef i386} + bestreal = extended; + ts32real = single; + ts64real = double; + ts80real = extended; + ts64comp = extended; +{$endif} +{$ifdef m68k} + bestreal = real; + ts32real = single; + ts64real = double; + ts80real = extended; + ts64comp = comp; +{$endif} +{$ifdef alpha} + bestreal = extended; + ts32real = single; + ts64real = double; + ts80real = extended; + ts64comp = comp; +{$endif} +{$ifdef powerpc} + bestreal = double; + ts32real = single; + ts64real = double; + ts80real = extended; + ts64comp = comp; +{$endif powerpc} + pbestreal=^bestreal; + + { Switches which can be changed locally } + tlocalswitch = (cs_localnone, + { codegen } + cs_check_overflow,cs_check_range,cs_check_object_ext, + cs_check_io,cs_check_stack, + cs_omitstackframe,cs_do_assertion,cs_generate_rtti, + { mmx } + cs_mmx,cs_mmx_saturation, + { parser } + cs_typed_addresses,cs_strict_var_strings,cs_ansistrings + ); + tlocalswitches = set of tlocalswitch; + + { Switches which can be changed only at the beginning of a new module } + tmoduleswitch = (cs_modulenone, + { parser } + cs_fp_emulation,cs_extsyntax,cs_openstring, + { support } + cs_support_inline,cs_support_goto,cs_support_macro, + cs_support_c_operators,cs_static_keyword, + cs_typed_const_not_changeable, + { generation } + cs_profile,cs_debuginfo,cs_browser,cs_local_browser,cs_compilesystem, + cs_lineinfo, + { linking } + cs_create_smart,cs_create_dynamic + ); + tmoduleswitches = set of tmoduleswitch; + + { Switches which can be changed only for a whole program/compilation, + mostly set with commandline } + tglobalswitch = (cs_globalnone, + { parameter switches } + cs_check_unit_name,cs_constructor_name, + { units } + cs_load_objpas_unit, + cs_load_gpc_unit, + { optimizer } + cs_regalloc,cs_uncertainopts,cs_littlesize,cs_optimize, + cs_fastoptimize, cs_slowoptimize,cs_align, + { browser } + cs_browser_log, + { debugger } + cs_gdb_dbx,cs_gdb_gsym,cs_gdb_heaptrc,cs_gdb_lineinfo,cs_checkpointer, + { assembling } + cs_asm_leave,cs_asm_extern,cs_asm_pipe,cs_asm_source, + cs_asm_regalloc,cs_asm_tempalloc, + { linking } + cs_link_extern,cs_link_static,cs_link_smart,cs_link_shared,cs_link_deffile, + cs_link_strip,cs_link_toc,cs_link_staticflag + ); + tglobalswitches = set of tglobalswitch; + + { Switches which can be changed by a mode (fpc,tp7,delphi) } + tmodeswitch = (m_none,m_all, { needed for keyword } + { generic } + m_fpc,m_objfpc,m_delphi,m_tp,m_tp7,m_gpc, + { more specific } + m_class, { delphi class model } + m_objpas, { load objpas unit } + m_result, { result in functions } + m_string_pchar, { pchar 2 string conversion } + m_cvar_support, { cvar variable directive } + m_nested_comment, { nested comments } + m_tp_procvar, { tp style procvars (no @ needed) } + m_repeat_forward, { repeating forward declarations is needed } + m_pointer_2_procedure, { allows the assignement of pointers to + procedure variables } + m_autoderef, { does auto dereferencing of struct. vars } + m_initfinal, { initialization/finalization for units } + m_add_pointer, { allow pointer add/sub operations } + m_default_ansistring { ansistring turned on by default } + ); + tmodeswitches = set of tmodeswitch; + + { win32 sub system } + tapptype = (at_none, + at_gui,at_cui + ); + + { currently parsed block type } + tblock_type = (bt_none, + bt_general,bt_type,bt_const,bt_except + ); + + { packrecords types } + tpackrecords = (packrecord_none, + packrecord_1,packrecord_2,packrecord_4, + packrecord_8,packrecord_16,packrecord_32, + packrecord_C + ); + + const + packrecordalignment : array[tpackrecords] of byte=(0, + 1,2,4,8,16,32,1 + ); + + type + stringid = string[maxidlen]; + + tnormalset = set of byte; { 256 elements set } + pnormalset = ^tnormalset; + + pdouble = ^double; + pbyte = ^byte; + pword = ^word; + plongint = ^longint; + + {$IFDEF TP} + Tconstant=record + case signed:boolean of + false: + (valueu:longint); + true: + (values:longint); + end; + {$ELSE} + Tconstant=record + case signed:boolean of + false: + (valueu:cardinal); + true: + (values:longint); + end; + {$ENDIF} + + const + { link options } + link_none = $0; + link_allways = $1; + link_static = $2; + link_smart = $4; + link_shared = $8; + + +implementation + + +begin +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.32 2000/06/11 07:00:21 peter + * fixed pchar->string conversion for delphi mode + + Revision 1.31 2000/05/31 06:57:11 florian + * first implementation of -Oa switch + + Revision 1.30 2000/05/16 20:19:05 pierre + + -CR option to enable check for object virtual method + + Revision 1.29 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.28 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.27 2000/02/09 10:35:48 peter + * -Xt option to link staticly against c libs + + Revision 1.26 2000/02/06 17:20:52 peter + * -gl switch for auto lineinfo including + + Revision 1.25 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.24 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.23 1999/11/09 13:00:38 peter + * define FPC_DELPHI,FPC_OBJFPC,FPC_TP,FPC_GPC + * initial support for ansistring default with modes + + Revision 1.22 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.21 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.20 1999/10/22 10:39:34 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.19 1999/09/20 16:38:54 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.18 1999/09/08 16:05:32 peter + * pointer add/sub is now as expected and the same results as inc/dec + + Revision 1.17 1999/08/13 15:44:58 peter + * first things to include lineinfo in the executable + + Revision 1.16 1999/08/11 17:26:33 peter + * tlinker object is now inherited for win32 and dos + * postprocessexecutable is now a method of tlinker + + Revision 1.15 1999/08/04 13:02:42 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.14 1999/08/01 23:04:48 michael + + Changes for Alpha + + Revision 1.13 1999/07/23 16:05:21 peter + * alignment is now saved in the symtable + * C alignment added for records + * PPU version increased to solve .12 <-> .13 probs + +} \ No newline at end of file diff --git a/befpc/compiler/hcgdata.pas b/befpc/compiler/hcgdata.pas new file mode 100644 index 0000000..52c2004 --- /dev/null +++ b/befpc/compiler/hcgdata.pas @@ -0,0 +1,795 @@ +{ + $Id: hcgdata.pas,v 1.1.1.1 2001-07-23 17:16:28 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Routines for the code generation of data structures + like VMT,Messages + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit hcgdata; +interface + + uses + symtable,aasm; + + { generates the message tables for a class } + function genstrmsgtab(_class : pobjectdef) : pasmlabel; + function genintmsgtab(_class : pobjectdef) : pasmlabel; + { generates the method name table } + function genpublishedmethodstable(_class : pobjectdef) : pasmlabel; + + { generates a VMT for _class } + procedure genvmt(list : paasmoutput;_class : pobjectdef); + +{$ifdef WITHDMT} + { generates a DMT for _class } + function gendmt(_class : pobjectdef) : pasmlabel; +{$endif WITHDMT} + +implementation + + uses + strings,cobjects, + globtype,globals,verbose, + symconst,types, + hcodegen; + + +{***************************************************************************** + Message +*****************************************************************************} + + type + pprocdeftree = ^tprocdeftree; + tprocdeftree = record + p : pprocdef; + nl : pasmlabel; + l,r : pprocdeftree; + end; + + var + root : pprocdeftree; + count : longint; + + procedure insertstr(p : pprocdeftree;var at : pprocdeftree); + + var + i : longint; + + begin + if at=nil then + begin + at:=p; + inc(count); + end + else + begin + i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str); + if i<0 then + insertstr(p,at^.l) + else if i>0 then + insertstr(p,at^.r) + else + Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str)); + end; + end; + + procedure disposeprocdeftree(p : pprocdeftree); + + begin + if assigned(p^.l) then + disposeprocdeftree(p^.l); + if assigned(p^.r) then + disposeprocdeftree(p^.r); + dispose(p); + end; + + procedure insertmsgstr(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + hp : pprocdef; + pt : pprocdeftree; + + begin + if psym(p)^.typ=procsym then + begin + hp:=pprocsym(p)^.definition; + while assigned(hp) do + begin + if (po_msgstr in hp^.procoptions) then + begin + new(pt); + pt^.p:=hp; + pt^.l:=nil; + pt^.r:=nil; + insertstr(pt,root); + end; + hp:=hp^.nextoverloaded; + end; + end; + end; + + procedure insertint(p : pprocdeftree;var at : pprocdeftree); + + begin + if at=nil then + begin + at:=p; + inc(count); + end + else + begin + if p^.p^.messageinf.iat^.p^.messageinf.i then + insertint(p,at^.r) + else + Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i)); + end; + end; + + procedure insertmsgint(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + hp : pprocdef; + pt : pprocdeftree; + + begin + if psym(p)^.typ=procsym then + begin + hp:=pprocsym(p)^.definition; + while assigned(hp) do + begin + if (po_msgint in hp^.procoptions) then + begin + new(pt); + pt^.p:=hp; + pt^.l:=nil; + pt^.r:=nil; + insertint(pt,root); + end; + hp:=hp^.nextoverloaded; + end; + end; + end; + + procedure writenames(p : pprocdeftree); + + begin + getdatalabel(p^.nl); + if assigned(p^.l) then + writenames(p^.l); + datasegment^.concat(new(pai_label,init(p^.nl))); + datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str)))); + datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str))); + if assigned(p^.r) then + writenames(p^.r); + end; + + procedure writestrentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writestrentry(p^.l); + + { write name label } + datasegment^.concat(new(pai_const_symbol,init(p^.nl))); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + + if assigned(p^.r) then + writestrentry(p^.r); + end; + + function genstrmsgtab(_class : pobjectdef) : pasmlabel; + + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + { insert all message handlers into a tree, sorted by name } + _class^.symtable^.foreach({$ifndef TP}@{$endif}insertmsgstr); + + { write all names } + if assigned(root) then + writenames(root); + + { now start writing of the message string table } + getdatalabel(r); + datasegment^.concat(new(pai_label,init(r))); + genstrmsgtab:=r; + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writestrentry(root); + disposeprocdeftree(root); + end; + end; + + + procedure writeintentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writeintentry(p^.l); + + { write name label } + datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i))); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + + if assigned(p^.r) then + writeintentry(p^.r); + end; + + function genintmsgtab(_class : pobjectdef) : pasmlabel; + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + { insert all message handlers into a tree, sorted by name } + _class^.symtable^.foreach({$ifndef TP}@{$endif}insertmsgint); + + { now start writing of the message string table } + getdatalabel(r); + datasegment^.concat(new(pai_label,init(r))); + genintmsgtab:=r; + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writeintentry(root); + disposeprocdeftree(root); + end; + end; + +{$ifdef WITHDMT} + + procedure insertdmtentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + hp : pprocdef; + pt : pprocdeftree; + + begin + if psym(p)^.typ=procsym then + begin + hp:=pprocsym(p)^.definition; + while assigned(hp) do + begin + if (po_msgint in hp^.procoptions) then + begin + new(pt); + pt^.p:=hp; + pt^.l:=nil; + pt^.r:=nil; + insertint(pt,root); + end; + hp:=hp^.nextoverloaded; + end; + end; + end; + + procedure writedmtindexentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writedmtindexentry(p^.l); + datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i))); + if assigned(p^.r) then + writedmtindexentry(p^.r); + end; + + procedure writedmtaddressentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writedmtaddressentry(p^.l); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + if assigned(p^.r) then + writedmtaddressentry(p^.r); + end; + + function gendmt(_class : pobjectdef) : pasmlabel; + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + gendmt:=nil; + { insert all message handlers into a tree, sorted by number } + _class^.symtable^.foreach({$ifndef TP}@{$endif}insertdmtentry); + + if count>0 then + begin + getdatalabel(r); + gendmt:=r; + datasegment^.concat(new(pai_label,init(r))); + { entries for caching } + datasegment^.concat(new(pai_const,init_32bit(0))); + datasegment^.concat(new(pai_const,init_32bit(0))); + + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writedmtindexentry(root); + writedmtaddressentry(root); + disposeprocdeftree(root); + end; + end; + end; + +{$endif WITHDMT} + + procedure do_count(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + begin + if (psym(p)^.typ=procsym) and (sp_published in psym(p)^.symoptions) then + inc(count); + end; + + procedure genpubmethodtableentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + hp : pprocdef; + l : pasmlabel; + + begin + if (psym(p)^.typ=procsym) and (sp_published in psym(p)^.symoptions) then + begin + hp:=pprocsym(p)^.definition; + if assigned(hp^.nextoverloaded) then + internalerror(1209992); + getdatalabel(l); + + consts^.concat(new(pai_label,init(l))); + consts^.concat(new(pai_const,init_8bit(length(p^.name)))); + consts^.concat(new(pai_string,init(p^.name))); + + datasegment^.concat(new(pai_const_symbol,init(l))); + datasegment^.concat(new(pai_const_symbol,initname(hp^.mangledname))); + end; + end; + + function genpublishedmethodstable(_class : pobjectdef) : pasmlabel; + + var + l : pasmlabel; + + begin + count:=0; + _class^.symtable^.foreach({$ifndef TP}@{$endif}do_count); + if count>0 then + begin + getdatalabel(l); + datasegment^.concat(new(pai_label,init(l))); + datasegment^.concat(new(pai_const,init_32bit(count))); + _class^.symtable^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry); + genpublishedmethodstable:=l; + end + else + genpublishedmethodstable:=nil; + end; + +{***************************************************************************** + VMT +*****************************************************************************} + + type + pprocdefcoll = ^tprocdefcoll; + + tprocdefcoll = record + next : pprocdefcoll; + data : pprocdef; + end; + + psymcoll = ^tsymcoll; + + tsymcoll = record + next : psymcoll; + name : pstring; + data : pprocdefcoll; + end; + + var + wurzel : psymcoll; + nextvirtnumber : longint; + _c : pobjectdef; + has_constructor,has_virtual_method : boolean; + + procedure eachsym(sym : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + procdefcoll : pprocdefcoll; + hp : pprocdef; + symcoll : psymcoll; + _name : string; + stored : boolean; + + { creates a new entry in the procsym list } + procedure newentry; + + begin + { if not, generate a new symbol item } + new(symcoll); + symcoll^.name:=stringdup(sym^.name); + symcoll^.next:=wurzel; + symcoll^.data:=nil; + wurzel:=symcoll; + hp:=pprocsym(sym)^.definition; + + { inserts all definitions } + while assigned(hp) do + begin + new(procdefcoll); + procdefcoll^.data:=hp; + procdefcoll^.next:=symcoll^.data; + symcoll^.data:=procdefcoll; + + { if it's a virtual method } + if (po_virtualmethod in hp^.procoptions) then + begin + { then it gets a number ... } + hp^.extnumber:=nextvirtnumber; + { and we inc the number } + inc(nextvirtnumber); + has_virtual_method:=true; + end; + + if (hp^.proctypeoption=potype_constructor) then + has_constructor:=true; + + { check, if a method should be overridden } + if (po_overridingmethod in hp^.procoptions) then + MessagePos1(hp^.fileinfo,parser_e_nothing_to_be_overridden,_c^.objname^+'.'+_name+hp^.demangled_paras); + { next overloaded method } + hp:=hp^.nextoverloaded; + end; + end; + + procedure newdefentry; + + begin + new(procdefcoll); + procdefcoll^.data:=hp; + procdefcoll^.next:=symcoll^.data; + symcoll^.data:=procdefcoll; + + { if it's a virtual method } + if (po_virtualmethod in hp^.procoptions) then + begin + { then it gets a number ... } + hp^.extnumber:=nextvirtnumber; + { and we inc the number } + inc(nextvirtnumber); + has_virtual_method:=true; + end; + + if (hp^.proctypeoption=potype_constructor) then + has_constructor:=true; + + { check, if a method should be overridden } + if (po_overridingmethod in hp^.procoptions) then + MessagePos1(hp^.fileinfo,parser_e_nothing_to_be_overridden,_c^.objname^+'.'+_name+hp^.demangled_paras); + end; + + label + handlenextdef; + + begin + { put only sub routines into the VMT } + if psym(sym)^.typ=procsym then + begin + _name:=sym^.name; + symcoll:=wurzel; + while assigned(symcoll) do + begin + { does the symbol already exist in the list ? } + if _name=symcoll^.name^ then + begin + { walk through all defs of the symbol } + hp:=pprocsym(sym)^.definition; + while assigned(hp) do + begin + { compare with all stored definitions } + procdefcoll:=symcoll^.data; + stored:=false; + while assigned(procdefcoll) do + begin + { compare parameters } + if equal_paras(procdefcoll^.data^.para,hp^.para,cp_all) and + ( + (po_virtualmethod in procdefcoll^.data^.procoptions) or + (po_virtualmethod in hp^.procoptions) + ) then + begin { same parameters } + { wenn sie gleich sind } + { und eine davon virtual deklariert ist } + { Fehler falls nur eine VIRTUAL } + if (po_virtualmethod in procdefcoll^.data^.procoptions)<> + (po_virtualmethod in hp^.procoptions) then + begin + { in classes, we hide the old method } + if _c^.is_class then + begin + { warn only if it is the first time, + we hide the method } + if _c=hp^._class then + Message1(parser_w_should_use_override,_c^.objname^+'.'+_name); + end + else + if _c=hp^._class then + begin + if (po_virtualmethod in procdefcoll^.data^.procoptions) then + Message1(parser_w_overloaded_are_not_both_virtual,_c^.objname^+'.'+_name) + else + Message1(parser_w_overloaded_are_not_both_non_virtual, + _c^.objname^+'.'+_name); + end; + { was newentry; exit; (FK) } + newdefentry; + goto handlenextdef; + end + else + { the flags have to match } + { except abstract and override } + { only if both are virtual !! } + if (procdefcoll^.data^.proccalloptions<>hp^.proccalloptions) or + (procdefcoll^.data^.proctypeoption<>hp^.proctypeoption) or + ((procdefcoll^.data^.procoptions- + [po_abstractmethod,po_overridingmethod,po_assembler])<> + (hp^.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler])) then + Message1(parser_e_header_dont_match_forward,_c^.objname^+'.'+_name); + + { check, if the overridden directive is set } + { (povirtualmethod is set! } + + { class ? } + if _c^.is_class and + not(po_overridingmethod in hp^.procoptions) then + begin + { warn only if it is the first time, + we hide the method } + if _c=hp^._class then + Message1(parser_w_should_use_override,_c^.objname^+'.'+_name); + { was newentry; (FK) } + newdefentry; + exit; + end; + + { error, if the return types aren't equal } + if not(is_equal(procdefcoll^.data^.rettype.def,hp^.rettype.def)) and + not((procdefcoll^.data^.rettype.def^.deftype=objectdef) and + (hp^.rettype.def^.deftype=objectdef) and + (pobjectdef(procdefcoll^.data^.rettype.def)^.is_class) and + (pobjectdef(hp^.rettype.def)^.is_class) and + (pobjectdef(hp^.rettype.def)^.is_related( + pobjectdef(procdefcoll^.data^.rettype.def)))) then + Message1(parser_e_overloaded_methodes_not_same_ret,_c^.objname^+'.'+_name); + + + { now set the number } + hp^.extnumber:=procdefcoll^.data^.extnumber; + { and exchange } + procdefcoll^.data:=hp; + stored:=true; + goto handlenextdef; + end; { same parameters } + procdefcoll:=procdefcoll^.next; + end; + { if it isn't saved in the list } + { we create a new entry } + if not(stored) then + begin + new(procdefcoll); + procdefcoll^.data:=hp; + procdefcoll^.next:=symcoll^.data; + symcoll^.data:=procdefcoll; + { if the method is virtual ... } + if (po_virtualmethod in hp^.procoptions) then + begin + { ... it will get a number } + hp^.extnumber:=nextvirtnumber; + inc(nextvirtnumber); + end; + { check, if a method should be overridden } + if (po_overridingmethod in hp^.procoptions) then + MessagePos1(hp^.fileinfo,parser_e_nothing_to_be_overridden, + _c^.objname^+'.'+_name+hp^.demangled_paras); + end; + handlenextdef: + hp:=hp^.nextoverloaded; + end; + exit; + end; + symcoll:=symcoll^.next; + end; + newentry; + end; + end; + + procedure genvmt(list : paasmoutput;_class : pobjectdef); + + procedure do_genvmt(p : pobjectdef); + + begin + { start with the base class } + if assigned(p^.childof) then + do_genvmt(p^.childof); + + { walk through all public syms } + { I had to change that to solve bug0260 (PM)} + { _c:=p; } + _c:=_class; + { Florian, please check if you agree (PM) } + { no it wasn't correct, but I fixed it at } + { another place: your fix hides only a bug } + { _c is only used to give correct warnings } + p^.symtable^.foreach({$ifndef TP}@{$endif}eachsym); + end; + + var + symcoll : psymcoll; + procdefcoll : pprocdefcoll; + i : longint; + + begin + wurzel:=nil; + nextvirtnumber:=0; + + has_constructor:=false; + has_virtual_method:=false; + + { generates a tree of all used methods } + do_genvmt(_class); + + if has_virtual_method and not(has_constructor) then + Message1(parser_w_virtual_without_constructor,_class^.objname^); + + + { generates the VMT } + + { walk trough all numbers for virtual methods and search } + { the method } + for i:=0 to nextvirtnumber-1 do + begin + symcoll:=wurzel; + + { walk trough all symbols } + while assigned(symcoll) do + begin + + { walk trough all methods } + procdefcoll:=symcoll^.data; + while assigned(procdefcoll) do + begin + { writes the addresses to the VMT } + { but only this which are declared as virtual } + if procdefcoll^.data^.extnumber=i then + begin + if (po_virtualmethod in procdefcoll^.data^.procoptions) then + begin + { if a method is abstract, then is also the } + { class abstract and it's not allow to } + { generates an instance } + if (po_abstractmethod in procdefcoll^.data^.procoptions) then + begin + include(_class^.objectoptions,oo_has_abstract); + list^.concat(new(pai_const_symbol,initname('FPC_ABSTRACTERROR'))); + end + else + begin + list^.concat(new(pai_const_symbol, + initname(procdefcoll^.data^.mangledname))); + end; + end; + end; + procdefcoll:=procdefcoll^.next; + end; + symcoll:=symcoll^.next; + end; + end; + { disposes the above generated tree } + symcoll:=wurzel; + while assigned(symcoll) do + begin + wurzel:=symcoll^.next; + stringdispose(symcoll^.name); + procdefcoll:=symcoll^.data; + while assigned(procdefcoll) do + begin + symcoll^.data:=procdefcoll^.next; + dispose(procdefcoll); + procdefcoll:=symcoll^.data; + end; + dispose(symcoll); + symcoll:=wurzel; + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.30 2000/06/30 22:11:28 peter + * fixed some getlabel to getdatalabel + + Revision 1.29 2000/06/20 12:47:52 pierre + * equal_paras and convertable_paras changed by transforming third parameter + into an enum with three possible values: + cp_none, cp_value_equal_const and cp_all. + + Revision 1.28 2000/05/11 06:55:28 florian + * fixed some vmt problems, especially related to overloaded methods + in objects/classes + + Revision 1.27 2000/04/29 12:49:30 peter + * fixed long line for tp7 + + Revision 1.26 2000/03/06 15:57:42 peter + * better error pos for overridden error + + Revision 1.25 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.24 2000/01/28 23:17:53 florian + * virtual XXXX; support for objects, only if -dWITHDMT is defined + + Revision 1.23 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.22 1999/12/02 19:22:16 peter + * write also parameters for override info + + Revision 1.21 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.20 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.19 1999/11/29 23:42:49 pierre + * fix for form bug 555 + + Revision 1.18 1999/10/26 12:30:41 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.17 1999/09/13 16:23:42 peter + * remvoed unused var + + Revision 1.16 1999/09/12 14:50:50 florian + + implemented creation of methodname/address tables + + Revision 1.15 1999/09/01 13:44:56 florian + * fixed writing of class rtti: vmt offset were written wrong + + Revision 1.14 1999/08/03 22:02:52 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/hcodegen.pas b/befpc/compiler/hcodegen.pas new file mode 100644 index 0000000..df8cdf5 --- /dev/null +++ b/befpc/compiler/hcodegen.pas @@ -0,0 +1,540 @@ +{ + $Id: hcodegen.pas,v 1.1.1.1 2001-07-23 17:16:29 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit exports some help routines for the code generation + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit hcodegen; + +{$ifdef newcg} +interface + +implementation +{$else newcg} + + interface + + uses + cobjects, + tokens,verbose, + aasm,symconst,symtable,cpubase; + + const + pi_uses_asm = $1; { set, if the procedure uses asm } + pi_is_global = $2; { set, if the procedure is exported by an unit } + pi_do_call = $4; { set, if the procedure does a call } + pi_operator = $8; { set, if the procedure is an operator } + pi_C_import = $10; { set, if the procedure is an external C function } + pi_uses_exceptions = $20;{ set, if the procedure has a try statement => } + { no register variables } + pi_is_assembler = $40; { set if the procedure is declared as ASSEMBLER + => don't optimize} + pi_needs_implicit_finally = $80; { set, if the procedure contains data which } + { needs to be finalized } + type + pprocinfo = ^tprocinfo; + tprocinfo = object + { pointer to parent in nested procedures } + parent : pprocinfo; + { current class, if we are in a method } + _class : pobjectdef; + { return type } + returntype : ttype; + { symbol of the function, and the sym for result variable } + resultfuncretsym, + funcretsym : pfuncretsym; + funcret_state : tvarstate; + { the definition of the proc itself } + def : pprocdef; + sym : pprocsym; + + { frame pointer offset } + framepointer_offset : longint; + { self pointer offset } + selfpointer_offset : longint; + { result value offset } + return_offset : longint; + { firsttemp position } + firsttemp_offset : longint; + { parameter offset } + para_offset : longint; + + { some collected informations about the procedure } + { see pi_xxxx above } + flags : longint; + + { register used as frame pointer } + framepointer : tregister; + + { true, if the procedure is exported by an unit } + globalsymbol : boolean; + + { true, if the procedure should be exported (only OS/2) } + exported : boolean; + + { true, if we can not use fast exit code } + no_fast_exit : boolean; + + { code for the current procedure } + aktproccode,aktentrycode, + aktexitcode,aktlocaldata : paasmoutput; + { local data is used for smartlink } + + constructor init; + destructor done; + end; + + { some kind of temp. types needs to be destructed } + { for example ansistring, this is done using this } + { list } + ptemptodestroy = ^ttemptodestroy; + ttemptodestroy = object(tlinkedlist_item) + typ : pdef; + address : treference; + constructor init(const a : treference;p : pdef); + end; + + var + { info about the current sub routine } + procinfo : pprocinfo; + + { labels for BREAK and CONTINUE } + aktbreaklabel,aktcontinuelabel : pasmlabel; + + { label when the result is true or false } + truelabel,falselabel : pasmlabel; + + { label to leave the sub routine } + aktexitlabel : pasmlabel; + + { also an exit label, only used we need to clear only the stack } + aktexit2label : pasmlabel; + + { only used in constructor for fail or if getmem fails } + faillabel,quickexitlabel : pasmlabel; + + { Boolean, wenn eine loadn kein Assembler erzeugt hat } + simple_loadn : boolean; + + { true, if an error while code generation occurs } + codegenerror : boolean; + + { save the size of pushed parameter, needed for aligning } + pushedparasize : longint; + + make_const_global : boolean; + + { message calls with codegenerror support } + procedure cgmessage(t : longint); + procedure cgmessage1(t : longint;const s : string); + procedure cgmessage2(t : longint;const s1,s2 : string); + procedure cgmessage3(t : longint;const s1,s2,s3 : string); + procedure CGMessagePos(const pos:tfileposinfo;t:longint); + procedure CGMessagePos1(const pos:tfileposinfo;t:longint;const s1:string); + procedure CGMessagePos2(const pos:tfileposinfo;t:longint;const s1,s2:string); + procedure CGMessagePos3(const pos:tfileposinfo;t:longint;const s1,s2,s3:string); + + { initialize respectively terminates the code generator } + { for a new module or procedure } + procedure codegen_doneprocedure; + procedure codegen_donemodule; + procedure codegen_newmodule; + procedure codegen_newprocedure; + +implementation + + uses + systems,globals,files,strings,cresstr +{$ifdef fixLeaksOnError} + ,comphook +{$endif fixLeaksOnError} + + ; + +{$ifdef fixLeaksOnError} + var procinfoStack: TStack; + hcodegen_old_do_stop: tstopprocedure; +{$endif fixLeaksOnError} + +{***************************************************************************** + override the message calls to set codegenerror +*****************************************************************************} + + procedure cgmessage(t : longint); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.Message(t); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessage1(t : longint;const s : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.Message1(t,s); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessage2(t : longint;const s1,s2 : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.Message2(t,s1,s2); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessage3(t : longint;const s1,s2,s3 : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.Message3(t,s1,s2,s3); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + + procedure cgmessagepos(const pos:tfileposinfo;t : longint); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.MessagePos(pos,t); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessagepos1(const pos:tfileposinfo;t : longint;const s1 : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.MessagePos1(pos,t,s1); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessagepos2(const pos:tfileposinfo;t : longint;const s1,s2 : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.MessagePos2(pos,t,s1,s2); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + procedure cgmessagepos3(const pos:tfileposinfo;t : longint;const s1,s2,s3 : string); + var + olderrorcount : longint; + begin + if not(codegenerror) then + begin + olderrorcount:=Errorcount; + verbose.MessagePos3(pos,t,s1,s2,s3); + codegenerror:=olderrorcount<>Errorcount; + end; + end; + + +{**************************************************************************** + TProcInfo +****************************************************************************} + + constructor tprocinfo.init; + begin + parent:=nil; + _class:=nil; + returntype.reset; + resultfuncretsym:=nil; + funcretsym:=nil; + funcret_state:=vs_none; + def:=nil; + sym:=nil; + framepointer_offset:=0; + selfpointer_offset:=0; + return_offset:=0; + firsttemp_offset:=0; + para_offset:=0; + flags:=0; + framepointer:=R_NO; + globalsymbol:=false; + exported:=false; + no_fast_exit:=false; + + aktentrycode:=new(paasmoutput,init); + aktexitcode:=new(paasmoutput,init); + aktproccode:=new(paasmoutput,init); + aktlocaldata:=new(paasmoutput,init); + end; + + + destructor tprocinfo.done; + begin + dispose(aktentrycode,done); + dispose(aktexitcode,done); + dispose(aktproccode,done); + dispose(aktlocaldata,done); + end; + + +{***************************************************************************** + initialize/terminate the codegen for procedure and modules +*****************************************************************************} + + procedure codegen_newprocedure; + begin + aktbreaklabel:=nil; + aktcontinuelabel:=nil; + { aktexitlabel:=0; is store in oldaktexitlabel + so it must not be reset to zero before this storage !} + { new procinfo } + new(procinfo,init); +{$ifdef fixLeaksOnError} + procinfoStack.push(procinfo); +{$endif fixLeaksOnError} + end; + + + + procedure codegen_doneprocedure; + begin +{$ifdef fixLeaksOnError} + if procinfo <> procinfoStack.pop then + writeln('problem with procinfoStack!'); +{$endif fixLeaksOnError} + dispose(procinfo,done); + procinfo:=nil; + end; + + + + procedure codegen_newmodule; + begin + exprasmlist:=new(paasmoutput,init); + datasegment:=new(paasmoutput,init); + codesegment:=new(paasmoutput,init); + bsssegment:=new(paasmoutput,init); + debuglist:=new(paasmoutput,init); + withdebuglist:=new(paasmoutput,init); + consts:=new(paasmoutput,init); + rttilist:=new(paasmoutput,init); + ResourceStringList:=Nil; + importssection:=nil; + exportssection:=nil; + resourcesection:=nil; + { assembler symbols } + asmsymbollist:=new(pasmsymbollist,init); + asmsymbollist^.usehash; + { resourcestrings } + new(ResourceStrings,Init); + end; + + + + procedure codegen_donemodule; +{$ifdef MEMDEBUG} + var + d : tmemdebug; +{$endif} + begin +{$ifdef MEMDEBUG} + d.init('asmlist'); +{$endif} + dispose(exprasmlist,done); + dispose(codesegment,done); + dispose(bsssegment,done); + dispose(datasegment,done); + dispose(debuglist,done); + dispose(withdebuglist,done); + dispose(consts,done); + dispose(rttilist,done); + if assigned(ResourceStringList) then + dispose(ResourceStringList,done); + if assigned(importssection) then + dispose(importssection,done); + if assigned(exportssection) then + dispose(exportssection,done); + if assigned(resourcesection) then + dispose(resourcesection,done); +{$ifdef MEMDEBUG} + d.done; +{$endif} + { assembler symbols } +{$ifdef MEMDEBUG} + d.init('asmsymbol'); +{$endif} + dispose(asmsymbollist,done); +{$ifdef MEMDEBUG} + d.done; +{$endif} + { resource strings } + dispose(ResourceStrings,done); + end; + + +{***************************************************************************** + TTempToDestroy +*****************************************************************************} + + constructor ttemptodestroy.init(const a : treference;p : pdef); + begin + inherited init; + address:=a; + typ:=p; + end; +{$endif newcg} + +{$ifdef fixLeaksOnError} +procedure hcodegen_do_stop; {$ifdef tp} far; {$endif tp} +var p: pprocinfo; +begin + p := pprocinfo(procinfoStack.pop); + while p <> nil Do + begin + dispose(p,done); + p := pprocinfo(procinfoStack.pop); + end; + procinfoStack.done; + do_stop := hcodegen_old_do_stop; +{$ifdef tp} + do_stop; +{$else tp} + do_stop(); +{$endif tp} +end; + +begin + hcodegen_old_do_stop := do_stop; + do_stop := {$ifdef tp}@{$endif}hcodegen_do_stop; + procinfoStack.init; +{$endif fixLeaksOnError} +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.60 2000/06/30 20:23:36 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.59 2000/06/01 19:09:57 peter + * made resourcestrings OOP so it's easier to handle it per module + + Revision 1.58 2000/04/02 18:30:12 florian + * fixed another problem with readln(); + * the register allocator takes now care of necessary pushes/pops for + readln/writeln + + Revision 1.57 2000/02/18 20:53:14 pierre + * fixes a stabs problem for functions + + includes a stabs local var for with statements + the name is with in lowercase followed by an index + for nested with. + + Withdebuglist added because the stabs declarations of local + var are postponed to end of function. + + Revision 1.56 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.55 2000/01/16 22:17:11 peter + * renamed call_offset to para_offset + + Revision 1.54 2000/01/11 17:16:04 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.53 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.52 1999/12/09 23:18:04 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.51 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.50 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.49 1999/11/17 17:04:59 pierre + * Notes/hints changes + + Revision 1.48 1999/11/09 23:06:45 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.47 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.46 1999/10/21 14:18:54 peter + * tp7 fix + + Revision 1.45 1999/10/14 14:57:52 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.44 1999/10/13 10:42:15 peter + * cgmessagepos functions + + Revision 1.43 1999/09/27 23:44:51 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.42 1999/08/26 20:24:40 michael + + Hopefuly last fixes for resourcestrings + + Revision 1.41 1999/08/24 13:14:03 peter + * MEMDEBUG to see the sizes of asmlist,asmsymbols,symtables + + Revision 1.40 1999/08/24 12:01:32 michael + + changes for resourcestrings + + Revision 1.39 1999/08/19 13:10:18 pierre + + faillabel for _FAIL + + Revision 1.38 1999/08/16 18:23:56 peter + * reset resourcestringlist in newmodule. + + Revision 1.37 1999/08/04 00:23:02 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.36 1999/08/01 23:09:26 michael + * procbase -> cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/htypechk.pas b/befpc/compiler/htypechk.pas new file mode 100644 index 0000000..2f8325a --- /dev/null +++ b/befpc/compiler/htypechk.pas @@ -0,0 +1,1255 @@ +{ + $Id: htypechk.pas,v 1.1.1.1 2001-07-23 17:16:29 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit exports some help routines for the type checking + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit htypechk; +interface + + uses + tokens,tree,symtable; + + type + Ttok2nodeRec=record + tok : ttoken; + nod : ttreetyp; + op_overloading_supported : boolean; + end; + + const + tok2nodes=25; + tok2node:array[1..tok2nodes] of ttok2noderec=( + (tok:_PLUS ;nod:addn;op_overloading_supported:true), { binary overloading supported } + (tok:_MINUS ;nod:subn;op_overloading_supported:true), { binary and unary overloading supported } + (tok:_STAR ;nod:muln;op_overloading_supported:true), { binary overloading supported } + (tok:_SLASH ;nod:slashn;op_overloading_supported:true), { binary overloading supported } + (tok:_EQUAL ;nod:equaln;op_overloading_supported:true), { binary overloading supported } + (tok:_GT ;nod:gtn;op_overloading_supported:true), { binary overloading supported } + (tok:_LT ;nod:ltn;op_overloading_supported:true), { binary overloading supported } + (tok:_GTE ;nod:gten;op_overloading_supported:true), { binary overloading supported } + (tok:_LTE ;nod:lten;op_overloading_supported:true), { binary overloading supported } + (tok:_SYMDIF ;nod:symdifn;op_overloading_supported:true), { binary overloading supported } + (tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_NOT ;nod:notn;op_overloading_supported:true), { unary overloading supported } + (tok:_OP_MOD ;nod:modn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_SHL ;nod:shln;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_SHR ;nod:shrn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_XOR ;nod:xorn;op_overloading_supported:true), { binary overloading supported } + (tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported } + (tok:_CARET ;nod:caretn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead } + ); + const + { firstcallparan without varspez we don't count the ref } +{$ifdef extdebug} + count_ref : boolean = true; +{$endif def extdebug} + get_para_resulttype : boolean = false; + allow_array_constructor : boolean = false; + + + { Conversion } + function isconvertable(def_from,def_to : pdef; + var doconv : tconverttype;fromtreetype : ttreetyp; + explicit : boolean) : byte; + { is overloading of this operator allowed for this + binary operator } + function isbinaryoperatoroverloadable(ld, rd,dd : pdef; + treetyp : ttreetyp) : boolean; + + { is overloading of this operator allowed for this + unary operator } + function isunaryoperatoroverloadable(rd,dd : pdef; + treetyp : ttreetyp) : boolean; + + { check operator args and result type } + function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean; + + { Register Allocation } + procedure make_not_regable(p : ptree); + procedure left_right_max(p : ptree); + procedure calcregisters(p : ptree;r32,fpu,mmx : word); + + { subroutine handling } + procedure test_protected_sym(sym : psym); + procedure test_protected(p : ptree); + function valid_for_formal_var(p : ptree) : boolean; + function valid_for_formal_const(p : ptree) : boolean; + function is_procsym_load(p:Ptree):boolean; + function is_procsym_call(p:Ptree):boolean; + function assignment_overloaded(from_def,to_def : pdef) : pprocdef; + procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef); + function valid_for_assign(p:ptree;allowprop:boolean):boolean; + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst, + types,pass_1,cpubase, +{$ifdef newcg} + cgbase +{$else} + hcodegen +{$endif} + ; + +{**************************************************************************** + Convert +****************************************************************************} + + { Returns: + 0 - Not convertable + 1 - Convertable + 2 - Convertable, but not first choice } + function isconvertable(def_from,def_to : pdef; + var doconv : tconverttype;fromtreetype : ttreetyp; + explicit : boolean) : byte; + + { Tbasetype: uauto,uvoid,uchar, + u8bit,u16bit,u32bit, + s8bit,s16bit,s32, + bool8bit,bool16bit,bool32bit, + u64bit,s64bitint } + type + tbasedef=(bvoid,bchar,bint,bbool); + const + basedeftbl:array[tbasetype] of tbasedef = + (bvoid,bvoid,bchar, + bint,bint,bint, + bint,bint,bint, + bbool,bbool,bbool,bint,bint,bchar); + + basedefconverts : array[tbasedef,tbasedef] of tconverttype = + ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible), + (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible), + (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool), + (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool)); + + var + b : byte; + hd1,hd2 : pdef; + hct : tconverttype; + begin + { safety check } + if not(assigned(def_from) and assigned(def_to)) then + begin + isconvertable:=0; + exit; + end; + + { tp7 procvar def support, in tp7 a procvar is always called, if the + procvar is passed explicit a addrn would be there } + if (m_tp_procvar in aktmodeswitches) and + (def_from^.deftype=procvardef) and + (fromtreetype=loadn) then + begin + def_from:=pprocvardef(def_from)^.rettype.def; + end; + + { we walk the wanted (def_to) types and check then the def_from + types if there is a conversion possible } + b:=0; + case def_to^.deftype of + orddef : + begin + case def_from^.deftype of + orddef : + begin + doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]]; + b:=1; + if (doconv=tc_not_possible) or + ((doconv=tc_int_2_bool) and + (not explicit) and + (not is_boolean(def_from))) or + ((doconv=tc_bool_2_int) and + (not explicit) and + (not is_boolean(def_to))) then + b:=0; + end; + enumdef : + begin + { needed for char(enum) } + if explicit then + begin + doconv:=tc_int_2_int; + b:=1; + end; + end; + end; + end; + + stringdef : + begin + case def_from^.deftype of + stringdef : + begin + doconv:=tc_string_2_string; + b:=1; + end; + orddef : + begin + { char to string} + if is_char(def_from) then + begin + doconv:=tc_char_2_string; + b:=1; + end; + end; + arraydef : + begin + { array of char to string, the length check is done by the firstpass of this node } + if is_chararray(def_from) then + begin + doconv:=tc_chararray_2_string; + if (not(cs_ansistrings in aktlocalswitches) and + is_shortstring(def_to)) or + ((cs_ansistrings in aktlocalswitches) and + is_ansistring(def_to)) then + b:=1 + else + b:=2; + end; + end; + pointerdef : + begin + { pchar can be assigned to short/ansistrings, + but not in tp7 compatible mode } + if is_pchar(def_from) and not(m_tp7 in aktmodeswitches) then + begin + doconv:=tc_pchar_2_string; + b:=1; + end; + end; + end; + end; + + floatdef : + begin + case def_from^.deftype of + orddef : + begin { ordinal to real } + if is_integer(def_from) then + begin + if pfloatdef(def_to)^.typ=f32bit then + doconv:=tc_int_2_fix + else + doconv:=tc_int_2_real; + b:=1; + end; + end; + floatdef : + begin { 2 float types ? } + if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then + doconv:=tc_equal + else + begin + if pfloatdef(def_from)^.typ=f32bit then + doconv:=tc_fix_2_real + else + if pfloatdef(def_to)^.typ=f32bit then + doconv:=tc_real_2_fix + else + doconv:=tc_real_2_real; + end; + b:=1; + end; + end; + end; + + enumdef : + begin + if (def_from^.deftype=enumdef) then + begin + hd1:=def_from; + while assigned(penumdef(hd1)^.basedef) do + hd1:=penumdef(hd1)^.basedef; + hd2:=def_to; + while assigned(penumdef(hd2)^.basedef) do + hd2:=penumdef(hd2)^.basedef; + if (hd1=hd2) then + begin + b:=1; + doconv:=tc_equal; + end; + end; + end; + + arraydef : + begin + { open array is also compatible with a single element of its base type } + if is_open_array(def_to) and + is_equal(parraydef(def_to)^.elementtype.def,def_from) then + begin + doconv:=tc_equal; + b:=1; + end + else + begin + case def_from^.deftype of + arraydef : + begin + { array constructor -> open array } + if is_open_array(def_to) and + is_array_constructor(def_from) then + begin + if is_void(parraydef(def_from)^.elementtype.def) or + is_equal(parraydef(def_to)^.elementtype.def,parraydef(def_from)^.elementtype.def) then + begin + doconv:=tc_equal; + b:=1; + end + else + if isconvertable(parraydef(def_from)^.elementtype.def, + parraydef(def_to)^.elementtype.def,hct,arrayconstructn,false)<>0 then + begin + doconv:=hct; + b:=2; + end; + end; + end; + pointerdef : + begin + if is_zero_based_array(def_to) and + is_equal(ppointerdef(def_from)^.pointertype.def,parraydef(def_to)^.elementtype.def) then + begin + doconv:=tc_pointer_2_array; + b:=1; + end; + end; + stringdef : + begin + { string to array of char} + if (not(is_special_array(def_to)) or is_open_array(def_to)) and + is_equal(parraydef(def_to)^.elementtype.def,cchardef) then + begin + doconv:=tc_string_2_chararray; + b:=1; + end; + end; + end; + end; + end; + + pointerdef : + begin + case def_from^.deftype of + stringdef : + begin + { string constant (which can be part of array constructor) + to zero terminated string constant } + if (fromtreetype in [arrayconstructn,stringconstn]) and + is_pchar(def_to) then + begin + doconv:=tc_cstring_2_pchar; + b:=1; + end; + end; + orddef : + begin + { char constant to zero terminated string constant } + if (fromtreetype=ordconstn) then + begin + if is_equal(def_from,cchardef) and + is_pchar(def_to) then + begin + doconv:=tc_cchar_2_pchar; + b:=1; + end + else + if is_integer(def_from) then + begin + doconv:=tc_cord_2_pointer; + b:=1; + end; + end; + end; + arraydef : + begin + { chararray to pointer } + if is_zero_based_array(def_from) and + is_equal(parraydef(def_from)^.elementtype.def,ppointerdef(def_to)^.pointertype.def) then + begin + doconv:=tc_array_2_pointer; + b:=1; + end; + end; + pointerdef : + begin + { child class pointer can be assigned to anchestor pointers } + if ( + (ppointerdef(def_from)^.pointertype.def^.deftype=objectdef) and + (ppointerdef(def_to)^.pointertype.def^.deftype=objectdef) and + pobjectdef(ppointerdef(def_from)^.pointertype.def)^.is_related( + pobjectdef(ppointerdef(def_to)^.pointertype.def)) + ) or + { all pointers can be assigned to void-pointer } + is_equal(ppointerdef(def_to)^.pointertype.def,voiddef) or + { in my opnion, is this not clean pascal } + { well, but it's handy to use, it isn't ? (FK) } + is_equal(ppointerdef(def_from)^.pointertype.def,voiddef) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + procvardef : + begin + { procedure variable can be assigned to an void pointer } + { Not anymore. Use the @ operator now.} + if not(m_tp_procvar in aktmodeswitches) and + (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and + (porddef(ppointerdef(def_to)^.pointertype.def)^.typ=uvoid) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + classrefdef, + objectdef : + begin + { class types and class reference type + can be assigned to void pointers } + if ( + ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.is_class) or + (def_from^.deftype=classrefdef) + ) and + (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and + (porddef(ppointerdef(def_to)^.pointertype.def)^.typ=uvoid) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + end; + end; + + setdef : + begin + { automatic arrayconstructor -> set conversion } + if is_array_constructor(def_from) then + begin + doconv:=tc_arrayconstructor_2_set; + b:=1; + end; + end; + + procvardef : + begin + { proc -> procvar } + if (def_from^.deftype=procdef) then + begin + doconv:=tc_proc_2_procvar; + if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then + b:=1; + end + else + { for example delphi allows the assignement from pointers } + { to procedure variables } + if (m_pointer_2_procedure in aktmodeswitches) and + (def_from^.deftype=pointerdef) and + (ppointerdef(def_from)^.pointertype.def^.deftype=orddef) and + (porddef(ppointerdef(def_from)^.pointertype.def)^.typ=uvoid) then + begin + doconv:=tc_equal; + b:=1; + end + else + { nil is compatible with procvars } + if (fromtreetype=niln) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + + objectdef : + begin + { object pascal objects } + if (def_from^.deftype=objectdef) {and + pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then + begin + doconv:=tc_equal; + if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then + b:=1; + end + else + { Class specific } + if (pobjectdef(def_to)^.is_class) then + begin + { void pointer also for delphi mode } + if (m_delphi in aktmodeswitches) and + is_voidpointer(def_from) then + begin + doconv:=tc_equal; + b:=1; + end + else + { nil is compatible with class instances } + if (fromtreetype=niln) and (pobjectdef(def_to)^.is_class) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + end; + + classrefdef : + begin + { class reference types } + if (def_from^.deftype=classrefdef) then + begin + doconv:=tc_equal; + if pobjectdef(pclassrefdef(def_from)^.pointertype.def)^.is_related( + pobjectdef(pclassrefdef(def_to)^.pointertype.def)) then + b:=1; + end + else + { nil is compatible with class references } + if (fromtreetype=niln) then + begin + doconv:=tc_equal; + b:=1; + end; + end; + + filedef : + begin + { typed files are all equal to the abstract file type + name TYPEDFILE in system.pp in is_equal in types.pas + the problem is that it sholud be also compatible to FILE + but this would leed to a problem for ASSIGN RESET and REWRITE + when trying to find the good overloaded function !! + so all file function are doubled in system.pp + this is not very beautiful !!} + if (def_from^.deftype=filedef) and + ( + ( + (pfiledef(def_from)^.filetyp = ft_typed) and + (pfiledef(def_to)^.filetyp = ft_typed) and + ( + (pfiledef(def_from)^.typedfiletype.def = pdef(voiddef)) or + (pfiledef(def_to)^.typedfiletype.def = pdef(voiddef)) + ) + ) or + ( + ( + (pfiledef(def_from)^.filetyp = ft_untyped) and + (pfiledef(def_to)^.filetyp = ft_typed) + ) or + ( + (pfiledef(def_from)^.filetyp = ft_typed) and + (pfiledef(def_to)^.filetyp = ft_untyped) + ) + ) + ) then + begin + doconv:=tc_equal; + b:=1; + end + end; + + else + begin + { assignment overwritten ?? } + if assignment_overloaded(def_from,def_to)<>nil then + b:=2; + end; + end; + isconvertable:=b; + end; + + { ld is the left type definition + rd the right type definition + dd the result type definition or voiddef if unkown } + function isbinaryoperatoroverloadable(ld, rd, dd : pdef; + treetyp : ttreetyp) : boolean; + begin + isbinaryoperatoroverloadable:= + (treetyp=starstarn) or + (ld^.deftype=recorddef) or + (rd^.deftype=recorddef) or + ((rd^.deftype=pointerdef) and + not(is_pchar(rd) and + (is_chararray(ld) or + (ld^.deftype=stringdef) or + (treetyp=addn))) and + (not(ld^.deftype in [pointerdef,objectdef,classrefdef,procvardef]) or + not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,subn]) + ) and + (not is_integer(ld) or not (treetyp in [addn,subn])) + ) or + ((ld^.deftype=pointerdef) and + not(is_pchar(ld) and + (is_chararray(rd) or + (rd^.deftype=stringdef) or + (treetyp=addn))) and + (not(rd^.deftype in [stringdef,pointerdef,objectdef,classrefdef,procvardef]) and + ((not is_integer(rd) and (rd^.deftype<>objectdef) + and (rd^.deftype<>classrefdef)) or + not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,addn,subn]) + ) + ) + ) or + { array def, but not mmx or chararray+[char,string,chararray] } + ((ld^.deftype=arraydef) and + not((cs_mmx in aktlocalswitches) and + is_mmx_able_array(ld)) and + not(is_chararray(ld) and + (is_char(rd) or + is_pchar(rd) or + (rd^.deftype=stringdef) or + is_chararray(rd))) + ) or + ((rd^.deftype=arraydef) and + not((cs_mmx in aktlocalswitches) and + is_mmx_able_array(rd)) and + not(is_chararray(rd) and + (is_char(ld) or + is_pchar(ld) or + (ld^.deftype=stringdef) or + is_chararray(ld))) + ) or + { <> and = are defined for classes } + ((ld^.deftype=objectdef) and + (not(pobjectdef(ld)^.is_class) or + not(treetyp in [equaln,unequaln]) + ) + ) or + ((rd^.deftype=objectdef) and + (not(pobjectdef(rd)^.is_class) or + not(treetyp in [equaln,unequaln]) + ) + or + { allow other operators that + on strings } + ( + (is_char(rd) or + is_pchar(rd) or + (rd^.deftype=stringdef) or + is_chararray(rd) or + is_char(ld) or + is_pchar(ld) or + (ld^.deftype=stringdef) or + is_chararray(ld) + ) and + not(treetyp in [addn,equaln,unequaln,gtn,gten,ltn,lten]) and + not(is_pchar(ld) and + (is_integer(rd) or (rd^.deftype=pointerdef)) and + (treetyp=subn) + ) + ) + ); + end; + + + function isunaryoperatoroverloadable(rd,dd : pdef; + treetyp : ttreetyp) : boolean; + begin + isunaryoperatoroverloadable:=false; + { what assignment overloading should be allowed ?? } + if (treetyp=assignn) then + begin + isunaryoperatoroverloadable:=true; + { this already get tbs0261 to fail + isunaryoperatoroverloadable:=not is_equal(rd,dd); PM } + end + { should we force that rd and dd are equal ?? } + else if (treetyp=subn { unaryminusn }) then + begin + isunaryoperatoroverloadable:= + not is_integer(rd) and not (rd^.deftype=floatdef) +{$ifdef SUPPORT_MMX} + and not ((cs_mmx in aktlocalswitches) and + is_mmx_able_array(rd)) +{$endif SUPPORT_MMX} + ; + end + else if (treetyp=notn) then + begin + isunaryoperatoroverloadable:=not is_integer(rd) and not is_boolean(rd) +{$ifdef SUPPORT_MMX} + and not ((cs_mmx in aktlocalswitches) and + is_mmx_able_array(rd)) +{$endif SUPPORT_MMX} + ; + end; + end; + + function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean; + var + ld,rd,dd : pdef; + i : longint; + begin + case pf^.parast^.symindex^.count of + 2 : begin + isoperatoracceptable:=false; + for i:=1 to tok2nodes do + if tok2node[i].tok=optoken then + begin + ld:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def; + rd:=pvarsym(pf^.parast^.symindex^.first^.next)^.vartype.def; + dd:=pf^.rettype.def; + isoperatoracceptable:= + tok2node[i].op_overloading_supported and + isbinaryoperatoroverloadable(ld,rd,dd,tok2node[i].nod); + break; + end; + end; + 1 : begin + rd:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def; + dd:=pf^.rettype.def; + for i:=1 to tok2nodes do + if tok2node[i].tok=optoken then + begin + isoperatoracceptable:= + tok2node[i].op_overloading_supported and + isunaryoperatoroverloadable(rd,dd,tok2node[i].nod); + break; + end; + end; + else + isoperatoracceptable:=false; + end; + end; + +{**************************************************************************** + Register Calculation +****************************************************************************} + + { marks an lvalue as "unregable" } + procedure make_not_regable(p : ptree); + begin + case p^.treetype of + typeconvn : + make_not_regable(p^.left); + loadn : + if p^.symtableentry^.typ=varsym then + pvarsym(p^.symtableentry)^.varoptions:=pvarsym(p^.symtableentry)^.varoptions-[vo_regable,vo_fpuregable]; + end; + end; + + + procedure left_right_max(p : ptree); + begin + if assigned(p^.left) then + begin + if assigned(p^.right) then + begin + p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); + p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); +{$endif SUPPORT_MMX} + end + else + begin + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + end; + end; + end; + + { calculates the needed registers for a binary operator } + procedure calcregisters(p : ptree;r32,fpu,mmx : word); + + begin + left_right_max(p); + + { Only when the difference between the left and right registers < the + wanted registers allocate the amount of registers } + + if assigned(p^.left) then + begin + if assigned(p^.right) then + begin + if (abs(p^.left^.registers32-p^.right^.registers32)0) and + (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM]) and + (p^.right^.location.loc in [LOC_REFERENCE,LOC_MEM]) then + inc(p^.registers32); + end + else + begin + if (p^.left^.registers328 then + CGMessage(cg_e_too_complex_expr); + end; + +{**************************************************************************** + Subroutine Handling +****************************************************************************} + +{ protected field handling + protected field can not appear in + var parameters of function !! + this can only be done after we have determined the + overloaded function + this is the reason why it is not in the parser, PM } + + procedure test_protected_sym(sym : psym); + begin + if (sp_protected in sym^.symoptions) and + ((sym^.owner^.symtabletype=unitsymtable) or + ((sym^.owner^.symtabletype=objectsymtable) and + (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable)) + ) then + CGMessage(parser_e_cant_access_protected_member); + end; + + + procedure test_protected(p : ptree); + begin + case p^.treetype of + loadn : test_protected_sym(p^.symtableentry); + typeconvn : test_protected(p^.left); + derefn : test_protected(p^.left); + subscriptn : begin + { test_protected(p^.left); + Is a field of a protected var + also protected ??? PM } + test_protected_sym(p^.vs); + end; + end; + end; + + function valid_for_formal_var(p : ptree) : boolean; + var + v : boolean; + begin + case p^.treetype of + loadn : + v:=(p^.symtableentry^.typ in [typedconstsym,varsym]); + typeconvn : + v:=valid_for_formal_var(p^.left); + derefn, + subscriptn, + vecn, + funcretn, + selfn : + v:=true; + calln : { procvars are callnodes first } + v:=assigned(p^.right) and not assigned(p^.left); + addrn : + begin + { addrn is not allowed as this generate a constant value, + but a tp procvar are allowed (PFV) } + if p^.procvarload then + v:=true + else + v:=false; + end; + else + v:=false; + end; + valid_for_formal_var:=v; + end; + + function valid_for_formal_const(p : ptree) : boolean; + var + v : boolean; + begin + { p must have been firstpass'd before } + { accept about anything but not a statement ! } + case p^.treetype of + calln, + statementn, + addrn : + begin + { addrn is not allowed as this generate a constant value, + but a tp procvar are allowed (PFV) } + if p^.procvarload then + v:=true + else + v:=false; + end; + else + v:=true; + end; + valid_for_formal_const:=v; + end; + + function is_procsym_load(p:Ptree):boolean; + begin + is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or + ((p^.treetype=addrn) and (p^.left^.treetype=loadn) + and (p^.left^.symtableentry^.typ=procsym)) ; + end; + + { change a proc call to a procload for assignment to a procvar } + { this can only happen for proc/function without arguments } + function is_procsym_call(p:Ptree):boolean; + begin + is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and + (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or + ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym))); + end; + + + function assignment_overloaded(from_def,to_def : pdef) : pprocdef; + var + passproc : pprocdef; + convtyp : tconverttype; + begin + assignment_overloaded:=nil; + if assigned(overloaded_operators[_assignment]) then + passproc:=overloaded_operators[_assignment]^.definition + else + exit; + while passproc<>nil do + begin + if is_equal(passproc^.rettype.def,to_def) and + (is_equal(pparaitem(passproc^.para^.first)^.paratype.def,from_def) or + (isconvertable(from_def,pparaitem(passproc^.para^.first)^.paratype.def,convtyp,ordconstn,false)=1)) then + begin + assignment_overloaded:=passproc; + break; + end; + passproc:=passproc^.nextoverloaded; + end; + end; + + + { local routines can't be assigned to procvars } + procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef); + begin + if (from_def^.symtablelevel>1) and (to_def^.deftype=procvardef) then + CGMessage(type_e_cannot_local_proc_to_procvar); + end; + + + function valid_for_assign(p:ptree;allowprop:boolean):boolean; + var + hp : ptree; + gotwith, + gotsubscript, + gotpointer, + gotclass, + gotderef : boolean; + begin + valid_for_assign:=false; + gotsubscript:=false; + gotderef:=false; + gotclass:=false; + gotpointer:=false; + gotwith:=false; + hp:=p; + while assigned(hp) do + begin + { property allowed? calln has a property check itself } + if (not allowprop) and + (hp^.isproperty) and + (hp^.treetype<>calln) then + begin + CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned); + exit; + end; + case hp^.treetype of + derefn : + begin + gotderef:=true; + hp:=hp^.left; + end; + typeconvn : + begin + case hp^.resulttype^.deftype of + pointerdef : + gotpointer:=true; + objectdef : + gotclass:=pobjectdef(hp^.resulttype)^.is_class; + classrefdef : + gotclass:=true; + arraydef : + begin + { pointer -> array conversion is done then we need to see it + as a deref, because a ^ is then not required anymore } + if (hp^.left^.resulttype^.deftype=pointerdef) then + gotderef:=true; + end; + end; + hp:=hp^.left; + end; + vecn, + asn : + hp:=hp^.left; + subscriptn : + begin + gotsubscript:=true; + hp:=hp^.left; + end; + subn, + addn : + begin + { Allow add/sub operators on a pointer, or an integer + and a pointer typecast and deref has been found } + if (hp^.resulttype^.deftype=pointerdef) or + (is_integer(hp^.resulttype) and gotpointer and gotderef) then + valid_for_assign:=true + else + CGMessagePos(hp^.fileinfo,type_e_variable_id_expected); + exit; + end; + addrn : + begin + if not(gotderef) and + not(hp^.procvarload) then + CGMessagePos(hp^.fileinfo,type_e_no_assign_to_addr); + exit; + end; + selfn, + funcretn : + begin + valid_for_assign:=true; + exit; + end; + calln : + begin + { check return type } + case hp^.resulttype^.deftype of + pointerdef : + gotpointer:=true; + objectdef : + gotclass:=pobjectdef(hp^.resulttype)^.is_class; + recorddef, { handle record like class it needs a subscription } + classrefdef : + gotclass:=true; + end; + { 1. if it returns a pointer and we've found a deref, + 2. if it returns a class or record and a subscription or with is found, + 3. property is allowed } + if (gotpointer and gotderef) or + (gotclass and (gotsubscript or gotwith)) or + (hp^.isproperty and allowprop) then + valid_for_assign:=true + else + CGMessagePos(hp^.fileinfo,type_e_argument_cant_be_assigned); + exit; + end; + loadn : + begin + case hp^.symtableentry^.typ of + absolutesym, + varsym : + begin + if (pvarsym(hp^.symtableentry)^.varspez=vs_const) then + begin + { allow p^:= constructions with p is const parameter } + if gotderef then + valid_for_assign:=true + else + CGMessagePos(hp^.fileinfo,type_e_no_assign_to_const); + exit; + end; + { Are we at a with symtable, then we need to process the + withrefnode also to check for maybe a const load } + if (hp^.symtable^.symtabletype=withsymtable) then + begin + { continue with processing the withref node } + hp:=ptree(pwithsymtable(hp^.symtable)^.withrefnode); + gotwith:=true; + end + else + begin + { set the assigned flag for varsyms } + if (pvarsym(hp^.symtableentry)^.varstate=vs_declared) then + pvarsym(hp^.symtableentry)^.varstate:=vs_assigned; + valid_for_assign:=true; + exit; + end; + end; + funcretsym, + typedconstsym : + begin + valid_for_assign:=true; + exit; + end; + end; + end; + else + begin + CGMessagePos(hp^.fileinfo,type_e_variable_id_expected); + exit; + end; + end; + end; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.71 2000/07/06 18:56:58 peter + * fixed function returning record type and assigning to the result + + Revision 1.70 2000/06/18 19:41:19 peter + * fixed pchar<->[string,chararray] operations + + Revision 1.69 2000/06/11 07:00:21 peter + * fixed pchar->string conversion for delphi mode + + Revision 1.68 2000/06/06 20:25:43 pierre + * unary minus operator overloading was broken + + accept pointer args in binary operator + + Revision 1.67 2000/06/05 20:41:17 pierre + + support for NOT overloading + + unsupported overloaded operators generate errors + + Revision 1.66 2000/06/04 09:04:30 peter + * check for procvar in valid_for_formal + + Revision 1.65 2000/06/02 21:22:04 pierre + + isbinaryoperatoracceptable and isunaryoperatoracceptable + for a more coherent operator overloading implementation + tok2node moved from pexpr unit to htypechk + + Revision 1.64 2000/06/01 19:13:02 peter + * fixed long line for tp7 + + Revision 1.63 2000/06/01 11:00:52 peter + * fixed string->pchar conversion for array constructors + + Revision 1.62 2000/05/30 18:38:45 florian + * fixed assignments of subrange enumeration types + + Revision 1.61 2000/05/26 18:21:41 peter + * give error for @ with formal const,var parameter. Because @ generates + a constant value and not a reference + + Revision 1.60 2000/05/16 16:01:03 florian + * fixed type conversion test for open arrays: the to and from fields where + exchanged which leads under certain circumstances to problems when + passing arrays of classes/class references as open array parameters + + Revision 1.59 2000/02/18 16:13:29 florian + * optimized ansistring compare with '' + * fixed 852 + + Revision 1.58 2000/02/09 13:22:53 peter + * log truncated + + Revision 1.57 2000/02/05 12:11:50 peter + * property check for assigning fixed for calln + + Revision 1.56 2000/02/01 09:41:27 peter + * allow class -> voidpointer for delphi mode + + Revision 1.55 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.54 1999/12/31 14:26:27 peter + * fixed crash with empty array constructors + + Revision 1.53 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.52 1999/12/16 19:12:04 peter + * allow constant pointer^ also for assignment + + Revision 1.51 1999/12/09 09:35:54 peter + * allow assigning to self + + Revision 1.50 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.49 1999/11/18 15:34:45 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.48 1999/11/09 14:47:03 peter + * pointer->array is allowed for all pointer types in FPC, fixed assign + check for it. + + Revision 1.47 1999/11/09 13:29:33 peter + * valid_for_assign allow properties with calln + + Revision 1.46 1999/11/08 22:45:33 peter + * allow typecasting to integer within pointer typecast+deref + + Revision 1.45 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.44 1999/11/04 23:11:21 peter + * fixed pchar and deref detection for assigning + + Revision 1.43 1999/10/27 16:04:45 peter + * valid_for_assign support for calln,asn + + Revision 1.42 1999/10/26 12:30:41 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.41 1999/10/14 14:57:52 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.40 1999/09/26 21:30:15 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.39 1999/09/17 17:14:04 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.38 1999/08/17 13:26:07 peter + * arrayconstructor -> arrayofconst fixed when arraycosntructor was not + variant. + +} diff --git a/befpc/compiler/i386att.inc b/befpc/compiler/i386att.inc new file mode 100644 index 0000000..d70d3f6 --- /dev/null +++ b/befpc/compiler/i386att.inc @@ -0,0 +1,469 @@ +{ don't edit, this file is generated from i386ins.dat } +( +'none', +'aaa', +'aad', +'aam', +'aas', +'adc', +'add', +'and', +'arpl', +'bound', +'bsf', +'bsr', +'bswap', +'bt', +'btc', +'btr', +'bts', +'call', +'cbtw', +'cltd', +'clc', +'cld', +'cli', +'clts', +'cmc', +'cmp', +'cmpsb', +'cmpsl', +'cmpsw', +'cmpxchg', +'cmpxchg486', +'cmpxchg8b', +'cpuid', +'cwd', +'cwtl', +'daa', +'das', +'dec', +'div', +'emms', +'enter', +'f2xm1', +'fabs', +'fadd', +'faddp', +'fbld', +'fbstp', +'fchs', +'fclex', +'fcmovb', +'fcmovbe', +'fcmove', +'fcmovnb', +'fcmovnbe', +'fcmovne', +'fcmovnu', +'fcmovu', +'fcom', +'fcomi', +'fcomip', +'fcomp', +'fcompp', +'fcos', +'fdecstp', +'fdisi', +'fdiv', +'fdivp', +'fdivr', +'fdivrp', +'femms', +'feni', +'ffree', +'fiadd', +'ficom', +'ficomp', +'fidiv', +'fidivr', +'fild', +'fimul', +'fincstp', +'finit', +'fist', +'fistp', +'fisub', +'fisubr', +'fld', +'fld1', +'fldcw', +'fldenv', +'fldl2e', +'fldl2t', +'fldlg2', +'fldln2', +'fldpi', +'fldz', +'fmul', +'fmulp', +'fnclex', +'fndisi', +'fneni', +'fninit', +'fnop', +'fnsave', +'fnstcw', +'fnstenv', +'fnstsw', +'fpatan', +'fprem', +'fprem1', +'fptan', +'frndint', +'frstor', +'fsave', +'fscale', +'fsetpm', +'fsin', +'fsincos', +'fsqrt', +'fst', +'fstcw', +'fstenv', +'fstp', +'fstsw', +'fsub', +'fsubp', +'fsubr', +'fsubrp', +'ftst', +'fucom', +'fucomi', +'fucomip', +'fucomp', +'fucompp', +'fwait', +'fxam', +'fxch', +'fxtract', +'fyl2x', +'fyl2xp1', +'hlt', +'ibts', +'icebp', +'idiv', +'imul', +'in', +'inc', +'insb', +'insl', +'insw', +'int', +'int01', +'int1', +'int03', +'int3', +'into', +'invd', +'invlpg', +'iret', +'iretd', +'iretw', +'jcxz', +'jecxz', +'jmp', +'lahf', +'lar', +'lcall', +'lds', +'lea', +'leave', +'les', +'lfs', +'lgdt', +'lgs', +'lidt', +'ljmp', +'lldt', +'lmsw', +'loadall', +'loadall286', +'lock', +'lodsb', +'lodsl', +'lodsw', +'loop', +'loope', +'loopne', +'loopnz', +'loopz', +'lsl', +'lss', +'ltr', +'mov', +'movd', +'movq', +'movsb', +'movsl', +'movsw', +'movs', +'movz', +'mul', +'neg', +'nop', +'not', +'or', +'out', +'outsb', +'outsl', +'outsw', +'packssdw', +'packsswb', +'packuswb', +'paddb', +'paddd', +'paddsb', +'paddsiw', +'paddsw', +'paddusb', +'paddusw', +'paddw', +'pand', +'pandn', +'paveb', +'pavgusb', +'pcmpeqb', +'pcmpeqd', +'pcmpeqw', +'pcmpgtb', +'pcmpgtd', +'pcmpgtw', +'pdistib', +'pf2id', +'pfacc', +'pfadd', +'pfcmpeq', +'pfcmpge', +'pfcmpgt', +'pfmax', +'pfmin', +'pfmul', +'pfrcp', +'pfrcpit1', +'pfrcpit2', +'pfrsqit1', +'pfrsqrt', +'pfsub', +'pfsubr', +'pi2fd', +'pmachriw', +'pmaddwd', +'pmagw', +'pmulhriw', +'pmulhrwa', +'pmulhrwc', +'pmulhw', +'pmullw', +'pmvgezb', +'pmvlzb', +'pmvnzb', +'pmvzb', +'pop', +'popa', +'popal', +'popaw', +'popf', +'popfl', +'popfw', +'por', +'prefetch', +'prefetchw', +'pslld', +'psllq', +'psllw', +'psrad', +'psraw', +'psrld', +'psrlq', +'psrlw', +'psubb', +'psubd', +'psubsb', +'psubsiw', +'psubsw', +'psubusb', +'psubusw', +'psubw', +'punpckhbw', +'punpckhdq', +'punpckhwd', +'punpcklbw', +'punpckldq', +'punpcklwd', +'push', +'pusha', +'pushal', +'pushaw', +'pushf', +'pushfl', +'pushfw', +'pxor', +'rcl', +'rcr', +'rdshr', +'rdmsr', +'rdpmc', +'rdtsc', +'rep', +'repe', +'repne', +'repnz', +'repz', +'ret', +'retf', +'retn', +'rol', +'ror', +'rsdc', +'rsldt', +'rsm', +'sahf', +'sal', +'salc', +'sar', +'sbb', +'scasb', +'scasl', +'scasw', +'cs', +'ds', +'es', +'fs', +'gs', +'ss', +'sgdt', +'shl', +'shld', +'shr', +'shrd', +'sidt', +'sldt', +'smi', +'smint', +'smintold', +'smsw', +'stc', +'std', +'sti', +'stosb', +'stosl', +'stosw', +'str', +'sub', +'svdc', +'svldt', +'svts', +'syscall', +'sysenter', +'sysexit', +'sysret', +'test', +'ud1', +'ud2', +'umov', +'verr', +'verw', +'wait', +'wbinvd', +'wrshr', +'wrmsr', +'xadd', +'xbts', +'xchg', +'xlat', +'xlatb', +'xor', +'cmov', +'j', +'set', +'addps', +'addss', +'andnps', +'andps', +'cmpeqps', +'cmpeqss', +'cmpleps', +'cmpless', +'cmpltps', +'cmpltss', +'cmpneqps', +'cmpneqss', +'cmpnleps', +'cmpnless', +'cmpnltps', +'cmpnltss', +'cmpordps', +'cmpordss', +'cmpunordps', +'cmpunordss', +'cmpps', +'cmpss', +'comiss', +'cvtpi2ps', +'cvtps2pi', +'cvtsi2ss', +'cvtss2si', +'cvttps2pi', +'cvttss2si', +'divps', +'divss', +'ldmxcsr', +'maxps', +'maxss', +'minps', +'minss', +'movaps', +'movhps', +'movlhps', +'movlps', +'movhlps', +'movmskps', +'movntps', +'movss', +'movups', +'mulps', +'mulss', +'orps', +'rcpps', +'rcpss', +'rsqrtps', +'rsqrtss', +'shufps', +'sqrtps', +'sqrtss', +'stmxcsr', +'subps', +'subss', +'ucomiss', +'unpckhps', +'unpcklps', +'xorps', +'fxrstor', +'fxsave', +'prefetchnta', +'prefetcht0', +'prefetcht1', +'prefetcht2', +'sfence', +'maskmovq', +'movntq', +'pavgb', +'pavgw', +'pextrw', +'pinsrw', +'pmaxsw', +'pmaxub', +'pminsw', +'pminub', +'pmovmskb', +'pmulhuw', +'psadbw', +'pshufw', +'pfnacc', +'pfpnacc', +'pi2fw', +'pf2iw', +'pswapd', +'ffreep' +); diff --git a/befpc/compiler/i386atts.inc b/befpc/compiler/i386atts.inc new file mode 100644 index 0000000..a60be9a --- /dev/null +++ b/befpc/compiler/i386atts.inc @@ -0,0 +1,469 @@ +{ don't edit, this file is generated from i386ins.dat } +( +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufNONE, +attsufNONE, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufNONE, +attsufNONE, +attsufNONE, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufNONE, +attsufNONE, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPUint, +attsufFPU, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufFPU, +attsufFPU, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufFPU, +attsufINT, +attsufNONE, +attsufFPU, +attsufINT, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufNONE, +attsufFPU, +attsufFPU, +attsufFPU, +attsufFPU, +attsufNONE, +attsufNONE, +attsufNONE, +attsufFPU, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufINT, +attsufNONE, +attsufNONE, +attsufINT, +attsufINT, +attsufNONE, +attsufINT, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE, +attsufNONE +); diff --git a/befpc/compiler/i386ins.dat b/befpc/compiler/i386ins.dat new file mode 100644 index 0000000..16afb75 --- /dev/null +++ b/befpc/compiler/i386ins.dat @@ -0,0 +1,2766 @@ +; +; $Id: i386ins.dat,v 1.1.1.1 2001-07-23 17:16:32 memson Exp $ +; +; Table of assembler instructions for Free Pascal +; adapted from Netwide Assembler by Peter Vreman +; +; The Netwide Assembler is copyright (C) 1996 Simon Tatham and +; Julian Hall. All rights reserved. +; +; Layout +; [OPCODE,attnameX] (X means suffix in att name) +; arguments bytes flags +; + +[NONE] +(Ch_None, Ch_None, Ch_None) +void void none + +[AAA] +(Ch_MEAX, Ch_WFlags, Ch_None) +void \1\x37 8086 + +[AAD,aadX] +(Ch_MEAX, Ch_WFlags, Ch_None) +void \2\xD5\x0A 8086 +imm \1\xD5\24 8086,SB + +[AAM,aamX] +(Ch_MEAX, Ch_WFlags, Ch_None) +void \2\xD4\x0A 8086 +imm \1\xD4\24 8086,SB + +[AAS] +(Ch_MEAX, Ch_WFlags, Ch_None) +void \1\x3F 8086 + +[ADC,adcX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +mem,reg8 \300\1\x10\101 8086,SM +reg8,reg8 \300\1\x10\101 8086 +mem,reg16 \320\300\1\x11\101 8086,SM +reg16,reg16 \320\300\1\x11\101 8086 +mem,reg32 \321\300\1\x11\101 386,SM +reg32,reg32 \321\300\1\x11\101 386 +reg8,mem \301\1\x12\110 8086,SM +reg8,reg8 \301\1\x12\110 8086 +reg16,mem \320\301\1\x13\110 8086,SM +reg16,reg16 \320\301\1\x13\110 8086 +reg32,mem \321\301\1\x13\110 386,SM +reg32,reg32 \321\301\1\x13\110 386 +rm16,imm8 \320\300\1\x83\202\15 8086 +rm32,imm8 \321\300\1\x83\202\15 386 +reg_al,imm \1\x14\21 8086,SM +reg_ax,imm \320\1\x15\31 8086,SM +reg_eax,imm \321\1\x15\41 386,SM +rm8,imm \300\1\x80\202\21 8086,SM +rm16,imm \320\300\1\x81\202\31 8086,SM +rm32,imm \321\300\1\x81\202\41 386,SM +mem,imm8 \300\1\x80\202\21 8086,SM +mem,imm16 \320\300\1\x81\202\31 8086,SM +mem,imm32 \321\300\1\x81\202\41 386,SM + +[ADD,addX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg8 \300\17\101 8086,SM +reg8,reg8 \300\17\101 8086 +mem,reg16 \320\300\1\x01\101 8086,SM +reg16,reg16 \320\300\1\x01\101 8086 +mem,reg32 \321\300\1\x01\101 386,SM +reg32,reg32 \321\300\1\x01\101 386 +reg8,mem \301\1\x02\110 8086,SM +reg8,reg8 \301\1\x02\110 8086 +reg16,mem \320\301\1\x03\110 8086,SM +reg16,reg16 \320\301\1\x03\110 8086 +reg32,mem \321\301\1\x03\110 386,SM +reg32,reg32 \321\301\1\x03\110 386 +rm16,imm8 \320\300\1\x83\200\15 8086 +rm32,imm8 \321\300\1\x83\200\15 386 +reg_al,imm \1\x04\21 8086,SM +reg_ax,imm \320\1\x05\31 8086,SM +reg_eax,imm \321\1\x05\41 386,SM +rm8,imm \300\1\x80\200\21 8086,SM +rm16,imm \320\300\1\x81\200\31 8086,SM +rm32,imm \321\300\1\x81\200\41 386,SM +mem,imm8 \300\1\x80\200\21 8086,SM +mem,imm16 \320\300\1\x81\200\31 8086,SM +mem,imm32 \321\300\1\x81\200\41 386,SM + +[AND,andX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg8 \300\1\x20\101 8086,SM +reg8,reg8 \300\1\x20\101 8086 +mem,reg16 \320\300\1\x21\101 8086,SM +reg16,reg16 \320\300\1\x21\101 8086 +mem,reg32 \321\300\1\x21\101 386,SM +reg32,reg32 \321\300\1\x21\101 386 +reg8,mem \301\1\x22\110 8086,SM +reg8,reg8 \301\1\x22\110 8086 +reg16,mem \320\301\1\x23\110 8086,SM +reg16,reg16 \320\301\1\x23\110 8086 +reg32,mem \321\301\1\x23\110 386,SM +reg32,reg32 \321\301\1\x23\110 386 +rm16,imm8 \320\300\1\x83\204\15 8086 +rm32,imm8 \321\300\1\x83\204\15 386 +reg_al,imm \1\x24\21 8086,SM +reg_ax,imm \320\1\x25\31 8086,SM +reg_eax,imm \321\1\x25\41 386,SM +rm8,imm \300\1\x80\204\21 8086,SM +rm16,imm \320\300\1\x81\204\31 8086,SM +rm32,imm \321\300\1\x81\204\41 386,SM +mem,imm8 \300\1\x80\204\21 8086,SM +mem,imm16 \320\300\1\x81\204\31 8086,SM +mem,imm32 \321\300\1\x81\204\41 386,SM + +[ARPL,arplX] +(Ch_WFlags, Ch_None, Ch_None) +mem,reg16 \300\1\x63\101 286,PROT,SM +reg16,reg16 \300\1\x63\101 286,PROT + +[BOUND,boundX] +(Ch_Rop1, Ch_None, Ch_None) +reg16,mem \320\301\1\x62\110 186 +reg32,mem \321\301\1\x62\110 386 + +[BSF,bsfX] +(Ch_Wop2, Ch_WFlags, Ch_Rop1) +reg16,mem \320\301\2\x0F\xBC\110 386,SM +reg16,reg16 \320\301\2\x0F\xBC\110 386 +reg32,mem \321\301\2\x0F\xBC\110 386,SM +reg32,reg32 \321\301\2\x0F\xBC\110 386 + +[BSR,bsrX] +(Ch_Wop2, Ch_WFlags, Ch_Rop1) +reg16,mem \320\301\2\x0F\xBD\110 386,SM +reg16,reg16 \320\301\2\x0F\xBD\110 386 +reg32,mem \321\301\2\x0F\xBD\110 386,SM +reg32,reg32 \321\301\2\x0F\xBD\110 386 + +[BSWAP,bswapX] +(Ch_MOp1, Ch_None, Ch_None) +reg32 \321\1\x0F\10\xC8 486 + +[BT,btX] +(Ch_WFlags, Ch_Rop1, Ch_None) +mem,reg16 \320\300\2\x0F\xA3\101 386,SM +reg16,reg16 \320\300\2\x0F\xA3\101 386 +mem,reg32 \321\300\2\x0F\xA3\101 386,SM +reg32,reg32 \321\300\2\x0F\xA3\101 386 +rm16,imm \320\300\2\x0F\xBA\204\25 386,SB +rm32,imm \321\300\2\x0F\xBA\204\25 386,SB + +[BTC,btcX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg16 \320\300\2\x0F\xBB\101 386,SM +reg16,reg16 \320\300\2\x0F\xBB\101 386 +mem,reg32 \321\300\2\x0F\xBB\101 386,SM +reg32,reg32 \321\300\2\x0F\xBB\101 386 +rm16,imm \320\300\2\x0F\xBA\207\25 386,SB +rm32,imm \321\300\2\x0F\xBA\207\25 386,SB + +[BTR,btrX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg16 \320\300\2\x0F\xB3\101 386,SM +reg16,reg16 \320\300\2\x0F\xB3\101 386 +mem,reg32 \321\300\2\x0F\xB3\101 386,SM +reg32,reg32 \321\300\2\x0F\xB3\101 386 +rm16,imm \320\300\2\x0F\xBA\206\25 386,SB +rm32,imm \321\300\2\x0F\xBA\206\25 386,SB + +[BTS,btsX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg16 \320\300\2\x0F\xAB\101 386,SM +reg16,reg16 \320\300\2\x0F\xAB\101 386 +mem,reg32 \321\300\2\x0F\xAB\101 386,SM +reg32,reg32 \321\300\2\x0F\xAB\101 386 +rm16,imm \320\300\2\x0F\xBA\205\25 386,SB +rm32,imm \321\300\2\x0F\xBA\205\25 386,SB + +[CALL,call] +; don't know value of any register +(Ch_All, Ch_None, Ch_None) +imm \322\1\xE8\64 8086 +imm|near \322\1\xE8\64 8086 +imm|far \322\1\x9A\34\37 8086,ND +imm16 \320\1\xE8\64 8086 +imm16|near \320\1\xE8\64 8086 +imm16|far \320\1\x9A\34\37 8086,ND +imm32 \321\1\xE8\64 8086 +imm32|near \321\1\xE8\64 8086 +imm32|far \321\1\x9A\34\37 8086,ND +imm:imm \322\1\x9A\35\30 8086 +imm16:imm \320\1\x9A\31\30 8086 +imm:imm16 \320\1\x9A\31\30 8086 +imm32:imm \321\1\x9A\41\30 386 +imm:imm32 \321\1\x9A\41\30 386 +mem|far \322\300\1\xFF\203 8086 +mem16|far \320\300\1\xFF\203 8086 +mem32|far \321\300\1\xFF\203 386 +mem|near \322\300\1\xFF\202 8086 +mem16|near \320\300\1\xFF\202 8086 +mem32|near \321\300\1\xFF\202 386 +reg16 \320\300\1\xFF\202 8086 +reg32 \321\300\1\xFF\202 386 +mem \322\300\1\xFF\202 8086 +mem16 \320\300\1\xFF\202 8086 +mem32 \321\300\1\xFF\202 386 + +[CBW,cbtw] +(Ch_MEAX, Ch_None, Ch_None) +void \320\1\x98 8086 + +[CDQ,cltd] +(Ch_MEAX, Ch_WEDX, Ch_None) +void \321\1\x99 386 + +[CLC] +(Ch_WFlags, Ch_None, Ch_None) +void \1\xF8 8086 + +[CLD] +(Ch_CDirFlag, Ch_None, Ch_None) +void \1\xFC 8086 + +[CLI] +(Ch_WFlags, Ch_None, Ch_None) +void \1\xFA 8086 + +[CLTS] +(Ch_None, Ch_None, Ch_None) +void \2\x0F\x06 286,PRIV + +[CMC] +(Ch_WFlags, Ch_None, Ch_None) +void \1\xF5 8086 + +[CMP,cmpX] +(Ch_ROp1, Ch_ROp2, Ch_WFlags) +mem,reg8 \300\1\x38\101 8086,SM +reg8,reg8 \300\1\x38\101 8086 +mem,reg16 \320\300\1\x39\101 8086,SM +reg16,reg16 \320\300\1\x39\101 8086 +mem,reg32 \321\300\1\x39\101 386,SM +reg32,reg32 \321\300\1\x39\101 386 +reg8,mem \301\1\x3A\110 8086,SM +reg8,reg8 \301\1\x3A\110 8086 +reg16,mem \320\301\1\x3B\110 8086,SM +reg16,reg16 \320\301\1\x3B\110 8086 +reg32,mem \321\301\1\x3B\110 386,SM +reg32,reg32 \321\301\1\x3B\110 386 +rm16,imm8 \320\300\1\x83\207\15 8086 +rm32,imm8 \321\300\1\x83\207\15 386 +reg_al,imm \1\x3C\21 8086,SM +reg_ax,imm \320\1\x3D\31 8086,SM +reg_eax,imm \321\1\x3D\41 386,SM +rm8,imm \300\1\x80\207\21 8086,SM +rm16,imm \320\300\1\x81\207\31 8086,SM +rm32,imm \321\300\1\x81\207\41 386,SM +mem,imm8 \300\1\x80\207\21 8086,SM +mem,imm16 \320\300\1\x81\207\31 8086,SM +mem,imm32 \321\300\1\x81\207\41 386,SM + +[CMPSB] +(Ch_All, Ch_None, Ch_None) +void \332\1\xA6 8086 + +[CMPSD,cmpsl] +(Ch_All, Ch_None, Ch_None) +void \332\321\1\xA7 386 + +[CMPSW] +(Ch_All, Ch_None, Ch_None) +void \332\320\1\xA7 8086 + +[CMPXCHG,cmpxchgX] +(Ch_All, Ch_None, Ch_None) +mem,reg8 \300\2\x0F\xB0\101 PENT,SM +reg8,reg8 \300\2\x0F\xB0\101 PENT +mem,reg16 \320\300\2\x0F\xB1\101 PENT,SM +reg16,reg16 \320\300\2\x0F\xB1\101 PENT +mem,reg32 \321\300\2\x0F\xB1\101 PENT,SM +reg32,reg32 \321\300\2\x0F\xB1\101 PENT + +[CMPXCHG486,cmpxchg486X] +(Ch_All, Ch_None, Ch_None) +mem,reg8 \300\2\x0F\xA6\101 486,SM,UNDOC +reg8,reg8 \300\2\x0F\xA6\101 486,UNDOC +mem,reg16 \320\300\2\x0F\xA7\101 486,SM,UNDOC +reg16,reg16 \320\300\2\x0F\xA7\101 486,UNDOC +mem,reg32 \321\300\2\x0F\xA7\101 486,SM,UNDOC +reg32,reg32 \321\300\2\x0F\xA7\101 486,UNDOC + +[CMPXCHG8B,cmpxchg8bX] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\xC7\201 PENT + +[CPUID] +(Ch_All, Ch_None, Ch_none) +void \2\x0F\xA2 PENT + +[CWD] +(Ch_MEAX, Ch_WEDX, Ch_None) +void \320\1\x99 8086 + +[CWDE,cwtl] +(Ch_MEAX, Ch_None, Ch_None) +void \321\1\x98 386 + +[DAA] +(Ch_MEAX, Ch_None, Ch_None) +void \1\x27 8086 + +[DAS] +(Ch_MEAX, Ch_None, Ch_None) +void \1\x2F 8086 + +[DEC,decX] +(Ch_Mop1, Ch_WFlags, Ch_None) +reg16 \320\10\x48 8086 +reg32 \321\10\x48 386 +rm8 \300\1\xFE\201 8086 +rm16 \320\300\1\xFF\201 8086 +rm32 \321\300\1\xFF\201 386 + +[DIV,divX] +(Ch_RWEAX, Ch_WEDX, Ch_WFlags) +rm8 \300\1\xF6\206 8086 +rm16 \320\300\1\xF7\206 8086 +rm32 \321\300\1\xF7\206 386 + +[EMMS] +(Ch_FPU, Ch_None, Ch_None) +void \2\x0F\x77 PENT,MMX + +[ENTER,enterX] +(Ch_RWESP, Ch_None, Ch_None) +imm,imm \1\xC8\30\25 186 + +[F2XM1] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF0 8086,FPU + +[FABS] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE1 8086,FPU + +[FADD,faddF] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xD8\200 8086,FPU +mem64 \300\1\xDC\200 8086,FPU +void \2\xDE\xC1 8086,FPU +fpureg|to \1\xDC\10\xC0 8086,FPU +fpureg,fpu0 \1\xDC\10\xC0 8086,FPU +fpureg \1\xD8\10\xC0 8086,FPU +fpu0,fpureg \1\xD8\11\xC0 8086,FPU + +[FADDP,faddpF] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDE\xC1 8086,FPU +fpureg \1\xDE\10\xC0 8086,FPU +fpureg,fpu0 \1\xDE\10\xC0 8086,FPU + +[FBLD,fbldF] +(Ch_Rop1, Ch_FPU, Ch_None) +mem80 \300\1\xDF\204 8086,FPU +mem \300\1\xDF\204 8086,FPU + +[FBSTP,fbstpF] +(Ch_Wop1, Ch_FPU, Ch_None) +mem80 \300\1\xDF\206 8086,FPU +mem \300\1\xDF\206 8086,FPU + +[FCHS] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE0 8086,FPU + +[FCLEX] +(Ch_FPU, Ch_None, Ch_None) +void \3\x9B\xDB\xE2 8086,FPU + +[FCMOVB,fcmovbF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDA\xC1 P6,FPU +fpureg \1\xDA\10\xC0 P6,FPU +fpu0,fpureg \1\xDA\11\xC0 P6,FPU + +[FCMOVBE,fcmovbeF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDA\xD1 P6,FPU +fpureg \1\xDA\10\xD0 P6,FPU +fpu0,fpureg \1\xDA\11\xD0 P6,FPU + +[FCMOVE,fcmoveF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDA\xC9 P6,FPU +fpureg \1\xDA\10\xC8 P6,FPU +fpu0,fpureg \1\xDA\11\xC8 P6,FPU + +[FCMOVNB,fcmovnbF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDB\xC1 P6,FPU +fpureg \1\xDB\10\xC0 P6,FPU +fpu0,fpureg \1\xDB\11\xC0 P6,FPU + +[FCMOVNBE,fcmovnbeF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDB\xD1 P6,FPU +fpureg \1\xDB\10\xD0 P6,FPU +fpu0,fpureg \1\xDB\11\xD0 P6,FPU + +[FCMOVNE,fcmovneF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDB\xC9 P6,FPU +fpureg \1\xDB\10\xC8 P6,FPU +fpu0,fpureg \1\xDB\11\xC8 P6,FPU + +[FCMOVNU,fcmovnuF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDB\xD9 P6,FPU +fpureg \1\xDB\10\xD8 P6,FPU +fpu0,fpureg \1\xDB\11\xD8 P6,FPU + +[FCMOVU,fcmovuF] +(Ch_FPU, Ch_RFLAGS, Ch_None) +void \2\xDA\xD9 P6,FPU +fpureg \1\xDA\10\xD8 P6,FPU +fpu0,fpureg \1\xDA\11\xD8 P6,FPU + +[FCOM,fcomF] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xD8\202 8086,FPU +mem64 \300\1\xDC\202 8086,FPU +void \2\xD8\xD1 8086,FPU +fpureg \1\xD8\10\xD0 8086,FPU +fpu0,fpureg \1\xD8\11\xD0 8086,FPU + +[FCOMI,fcomiF] +(Ch_WFLAGS, Ch_None, Ch_None) +void \2\xDB\xF1 P6,FPU +fpureg \1\xDB\10\xF0 P6,FPU +fpu0,fpureg \1\xDB\11\xF0 P6,FPU + +[FCOMIP,fcomipF] +(Ch_FPU, Ch_WFLAGS, Ch_None) +void \2\xDF\xF1 P6,FPU +fpureg \1\xDF\10\xF0 P6,FPU +fpu0,fpureg \1\xDF\11\xF0 P6,FPU + +[FCOMP,fcompF] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xD8\203 8086,FPU +mem64 \300\1\xDC\203 8086,FPU +void \2\xD8\xD9 8086,FPU +fpureg \1\xD8\10\xD8 8086,FPU +fpu0,fpureg \1\xD8\11\xD8 8086,FPU + +[FCOMPP] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDE\xD9 8086,FPU + +[FCOS] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFF 386,FPU + +[FDECSTP] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF6 8086,FPU + +[FDISI] +(Ch_FPU, Ch_None, Ch_None) +void \3\x9B\xDB\xE1 8086,FPU + +[FDIV,fdivF] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xD8\206 8086,FPU +mem64 \300\1\xDC\206 8086,FPU +void \2\xDC\xF1 8086,FPU +fpureg|to \1\xDC\10\xF0 8086,FPU +fpureg,fpu0 \1\xDC\10\xF0 8086,FPU +fpureg \1\xD8\10\xF0 8086,FPU +fpu0,fpureg \1\xD8\11\xF0 8086,FPU + +[FDIVP,fdivpF] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDE\xF1 8086,FPU +fpureg,fpu0 \1\xDE\10\xF0 8086,FPU +fpureg \1\xDE\10\xF0 8086,FPU + +[FDIVR,fdivrF] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xD8\207 8086,FPU +mem64 \300\1\xDC\207 8086,FPU +void \2\xDC\xF9 8086,FPU +fpureg|to \1\xDC\10\xF8 8086,FPU +fpureg,fpu0 \1\xDC\10\xF8 8086,FPU +fpureg \1\xD8\10\xF8 8086,FPU +fpu0,fpureg \1\xD8\11\xF8 8086,FPU + +[FDIVRP,fdivrpF] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDE\xF9 8086,FPU +fpureg \1\xDE\10\xF8 8086,FPU +fpureg,fpu0 \1\xDE\10\xF8 8086,FPU + +[FEMMS] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x0E PENT,3DNOW + +[FENI] +(Ch_FPU, Ch_None, Ch_None) +void \3\x9B\xDB\xE0 8086,FPU + +[FFREE] +(Ch_FPU, Ch_None, Ch_None) +fpureg \1\xDD\10\xC0 8086,FPU + +[FIADD,fiaddR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\200 8086,FPU +mem32 \300\1\xDA\200 8086,FPU + +[FICOM,ficomR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\202 8086,FPU +mem32 \300\1\xDA\202 8086,FPU + +[FICOMP,ficompR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\203 8086,FPU +mem32 \300\1\xDA\203 8086,FPU + +[FIDIV,fidivR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\206 8086,FPU +mem32 \300\1\xDA\206 8086,FPU + +[FIDIVR,fidivrR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\207 8086,FPU +mem32 \300\1\xDA\207 8086,FPU + +[FILD,fildR] +(Ch_FPU, Ch_None, Ch_None) +mem32 \300\1\xDB\200 8086,FPU +mem16 \320\300\1\xDF\200 8086,FPU +mem64 \300\1\xDF\205 8086,FPU + +[FIMUL,fimulR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\201 8086,FPU +mem32 \300\1\xDA\201 8086,FPU + +[FINCSTP] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF7 8086,FPU + +[FINIT] +(Ch_FPU, Ch_None, Ch_None) +void \3\x9B\xDB\xE3 8086,FPU + +[FIST,fistR] +(Ch_Wop1, Ch_None, Ch_None) +mem32 \300\1\xDB\202 8086,FPU +mem16 \320\300\1\xDF\202 8086,FPU + +[FISTP,fistpR] +(Ch_Wop1, Ch_None, Ch_None) +mem32 \300\1\xDB\203 8086,FPU +mem16 \320\300\1\xDF\203 8086,FPU +mem64 \300\1\xDF\207 8086,FPU + +[FISUB,fisubR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\204 8086,FPU +mem32 \300\1\xDA\204 8086,FPU + +[FISUBR,fisubrR] +(Ch_FPU, Ch_None, Ch_None) +mem16 \300\1\xDE\205 8086,FPU +mem32 \300\1\xDA\205 8086,FPU + +[FLD,fldF] +(Ch_Rop1, Ch_FPU, Ch_None) +mem32 \300\1\xD9\200 8086,FPU +mem64 \300\1\xDD\200 8086,FPU +mem80 \300\1\xDB\205 8086,FPU +fpureg \1\xD9\10\xC0 8086,FPU + +[FLD1] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE8 8086,FPU + +[FLDCW,fldcwX] +(Ch_FPU, Ch_None, Ch_None) +mem \300\1\xD9\205 8086,FPU,SW + +[FLDENV,fldenv] +(Ch_FPU, Ch_None, Ch_None) +mem \300\1\xD9\204 8086,FPU + +[FLDL2E] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xEA 8086,FPU + +[FLDL2T] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE9 8086,FPU + +[FLDLG2] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xEC 8086,FPU + +[FLDLN2] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xED 8086,FPU + +[FLDPI] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xEB 8086,FPU + +[FLDZ] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xEE 8086,FPU + +[FMUL,fmulF] +(Ch_ROp1, Ch_FPU, Ch_None) +mem32 \300\1\xD8\201 8086,FPU +mem64 \300\1\xDC\201 8086,FPU +void \2\xDC\xC9 8086,FPU +fpureg|to \1\xDC\10\xC8 8086,FPU +fpureg,fpu0 \1\xDC\10\xC8 8086,FPU +fpureg \1\xD8\10\xC8 8086,FPU +fpu0,fpureg \1\xD8\11\xC8 8086,FPU + +[FMULP,fmulpF] +(Ch_ROp1, Ch_FPU, Ch_None) +void \2\xDE\xC9 8086,FPU +fpureg \1\xDE\10\xC8 8086,FPU +fpureg,fpu0 \1\xDE\10\xC8 8086,FPU + +[FNCLEX] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDB\xE2 8086,FPU + +[FNDISI] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDB\xE1 8086,FPU + +[FNENI] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDB\xE0 8086,FPU + +[FNINIT] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDB\xE3 8086,FPU + +[FNOP] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xD0 8086,FPU + +[FNSAVE,fnsave] +(Ch_FPU, Ch_None, Ch_None) +mem \300\1\xDD\206 8086,FPU + +[FNSTCW,fnstcwX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\1\xD9\207 8086,FPU,SW + +[FNSTENV,fnstenv] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\1\xD9\206 8086,FPU + +[FNSTSW,fnstswX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\1\xDD\207 8086,FPU,SW +reg_ax \2\xDF\xE0 286,FPU + +[FPATAN] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF3 8086,FPU + +[FPREM] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF8 8086,FPU + +[FPREM1] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF5 386,FPU + +[FPTAN] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF2 8086,FPU + +[FRNDINT] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFC 8086,FPU + +[FRSTOR,frstor] +(Ch_FPU, Ch_None, Ch_None) +mem \300\1\xDD\204 8086,FPU + +[FSAVE,fsave] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x9B\xDD\206 8086,FPU + +[FSCALE] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFD 8086,FPU + +[FSETPM] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDB\xE4 286,FPU + +[FSIN] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFE 386,FPU + +[FSINCOS] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFB 386,FPU + +[FSQRT] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xFA 8086,FPU + +[FST,fstF] +(Ch_Wop1, Ch_None, Ch_None) +mem32 \300\1\xD9\202 8086,FPU +mem64 \300\1\xDD\202 8086,FPU +fpureg \1\xDD\10\xD0 8086,FPU + +[FSTCW,fstcwX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x9B\xD9\207 8086,FPU,SW + +[FSTENV,fstenv] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x9B\xD9\206 8086,FPU + +[FSTP,fstpF] +(Ch_Wop1, Ch_FPU, Ch_None) +mem32 \300\1\xD9\203 8086,FPU +mem64 \300\1\xDD\203 8086,FPU +mem80 \300\1\xDB\207 8086,FPU +fpureg \1\xDD\10\xD8 8086,FPU + +[FSTSW,fstswX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x9B\xDD\207 8086,FPU,SW +void \3\x9B\xDF\xE0 286,FPU +reg_ax \3\x9B\xDF\xE0 286,FPU + +[FSUB,fsubF] +(Ch_ROp1, Ch_FPU, Ch_None) +mem32 \300\1\xD8\204 8086,FPU +mem64 \300\1\xDC\204 8086,FPU +void \2\xDC\xE1 8086,FPU +fpureg|to \1\xDC\10\xE0 8086,FPU +fpureg,fpu0 \1\xDC\10\xE0 8086,FPU +fpureg \1\xD8\10\xE0 8086,FPU +fpu0,fpureg \1\xD8\11\xE0 8086,FPU + +[FSUBP,fsubpF] +(Ch_ROp1, Ch_FPU, Ch_None) +void \2\xDE\xE1 8086,FPU +fpureg \1\xDE\10\xE0 8086,FPU +fpureg,fpu0 \1\xDE\10\xE0 8086,FPU + +[FSUBR,fsubrF] +(Ch_ROp1, Ch_FPU, Ch_None) +mem32 \300\1\xD8\205 8086,FPU +mem64 \300\1\xDC\205 8086,FPU +void \2\xDC\xE9 8086,FPU +fpureg|to \1\xDC\10\xE8 8086,FPU +fpureg,fpu0 \1\xDC\10\xE8 8086,FPU +fpureg \1\xD8\10\xE8 8086,FPU +fpu0,fpureg \1\xD8\11\xE8 8086,FPU + +[FSUBRP,fsubrpF] +(Ch_ROp1, Ch_FPU, Ch_None) +void \2\xDE\xE9 8086,FPU +fpureg \1\xDE\10\xE8 8086,FPU +fpureg,fpu0 \1\xDE\10\xE8 8086,FPU + +[FTST] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE4 8086,FPU + +[FUCOM,fucomF] +(Ch_None, Ch_None, Ch_None) +void \2\xDD\xE1 386,FPU +fpureg \1\xDD\10\xE0 386,FPU +fpu0,fpureg \1\xDD\11\xE0 386,FPU + +[FUCOMI,fucomiF] +(Ch_WFLAGS, Ch_None, Ch_None) +void \2\xDB\xE9 P6,FPU +fpureg \1\xDB\10\xE8 P6,FPU +fpu0,fpureg \1\xDB\11\xE8 P6,FPU + +[FUCOMIP,fucomipF] +(Ch_FPU, Ch_WFLAGS, Ch_None) +void \2\xDF\xE9 P6,FPU +fpureg \1\xDF\10\xE8 P6,FPU +fpu0,fpureg \1\xDF\11\xE8 P6,FPU + +[FUCOMP,fucompF] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDD\xE9 386,FPU +fpureg \1\xDD\10\xE8 386,FPU +fpu0,fpureg \1\xDD\11\xE8 386,FPU + +[FUCOMPP] +(Ch_FPU, Ch_None, Ch_None) +void \2\xDA\xE9 386,FPU + +[FWAIT] +(Ch_FPU, Ch_None, Ch_None) +void \1\x9B 8086,FPU + +[FXAM] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xE5 8086,FPU + +[FXCH,fxchF] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xC9 8086,FPU +fpureg \1\xD9\10\xC8 8086,FPU +fpureg,fpu0 \1\xD9\10\xC8 8086,FPU +fpu0,fpureg \1\xD9\11\xC8 8086,FPU + +[FXTRACT] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF4 8086,FPU + +[FYL2X] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF1 8086,FPU + +[FYL2XP1] +(Ch_FPU, Ch_None, Ch_None) +void \2\xD9\xF9 8086,FPU + +[HLT] +(Ch_None, Ch_None, Ch_None) +void \1\xF4 8086,PRIV + +[IBTS,ibtsX] +(Ch_All, Ch_None, Ch_None) +mem,reg16 \320\300\2\x0F\xA7\101 386,SW,UNDOC,ND +reg16,reg16 \320\300\2\x0F\xA7\101 386,UNDOC,ND +mem,reg32 \321\300\2\x0F\xA7\101 386,SD,UNDOC,ND +reg32,reg32 \321\300\2\x0F\xA7\101 386,UNDOC,ND + +[ICEBP] +(Ch_All, Ch_None, Ch_None) +void \1\xF1 386,ND + +[IDIV,idivX] +(Ch_RWEAX, Ch_WEDX, Ch_WFlags) +rm8 \300\1\xF6\207 8086 +rm16 \320\300\1\xF7\207 8086 +rm32 \321\300\1\xF7\207 386 + +[IMUL,imulX] +(Ch_RWEAX, Ch_WEDX, Ch_WFlags) +rm8 \300\1\xF6\205 8086 +rm16 \320\300\1\xF7\205 8086 +rm32 \321\300\1\xF7\205 386 +reg16,mem \320\301\2\x0F\xAF\110 386,SM +reg16,reg16 \320\301\2\x0F\xAF\110 386 +reg32,mem \321\301\2\x0F\xAF\110 386,SM +reg32,reg32 \321\301\2\x0F\xAF\110 386 +reg16,mem,imm8 \320\301\1\x6B\110\16 286,SM +reg16,reg16,imm8 \320\301\1\x6B\110\16 286 +reg16,mem,imm \320\301\1\x69\110\32 286,SM +reg16,reg16,imm \320\301\1\x69\110\32 286,SM +reg32,mem,imm8 \321\301\1\x6B\110\16 386,SM +reg32,reg32,imm8 \321\301\1\x6B\110\16 386 +reg32,mem,imm \321\301\1\x69\110\42 386,SM +reg32,reg32,imm \321\301\1\x69\110\42 386,SM +reg16,imm8 \320\1\x6B\100\15 286 +reg16,imm \320\1\x69\100\31 286,SM +reg32,imm8 \321\1\x6B\100\15 386 +reg32,imm \321\1\x69\100\41 386,SM + +[IN,inX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg_al,imm \1\xE4\25 8086,SB +reg_ax,imm \320\1\xE5\25 8086,SB +reg_eax,imm \321\1\xE5\25 386,SB +reg_al,reg_dx \1\xEC 8086 +reg_ax,reg_dx \320\1\xED 8086 +reg_eax,reg_dx \321\1\xED 386 + +[INC,incX] +(Ch_Mop1, Ch_WFlags, Ch_None) +reg16 \320\10\x40 8086 +reg32 \321\10\x40 386 +rm8 \300\1\xFE\200 8086 +rm16 \320\300\1\xFF\200 8086 +rm32 \321\300\1\xFF\200 386 + +[INSB] +(Ch_WMemEDI, Ch_RWEDI, Ch_REDX) +void \1\x6C 186 + +[INSD,insl] +(Ch_WMemEDI, Ch_RWEDI, Ch_REDX) +void \321\1\x6D 386 + +[INSW] +(Ch_WMemEDI, Ch_RWEDI, Ch_REDX) +void \320\1\x6D 186 + +[INT] +(Ch_All, Ch_None, Ch_None) +imm \1\xCD\24 8086,SB + +[INT01] +(Ch_All, Ch_None, Ch_None) +void \1\xF1 386,ND + +[INT1] +(Ch_All, Ch_None, Ch_None) +void \1\xF1 386 + +[INT03] +(Ch_None, Ch_None, Ch_None) +void \1\xCC 8086,ND + +[INT3] +(Ch_None, Ch_None, Ch_None) +void \1\xCC 8086 + +[INTO] +(Ch_All, Ch_None, Ch_None) +void \1\xCE 8086 + +[INVD] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x08 486,PRIV + +[INVLPG,invlpgX] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\x01\207 486,PRIV + +[IRET] +(Ch_All, Ch_None, Ch_None) +void \322\1\xCF 8086 + +[IRETD] +(Ch_All, Ch_None, Ch_None) +void \321\1\xCF 386 + +[IRETW] +(Ch_All, Ch_None, Ch_None) +void \320\1\xCF 8086 + +[JCXZ] +(Ch_RECX, Ch_None, Ch_None) +imm \320\1\xE3\50 8086 + +[JECXZ] +(Ch_RECX, Ch_None, Ch_None) +imm \321\1\xE3\50 386 + +[JMP,jmpX] +(Ch_None, Ch_None, Ch_None) +imm|short \1\xEB\50 8086 +imm \322\1\xE9\64 8086,PASS2 +imm|near \322\1\xE9\64 8086,ND,PASS2 +imm|far \322\1\xEA\34\37 8086,ND +imm16 \320\1\xE9\64 8086,PASS2 +imm16|near \320\1\xE9\64 8086,ND,PASS2 +imm16|far \320\1\xEA\34\37 8086,ND,PASS2 +imm32 \321\1\xE9\64 8086,PASS2 +imm32|near \321\1\xE9\64 8086,ND,PASS2 +imm32|far \321\1\xEA\34\37 8086,ND,PASS2 +imm:imm \322\1\xEA\35\30 8086 +imm16:imm \320\1\xEA\31\30 8086 +imm:imm16 \320\1\xEA\31\30 8086 +imm32:imm \321\1\xEA\41\30 386 +imm:imm32 \321\1\xEA\41\30 386 +mem|far \322\300\1\xFF\205 8086 +mem16|far \320\300\1\xFF\205 8086 +mem32|far \321\300\1\xFF\205 386 +mem|near \322\300\1\xFF\204 8086 +mem16|near \320\300\1\xFF\204 8086 +mem32|near \321\300\1\xFF\204 386 +reg16 \320\300\1\xFF\204 8086 +reg32 \321\300\1\xFF\204 386 +mem \322\300\1\xFF\204 8086 +mem16 \320\300\1\xFF\204 8086 +mem32 \321\300\1\xFF\204 386 + +[LAHF] +(Ch_WEAX, Ch_RFlags, Ch_None) +void \1\x9F 8086 + +[LAR,larX] +(Ch_Wop2, Ch_None, Ch_None) +reg16,mem \320\301\2\x0F\x02\110 286,PROT,SM +reg16,reg16 \320\301\2\x0F\x02\110 286,PROT +reg32,mem \321\301\2\x0F\x02\110 286,PROT,SM +reg32,reg32 \321\301\2\x0F\x02\110 286,PROT + +[LCALL,lcall] +; don't know value of any register +(Ch_All, Ch_None, Ch_None) +mem|far \322\300\1\xFF\203 8086 +mem16|far \320\300\1\xFF\203 8086 +mem32|far \321\300\1\xFF\203 386 +mem|near \322\300\1\xFF\202 8086 +mem16|near \320\300\1\xFF\202 8086 +mem32|near \321\300\1\xFF\202 386 +reg16 \320\300\1\xFF\202 8086 +reg32 \321\300\1\xFF\202 386 +mem \322\300\1\xFF\202 8086 +mem16 \320\300\1\xFF\202 8086 +mem32 \321\300\1\xFF\202 386 + +[LDS,ldsX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\1\xC5\110 8086 +reg32,mem \321\301\1\xC5\110 8086 + +[LEA,leaX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\1\x8D\110 8086 +reg32,mem \321\301\1\x8D\110 8086 +reg32,imm32 \321\301\1\x8D\110 8086 + +[LEAVE] +(Ch_RWESP, Ch_WEBP, Ch_None) +void \1\xC9 186 + +[LES,lesX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\1\xC4\110 8086 +reg32,mem \321\301\1\xC4\110 8086 + +[LFS,lfsX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\2\x0F\xB4\110 386 +reg32,mem \321\301\2\x0F\xB4\110 386 + +[LGDT,lgdtX] +(Ch_None, Ch_None, Ch_None) +mem \300\2\x0F\x01\202 286,PRIV + +[LGS,lgsX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\2\x0F\xB5\110 386 +reg32,mem \321\301\2\x0F\xB5\110 386 + +[LIDT,lidtX] +(Ch_None, Ch_None, Ch_None) +mem \300\2\x0F\x01\203 286,PRIV + +[LJMP,ljmp] +(Ch_None, Ch_None, Ch_None) +mem|far \322\300\1\xFF\205 8086 +mem16|far \320\300\1\xFF\205 8086 +mem32|far \321\300\1\xFF\205 386 +mem|near \322\300\1\xFF\204 8086 +mem16|near \320\300\1\xFF\204 8086 +mem32|near \321\300\1\xFF\204 386 +reg16 \320\300\1\xFF\204 8086 +reg32 \321\300\1\xFF\204 386 +mem \322\300\1\xFF\204 8086 +mem16 \320\300\1\xFF\204 8086 +mem32 \321\300\1\xFF\204 386 + +[LLDT,lldtX] +(Ch_None, Ch_None, Ch_None) +mem \300\1\x0F\17\202 286,PROT,PRIV +mem16 \300\1\x0F\17\202 286,PROT,PRIV +reg16 \300\1\x0F\17\202 286,PROT,PRIV + +[LMSW,lmswX] +(Ch_None, Ch_None, Ch_None) +mem \300\2\x0F\x01\206 286,PRIV +mem16 \300\2\x0F\x01\206 286,PRIV +reg16 \300\2\x0F\x01\206 286,PRIV + +[LOADALL] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x07 386,UNDOC + +[LOADALL286] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x05 286,UNDOC + +[LOCK] +(Ch_None, Ch_None, Ch_None) +void \1\xF0 8086,PRE + +[LODSB] +(Ch_WEAX, Ch_RWESI, Ch_None) +void \1\xAC 8086 + +[LODSD,lodsl] +(Ch_WEAX, Ch_RWESI, Ch_None) +void \321\1\xAD 386 + +[LODSW] +(Ch_WEAX, Ch_RWESI, Ch_None) +void \320\1\xAD 8086 + +[LOOP] +(Ch_RWECX, Ch_None, Ch_None) +imm \312\1\xE2\50 8086 +imm,reg_cx \310\1\xE2\50 8086 +imm,reg_ecx \311\1\xE2\50 386 + +[LOOPE] +(Ch_RWECX, Ch_RFlags, Ch_None) +imm \312\1\xE1\50 8086 +imm,reg_cx \310\1\xE1\50 8086 +imm,reg_ecx \311\1\xE1\50 386 + +[LOOPNE] +(Ch_RWECX, Ch_RFlags, Ch_None) +imm \312\1\xE0\50 8086 +imm,reg_cx \310\1\xE0\50 8086 +imm,reg_ecx \311\1\xE0\50 386 + +[LOOPNZ] +(Ch_RWECX, Ch_RFlags, Ch_None) +imm \312\1\xE0\50 8086 +imm,reg_cx \310\1\xE0\50 8086 +imm,reg_ecx \311\1\xE0\50 386 + +[LOOPZ] +(Ch_RWECX, Ch_RFlags, Ch_None) +imm \312\1\xE1\50 8086 +imm,reg_cx \310\1\xE1\50 8086 +imm,reg_ecx \311\1\xE1\50 386 + +[LSL,lslX] +(Ch_Wop2, Ch_WFlags, Ch_None) +reg16,mem \320\301\2\x0F\x03\110 286,PROT,SM +reg16,reg16 \320\301\2\x0F\x03\110 286,PROT +reg32,mem \321\301\2\x0F\x03\110 286,PROT,SM +reg32,reg32 \321\301\2\x0F\x03\110 286,PROT + +[LSS,lssX] +(Ch_Wop2, Ch_ROP1, Ch_None) +reg16,mem \320\301\2\x0F\xB2\110 386 +reg32,mem \321\301\2\x0F\xB2\110 386 + +[LTR,ltrX] +(Ch_None, Ch_None, Ch_None) +mem \300\1\x0F\17\203 286,PROT,PRIV +mem16 \300\1\x0F\17\203 286,PROT,PRIV +reg16 \300\1\x0F\17\203 286,PROT,PRIV + +[MOV,movX] +(Ch_Wop2, Ch_Rop1, Ch_None) +mem,reg_cs \320\300\1\x8C\201 8086,SM +mem,reg_dess \320\300\1\x8C\101 8086,SM +mem,reg_fsgs \320\300\1\x8C\101 386,SM +reg16,reg_cs \320\300\1\x8C\201 8086 +reg16,reg_dess \320\300\1\x8C\101 8086 +reg16,reg_fsgs \320\300\1\x8C\101 386 +rm32,reg_cs \321\300\1\x8C\201 8086 +rm32,reg_dess \321\300\1\x8C\101 8086 +rm32,reg_fsgs \321\300\1\x8C\101 386 +reg_dess,mem \320\301\1\x8E\110 8086,SM +reg_fsgs,mem \320\301\1\x8E\110 386,SM +reg_dess,reg16 \320\301\1\x8E\110 8086 +reg_fsgs,reg16 \320\301\1\x8E\110 386 +reg_dess,rm32 \321\301\1\x8E\110 8086 +reg_fsgs,rm32 \321\301\1\x8E\110 386 +reg_al,mem_offs \301\1\xA0\35 8086,SM +reg_ax,mem_offs \301\320\1\xA1\35 8086,SM +reg_eax,mem_offs \301\321\1\xA1\35 386,SM +mem_offs,reg_al \300\1\xA2\34 8086,SM +mem_offs,reg_ax \300\320\1\xA3\34 8086,SM +mem_offs,reg_eax \300\321\1\xA3\34 386,SM +reg32,reg_cr4 \2\x0F\x20\204 PENT,PRIV +reg32,reg_creg \2\x0F\x20\101 386,PRIV +reg32,reg_dreg \2\x0F\x21\101 386,PRIV +reg32,reg_treg \2\x0F\x24\101 386,PRIV +reg_cr4,reg32 \2\x0F\x22\214 PENT,PRIV +reg_creg,reg32 \2\x0F\x22\110 386,PRIV +reg_dreg,reg32 \2\x0F\x23\110 386,PRIV +reg_treg,reg32 \2\x0F\x26\110 386,PRIV +mem,reg8 \300\1\x88\101 8086,SM +reg8,reg8 \300\1\x88\101 8086 +mem,reg16 \320\300\1\x89\101 8086,SM +reg16,reg16 \320\300\1\x89\101 8086 +mem,reg32 \321\300\1\x89\101 386,SM +reg32,reg32 \321\300\1\x89\101 386 +reg8,mem \301\1\x8A\110 8086,SM +reg8,reg8 \301\1\x8A\110 8086 +reg16,mem \320\301\1\x8B\110 8086,SM +reg16,reg16 \320\301\1\x8B\110 8086 +reg32,mem \321\301\1\x8B\110 386,SM +reg32,reg32 \321\301\1\x8B\110 386 +reg8,imm \10\xB0\21 8086,SM +reg16,imm \320\10\xB8\31 8086,SM +reg32,imm \321\10\xB8\41 386,SM +rm8,imm \300\1\xC6\200\21 8086,SM +rm16,imm \320\300\1\xC7\200\31 8086,SM +rm32,imm \321\300\1\xC7\200\41 386,SM +mem,imm8 \300\1\xC6\200\21 8086,SM +mem,imm16 \320\300\1\xC7\200\31 8086,SM +mem,imm32 \321\300\1\xC7\200\41 386,SM + +[MOVD,movd] +(Ch_Rop1, Ch_Wop2, Ch_None) +mmxreg,mem \301\2\x0F\x6E\110 PENT,MMX,SD +mmxreg,reg32 \2\x0F\x6E\110 PENT,MMX +mem,mmxreg \300\2\x0F\x7E\101 PENT,MMX,SD +reg32,mmxreg \2\x0F\x7E\101 PENT,MMX + +[MOVQ,movq] +(Ch_Rop1, Ch_Wop2, Ch_None) +mmxreg,mem \301\2\x0F\x6F\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x6F\110 PENT,MMX +mem,mmxreg \300\2\x0F\x7F\101 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x7F\101 PENT,MMX + +[MOVSB] +(Ch_All, Ch_Rop1, Ch_None) +void \1\xA4 8086 + +[MOVSD,movsl] +(Ch_All, Ch_None, Ch_None) +void \321\1\xA5 386 + +[MOVSW] +(Ch_All, Ch_None, Ch_None) +void \320\1\xA5 8086 + +[MOVSX,movsX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\2\x0F\xBE\110 386,SB +reg16,reg8 \320\301\2\x0F\xBE\110 386 +reg32,rm8 \321\301\2\x0F\xBE\110 386 +reg32,rm16 \321\301\2\x0F\xBF\110 386 + +[MOVZX,movzX] +(Ch_Wop2, Ch_Rop1, Ch_None) +reg16,mem \320\301\2\x0F\xB6\110 386,SB +reg16,reg8 \320\301\2\x0F\xB6\110 386 +reg32,rm8 \321\301\2\x0F\xB6\110 386 +reg32,rm16 \321\301\2\x0F\xB7\110 386 + +[MUL,mulX] +(Ch_RWEAX, Ch_WEDX, Ch_WFlags) +rm8 \300\1\xF6\204 8086 +rm16 \320\300\1\xF7\204 8086 +rm32 \321\300\1\xF7\204 386 + +[NEG,negX] +(Ch_Mop1, Ch_None, Ch_None) +rm8 \300\1\xF6\203 8086 +rm16 \320\300\1\xF7\203 8086 +rm32 \321\300\1\xF7\203 386 + +[NOP] +(Ch_None, Ch_None, Ch_None) +void \1\x90 8086 + +[NOT,notX] +(Ch_Mop1, Ch_WFlags, Ch_None) +rm8 \300\1\xF6\202 8086 +rm16 \320\300\1\xF7\202 8086 +rm32 \321\300\1\xF7\202 386 + +[OR,orX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg8 \300\1\x08\101 8086,SM +reg8,reg8 \300\1\x08\101 8086 +mem,reg16 \320\300\1\x09\101 8086,SM +reg16,reg16 \320\300\1\x09\101 8086 +mem,reg32 \321\300\1\x09\101 386,SM +reg32,reg32 \321\300\1\x09\101 386 +reg8,mem \301\1\x0A\110 8086,SM +reg8,reg8 \301\1\x0A\110 8086 +reg16,mem \320\301\1\x0B\110 8086,SM +reg16,reg16 \320\301\1\x0B\110 8086 +reg32,mem \321\301\1\x0B\110 386,SM +reg32,reg32 \321\301\1\x0B\110 386 +rm16,imm8 \320\300\1\x83\201\15 8086 +rm32,imm8 \321\300\1\x83\201\15 386 +reg_al,imm \1\x0C\21 8086,SM +reg_ax,imm \320\1\x0D\31 8086,SM +reg_eax,imm \321\1\x0D\41 386,SM +rm8,imm \300\1\x80\201\21 8086,SM +rm16,imm \320\300\1\x81\201\31 8086,SM +rm32,imm \321\300\1\x81\201\41 386,SM +mem,imm8 \300\1\x80\201\21 8086,SM +mem,imm16 \320\300\1\x81\201\31 8086,SM +mem,imm32 \321\300\1\x81\201\41 386,SM + +[OUT,outX] +(Ch_Rop1, Ch_Rop2, Ch_None) +imm,reg_al \1\xE6\24 8086,SB +imm,reg_ax \320\1\xE7\24 8086,SB +imm,reg_eax \321\1\xE7\24 386,SB +reg_dx,reg_al \1\xEE 8086 +reg_dx,reg_ax \320\1\xEF 8086 +reg_dx,reg_eax \321\1\xEF 386 + +[OUTSB] +(Ch_All, Ch_None, Ch_None) +void \1\x6E 186 + +[OUTSD,outsl] +(Ch_All, Ch_None, Ch_None) +void \321\1\x6F 386 + +[OUTSW] +(Ch_All, Ch_None, Ch_None) +void \320\1\x6F 186 + +[PACKSSDW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x6B\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x6B\110 PENT,MMX + +[PACKSSWB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x63\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x63\110 PENT,MMX + +[PACKUSWB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x67\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x67\110 PENT,MMX + +[PADDB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xFC\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xFC\110 PENT,MMX + +[PADDD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xFE\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xFE\110 PENT,MMX + +[PADDSB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xEC\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xEC\110 PENT,MMX + +[PADDSIW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x51\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x51\110 PENT,MMX,CYRIX + +[PADDSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xED\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xED\110 PENT,MMX + +[PADDUSB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xDC\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xDC\110 PENT,MMX + +[PADDUSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xDD\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xDD\110 PENT,MMX + +[PADDW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xFD\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xFD\110 PENT,MMX + +[PAND] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xDB\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xDB\110 PENT,MMX + +[PANDN] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xDF\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xDF\110 PENT,MMX + +[PAVEB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x50\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x50\110 PENT,MMX,CYRIX + +[PAVGUSB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xBF PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xBF PENT,3DNOW + +[PCMPEQB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x74\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x74\110 PENT,MMX + +[PCMPEQD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x76\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x76\110 PENT,MMX + +[PCMPEQW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x75\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x75\110 PENT,MMX + +[PCMPGTB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x64\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x64\110 PENT,MMX + +[PCMPGTD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x66\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x66\110 PENT,MMX + +[PCMPGTW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x65\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x65\110 PENT,MMX + +[PDISTIB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x54\110 PENT,MMX,SM,CYRIX + +[PF2ID] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x1D PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x1D PENT,3DNOW + +[PFACC] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xAE PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xAE PENT,3DNOW + +[PFADD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x9E PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x9E PENT,3DNOW + +[PFCMPEQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xB0 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xB0 PENT,3DNOW + +[PFCMPGE] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x90 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x90 PENT,3DNOW + +[PFCMPGT] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xA0 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xA0 PENT,3DNOW + +[PFMAX] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xA4 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xA4 PENT,3DNOW + +[PFMIN] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x94 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x94 PENT,3DNOW + +[PFMUL] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xB4 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xB4 PENT,3DNOW + +[PFRCP] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x96 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x96 PENT,3DNOW + +[PFRCPIT1] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xA6 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xA6 PENT,3DNOW + +[PFRCPIT2] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xB6 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xB6 PENT,3DNOW + +[PFRSQIT1] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xA7 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xA7 PENT,3DNOW + +[PFRSQRT] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x97 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x97 PENT,3DNOW + +[PFSUB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x9A PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x9A PENT,3DNOW + +[PFSUBR] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xAA PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xAA PENT,3DNOW + +[PI2FD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x0D PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x0D PENT,3DNOW + +[PMACHRIW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x5E\110 PENT,MMX,SM,CYRIX + +[PMADDWD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF5\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF5\110 PENT,MMX + +[PMAGW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x52\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x52\110 PENT,MMX,CYRIX + +[PMULHRIW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x5D\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x5D\110 PENT,MMX,CYRIX + +[PMULHRWA] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\1\xB7 PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\1\xB7 PENT,3DNOW + +[PMULHRWC] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x59\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x59\110 PENT,MMX,CYRIX + +[PMULHW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xE5\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xE5\110 PENT,MMX + +[PMULLW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD5\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD5\110 PENT,MMX + +[PMVGEZB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x5C\110 PENT,MMX,SM,CYRIX + +[PMVLZB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x5B\110 PENT,MMX,SM,CYRIX + +[PMVNZB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x5A\110 PENT,MMX,SM,CYRIX + +[PMVZB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x58\110 PENT,MMX,SM,CYRIX + +[POP,popX] +(Ch_Wop1, Ch_RWESP, Ch_None) +reg16 \320\10\x58 8086 +reg32 \321\10\x58 386 +rm16 \320\300\1\x8F\200 8086 +rm32 \321\300\1\x8F\200 386 +reg_cs \1\x0F 8086,UNDOC,ND +reg_dess \4 8086 +reg_fsgs \1\x0F\5 386 + +[POPA,popaX] +(Ch_All, Ch_None, Ch_None) +void \322\1\x61 186 + +[POPAD,popal] +(Ch_All, Ch_None, Ch_None) +void \321\1\x61 386 + +[POPAW] +(Ch_All, Ch_None, Ch_None) +void \320\1\x61 186 + +[POPF] +(Ch_RWESP, Ch_WFlags, Ch_None) +void \322\1\x9D 186 + +[POPFD,popfl] +(Ch_RWESP, Ch_WFlags, Ch_None) +void \321\1\x9D 386 + +[POPFW] +(Ch_RWESP, Ch_WFLAGS, Ch_None) +void \320\1\x9D 186 + +[POR] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xEB\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xEB\110 PENT,MMX + +[PREFETCH,prefetchX] +(Ch_All, Ch_None, Ch_None) +mem \2\x0F\x0D\200 PENT,3DNOW,SM + +[PREFETCHW,prefetchwX] +(Ch_All, Ch_None, Ch_None) +mem \2\x0F\x0D\201 PENT,3DNOW,SM + +[PSLLD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF2\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF2\110 PENT,MMX +mmxreg,imm \2\x0F\x72\206\25 PENT,MMX + +[PSLLQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF3\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF3\110 PENT,MMX +mmxreg,imm \2\x0F\x73\206\25 PENT,MMX + +[PSLLW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF1\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF1\110 PENT,MMX +mmxreg,imm \2\x0F\x71\206\25 PENT,MMX + +[PSRAD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xE2\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xE2\110 PENT,MMX +mmxreg,imm \2\x0F\x72\204\25 PENT,MMX + +[PSRAW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xE1\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xE1\110 PENT,MMX +mmxreg,imm \2\x0F\x71\204\25 PENT,MMX + +[PSRLD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD2\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD2\110 PENT,MMX +mmxreg,imm \2\x0F\x72\202\25 PENT,MMX + +[PSRLQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD3\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD3\110 PENT,MMX +mmxreg,imm \2\x0F\x73\202\25 PENT,MMX + +[PSRLW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD1\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD1\110 PENT,MMX +mmxreg,imm \2\x0F\x71\202\25 PENT,MMX + +[PSUBB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF8\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF8\110 PENT,MMX + +[PSUBD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xFA\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xFA\110 PENT,MMX + +[PSUBSB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xE8\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xE8\110 PENT,MMX + +[PSUBSIW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x55\110 PENT,MMX,SM,CYRIX +mmxreg,mmxreg \2\x0F\x55\110 PENT,MMX,CYRIX + +[PSUBSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xE9\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xE9\110 PENT,MMX + +[PSUBUSB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD8\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD8\110 PENT,MMX + +[PSUBUSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xD9\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xD9\110 PENT,MMX + +[PSUBW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xF9\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xF9\110 PENT,MMX + +[PUNPCKHBW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x68\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x68\110 PENT,MMX + +[PUNPCKHDQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x6A\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x6A\110 PENT,MMX + +[PUNPCKHWD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x69\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x69\110 PENT,MMX + +[PUNPCKLBW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x60\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x60\110 PENT,MMX + +[PUNPCKLDQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x62\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x62\110 PENT,MMX + +[PUNPCKLWD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x61\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\x61\110 PENT,MMX + +[PUSH,pushX] +(Ch_Rop1, Ch_RWESP, Ch_None) +reg16 \320\10\x50 8086 +reg32 \321\10\x50 386 +rm16 \320\300\1\xFF\206 8086 +rm32 \321\300\1\xFF\206 386 +reg_fsgs \1\x0F\7 386 +reg_sreg \6 8086 +imm8 \1\x6A\14 286 +imm16 \320\1\x68\30 286 +imm32 \321\1\x68\40 386 + +[PUSHA,pushaX] +(Ch_All, Ch_None, Ch_None) +void \322\1\x60 186 + +[PUSHAD,pushal] +(Ch_All, Ch_None, Ch_None) +void \321\1\x60 386 + +[PUSHAW] +(Ch_All, Ch_None, Ch_None) +void \320\1\x60 186 + +[PUSHF] +(Ch_RWESP, Ch_RFlags, Ch_None) +void \322\1\x9C 186 + +[PUSHFD,pushfl] +(Ch_RWESP, Ch_RFlags, Ch_None) +void \321\1\x9C 386 + +[PUSHFW] +(Ch_RWESP, Ch_RFLAGS, Ch_None) +void \320\1\x9C 186 + +[PXOR] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\xEF\110 PENT,MMX,SM +mmxreg,mmxreg \2\x0F\xEF\110 PENT,MMX + +[RCL,rclX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +rm8,unity \300\1\xD0\202 8086 +rm8,reg_cl \300\1\xD2\202 8086 +rm8,imm \300\1\xC0\202\25 186,SB +rm16,unity \320\300\1\xD1\202 8086 +rm16,reg_cl \320\300\1\xD3\202 8086 +rm16,imm \320\300\1\xC1\202\25 186,SB +rm32,unity \321\300\1\xD1\202 386 +rm32,reg_cl \321\300\1\xD3\202 386 +rm32,imm \321\300\1\xC1\202\25 386,SB + +[RCR,rcrX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +rm8,unity \300\1\xD0\203 8086 +rm8,reg_cl \300\1\xD2\203 8086 +rm8,imm \300\1\xC0\203\25 186,SB +rm16,unity \320\300\1\xD1\203 8086 +rm16,reg_cl \320\300\1\xD3\203 8086 +rm16,imm \320\300\1\xC1\203\25 186,SB +rm32,unity \321\300\1\xD1\203 386 +rm32,reg_cl \321\300\1\xD3\203 386 +rm32,imm \321\300\1\xC1\203\25 386,SB + +[RDSHR] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x36 P6,CYRIX,SMM + +[RDMSR] +(Ch_WEAX, Ch_WEDX, Ch_None) +void \2\x0F\x32 PENT,PRIV + +[RDPMC] +(Ch_WEAX, Ch_WEDX, Ch_None) +void \2\x0F\x33 P6 + +[RDTSC] +(Ch_WEAX, Ch_WEDX, Ch_None) +void \2\x0F\x31 PENT + +[REP] +(Ch_RWECX, Ch_RWFlags, Ch_None) +void \1\xF3 8086,PRE + +[REPE] +(Ch_RWECX, Ch_RWFlags, Ch_None) +void \1\xF3 8086,PRE + +[REPNE] +(Ch_RWECX, Ch_RWFlags, Ch_None) +void \1\xF2 8086,PRE + +[REPNZ] +(Ch_RWECX, Ch_RWFLAGS, Ch_None) +void \1\xF2 8086,PRE + +[REPZ] +(Ch_RWECX, Ch_RWFLAGS, Ch_None) +void \1\xF3 8086,PRE + +[RET,retX] +(Ch_All, Ch_None, Ch_None) +void \1\xC3 8086 +imm \1\xC2\30 8086,SW + +[RETF,retfX] +(Ch_All, Ch_None, Ch_None) +void \1\xCB 8086 +imm \1\xCA\30 8086,SW + +[RETN,retnX] +(Ch_All, Ch_None, Ch_None) +void \1\xC3 8086 +imm \1\xC2\30 8086,SW + +[ROL,rolX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +rm8,unity \300\1\xD0\200 8086 +rm8,reg_cl \300\1\xD2\200 8086 +rm8,imm \300\1\xC0\200\25 186,SB +rm16,unity \320\300\1\xD1\200 8086 +rm16,reg_cl \320\300\1\xD3\200 8086 +rm16,imm \320\300\1\xC1\200\25 186,SB +rm32,unity \321\300\1\xD1\200 386 +rm32,reg_cl \321\300\1\xD3\200 386 +rm32,imm \321\300\1\xC1\200\25 386,SB + +[ROR,rorX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +rm8,unity \300\1\xD0\201 8086 +rm8,reg_cl \300\1\xD2\201 8086 +rm8,imm \300\1\xC0\201\25 186,SB +rm16,unity \320\300\1\xD1\201 8086 +rm16,reg_cl \320\300\1\xD3\201 8086 +rm16,imm \320\300\1\xC1\201\25 186,SB +rm32,unity \321\300\1\xD1\201 386 +rm32,reg_cl \321\300\1\xD3\201 386 +rm32,imm \321\300\1\xC1\201\25 386,SB + +[RSDC] +(Ch_All, Ch_None, Ch_None) +reg_sreg,mem80 \301\2\x0F\x79\101 486,CYRIX,SMM + +[RSLDT] +(Ch_All, Ch_None, Ch_None) +mem80 \300\2\x0F\x7B\200 486,CYRIX,SMM + +[RSM] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\xAA PENT,SMM + +[SAHF] +(Ch_WFlags, Ch_REAX, Ch_None) +void \1\x9E 8086 + +[SAL,salX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +rm8,unity \300\1\xD0\204 8086,ND +rm8,reg_cl \300\1\xD2\204 8086,ND +rm8,imm \300\1\xC0\204\25 186,ND,SB +rm16,unity \320\300\1\xD1\204 8086,ND +rm16,reg_cl \320\300\1\xD3\204 8086,ND +rm16,imm \320\300\1\xC1\204\25 186,ND,SB +rm32,unity \321\300\1\xD1\204 386,ND +rm32,reg_cl \321\300\1\xD3\204 386,ND +rm32,imm \321\300\1\xC1\204\25 386,ND,SB + +[SALC] +(Ch_WEAX, Ch_RFLAGS, Ch_None) +void \1\xD6 8086,UNDOC + +[SAR,sarX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +rm8,unity \300\1\xD0\207 8086 +rm8,reg_cl \300\1\xD2\207 8086 +rm8,imm \300\1\xC0\207\25 186,SB +rm16,unity \320\300\1\xD1\207 8086 +rm16,reg_cl \320\300\1\xD3\207 8086 +rm16,imm \320\300\1\xC1\207\25 186,SB +rm32,unity \321\300\1\xD1\207 386 +rm32,reg_cl \321\300\1\xD3\207 386 +rm32,imm \321\300\1\xC1\207\25 386,SB + +[SBB,sbbX] +(Ch_Mop2, Ch_Rop1, Ch_RWFlags) +mem,reg8 \300\1\x18\101 8086,SM +reg8,reg8 \300\1\x18\101 8086 +mem,reg16 \320\300\1\x19\101 8086,SM +reg16,reg16 \320\300\1\x19\101 8086 +mem,reg32 \321\300\1\x19\101 386,SM +reg32,reg32 \321\300\1\x19\101 386 +reg8,mem \301\1\x1A\110 8086,SM +reg8,reg8 \301\1\x1A\110 8086 +reg16,mem \320\301\1\x1B\110 8086,SM +reg16,reg16 \320\301\1\x1B\110 8086 +reg32,mem \321\301\1\x1B\110 386,SM +reg32,reg32 \321\301\1\x1B\110 386 +rm16,imm8 \320\300\1\x83\203\15 8086 +rm32,imm8 \321\300\1\x83\203\15 8086 +reg_al,imm \1\x1C\21 8086,SM +reg_ax,imm \320\1\x1D\31 8086,SM +reg_eax,imm \321\1\x1D\41 386,SM +rm8,imm \300\1\x80\203\21 8086,SM +rm16,imm \320\300\1\x81\203\31 8086,SM +rm32,imm \321\300\1\x81\203\41 386,SM +mem,imm8 \300\1\x80\203\21 8086,SM +mem,imm16 \320\300\1\x81\203\31 8086,SM +mem,imm32 \321\300\1\x81\203\41 386,SM + +[SCASB] +(Ch_All, Ch_None, Ch_None) +void \332\1\xAE 8086 + +[SCASD,scasl] +(Ch_All, Ch_None, Ch_None) +void \332\321\1\xAF 386 + +[SCASW] +(Ch_All, Ch_None, Ch_None) +void \332\320\1\xAF 8086 + +[SEGCS,cs] +(Ch_None, Ch_None, Ch_None) +void \1\x2E 8086,PRE + +[SEGDS,ds] +(Ch_None, Ch_None, Ch_None) +void \1\x3E 8086,PRE + +[SEGES,es] +(Ch_None, Ch_None, Ch_None) +void \1\x26 8086,PRE + +[SEGFS,fs] +(Ch_None, Ch_None, Ch_None) +void \1\x64 8086,PRE + +[SEGGS,gs] +(Ch_None, Ch_None, Ch_None) +void \1\x65 8086,PRE + +[SEGSS,ss] +(Ch_None, Ch_None, Ch_None) +void \1\x36 8086,PRE + +[SGDT] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x0F\x01\200 286 + +[SHL,shlX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +rm8,unity \300\1\xD0\204 8086 +rm8,reg_cl \300\1\xD2\204 8086 +rm8,imm \300\1\xC0\204\25 186,SB +rm16,unity \320\300\1\xD1\204 8086 +rm16,reg_cl \320\300\1\xD3\204 8086 +rm16,imm \320\300\1\xC1\204\25 186,SB +rm32,unity \321\300\1\xD1\204 386 +rm32,reg_cl \321\300\1\xD3\204 386 +rm32,imm \321\300\1\xC1\204\25 386,SB + +[SHLD,shldX] +(Ch_MOp3, Ch_RWFlags, Ch_Rop2) +mem,reg16,imm \300\320\2\x0F\xA4\101\26 386,SM2,SB,AR2 +reg16,reg16,imm \300\320\2\x0F\xA4\101\26 386,SM2,SB,AR2 +mem,reg32,imm \300\321\2\x0F\xA4\101\26 386,SM2,SB,AR2 +reg32,reg32,imm \300\321\2\x0F\xA4\101\26 386,SM2,SB,AR2 +mem,reg16,reg_cl \300\320\2\x0F\xA5\101 386,SM +reg16,reg16,reg_cl \300\320\2\x0F\xA5\101 386 +mem,reg32,reg_cl \300\321\2\x0F\xA5\101 386,SM +reg32,reg32,reg_cl \300\321\2\x0F\xA5\101 386 + +[SHR,shrX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +rm8,unity \300\1\xD0\205 8086 +rm8,reg_cl \300\1\xD2\205 8086 +rm8,imm \300\1\xC0\205\25 186,SB +rm16,unity \320\300\1\xD1\205 8086 +rm16,reg_cl \320\300\1\xD3\205 8086 +rm16,imm \320\300\1\xC1\205\25 186,SB +rm32,unity \321\300\1\xD1\205 386 +rm32,reg_cl \321\300\1\xD3\205 386 +rm32,imm \321\300\1\xC1\205\25 386,SB + +[SHRD,shrdX] +(Ch_MOp3, Ch_RWFlags, Ch_Rop2) +mem,reg16,imm \300\320\2\x0F\xAC\101\26 386,SM2,SB,AR2 +reg16,reg16,imm \300\320\2\x0F\xAC\101\26 386,SM2,SB,AR2 +mem,reg32,imm \300\321\2\x0F\xAC\101\26 386,SM2,SB,AR2 +reg32,reg32,imm \300\321\2\x0F\xAC\101\26 386,SM2,SB,AR2 +mem,reg16,reg_cl \300\320\2\x0F\xAD\101 386,SM +reg16,reg16,reg_cl \300\320\2\x0F\xAD\101 386 +mem,reg32,reg_cl \300\321\2\x0F\xAD\101 386,SM +reg32,reg32,reg_cl \300\321\2\x0F\xAD\101 386 + +[SIDT,sidtX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x0F\x01\201 286 + +[SLDT,sldtX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\1\x0F\17\200 286 +mem16 \300\1\x0F\17\200 286 +reg16 \300\1\x0F\17\200 286 + +[SMI] +(Ch_All, Ch_None, Ch_None) +void \1\xF1 386,UNDOC + +[SMINT] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x38 P6,CYRIX + +[SMINTOLD] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x7E 486,CYRIX,ND + +[SMSW,smswX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\2\x0F\x01\204 286 +mem16 \300\2\x0F\x01\204 286 +reg16 \300\2\x0F\x01\204 286 + +[STC] +(Ch_WFlags, Ch_None, Ch_None) +void \1\xF9 8086 + +[STD] +(Ch_SDirFlag, Ch_None, Ch_None) +void \1\xFD 8086 + +[STI] +(Ch_WFlags, Ch_None, Ch_None) +void \1\xFB 8086 + +[STOSB] +(Ch_REAX, Ch_WMemEDI, Ch_RWEDI) +void \1\xAA 8086 + +[STOSD,stosl] +(Ch_REAX, Ch_WMemEDI, Ch_RWEDI) +void \321\1\xAB 386 + +[STOSW] +(Ch_REAX, Ch_WMemEDI, Ch_RWEDI) +void \320\1\xAB 8086 + +[STR,strX] +(Ch_Wop1, Ch_None, Ch_None) +mem \300\1\x0F\17\201 286,PROT +mem16 \300\1\x0F\17\201 286,PROT +reg16 \300\1\x0F\17\201 286,PROT + +[SUB,subX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg8 \300\1\x28\101 8086,SM +reg8,reg8 \300\1\x28\101 8086 +mem,reg16 \320\300\1\x29\101 8086,SM +reg16,reg16 \320\300\1\x29\101 8086 +mem,reg32 \321\300\1\x29\101 386,SM +reg32,reg32 \321\300\1\x29\101 386 +reg8,mem \301\1\x2A\110 8086,SM +reg8,reg8 \301\1\x2A\110 8086 +reg16,mem \320\301\1\x2B\110 8086,SM +reg16,reg16 \320\301\1\x2B\110 8086 +reg32,mem \321\301\1\x2B\110 386,SM +reg32,reg32 \321\301\1\x2B\110 386 +rm16,imm8 \320\300\1\x83\205\15 8086 +rm32,imm8 \321\300\1\x83\205\15 386 +reg_al,imm \1\x2C\21 8086,SM +reg_ax,imm \320\1\x2D\31 8086,SM +reg_eax,imm \321\1\x2D\41 386,SM +rm8,imm \300\1\x80\205\21 8086,SM +rm16,imm \320\300\1\x81\205\31 8086,SM +rm32,imm \321\300\1\x81\205\41 386,SM +mem,imm8 \300\1\x80\205\21 8086,SM +mem,imm16 \320\300\1\x81\205\31 8086,SM +mem,imm32 \321\300\1\x81\205\41 386,SM + +[SVDC,svdcX] +(Ch_All, Ch_None, Ch_None) +mem80,reg_sreg \300\2\x0F\x78\101 486,CYRIX,SMM + +[SVLDT,svldtX] +(Ch_All, Ch_None, Ch_None) +mem80 \300\2\x0F\x7A\200 486,CYRIX,SMM + +[SVTS,svtsX] +(Ch_All, Ch_None, Ch_None) +mem80 \300\2\x0F\x7C\200 486,CYRIX,SMM + +[SYSCALL] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x05 P6,AMD + +[SYSENTER] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x34 P6 + +[SYSEXIT] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x36 P6,PRIV + +[SYSRET] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x07 P6,PRIV,AMD + +[TEST,testX] +(Ch_WFlags, Ch_Rop1, Ch_Rop2) +mem,reg8 \300\1\x84\101 8086,SM +reg8,reg8 \300\1\x84\101 8086 +mem,reg16 \320\300\1\x85\101 8086,SM +reg16,reg16 \320\300\1\x85\101 8086 +mem,reg32 \321\300\1\x85\101 386,SM +reg32,reg32 \321\300\1\x85\101 386 +reg8,mem \301\1\x84\110 8086,SM +reg16,mem \320\301\1\x85\110 8086,SM +reg32,mem \321\301\1\x85\110 386,SM +reg_al,imm \1\xA8\21 8086,SM +reg_ax,imm \320\1\xA9\31 8086,SM +reg_eax,imm \321\1\xA9\41 386,SM +rm8,imm \300\1\xF6\200\21 8086,SM +rm16,imm \320\300\1\xF7\200\31 8086,SM +rm32,imm \321\300\1\xF7\200\41 386,SM +mem,imm8 \300\1\xF6\200\21 8086,SM +mem,imm16 \320\300\1\xF7\200\31 8086,SM +mem,imm32 \321\300\1\xF7\200\41 386,SM + +[UD1] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\xB9 286,UNDOC + +[UD2] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x0B 286 + +[UMOV,umovX] +(Ch_All, Ch_None, Ch_None) +mem,reg8 \300\2\x0F\x10\101 386,UNDOC,SM +reg8,reg8 \300\2\x0F\x10\101 386,UNDOC +mem,reg16 \320\300\2\x0F\x11\101 386,UNDOC,SM +reg16,reg16 \320\300\2\x0F\x11\101 386,UNDOC +mem,reg32 \321\300\2\x0F\x11\101 386,UNDOC,SM +reg32,reg32 \321\300\2\x0F\x11\101 386,UNDOC +reg8,mem \301\2\x0F\x12\110 386,UNDOC,SM +reg8,reg8 \301\2\x0F\x12\110 386,UNDOC +reg16,mem \320\301\2\x0F\x13\110 386,UNDOC,SM +reg16,reg16 \320\301\2\x0F\x13\110 386,UNDOC +reg32,mem \321\301\2\x0F\x13\110 386,UNDOC,SM +reg32,reg32 \321\301\2\x0F\x13\110 386,UNDOC + +[VERR,verrX] +(Ch_WFlags, Ch_None, Ch_None) +mem \300\1\x0F\17\204 286,PROT +mem16 \300\1\x0F\17\204 286,PROT +reg16 \300\1\x0F\17\204 286,PROT + +[VERW] +(Ch_WFlags, Ch_None, Ch_None) +mem \300\1\x0F\17\205 286,PROT +mem16 \300\1\x0F\17\205 286,PROT +reg16 \300\1\x0F\17\205 286,PROT + +[WAIT] +(Ch_None, Ch_None, Ch_None) +void \1\x9B 8086 + +[WBINVD] +(Ch_None, Ch_None, Ch_None) +void \2\x0F\x09 486,PRIV + +[WRSHR] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x37 P6,CYRIX,SMM + +[WRMSR] +(Ch_All, Ch_None, Ch_None) +void \2\x0F\x30 PENT,PRIV + +[XADD,xaddX] +(Ch_All, Ch_None, Ch_None) +mem,reg8 \300\2\x0F\xC0\101 486,SM +reg8,reg8 \300\2\x0F\xC0\101 486 +mem,reg16 \320\300\2\x0F\xC1\101 486,SM +reg16,reg16 \320\300\2\x0F\xC1\101 486 +mem,reg32 \321\300\2\x0F\xC1\101 486,SM +reg32,reg32 \321\300\2\x0F\xC1\101 486 + +[XBTS,xbtsX] +(Ch_All, Ch_None, Ch_None) +reg16,mem \320\301\2\x0F\xA6\110 386,SW,UNDOC,ND +reg16,reg16 \320\301\2\x0F\xA6\110 386,UNDOC,ND +reg32,mem \321\301\2\x0F\xA6\110 386,SD,UNDOC,ND +reg32,reg32 \321\301\2\x0F\xA6\110 386,UNDOC,ND + +[XCHG,xchgX] +(Ch_RWop1, Ch_RWop2, Ch_None) +reg_ax,reg16 \320\11\x90 8086 +reg_eax,reg32 \321\11\x90 386 +reg16,reg_ax \320\10\x90 8086 +reg32,reg_eax \321\10\x90 386 +reg8,mem \301\1\x86\110 8086,SM +reg8,reg8 \301\1\x86\110 8086 +reg16,mem \320\301\1\x87\110 8086,SM +reg16,reg16 \320\301\1\x87\110 8086 +reg32,mem \321\301\1\x87\110 386,SM +reg32,reg32 \321\301\1\x87\110 386 +mem,reg8 \300\1\x86\101 8086,SM +reg8,reg8 \300\1\x86\101 8086 +mem,reg16 \320\300\1\x87\101 8086,SM +reg16,reg16 \320\300\1\x87\101 8086 +mem,reg32 \321\300\1\x87\101 386,SM +reg32,reg32 \321\300\1\x87\101 386 + +[XLAT] +(Ch_WEAX, Ch_REBX, Ch_None) +void \1\xD7 8086 + +[XLATB] +(Ch_WEAX, Ch_REBX, Ch_None) +void \1\xD7 8086 + +[XOR,xorX] +(Ch_Mop2, Ch_Rop1, Ch_WFlags) +mem,reg8 \300\1\x30\101 8086,SM +reg8,reg8 \300\1\x30\101 8086 +mem,reg16 \320\300\1\x31\101 8086,SM +reg16,reg16 \320\300\1\x31\101 8086 +mem,reg32 \321\300\1\x31\101 386,SM +reg32,reg32 \321\300\1\x31\101 386 +reg8,mem \301\1\x32\110 8086,SM +reg8,reg8 \301\1\x32\110 8086 +reg16,mem \320\301\1\x33\110 8086,SM +reg16,reg16 \320\301\1\x33\110 8086 +reg32,mem \321\301\1\x33\110 386,SM +reg32,reg32 \321\301\1\x33\110 386 +rm16,imm8 \320\300\1\x83\206\15 8086 +rm32,imm8 \321\300\1\x83\206\15 386 +reg_al,imm \1\x34\21 8086,SM +reg_ax,imm \320\1\x35\31 8086,SM +reg_eax,imm \321\1\x35\41 386,SM +rm8,imm \300\1\x80\206\21 8086,SM +rm16,imm \320\300\1\x81\206\31 8086,SM +rm32,imm \321\300\1\x81\206\41 386,SM +mem,imm8 \300\1\x80\206\21 8086,SM +mem,imm16 \320\300\1\x81\206\31 8086,SM +mem,imm32 \321\300\1\x81\206\41 386,SM + +[CMOVcc,cmovCCX] +(Ch_ROp1, Ch_WOp2, Ch_RFLAGS) +reg16,mem \320\301\1\x0F\330\x40\110 P6,SM +reg16,reg16 \320\301\1\x0F\330\x40\110 P6 +reg32,mem \321\301\1\x0F\330\x40\110 P6,SM +reg32,reg32 \321\301\1\x0F\330\x40\110 P6 + +[Jcc] +(Ch_None, Ch_None, Ch_None) +imm|near \322\1\x0F\330\x80\64 386,PASS2 +imm16|near \320\1\x0F\330\x80\64 386,PASS2 +imm32|near \321\1\x0F\330\x80\64 386,PASS2 +imm \330\x70\50 8086 +imm|short \330\x70\50 8086,ND + +[SETcc,setCCX] +(Ch_RFLAGS, Ch_WOp1, Ch_None) +mem \300\1\x0F\330\x90\200 386,SB +reg8 \300\1\x0F\330\x90\200 386 + +; +; Katmai Streaming SIMD instructions (SSE -- a.k.a. KNI, XMM, MMX2) +; + +[ADDPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x58\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x58\110 KATMAI,SSE + +[ADDSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x58\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x58\110 KATMAI,SSE + +[ANDNPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x55\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x55\110 KATMAI,SSE + +[ANDPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x54\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x54\110 KATMAI,SSE + +[CMPEQPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x00 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x00 KATMAI,SSE + +[CMPEQSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x00 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x00 KATMAI,SSE + +[CMPLEPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x02 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x02 KATMAI,SSE + +[CMPLESS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x02 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x02 KATMAI,SSE + +[CMPLTPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x01 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x01 KATMAI,SSE + +[CMPLTSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x01 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x01 KATMAI,SSE + +[CMPNEQPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x04 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x04 KATMAI,SSE + +[CMPNEQSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x04 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x04 KATMAI,SSE + +[CMPNLEPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x06 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x06 KATMAI,SSE + +[CMPNLESS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x06 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x06 KATMAI,SSE + +[CMPNLTPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x05 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x05 KATMAI,SSE + +[CMPNLTSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x05 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x05 KATMAI,SSE + +[CMPORDPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x07 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x07 KATMAI,SSE + +[CMPORDSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x07 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x07 KATMAI,SSE + +[CMPUNORDPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\xC2\110\1\x03 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\xC2\110\1\x03 KATMAI,SSE + +[CMPUNORDSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\xC2\110\1\x03 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\xC2\110\1\x03 KATMAI,SSE + +; +; CMPPS/CMPSS must come after the specific ops; that way the disassembler will find the +; specific ops first and only disassemble illegal ones as cmpps. +; + +[CMPPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem,imm \301\331\2\x0F\xC2\110\22 KATMAI,SSE,SB,AR2 +xmmreg,xmmreg,imm \331\2\x0F\xC2\110\22 KATMAI,SSE,SB,AR2 + +[CMPSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem,imm \301\333\2\x0F\xC2\110\22 KATMAI,SSE,SB,AR2 +xmmreg,xmmreg,imm \333\2\x0F\xC2\110\22 KATMAI,SSE,SB,AR2 + +[COMISS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x2F\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x2F\110 KATMAI,SSE + +[CVTPI2PS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x2A\110 KATMAI,SSE,MMX +xmmreg,mmxreg \331\2\x0F\x2A\110 KATMAI,SSE,MMX + +[CVTPS2PI] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\331\2\x0F\x2D\110 KATMAI,SSE,MMX +mmxreg,xmmreg \331\2\x0F\x2D\110 KATMAI,SSE,MMX + +[CVTSI2SS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x2A\110 KATMAI,SSE,SD,AR1 +xmmreg,reg32 \333\2\x0F\x2A\110 KATMAI,SSE + +[CVTSS2SI] +(Ch_All, Ch_None, Ch_None) +reg32,mem \301\333\2\x0F\x2D\110 KATMAI,SSE +reg32,xmmreg \333\2\x0F\x2D\110 KATMAI,SSE + +[CVTTPS2PI] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\331\2\x0F\x2C\110 KATMAI,SSE,MMX +mmxreg,xmmreg \331\2\x0F\x2C\110 KATMAI,SSE,MMX + +[CVTTSS2SI] +(Ch_All, Ch_None, Ch_None) +reg32,mem \301\333\2\x0F\x2C\110 KATMAI,SSE +reg32,xmmreg \333\2\x0F\x2C\110 KATMAI,SSE + +[DIVPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x5E\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x5E\110 KATMAI,SSE + +[DIVSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x5E\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x5E\110 KATMAI,SSE + +[LDMXCSR] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\xAE\202 KATMAI,SSE,SD + +[MAXPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x5F\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x5F\110 KATMAI,SSE + +[MAXSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x5F\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x5F\110 KATMAI,SSE + +[MINPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x5D\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x5D\110 KATMAI,SSE + +[MINSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x5D\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x5D\110 KATMAI,SSE + +[MOVAPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x28\110 KATMAI,SSE +mem,xmmreg \300\2\x0F\x29\101 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x28\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x29\101 KATMAI,SSE + +[MOVHPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x16\110 KATMAI,SSE +mem,xmmreg \300\2\x0F\x17\101 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x16\101 KATMAI,SSE,ND + +[MOVLHPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,xmmreg \2\x0F\x16\110 KATMAI,SSE + +[MOVLPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x12\110 KATMAI,SSE +mem,xmmreg \300\2\x0F\x13\101 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x12\101 KATMAI,SSE,ND + +[MOVHLPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,xmmreg \2\x0F\x12\110 KATMAI,SSE + +[MOVMSKPS] +(Ch_All, Ch_None, Ch_None) +reg32,xmmreg \2\x0F\x50\110 KATMAI,SSE + +[MOVNTPS] +(Ch_All, Ch_None, Ch_None) +mem,xmmreg \2\x0F\x2B\101 KATMAI,SSE + +[MOVSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x10\110 KATMAI,SSE +mem,xmmreg \300\333\2\x0F\x11\101 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x10\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x11\101 KATMAI,SSE + +[MOVUPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x10\110 KATMAI,SSE +mem,xmmreg \300\331\2\x0F\x11\101 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x10\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x11\101 KATMAI,SSE + +[MULPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x59\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x59\110 KATMAI,SSE + +[MULSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x59\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x59\110 KATMAI,SSE + +[ORPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x56\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x56\110 KATMAI,SSE + +[RCPPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x53\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x53\110 KATMAI,SSE + +[RCPSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x53\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x53\110 KATMAI,SSE + +[RSQRTPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x52\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x52\110 KATMAI,SSE + +[RSQRTSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x52\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x52\110 KATMAI,SSE + +[SHUFPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem,imm \301\2\x0F\xC6\110\22 KATMAI,SSE,SB,AR2 +xmmreg,xmmreg,imm \2\x0F\xC6\110\22 KATMAI,SSE,SB,AR2 + +[SQRTPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x51\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x51\110 KATMAI,SSE + +[SQRTSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x51\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x51\110 KATMAI,SSE + +[STMXCSR] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\xAE\203 KATMAI,SSE,SD + +[SUBPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\331\2\x0F\x5C\110 KATMAI,SSE +xmmreg,xmmreg \331\2\x0F\x5C\110 KATMAI,SSE + +[SUBSS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\333\2\x0F\x5C\110 KATMAI,SSE +xmmreg,xmmreg \333\2\x0F\x5C\110 KATMAI,SSE + +[UCOMISS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x2E\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x2E\110 KATMAI,SSE + +[UNPCKHPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x15\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x15\110 KATMAI,SSE + +[UNPCKLPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x14\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x14\110 KATMAI,SSE + +[XORPS] +(Ch_All, Ch_None, Ch_None) +xmmreg,mem \301\2\x0F\x57\110 KATMAI,SSE +xmmreg,xmmreg \2\x0F\x57\110 KATMAI,SSE + +; +; Introduced in Dechutes but necessary for SSE support +; + +[FXRSTOR] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\xAE\201 P6,SSE,FPU + +[FXSAVE] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\xAE\200 P6,SSE,FPU + +; +; These instructions aren't SSE-specific; they are generic memory operations +; and work even if CR4.OSFXFR == 0 +; + +[PREFETCHNTA] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\x18\200 KATMAI + +[PREFETCHT0] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\x18\201 KATMAI + +[PREFETCHT1] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\x18\202 KATMAI + +[PREFETCHT2] +(Ch_All, Ch_None, Ch_None) +mem \300\2\x0F\x18\203 KATMAI + +[SFENCE] +(Ch_All, Ch_None, Ch_None) +void \3\x0F\xAE\xF8 KATMAI + +; +; New MMX instructions introduced in Katmai +; + +[MASKMOVQ] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xF7\110 KATMAI,MMX + +[MOVNTQ] +(Ch_All, Ch_None, Ch_None) +mem,mmxreg \2\x0F\xE7\101 KATMAI,MMX,SM + +[PAVGB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xE0\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xE0\110 KATMAI,MMX,SM + +[PAVGW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xE3\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xE3\110 KATMAI,MMX,SM + +[PEXTRW] +(Ch_All, Ch_None, Ch_None) +reg32,mmxreg,imm \2\x0F\xC5\110\22 KATMAI,MMX,SB,AR2 + +[PINSRW] +(Ch_All, Ch_None, Ch_None) +; PINSRW is documented as using a reg32, but it's really using only 16 bit +; -- accept either, but be truthful in disassembly +mmxreg,reg16,imm \2\x0F\xC4\110\22 KATMAI,MMX,SB,AR2 +mmxreg,reg32,imm \2\x0F\xC4\110\22 KATMAI,MMX,SB,AR2,ND +mmxreg,mem,imm \301\2\x0F\xC4\110\22 KATMAI,MMX,SB,AR2 +mmxreg,mem16,imm \301\2\x0F\xC4\110\22 KATMAI,MMX,SB,AR2,ND + +[PMAXSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xEE\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xEE\110 KATMAI,MMX,SM + +[PMAXUB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xDE\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xDE\110 KATMAI,MMX,SM + +[PMINSW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xEA\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xEA\110 KATMAI,MMX,SM + +[PMINUB] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xDA\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xDA\110 KATMAI,MMX,SM + +[PMOVMSKB] +(Ch_All, Ch_None, Ch_None) +reg32,mmxreg \2\x0F\xD7\110 KATMAI,MMX + +[PMULHUW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xE4\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xE4\110 KATMAI,MMX,SM + +[PSADBW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg \2\x0F\xF6\110 KATMAI,MMX +mmxreg,mem \301\2\x0F\xF6\110 KATMAI,MMX,SM + +[PSHUFW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mmxreg,imm \2\x0F\x70\110\22 KATMAI,MMX,SB,AR2 +mmxreg,mem,imm \301\2\x0F\x70\110\22 KATMAI,MMX,SM2,SB,AR2 + +; +; New K7 Instructions +; + +[PFNACC] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x8A PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x8A PENT,3DNOW + +[PFPNACC] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x8E PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x8E PENT,3DNOW + +[PI2FW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x0C PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x0C PENT,3DNOW + +[PF2IW] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\x1C PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\x1C PENT,3DNOW + +[PSWAPD] +(Ch_All, Ch_None, Ch_None) +mmxreg,mem \301\2\x0F\x0F\110\01\xBB PENT,3DNOW,SM +mmxreg,mmxreg \2\x0F\x0F\110\01\xBB PENT,3DNOW,SM + +[FFREEP] +(Ch_All, Ch_None, Ch_None) +fpureg \1\xDF\10\xC0 PENT,3DNOW,FPU \ No newline at end of file diff --git a/befpc/compiler/i386int.inc b/befpc/compiler/i386int.inc new file mode 100644 index 0000000..57ad236 --- /dev/null +++ b/befpc/compiler/i386int.inc @@ -0,0 +1,469 @@ +{ don't edit, this file is generated from i386ins.dat } +( +'none', +'aaa', +'aad', +'aam', +'aas', +'adc', +'add', +'and', +'arpl', +'bound', +'bsf', +'bsr', +'bswap', +'bt', +'btc', +'btr', +'bts', +'call', +'cbw', +'cdq', +'clc', +'cld', +'cli', +'clts', +'cmc', +'cmp', +'cmpsb', +'cmpsd', +'cmpsw', +'cmpxchg', +'cmpxchg486', +'cmpxchg8b', +'cpuid', +'cwd', +'cwde', +'daa', +'das', +'dec', +'div', +'emms', +'enter', +'f2xm1', +'fabs', +'fadd', +'faddp', +'fbld', +'fbstp', +'fchs', +'fclex', +'fcmovb', +'fcmovbe', +'fcmove', +'fcmovnb', +'fcmovnbe', +'fcmovne', +'fcmovnu', +'fcmovu', +'fcom', +'fcomi', +'fcomip', +'fcomp', +'fcompp', +'fcos', +'fdecstp', +'fdisi', +'fdiv', +'fdivp', +'fdivr', +'fdivrp', +'femms', +'feni', +'ffree', +'fiadd', +'ficom', +'ficomp', +'fidiv', +'fidivr', +'fild', +'fimul', +'fincstp', +'finit', +'fist', +'fistp', +'fisub', +'fisubr', +'fld', +'fld1', +'fldcw', +'fldenv', +'fldl2e', +'fldl2t', +'fldlg2', +'fldln2', +'fldpi', +'fldz', +'fmul', +'fmulp', +'fnclex', +'fndisi', +'fneni', +'fninit', +'fnop', +'fnsave', +'fnstcw', +'fnstenv', +'fnstsw', +'fpatan', +'fprem', +'fprem1', +'fptan', +'frndint', +'frstor', +'fsave', +'fscale', +'fsetpm', +'fsin', +'fsincos', +'fsqrt', +'fst', +'fstcw', +'fstenv', +'fstp', +'fstsw', +'fsub', +'fsubp', +'fsubr', +'fsubrp', +'ftst', +'fucom', +'fucomi', +'fucomip', +'fucomp', +'fucompp', +'fwait', +'fxam', +'fxch', +'fxtract', +'fyl2x', +'fyl2xp1', +'hlt', +'ibts', +'icebp', +'idiv', +'imul', +'in', +'inc', +'insb', +'insd', +'insw', +'int', +'int01', +'int1', +'int03', +'int3', +'into', +'invd', +'invlpg', +'iret', +'iretd', +'iretw', +'jcxz', +'jecxz', +'jmp', +'lahf', +'lar', +'lcall', +'lds', +'lea', +'leave', +'les', +'lfs', +'lgdt', +'lgs', +'lidt', +'ljmp', +'lldt', +'lmsw', +'loadall', +'loadall286', +'lock', +'lodsb', +'lodsd', +'lodsw', +'loop', +'loope', +'loopne', +'loopnz', +'loopz', +'lsl', +'lss', +'ltr', +'mov', +'movd', +'movq', +'movsb', +'movsd', +'movsw', +'movsx', +'movzx', +'mul', +'neg', +'nop', +'not', +'or', +'out', +'outsb', +'outsd', +'outsw', +'packssdw', +'packsswb', +'packuswb', +'paddb', +'paddd', +'paddsb', +'paddsiw', +'paddsw', +'paddusb', +'paddusw', +'paddw', +'pand', +'pandn', +'paveb', +'pavgusb', +'pcmpeqb', +'pcmpeqd', +'pcmpeqw', +'pcmpgtb', +'pcmpgtd', +'pcmpgtw', +'pdistib', +'pf2id', +'pfacc', +'pfadd', +'pfcmpeq', +'pfcmpge', +'pfcmpgt', +'pfmax', +'pfmin', +'pfmul', +'pfrcp', +'pfrcpit1', +'pfrcpit2', +'pfrsqit1', +'pfrsqrt', +'pfsub', +'pfsubr', +'pi2fd', +'pmachriw', +'pmaddwd', +'pmagw', +'pmulhriw', +'pmulhrwa', +'pmulhrwc', +'pmulhw', +'pmullw', +'pmvgezb', +'pmvlzb', +'pmvnzb', +'pmvzb', +'pop', +'popa', +'popad', +'popaw', +'popf', +'popfd', +'popfw', +'por', +'prefetch', +'prefetchw', +'pslld', +'psllq', +'psllw', +'psrad', +'psraw', +'psrld', +'psrlq', +'psrlw', +'psubb', +'psubd', +'psubsb', +'psubsiw', +'psubsw', +'psubusb', +'psubusw', +'psubw', +'punpckhbw', +'punpckhdq', +'punpckhwd', +'punpcklbw', +'punpckldq', +'punpcklwd', +'push', +'pusha', +'pushad', +'pushaw', +'pushf', +'pushfd', +'pushfw', +'pxor', +'rcl', +'rcr', +'rdshr', +'rdmsr', +'rdpmc', +'rdtsc', +'rep', +'repe', +'repne', +'repnz', +'repz', +'ret', +'retf', +'retn', +'rol', +'ror', +'rsdc', +'rsldt', +'rsm', +'sahf', +'sal', +'salc', +'sar', +'sbb', +'scasb', +'scasd', +'scasw', +'segcs', +'segds', +'seges', +'segfs', +'seggs', +'segss', +'sgdt', +'shl', +'shld', +'shr', +'shrd', +'sidt', +'sldt', +'smi', +'smint', +'smintold', +'smsw', +'stc', +'std', +'sti', +'stosb', +'stosd', +'stosw', +'str', +'sub', +'svdc', +'svldt', +'svts', +'syscall', +'sysenter', +'sysexit', +'sysret', +'test', +'ud1', +'ud2', +'umov', +'verr', +'verw', +'wait', +'wbinvd', +'wrshr', +'wrmsr', +'xadd', +'xbts', +'xchg', +'xlat', +'xlatb', +'xor', +'cmov', +'j', +'set', +'addps', +'addss', +'andnps', +'andps', +'cmpeqps', +'cmpeqss', +'cmpleps', +'cmpless', +'cmpltps', +'cmpltss', +'cmpneqps', +'cmpneqss', +'cmpnleps', +'cmpnless', +'cmpnltps', +'cmpnltss', +'cmpordps', +'cmpordss', +'cmpunordps', +'cmpunordss', +'cmpps', +'cmpss', +'comiss', +'cvtpi2ps', +'cvtps2pi', +'cvtsi2ss', +'cvtss2si', +'cvttps2pi', +'cvttss2si', +'divps', +'divss', +'ldmxcsr', +'maxps', +'maxss', +'minps', +'minss', +'movaps', +'movhps', +'movlhps', +'movlps', +'movhlps', +'movmskps', +'movntps', +'movss', +'movups', +'mulps', +'mulss', +'orps', +'rcpps', +'rcpss', +'rsqrtps', +'rsqrtss', +'shufps', +'sqrtps', +'sqrtss', +'stmxcsr', +'subps', +'subss', +'ucomiss', +'unpckhps', +'unpcklps', +'xorps', +'fxrstor', +'fxsave', +'prefetchnta', +'prefetcht0', +'prefetcht1', +'prefetcht2', +'sfence', +'maskmovq', +'movntq', +'pavgb', +'pavgw', +'pextrw', +'pinsrw', +'pmaxsw', +'pmaxub', +'pminsw', +'pminub', +'pmovmskb', +'pmulhuw', +'psadbw', +'pshufw', +'pfnacc', +'pfpnacc', +'pi2fw', +'pf2iw', +'pswapd', +'ffreep' +); diff --git a/befpc/compiler/i386nop.inc b/befpc/compiler/i386nop.inc new file mode 100644 index 0000000..8270db7 --- /dev/null +++ b/befpc/compiler/i386nop.inc @@ -0,0 +1,2 @@ +{ don't edit, this file is generated from i386ins.dat } +1325; diff --git a/befpc/compiler/i386op.inc b/befpc/compiler/i386op.inc new file mode 100644 index 0000000..7968486 --- /dev/null +++ b/befpc/compiler/i386op.inc @@ -0,0 +1,469 @@ +{ don't edit, this file is generated from i386ins.dat } +( +A_NONE, +A_AAA, +A_AAD, +A_AAM, +A_AAS, +A_ADC, +A_ADD, +A_AND, +A_ARPL, +A_BOUND, +A_BSF, +A_BSR, +A_BSWAP, +A_BT, +A_BTC, +A_BTR, +A_BTS, +A_CALL, +A_CBW, +A_CDQ, +A_CLC, +A_CLD, +A_CLI, +A_CLTS, +A_CMC, +A_CMP, +A_CMPSB, +A_CMPSD, +A_CMPSW, +A_CMPXCHG, +A_CMPXCHG486, +A_CMPXCHG8B, +A_CPUID, +A_CWD, +A_CWDE, +A_DAA, +A_DAS, +A_DEC, +A_DIV, +A_EMMS, +A_ENTER, +A_F2XM1, +A_FABS, +A_FADD, +A_FADDP, +A_FBLD, +A_FBSTP, +A_FCHS, +A_FCLEX, +A_FCMOVB, +A_FCMOVBE, +A_FCMOVE, +A_FCMOVNB, +A_FCMOVNBE, +A_FCMOVNE, +A_FCMOVNU, +A_FCMOVU, +A_FCOM, +A_FCOMI, +A_FCOMIP, +A_FCOMP, +A_FCOMPP, +A_FCOS, +A_FDECSTP, +A_FDISI, +A_FDIV, +A_FDIVP, +A_FDIVR, +A_FDIVRP, +A_FEMMS, +A_FENI, +A_FFREE, +A_FIADD, +A_FICOM, +A_FICOMP, +A_FIDIV, +A_FIDIVR, +A_FILD, +A_FIMUL, +A_FINCSTP, +A_FINIT, +A_FIST, +A_FISTP, +A_FISUB, +A_FISUBR, +A_FLD, +A_FLD1, +A_FLDCW, +A_FLDENV, +A_FLDL2E, +A_FLDL2T, +A_FLDLG2, +A_FLDLN2, +A_FLDPI, +A_FLDZ, +A_FMUL, +A_FMULP, +A_FNCLEX, +A_FNDISI, +A_FNENI, +A_FNINIT, +A_FNOP, +A_FNSAVE, +A_FNSTCW, +A_FNSTENV, +A_FNSTSW, +A_FPATAN, +A_FPREM, +A_FPREM1, +A_FPTAN, +A_FRNDINT, +A_FRSTOR, +A_FSAVE, +A_FSCALE, +A_FSETPM, +A_FSIN, +A_FSINCOS, +A_FSQRT, +A_FST, +A_FSTCW, +A_FSTENV, +A_FSTP, +A_FSTSW, +A_FSUB, +A_FSUBP, +A_FSUBR, +A_FSUBRP, +A_FTST, +A_FUCOM, +A_FUCOMI, +A_FUCOMIP, +A_FUCOMP, +A_FUCOMPP, +A_FWAIT, +A_FXAM, +A_FXCH, +A_FXTRACT, +A_FYL2X, +A_FYL2XP1, +A_HLT, +A_IBTS, +A_ICEBP, +A_IDIV, +A_IMUL, +A_IN, +A_INC, +A_INSB, +A_INSD, +A_INSW, +A_INT, +A_INT01, +A_INT1, +A_INT03, +A_INT3, +A_INTO, +A_INVD, +A_INVLPG, +A_IRET, +A_IRETD, +A_IRETW, +A_JCXZ, +A_JECXZ, +A_JMP, +A_LAHF, +A_LAR, +A_LCALL, +A_LDS, +A_LEA, +A_LEAVE, +A_LES, +A_LFS, +A_LGDT, +A_LGS, +A_LIDT, +A_LJMP, +A_LLDT, +A_LMSW, +A_LOADALL, +A_LOADALL286, +A_LOCK, +A_LODSB, +A_LODSD, +A_LODSW, +A_LOOP, +A_LOOPE, +A_LOOPNE, +A_LOOPNZ, +A_LOOPZ, +A_LSL, +A_LSS, +A_LTR, +A_MOV, +A_MOVD, +A_MOVQ, +A_MOVSB, +A_MOVSD, +A_MOVSW, +A_MOVSX, +A_MOVZX, +A_MUL, +A_NEG, +A_NOP, +A_NOT, +A_OR, +A_OUT, +A_OUTSB, +A_OUTSD, +A_OUTSW, +A_PACKSSDW, +A_PACKSSWB, +A_PACKUSWB, +A_PADDB, +A_PADDD, +A_PADDSB, +A_PADDSIW, +A_PADDSW, +A_PADDUSB, +A_PADDUSW, +A_PADDW, +A_PAND, +A_PANDN, +A_PAVEB, +A_PAVGUSB, +A_PCMPEQB, +A_PCMPEQD, +A_PCMPEQW, +A_PCMPGTB, +A_PCMPGTD, +A_PCMPGTW, +A_PDISTIB, +A_PF2ID, +A_PFACC, +A_PFADD, +A_PFCMPEQ, +A_PFCMPGE, +A_PFCMPGT, +A_PFMAX, +A_PFMIN, +A_PFMUL, +A_PFRCP, +A_PFRCPIT1, +A_PFRCPIT2, +A_PFRSQIT1, +A_PFRSQRT, +A_PFSUB, +A_PFSUBR, +A_PI2FD, +A_PMACHRIW, +A_PMADDWD, +A_PMAGW, +A_PMULHRIW, +A_PMULHRWA, +A_PMULHRWC, +A_PMULHW, +A_PMULLW, +A_PMVGEZB, +A_PMVLZB, +A_PMVNZB, +A_PMVZB, +A_POP, +A_POPA, +A_POPAD, +A_POPAW, +A_POPF, +A_POPFD, +A_POPFW, +A_POR, +A_PREFETCH, +A_PREFETCHW, +A_PSLLD, +A_PSLLQ, +A_PSLLW, +A_PSRAD, +A_PSRAW, +A_PSRLD, +A_PSRLQ, +A_PSRLW, +A_PSUBB, +A_PSUBD, +A_PSUBSB, +A_PSUBSIW, +A_PSUBSW, +A_PSUBUSB, +A_PSUBUSW, +A_PSUBW, +A_PUNPCKHBW, +A_PUNPCKHDQ, +A_PUNPCKHWD, +A_PUNPCKLBW, +A_PUNPCKLDQ, +A_PUNPCKLWD, +A_PUSH, +A_PUSHA, +A_PUSHAD, +A_PUSHAW, +A_PUSHF, +A_PUSHFD, +A_PUSHFW, +A_PXOR, +A_RCL, +A_RCR, +A_RDSHR, +A_RDMSR, +A_RDPMC, +A_RDTSC, +A_REP, +A_REPE, +A_REPNE, +A_REPNZ, +A_REPZ, +A_RET, +A_RETF, +A_RETN, +A_ROL, +A_ROR, +A_RSDC, +A_RSLDT, +A_RSM, +A_SAHF, +A_SAL, +A_SALC, +A_SAR, +A_SBB, +A_SCASB, +A_SCASD, +A_SCASW, +A_SEGCS, +A_SEGDS, +A_SEGES, +A_SEGFS, +A_SEGGS, +A_SEGSS, +A_SGDT, +A_SHL, +A_SHLD, +A_SHR, +A_SHRD, +A_SIDT, +A_SLDT, +A_SMI, +A_SMINT, +A_SMINTOLD, +A_SMSW, +A_STC, +A_STD, +A_STI, +A_STOSB, +A_STOSD, +A_STOSW, +A_STR, +A_SUB, +A_SVDC, +A_SVLDT, +A_SVTS, +A_SYSCALL, +A_SYSENTER, +A_SYSEXIT, +A_SYSRET, +A_TEST, +A_UD1, +A_UD2, +A_UMOV, +A_VERR, +A_VERW, +A_WAIT, +A_WBINVD, +A_WRSHR, +A_WRMSR, +A_XADD, +A_XBTS, +A_XCHG, +A_XLAT, +A_XLATB, +A_XOR, +A_CMOVcc, +A_Jcc, +A_SETcc, +A_ADDPS, +A_ADDSS, +A_ANDNPS, +A_ANDPS, +A_CMPEQPS, +A_CMPEQSS, +A_CMPLEPS, +A_CMPLESS, +A_CMPLTPS, +A_CMPLTSS, +A_CMPNEQPS, +A_CMPNEQSS, +A_CMPNLEPS, +A_CMPNLESS, +A_CMPNLTPS, +A_CMPNLTSS, +A_CMPORDPS, +A_CMPORDSS, +A_CMPUNORDPS, +A_CMPUNORDSS, +A_CMPPS, +A_CMPSS, +A_COMISS, +A_CVTPI2PS, +A_CVTPS2PI, +A_CVTSI2SS, +A_CVTSS2SI, +A_CVTTPS2PI, +A_CVTTSS2SI, +A_DIVPS, +A_DIVSS, +A_LDMXCSR, +A_MAXPS, +A_MAXSS, +A_MINPS, +A_MINSS, +A_MOVAPS, +A_MOVHPS, +A_MOVLHPS, +A_MOVLPS, +A_MOVHLPS, +A_MOVMSKPS, +A_MOVNTPS, +A_MOVSS, +A_MOVUPS, +A_MULPS, +A_MULSS, +A_ORPS, +A_RCPPS, +A_RCPSS, +A_RSQRTPS, +A_RSQRTSS, +A_SHUFPS, +A_SQRTPS, +A_SQRTSS, +A_STMXCSR, +A_SUBPS, +A_SUBSS, +A_UCOMISS, +A_UNPCKHPS, +A_UNPCKLPS, +A_XORPS, +A_FXRSTOR, +A_FXSAVE, +A_PREFETCHNTA, +A_PREFETCHT0, +A_PREFETCHT1, +A_PREFETCHT2, +A_SFENCE, +A_MASKMOVQ, +A_MOVNTQ, +A_PAVGB, +A_PAVGW, +A_PEXTRW, +A_PINSRW, +A_PMAXSW, +A_PMAXUB, +A_PMINSW, +A_PMINUB, +A_PMOVMSKB, +A_PMULHUW, +A_PSADBW, +A_PSHUFW, +A_PFNACC, +A_PFPNACC, +A_PI2FW, +A_PF2IW, +A_PSWAPD, +A_FFREEP +); diff --git a/befpc/compiler/i386prop.inc b/befpc/compiler/i386prop.inc new file mode 100644 index 0000000..c2f67fb --- /dev/null +++ b/befpc/compiler/i386prop.inc @@ -0,0 +1,469 @@ +{ don't edit, this file is generated from i386ins.dat } +( +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_MEAX, Ch_WFlags, Ch_None)), +(Ch: (Ch_MEAX, Ch_WFlags, Ch_None)), +(Ch: (Ch_MEAX, Ch_WFlags, Ch_None)), +(Ch: (Ch_MEAX, Ch_WFlags, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_Rop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop2, Ch_WFlags, Ch_Rop1)), +(Ch: (Ch_Wop2, Ch_WFlags, Ch_Rop1)), +(Ch: (Ch_MOp1, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_Rop1, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_MEAX, Ch_None, Ch_None)), +(Ch: (Ch_MEAX, Ch_WEDX, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_CDirFlag, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_ROp1, Ch_ROp2, Ch_WFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_none)), +(Ch: (Ch_MEAX, Ch_WEDX, Ch_None)), +(Ch: (Ch_MEAX, Ch_None, Ch_None)), +(Ch: (Ch_MEAX, Ch_None, Ch_None)), +(Ch: (Ch_MEAX, Ch_None, Ch_None)), +(Ch: (Ch_Mop1, Ch_WFlags, Ch_None)), +(Ch: (Ch_RWEAX, Ch_WEDX, Ch_WFlags)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_RWESP, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Rop1, Ch_FPU, Ch_None)), +(Ch: (Ch_Wop1, Ch_FPU, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_WFLAGS, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_WFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Rop1, Ch_FPU, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_FPU, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_ROp1, Ch_FPU, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_WFLAGS, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_WFLAGS, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_FPU, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_RWEAX, Ch_WEDX, Ch_WFlags)), +(Ch: (Ch_RWEAX, Ch_WEDX, Ch_WFlags)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_Mop1, Ch_WFlags, Ch_None)), +(Ch: (Ch_WMemEDI, Ch_RWEDI, Ch_REDX)), +(Ch: (Ch_WMemEDI, Ch_RWEDI, Ch_REDX)), +(Ch: (Ch_WMemEDI, Ch_RWEDI, Ch_REDX)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_RECX, Ch_None, Ch_None)), +(Ch: (Ch_RECX, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_WEAX, Ch_RFlags, Ch_None)), +(Ch: (Ch_Wop2, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_RWESP, Ch_WEBP, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_WEAX, Ch_RWESI, Ch_None)), +(Ch: (Ch_WEAX, Ch_RWESI, Ch_None)), +(Ch: (Ch_WEAX, Ch_RWESI, Ch_None)), +(Ch: (Ch_RWECX, Ch_None, Ch_None)), +(Ch: (Ch_RWECX, Ch_RFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RFlags, Ch_None)), +(Ch: (Ch_Wop2, Ch_WFlags, Ch_None)), +(Ch: (Ch_Wop2, Ch_ROP1, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_Rop1, Ch_Wop2, Ch_None)), +(Ch: (Ch_Rop1, Ch_Wop2, Ch_None)), +(Ch: (Ch_All, Ch_Rop1, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_Wop2, Ch_Rop1, Ch_None)), +(Ch: (Ch_RWEAX, Ch_WEDX, Ch_WFlags)), +(Ch: (Ch_Mop1, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_Mop1, Ch_WFlags, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_Rop1, Ch_Rop2, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_RWESP, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_RWESP, Ch_WFlags, Ch_None)), +(Ch: (Ch_RWESP, Ch_WFlags, Ch_None)), +(Ch: (Ch_RWESP, Ch_WFLAGS, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Rop1, Ch_RWESP, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_RWESP, Ch_RFlags, Ch_None)), +(Ch: (Ch_RWESP, Ch_RFlags, Ch_None)), +(Ch: (Ch_RWESP, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_WEAX, Ch_WEDX, Ch_None)), +(Ch: (Ch_WEAX, Ch_WEDX, Ch_None)), +(Ch: (Ch_WEAX, Ch_WEDX, Ch_None)), +(Ch: (Ch_RWECX, Ch_RWFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RWFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RWFlags, Ch_None)), +(Ch: (Ch_RWECX, Ch_RWFLAGS, Ch_None)), +(Ch: (Ch_RWECX, Ch_RWFLAGS, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_REAX, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_WEAX, Ch_RFLAGS, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_RWFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_MOp3, Ch_RWFlags, Ch_Rop2)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_MOp3, Ch_RWFlags, Ch_Rop2)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_SDirFlag, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_REAX, Ch_WMemEDI, Ch_RWEDI)), +(Ch: (Ch_REAX, Ch_WMemEDI, Ch_RWEDI)), +(Ch: (Ch_REAX, Ch_WMemEDI, Ch_RWEDI)), +(Ch: (Ch_Wop1, Ch_None, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_Rop1, Ch_Rop2)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_WFlags, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_RWop1, Ch_RWop2, Ch_None)), +(Ch: (Ch_WEAX, Ch_REBX, Ch_None)), +(Ch: (Ch_WEAX, Ch_REBX, Ch_None)), +(Ch: (Ch_Mop2, Ch_Rop1, Ch_WFlags)), +(Ch: (Ch_ROp1, Ch_WOp2, Ch_RFLAGS)), +(Ch: (Ch_None, Ch_None, Ch_None)), +(Ch: (Ch_RFLAGS, Ch_WOp1, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)), +(Ch: (Ch_All, Ch_None, Ch_None)) +); diff --git a/befpc/compiler/i386tab.inc b/befpc/compiler/i386tab.inc new file mode 100644 index 0000000..992de95 --- /dev/null +++ b/befpc/compiler/i386tab.inc @@ -0,0 +1,9278 @@ +{ don't edit, this file is generated from i386ins.dat } +( + ( + opcode : A_NONE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #0; + flags : if_none + ), + ( + opcode : A_AAA; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#55; + flags : if_8086 + ), + ( + opcode : A_AAD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#213#10; + flags : if_8086 + ), + ( + opcode : A_AAD; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#213#20; + flags : if_8086 or if_sb + ), + ( + opcode : A_AAM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#212#10; + flags : if_8086 + ), + ( + opcode : A_AAM; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#212#20; + flags : if_8086 or if_sb + ), + ( + opcode : A_AAS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#63; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#16#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#16#65; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#17#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#17#65; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#17#65; + flags : if_386 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#17#65; + flags : if_386 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#18#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#18#72; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#19#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#19#72; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#19#72; + flags : if_386 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#19#72; + flags : if_386 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#130#13; + flags : if_8086 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#130#13; + flags : if_386 + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#20#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#21#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#21#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#130#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#130#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#130#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#130#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#130#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADC; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#130#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#15#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#15#65; + flags : if_8086 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#1#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#1#65; + flags : if_8086 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#1#65; + flags : if_386 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#1#65; + flags : if_386 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#2#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#2#72; + flags : if_8086 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#3#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#3#72; + flags : if_8086 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#3#72; + flags : if_386 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#3#72; + flags : if_386 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#128#13; + flags : if_8086 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#128#13; + flags : if_386 + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#4#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#5#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#5#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_ADD; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#32#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#32#65; + flags : if_8086 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#33#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#33#65; + flags : if_8086 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#33#65; + flags : if_386 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#33#65; + flags : if_386 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#34#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#34#72; + flags : if_8086 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#35#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#35#72; + flags : if_8086 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#35#72; + flags : if_386 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#35#72; + flags : if_386 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#132#13; + flags : if_8086 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#132#13; + flags : if_386 + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#36#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#37#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#37#33; + flags : if_386 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#132#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#132#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#132#33; + flags : if_386 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#132#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#132#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_AND; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#132#33; + flags : if_386 or if_sm + ), + ( + opcode : A_ARPL; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #192#1#99#65; + flags : if_286 or if_prot or if_sm + ), + ( + opcode : A_ARPL; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #192#1#99#65; + flags : if_286 or if_prot + ), + ( + opcode : A_BOUND; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#98#72; + flags : if_186 + ), + ( + opcode : A_BOUND; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#98#72; + flags : if_386 + ), + ( + opcode : A_BSF; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#188#72; + flags : if_386 or if_sm + ), + ( + opcode : A_BSF; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#188#72; + flags : if_386 + ), + ( + opcode : A_BSF; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#188#72; + flags : if_386 or if_sm + ), + ( + opcode : A_BSF; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#188#72; + flags : if_386 + ), + ( + opcode : A_BSR; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#189#72; + flags : if_386 or if_sm + ), + ( + opcode : A_BSR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#189#72; + flags : if_386 + ), + ( + opcode : A_BSR; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#189#72; + flags : if_386 or if_sm + ), + ( + opcode : A_BSR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#189#72; + flags : if_386 + ), + ( + opcode : A_BSWAP; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#1#15#8#200; + flags : if_486 + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#163#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#163#65; + flags : if_386 + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#163#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#163#65; + flags : if_386 + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#2#15#186#132#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BT; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#2#15#186#132#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#187#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#187#65; + flags : if_386 + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#187#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#187#65; + flags : if_386 + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#2#15#186#135#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTC; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#2#15#186#135#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#179#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#179#65; + flags : if_386 + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#179#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#179#65; + flags : if_386 + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#2#15#186#134#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#2#15#186#134#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#171#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#171#65; + flags : if_386 + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#171#65; + flags : if_386 or if_sm + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#171#65; + flags : if_386 + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#2#15#186#133#21; + flags : if_386 or if_sb + ), + ( + opcode : A_BTS; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#2#15#186#133#21; + flags : if_386 or if_sb + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #210#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_near,ot_none,ot_none); + code : #210#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_far,ot_none,ot_none); + code : #210#1#154#28#31; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits16,ot_none,ot_none); + code : #208#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#1#154#28#31; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits32,ot_none,ot_none); + code : #209#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#1#232#52; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#1#154#28#31; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_immediate,ot_none,ot_none); + code : #210#1#154#29#24; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_immediate,ot_none,ot_none); + code : #208#1#154#25#24; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_immediate or ot_bits16,ot_none,ot_none); + code : #208#1#154#25#24; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_immediate,ot_none,ot_none); + code : #209#1#154#33#24; + flags : if_386 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_immediate or ot_immediate or ot_bits32,ot_none,ot_none); + code : #209#1#154#33#24; + flags : if_386 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_far,ot_none,ot_none); + code : #210#192#1#255#131; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#192#1#255#131; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#192#1#255#131; + flags : if_386 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_near,ot_none,ot_none); + code : #210#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #210#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_CALL; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_CBW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#152; + flags : if_8086 + ), + ( + opcode : A_CDQ; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#153; + flags : if_386 + ), + ( + opcode : A_CLC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#248; + flags : if_8086 + ), + ( + opcode : A_CLD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#252; + flags : if_8086 + ), + ( + opcode : A_CLI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#250; + flags : if_8086 + ), + ( + opcode : A_CLTS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#6; + flags : if_286 or if_priv + ), + ( + opcode : A_CMC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#245; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#56#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#56#65; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#57#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#57#65; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#57#65; + flags : if_386 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#57#65; + flags : if_386 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#58#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#58#72; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#59#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#59#72; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#59#72; + flags : if_386 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#59#72; + flags : if_386 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#135#13; + flags : if_8086 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#135#13; + flags : if_386 + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#60#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#61#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#61#33; + flags : if_386 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#135#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#135#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#135#33; + flags : if_386 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#135#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#135#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_CMP; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#135#33; + flags : if_386 or if_sm + ), + ( + opcode : A_CMPSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#1#166; + flags : if_8086 + ), + ( + opcode : A_CMPSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#209#1#167; + flags : if_386 + ), + ( + opcode : A_CMPSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#208#1#167; + flags : if_8086 + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#2#15#176#65; + flags : if_pent or if_sm + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#2#15#176#65; + flags : if_pent + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#177#65; + flags : if_pent or if_sm + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#177#65; + flags : if_pent + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#177#65; + flags : if_pent or if_sm + ), + ( + opcode : A_CMPXCHG; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#177#65; + flags : if_pent + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#2#15#166#65; + flags : if_486 or if_sm or if_undoc + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#2#15#166#65; + flags : if_486 or if_undoc + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#167#65; + flags : if_486 or if_sm or if_undoc + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#167#65; + flags : if_486 or if_undoc + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#167#65; + flags : if_486 or if_sm or if_undoc + ), + ( + opcode : A_CMPXCHG486; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#167#65; + flags : if_486 or if_undoc + ), + ( + opcode : A_CMPXCHG8B; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#199#129; + flags : if_pent + ), + ( + opcode : A_CPUID; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#162; + flags : if_pent + ), + ( + opcode : A_CWD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#153; + flags : if_8086 + ), + ( + opcode : A_CWDE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#152; + flags : if_386 + ), + ( + opcode : A_DAA; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#39; + flags : if_8086 + ), + ( + opcode : A_DAS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#47; + flags : if_8086 + ), + ( + opcode : A_DEC; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#8#72; + flags : if_8086 + ), + ( + opcode : A_DEC; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#8#72; + flags : if_386 + ), + ( + opcode : A_DEC; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#254#129; + flags : if_8086 + ), + ( + opcode : A_DEC; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#129; + flags : if_8086 + ), + ( + opcode : A_DEC; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#129; + flags : if_386 + ), + ( + opcode : A_DIV; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#134; + flags : if_8086 + ), + ( + opcode : A_DIV; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#134; + flags : if_8086 + ), + ( + opcode : A_DIV; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#134; + flags : if_386 + ), + ( + opcode : A_EMMS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#119; + flags : if_pent or if_mmx + ), + ( + opcode : A_ENTER; + ops : 2; + optypes : (ot_immediate,ot_immediate,ot_none); + code : #1#200#24#21; + flags : if_186 + ), + ( + opcode : A_F2XM1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FABS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#225; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#193; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADD; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADDP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#193; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADDP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FADDP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FBLD; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#1#223#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FBLD; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#223#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FBSTP; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#1#223#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FBSTP; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#223#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCHS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCLEX; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#155#219#226; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCMOVB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#218#193; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVB; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#218#8#192; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVB; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#218#9#192; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVBE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#218#209; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVBE; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#218#8#208; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVBE; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#218#9#208; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#218#201; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVE; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#218#8#200; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVE; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#218#9#200; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#193; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNB; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#192; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNB; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#192; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNBE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#209; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNBE; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#208; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNBE; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#208; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#201; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNE; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#200; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNE; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#200; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNU; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#217; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNU; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#216; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVNU; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#216; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVU; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#218#217; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVU; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#218#8#216; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCMOVU; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#218#9#216; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOM; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOM; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#216#209; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOM; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#208; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOM; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#208; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#241; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMI; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#240; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMI; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#240; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMIP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#223#241; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMIP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#223#8#240; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMIP; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#223#9#240; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FCOMP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMP; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#216#217; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#216; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMP; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#216; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOMPP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#217; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FCOS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#255; + flags : if_386 or if_fpu + ), + ( + opcode : A_FDECSTP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#246; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDISI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#155#219#225; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#220#241; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIV; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#241; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#240; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#220#249; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVR; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVRP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#249; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVRP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FDIVRP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FEMMS; + ops : 0; + optypes : (ot_none,ot_none,ot_none or ot_signed); + code : #2#15#14; + flags : if_pent or if_3dnow + ), + ( + opcode : A_FENI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#155#219#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FFREE; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#221#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIADD; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIADD; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FICOM; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FICOM; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FICOMP; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FICOMP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIDIV; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIDIV; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIDIVR; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIDIVR; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FILD; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#219#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FILD; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#223#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FILD; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#223#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIMUL; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#129; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIMUL; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#129; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FINCSTP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#247; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FINIT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#155#219#227; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIST; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#219#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FIST; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#223#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISTP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#219#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISTP; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#223#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISTP; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#223#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISUB; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISUB; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISUBR; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#222#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FISUBR; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#218#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLD; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#217#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLD; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#221#128; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLD; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#1#219#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLD; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#217#8#192; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLD1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDCW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#217#133; + flags : if_8086 or if_fpu or if_sw + ), + ( + opcode : A_FLDENV; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#217#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDL2E; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#234; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDL2T; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#233; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDLG2; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#236; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDLN2; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#237; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDPI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#235; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FLDZ; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#238; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#129; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#129; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#220#201; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMUL; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMULP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#201; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMULP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FMULP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNCLEX; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#226; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNDISI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#225; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNENI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNINIT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#227; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNOP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#208; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNSAVE; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#221#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNSTCW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#217#135; + flags : if_8086 or if_fpu or if_sw + ), + ( + opcode : A_FNSTENV; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#217#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FNSTSW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#221#135; + flags : if_8086 or if_fpu or if_sw + ), + ( + opcode : A_FNSTSW; + ops : 1; + optypes : (ot_reg_ax,ot_none,ot_none); + code : #2#223#224; + flags : if_286 or if_fpu + ), + ( + opcode : A_FPATAN; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#243; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FPREM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#248; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FPREM1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#245; + flags : if_386 or if_fpu + ), + ( + opcode : A_FPTAN; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#242; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FRNDINT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#252; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FRSTOR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#221#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSAVE; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#155#221#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSCALE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#253; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSETPM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#228; + flags : if_286 or if_fpu + ), + ( + opcode : A_FSIN; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#254; + flags : if_386 or if_fpu + ), + ( + opcode : A_FSINCOS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#251; + flags : if_386 or if_fpu + ), + ( + opcode : A_FSQRT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#250; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FST; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#217#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FST; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#221#130; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FST; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#221#8#208; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTCW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#155#217#135; + flags : if_8086 or if_fpu or if_sw + ), + ( + opcode : A_FSTENV; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#155#217#134; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#217#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTP; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#221#131; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTP; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#1#219#135; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#221#8#216; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSTSW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#155#221#135; + flags : if_8086 or if_fpu or if_sw + ), + ( + opcode : A_FSTSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#155#223#224; + flags : if_286 or if_fpu + ), + ( + opcode : A_FSTSW; + ops : 1; + optypes : (ot_reg_ax,ot_none,ot_none); + code : #3#155#223#224; + flags : if_286 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#132; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#220#225; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUB; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#225; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#224; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #192#1#216#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 1; + optypes : (ot_memory or ot_bits64,ot_none,ot_none); + code : #192#1#220#133; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#220#233; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 1; + optypes : (ot_fpureg or ot_to,ot_none,ot_none); + code : #1#220#8#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#220#8#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#216#8#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBR; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#216#9#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBRP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#222#233; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBRP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#222#8#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FSUBRP; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#222#8#232; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FTST; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#228; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FUCOM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#221#225; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOM; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#221#8#224; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOM; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#221#9#224; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOMI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#219#233; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMI; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#219#8#232; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMI; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#219#9#232; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMIP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#223#233; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMIP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#223#8#232; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMIP; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#223#9#232; + flags : if_p6 or if_fpu + ), + ( + opcode : A_FUCOMP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#221#233; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOMP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#221#8#232; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOMP; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#221#9#232; + flags : if_386 or if_fpu + ), + ( + opcode : A_FUCOMPP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#218#233; + flags : if_386 or if_fpu + ), + ( + opcode : A_FWAIT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#155; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXAM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#229; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXCH; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#201; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXCH; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#217#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXCH; + ops : 2; + optypes : (ot_fpureg,ot_fpu0,ot_none); + code : #1#217#8#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXCH; + ops : 2; + optypes : (ot_fpu0,ot_fpureg,ot_none); + code : #1#217#9#200; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FXTRACT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#244; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FYL2X; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#241; + flags : if_8086 or if_fpu + ), + ( + opcode : A_FYL2XP1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#217#249; + flags : if_8086 or if_fpu + ), + ( + opcode : A_HLT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#244; + flags : if_8086 or if_priv + ), + ( + opcode : A_IBTS; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#167#65; + flags : if_386 or if_sw or if_undoc + ), + ( + opcode : A_IBTS; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#167#65; + flags : if_386 or if_undoc + ), + ( + opcode : A_IBTS; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#167#65; + flags : if_386 or if_sd or if_undoc + ), + ( + opcode : A_IBTS; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#167#65; + flags : if_386 or if_undoc + ), + ( + opcode : A_ICEBP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#241; + flags : if_386 + ), + ( + opcode : A_IDIV; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#135; + flags : if_8086 + ), + ( + opcode : A_IDIV; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#135; + flags : if_8086 + ), + ( + opcode : A_IDIV; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#135; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#133; + flags : if_8086 + ), + ( + opcode : A_IMUL; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#133; + flags : if_8086 + ), + ( + opcode : A_IMUL; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#133; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#175#72; + flags : if_386 or if_sm + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#175#72; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#175#72; + flags : if_386 or if_sm + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#175#72; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg16,ot_memory,ot_immediate or ot_bits8 or ot_signed); + code : #208#193#1#107#72#14; + flags : if_286 or if_sm + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_immediate or ot_bits8 or ot_signed); + code : #208#193#1#107#72#14; + flags : if_286 + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg16,ot_memory,ot_immediate); + code : #208#193#1#105#72#26; + flags : if_286 or if_sm + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_immediate); + code : #208#193#1#105#72#26; + flags : if_286 or if_sm + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg32,ot_memory,ot_immediate or ot_bits8 or ot_signed); + code : #209#193#1#107#72#14; + flags : if_386 or if_sm + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_immediate or ot_bits8 or ot_signed); + code : #209#193#1#107#72#14; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg32,ot_memory,ot_immediate); + code : #209#193#1#105#72#34; + flags : if_386 or if_sm + ), + ( + opcode : A_IMUL; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_immediate); + code : #209#193#1#105#72#34; + flags : if_386 or if_sm + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#1#107#64#13; + flags : if_286 + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg16,ot_immediate,ot_none); + code : #208#1#105#64#25; + flags : if_286 or if_sm + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#1#107#64#13; + flags : if_386 + ), + ( + opcode : A_IMUL; + ops : 2; + optypes : (ot_reg32,ot_immediate,ot_none); + code : #209#1#105#64#33; + flags : if_386 or if_sm + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#228#21; + flags : if_8086 or if_sb + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#229#21; + flags : if_8086 or if_sb + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#229#21; + flags : if_386 or if_sb + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_al,ot_reg_dx,ot_none); + code : #1#236; + flags : if_8086 + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_ax,ot_reg_dx,ot_none); + code : #208#1#237; + flags : if_8086 + ), + ( + opcode : A_IN; + ops : 2; + optypes : (ot_reg_eax,ot_reg_dx,ot_none); + code : #209#1#237; + flags : if_386 + ), + ( + opcode : A_INC; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#8#64; + flags : if_8086 + ), + ( + opcode : A_INC; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#8#64; + flags : if_386 + ), + ( + opcode : A_INC; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#254#128; + flags : if_8086 + ), + ( + opcode : A_INC; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#128; + flags : if_8086 + ), + ( + opcode : A_INC; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#128; + flags : if_386 + ), + ( + opcode : A_INSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#108; + flags : if_186 + ), + ( + opcode : A_INSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#109; + flags : if_386 + ), + ( + opcode : A_INSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#109; + flags : if_186 + ), + ( + opcode : A_INT; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#205#20; + flags : if_8086 or if_sb + ), + ( + opcode : A_INT01; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#241; + flags : if_386 + ), + ( + opcode : A_INT1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#241; + flags : if_386 + ), + ( + opcode : A_INT03; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#204; + flags : if_8086 + ), + ( + opcode : A_INT3; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#204; + flags : if_8086 + ), + ( + opcode : A_INTO; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#206; + flags : if_8086 + ), + ( + opcode : A_INVD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#8; + flags : if_486 or if_priv + ), + ( + opcode : A_INVLPG; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#135; + flags : if_486 or if_priv + ), + ( + opcode : A_IRET; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #210#1#207; + flags : if_8086 + ), + ( + opcode : A_IRETD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#207; + flags : if_386 + ), + ( + opcode : A_IRETW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#207; + flags : if_8086 + ), + ( + opcode : A_JCXZ; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #208#1#227#40; + flags : if_8086 + ), + ( + opcode : A_JECXZ; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #209#1#227#40; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_short,ot_none,ot_none); + code : #1#235#40; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #210#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_near,ot_none,ot_none); + code : #210#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_far,ot_none,ot_none); + code : #210#1#234#28#31; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits16,ot_none,ot_none); + code : #208#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#1#234#28#31; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits32,ot_none,ot_none); + code : #209#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#1#233#52; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#1#234#28#31; + flags : if_8086 or if_pass2 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_immediate,ot_none,ot_none); + code : #210#1#234#29#24; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_immediate,ot_none,ot_none); + code : #208#1#234#25#24; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_immediate or ot_bits16,ot_none,ot_none); + code : #208#1#234#25#24; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_immediate,ot_none,ot_none); + code : #209#1#234#33#24; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_immediate or ot_immediate or ot_bits32,ot_none,ot_none); + code : #209#1#234#33#24; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_far,ot_none,ot_none); + code : #210#192#1#255#133; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#192#1#255#133; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#192#1#255#133; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_near,ot_none,ot_none); + code : #210#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #210#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_JMP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_LAHF; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#159; + flags : if_8086 + ), + ( + opcode : A_LAR; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#2#72; + flags : if_286 or if_prot or if_sm + ), + ( + opcode : A_LAR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#2#72; + flags : if_286 or if_prot + ), + ( + opcode : A_LAR; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#2#72; + flags : if_286 or if_prot or if_sm + ), + ( + opcode : A_LAR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#2#72; + flags : if_286 or if_prot + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_far,ot_none,ot_none); + code : #210#192#1#255#131; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#192#1#255#131; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#192#1#255#131; + flags : if_386 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_near,ot_none,ot_none); + code : #210#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #210#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#130; + flags : if_8086 + ), + ( + opcode : A_LCALL; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#130; + flags : if_386 + ), + ( + opcode : A_LDS; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#197#72; + flags : if_8086 + ), + ( + opcode : A_LDS; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#197#72; + flags : if_8086 + ), + ( + opcode : A_LEA; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#141#72; + flags : if_8086 + ), + ( + opcode : A_LEA; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#141#72; + flags : if_8086 + ), + ( + opcode : A_LEA; + ops : 2; + optypes : (ot_reg32,ot_immediate or ot_bits32,ot_none); + code : #209#193#1#141#72; + flags : if_8086 + ), + ( + opcode : A_LEAVE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#201; + flags : if_186 + ), + ( + opcode : A_LES; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#196#72; + flags : if_8086 + ), + ( + opcode : A_LES; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#196#72; + flags : if_8086 + ), + ( + opcode : A_LFS; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#180#72; + flags : if_386 + ), + ( + opcode : A_LFS; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#180#72; + flags : if_386 + ), + ( + opcode : A_LGDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#130; + flags : if_286 or if_priv + ), + ( + opcode : A_LGS; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#181#72; + flags : if_386 + ), + ( + opcode : A_LGS; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#181#72; + flags : if_386 + ), + ( + opcode : A_LIDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#131; + flags : if_286 or if_priv + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_far,ot_none,ot_none); + code : #210#192#1#255#133; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_far,ot_none,ot_none); + code : #208#192#1#255#133; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_far,ot_none,ot_none); + code : #209#192#1#255#133; + flags : if_386 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_near,ot_none,ot_none); + code : #210#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #210#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#132; + flags : if_8086 + ), + ( + opcode : A_LJMP; + ops : 1; + optypes : (ot_memory or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#132; + flags : if_386 + ), + ( + opcode : A_LLDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#130; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_LLDT; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#130; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_LLDT; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#130; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_LMSW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#134; + flags : if_286 or if_priv + ), + ( + opcode : A_LMSW; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#2#15#1#134; + flags : if_286 or if_priv + ), + ( + opcode : A_LMSW; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#2#15#1#134; + flags : if_286 or if_priv + ), + ( + opcode : A_LOADALL; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#7; + flags : if_386 or if_undoc + ), + ( + opcode : A_LOADALL286; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#5; + flags : if_286 or if_undoc + ), + ( + opcode : A_LOCK; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#240; + flags : if_8086 or if_pre + ), + ( + opcode : A_LODSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#172; + flags : if_8086 + ), + ( + opcode : A_LODSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#173; + flags : if_386 + ), + ( + opcode : A_LODSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#173; + flags : if_8086 + ), + ( + opcode : A_LOOP; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #202#1#226#40; + flags : if_8086 + ), + ( + opcode : A_LOOP; + ops : 2; + optypes : (ot_immediate,ot_reg_cx,ot_none); + code : #200#1#226#40; + flags : if_8086 + ), + ( + opcode : A_LOOP; + ops : 2; + optypes : (ot_immediate,ot_reg_ecx,ot_none); + code : #201#1#226#40; + flags : if_386 + ), + ( + opcode : A_LOOPE; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #202#1#225#40; + flags : if_8086 + ), + ( + opcode : A_LOOPE; + ops : 2; + optypes : (ot_immediate,ot_reg_cx,ot_none); + code : #200#1#225#40; + flags : if_8086 + ), + ( + opcode : A_LOOPE; + ops : 2; + optypes : (ot_immediate,ot_reg_ecx,ot_none); + code : #201#1#225#40; + flags : if_386 + ), + ( + opcode : A_LOOPNE; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #202#1#224#40; + flags : if_8086 + ), + ( + opcode : A_LOOPNE; + ops : 2; + optypes : (ot_immediate,ot_reg_cx,ot_none); + code : #200#1#224#40; + flags : if_8086 + ), + ( + opcode : A_LOOPNE; + ops : 2; + optypes : (ot_immediate,ot_reg_ecx,ot_none); + code : #201#1#224#40; + flags : if_386 + ), + ( + opcode : A_LOOPNZ; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #202#1#224#40; + flags : if_8086 + ), + ( + opcode : A_LOOPNZ; + ops : 2; + optypes : (ot_immediate,ot_reg_cx,ot_none); + code : #200#1#224#40; + flags : if_8086 + ), + ( + opcode : A_LOOPNZ; + ops : 2; + optypes : (ot_immediate,ot_reg_ecx,ot_none); + code : #201#1#224#40; + flags : if_386 + ), + ( + opcode : A_LOOPZ; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #202#1#225#40; + flags : if_8086 + ), + ( + opcode : A_LOOPZ; + ops : 2; + optypes : (ot_immediate,ot_reg_cx,ot_none); + code : #200#1#225#40; + flags : if_8086 + ), + ( + opcode : A_LOOPZ; + ops : 2; + optypes : (ot_immediate,ot_reg_ecx,ot_none); + code : #201#1#225#40; + flags : if_386 + ), + ( + opcode : A_LSL; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#3#72; + flags : if_286 or if_prot or if_sm + ), + ( + opcode : A_LSL; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#3#72; + flags : if_286 or if_prot + ), + ( + opcode : A_LSL; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#3#72; + flags : if_286 or if_prot or if_sm + ), + ( + opcode : A_LSL; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#3#72; + flags : if_286 or if_prot + ), + ( + opcode : A_LSS; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#178#72; + flags : if_386 + ), + ( + opcode : A_LSS; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#178#72; + flags : if_386 + ), + ( + opcode : A_LTR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#131; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_LTR; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#131; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_LTR; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#131; + flags : if_286 or if_prot or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg_cs,ot_none); + code : #208#192#1#140#129; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg_dess,ot_none); + code : #208#192#1#140#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg_fsgs,ot_none); + code : #208#192#1#140#65; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_reg_cs,ot_none); + code : #208#192#1#140#129; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_reg_dess,ot_none); + code : #208#192#1#140#65; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_reg_fsgs,ot_none); + code : #208#192#1#140#65; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cs,ot_none); + code : #209#192#1#140#129; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_dess,ot_none); + code : #209#192#1#140#65; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_fsgs,ot_none); + code : #209#192#1#140#65; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_dess,ot_memory,ot_none); + code : #208#193#1#142#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_fsgs,ot_memory,ot_none); + code : #208#193#1#142#72; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_dess,ot_reg16,ot_none); + code : #208#193#1#142#72; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_fsgs,ot_reg16,ot_none); + code : #208#193#1#142#72; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_dess,ot_regmem or ot_bits32,ot_none); + code : #209#193#1#142#72; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_fsgs,ot_regmem or ot_bits32,ot_none); + code : #209#193#1#142#72; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_al,ot_mem_offs,ot_none); + code : #193#1#160#29; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_ax,ot_mem_offs,ot_none); + code : #193#208#1#161#29; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_eax,ot_mem_offs,ot_none); + code : #193#209#1#161#29; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_mem_offs,ot_reg_al,ot_none); + code : #192#1#162#28; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_mem_offs,ot_reg_ax,ot_none); + code : #192#208#1#163#28; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_mem_offs,ot_reg_eax,ot_none); + code : #192#209#1#163#28; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg_cr4,ot_none); + code : #2#15#32#132; + flags : if_pent or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg_creg,ot_none); + code : #2#15#32#65; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg_dreg,ot_none); + code : #2#15#33#65; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg_treg,ot_none); + code : #2#15#36#65; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_cr4,ot_reg32,ot_none); + code : #2#15#34#140; + flags : if_pent or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_creg,ot_reg32,ot_none); + code : #2#15#34#72; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_dreg,ot_reg32,ot_none); + code : #2#15#35#72; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg_treg,ot_reg32,ot_none); + code : #2#15#38#72; + flags : if_386 or if_priv + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#136#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#136#65; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#137#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#137#65; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#137#65; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#137#65; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#138#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#138#72; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#139#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#139#72; + flags : if_8086 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#139#72; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#139#72; + flags : if_386 + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg8,ot_immediate,ot_none); + code : #8#176#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg16,ot_immediate,ot_none); + code : #208#8#184#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_reg32,ot_immediate,ot_none); + code : #209#8#184#33; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#198#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#199#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#199#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#198#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#199#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_MOV; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#199#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_MOVD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#110#72; + flags : if_pent or if_mmx or if_sd + ), + ( + opcode : A_MOVD; + ops : 2; + optypes : (ot_mmxreg,ot_reg32,ot_none); + code : #2#15#110#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_MOVD; + ops : 2; + optypes : (ot_memory,ot_mmxreg,ot_none); + code : #192#2#15#126#65; + flags : if_pent or if_mmx or if_sd + ), + ( + opcode : A_MOVD; + ops : 2; + optypes : (ot_reg32,ot_mmxreg,ot_none); + code : #2#15#126#65; + flags : if_pent or if_mmx + ), + ( + opcode : A_MOVQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#111#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_MOVQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#111#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_MOVQ; + ops : 2; + optypes : (ot_memory,ot_mmxreg,ot_none); + code : #192#2#15#127#65; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_MOVQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#127#65; + flags : if_pent or if_mmx + ), + ( + opcode : A_MOVSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#164; + flags : if_8086 + ), + ( + opcode : A_MOVSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#165; + flags : if_386 + ), + ( + opcode : A_MOVSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#165; + flags : if_8086 + ), + ( + opcode : A_MOVSX; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#190#72; + flags : if_386 or if_sb + ), + ( + opcode : A_MOVSX; + ops : 2; + optypes : (ot_reg16,ot_reg8,ot_none); + code : #208#193#2#15#190#72; + flags : if_386 + ), + ( + opcode : A_MOVSX; + ops : 2; + optypes : (ot_reg32,ot_regmem or ot_bits8,ot_none); + code : #209#193#2#15#190#72; + flags : if_386 + ), + ( + opcode : A_MOVSX; + ops : 2; + optypes : (ot_reg32,ot_regmem or ot_bits16,ot_none); + code : #209#193#2#15#191#72; + flags : if_386 + ), + ( + opcode : A_MOVZX; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#182#72; + flags : if_386 or if_sb + ), + ( + opcode : A_MOVZX; + ops : 2; + optypes : (ot_reg16,ot_reg8,ot_none); + code : #208#193#2#15#182#72; + flags : if_386 + ), + ( + opcode : A_MOVZX; + ops : 2; + optypes : (ot_reg32,ot_regmem or ot_bits8,ot_none); + code : #209#193#2#15#182#72; + flags : if_386 + ), + ( + opcode : A_MOVZX; + ops : 2; + optypes : (ot_reg32,ot_regmem or ot_bits16,ot_none); + code : #209#193#2#15#183#72; + flags : if_386 + ), + ( + opcode : A_MUL; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#132; + flags : if_8086 + ), + ( + opcode : A_MUL; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#132; + flags : if_8086 + ), + ( + opcode : A_MUL; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#132; + flags : if_386 + ), + ( + opcode : A_NEG; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#131; + flags : if_8086 + ), + ( + opcode : A_NEG; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#131; + flags : if_8086 + ), + ( + opcode : A_NEG; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#131; + flags : if_386 + ), + ( + opcode : A_NOP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#144; + flags : if_8086 + ), + ( + opcode : A_NOT; + ops : 1; + optypes : (ot_regmem or ot_bits8,ot_none,ot_none); + code : #192#1#246#130; + flags : if_8086 + ), + ( + opcode : A_NOT; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#247#130; + flags : if_8086 + ), + ( + opcode : A_NOT; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#247#130; + flags : if_386 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#8#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#8#65; + flags : if_8086 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#9#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#9#65; + flags : if_8086 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#9#65; + flags : if_386 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#9#65; + flags : if_386 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#10#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#10#72; + flags : if_8086 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#11#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#11#72; + flags : if_8086 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#11#72; + flags : if_386 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#11#72; + flags : if_386 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#129#13; + flags : if_8086 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#129#13; + flags : if_386 + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#12#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#13#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#13#33; + flags : if_386 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#129#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#129#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#129#33; + flags : if_386 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#129#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#129#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_OR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#129#33; + flags : if_386 or if_sm + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_immediate,ot_reg_al,ot_none); + code : #1#230#20; + flags : if_8086 or if_sb + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_immediate,ot_reg_ax,ot_none); + code : #208#1#231#20; + flags : if_8086 or if_sb + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_immediate,ot_reg_eax,ot_none); + code : #209#1#231#20; + flags : if_386 or if_sb + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_reg_dx,ot_reg_al,ot_none); + code : #1#238; + flags : if_8086 + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_reg_dx,ot_reg_ax,ot_none); + code : #208#1#239; + flags : if_8086 + ), + ( + opcode : A_OUT; + ops : 2; + optypes : (ot_reg_dx,ot_reg_eax,ot_none); + code : #209#1#239; + flags : if_386 + ), + ( + opcode : A_OUTSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#110; + flags : if_186 + ), + ( + opcode : A_OUTSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#111; + flags : if_386 + ), + ( + opcode : A_OUTSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#111; + flags : if_186 + ), + ( + opcode : A_PACKSSDW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#107#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PACKSSDW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#107#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PACKSSWB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#99#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PACKSSWB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#99#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PACKUSWB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#103#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PACKUSWB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#103#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#252#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#252#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#254#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#254#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDSB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#236#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDSB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#236#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDSIW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#81#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PADDSIW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#81#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PADDSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#237#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#237#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDUSB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#220#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDUSB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#220#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDUSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#221#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDUSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#221#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PADDW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#253#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PADDW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#253#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PAND; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#219#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PAND; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#219#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PANDN; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#223#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PANDN; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#223#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PAVEB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#80#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PAVEB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#80#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PAVGUSB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#191; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PAVGUSB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#191; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PCMPEQB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#116#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPEQB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#116#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PCMPEQD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#118#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPEQD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#118#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PCMPEQW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#117#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPEQW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#117#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PCMPGTB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#100#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPGTB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#100#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PCMPGTD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#102#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPGTD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#102#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PCMPGTW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#101#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PCMPGTW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#101#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PDISTIB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#84#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PF2ID; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#29; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PF2ID; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#29; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFACC; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#174; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFACC; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#174; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFADD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#158; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFADD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#158; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFCMPEQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#176; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFCMPEQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#176; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFCMPGE; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#144; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFCMPGE; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#144; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFCMPGT; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#160; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFCMPGT; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#160; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFMAX; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#164; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFMAX; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#164; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFMIN; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#148; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFMIN; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#148; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFMUL; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#180; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFMUL; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#180; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFRCP; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#150; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFRCP; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#150; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFRCPIT1; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#166; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFRCPIT1; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#166; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFRCPIT2; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#182; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFRCPIT2; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#182; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFRSQIT1; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#167; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFRSQIT1; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#167; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFRSQRT; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#151; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFRSQRT; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#151; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFSUB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#154; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFSUB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#154; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFSUBR; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#170; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFSUBR; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#170; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PI2FD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#13; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PI2FD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#13; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PMACHRIW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#94#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMADDWD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#245#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PMADDWD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#245#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PMAGW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#82#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMAGW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#82#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PMULHRIW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#93#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMULHRIW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#93#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PMULHRWA; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#183; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PMULHRWA; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#183; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PMULHRWC; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#89#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMULHRWC; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#89#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PMULHW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#229#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PMULHW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#229#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PMULLW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#213#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PMULLW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#213#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PMVGEZB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#92#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMVLZB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#91#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMVNZB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#90#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PMVZB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#88#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#8#88; + flags : if_8086 + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#8#88; + flags : if_386 + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#143#128; + flags : if_8086 + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#143#128; + flags : if_386 + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_reg_cs,ot_none,ot_none); + code : #1#15; + flags : if_8086 or if_undoc + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_reg_dess,ot_none,ot_none); + code : #4; + flags : if_8086 + ), + ( + opcode : A_POP; + ops : 1; + optypes : (ot_reg_fsgs,ot_none,ot_none); + code : #1#15#5; + flags : if_386 + ), + ( + opcode : A_POPA; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #210#1#97; + flags : if_186 + ), + ( + opcode : A_POPAD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#97; + flags : if_386 + ), + ( + opcode : A_POPAW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#97; + flags : if_186 + ), + ( + opcode : A_POPF; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #210#1#157; + flags : if_186 + ), + ( + opcode : A_POPFD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#157; + flags : if_386 + ), + ( + opcode : A_POPFW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#157; + flags : if_186 + ), + ( + opcode : A_POR; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#235#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_POR; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#235#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PREFETCH; + ops : 1; + optypes : (ot_memory,ot_none or ot_signed,ot_none); + code : #2#15#13#128; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PREFETCHW; + ops : 1; + optypes : (ot_memory,ot_none or ot_signed,ot_none); + code : #2#15#13#129; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PSLLD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#242#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSLLD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#242#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSLLD; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#114#134#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSLLQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#243#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSLLQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#243#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSLLQ; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#115#134#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSLLW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#241#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSLLW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#241#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSLLW; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#113#134#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRAD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#226#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSRAD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#226#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRAD; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#114#132#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRAW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#225#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSRAW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#225#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRAW; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#113#132#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#210#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSRLD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#210#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLD; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#114#130#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#211#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSRLQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#211#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLQ; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#115#130#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#209#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSRLW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#209#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSRLW; + ops : 2; + optypes : (ot_mmxreg,ot_immediate,ot_none); + code : #2#15#113#130#21; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#248#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#248#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#250#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#250#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBSB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#232#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBSB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#232#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBSIW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#85#72; + flags : if_pent or if_mmx or if_sm or if_cyrix + ), + ( + opcode : A_PSUBSIW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#85#72; + flags : if_pent or if_mmx or if_cyrix + ), + ( + opcode : A_PSUBSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#233#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#233#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBUSB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#216#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBUSB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#216#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBUSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#217#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBUSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#217#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PSUBW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#249#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PSUBW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#249#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKHBW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#104#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKHBW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#104#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKHDQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#106#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKHDQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#106#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKHWD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#105#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKHWD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#105#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKLBW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#96#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKLBW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#96#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKLDQ; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#98#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKLDQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#98#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUNPCKLWD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#97#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PUNPCKLWD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#97#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #208#8#80; + flags : if_8086 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_reg32,ot_none,ot_none); + code : #209#8#80; + flags : if_386 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_regmem or ot_bits16,ot_none,ot_none); + code : #208#192#1#255#134; + flags : if_8086 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_regmem or ot_bits32,ot_none,ot_none); + code : #209#192#1#255#134; + flags : if_386 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_reg_fsgs,ot_none,ot_none); + code : #1#15#7; + flags : if_386 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_reg_sreg,ot_none,ot_none); + code : #6; + flags : if_8086 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_immediate or ot_bits8 or ot_signed,ot_none,ot_none); + code : #1#106#12; + flags : if_286 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_immediate or ot_bits16,ot_none,ot_none); + code : #208#1#104#24; + flags : if_286 + ), + ( + opcode : A_PUSH; + ops : 1; + optypes : (ot_immediate or ot_bits32,ot_none,ot_none); + code : #209#1#104#32; + flags : if_386 + ), + ( + opcode : A_PUSHA; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #210#1#96; + flags : if_186 + ), + ( + opcode : A_PUSHAD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#96; + flags : if_386 + ), + ( + opcode : A_PUSHAW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#96; + flags : if_186 + ), + ( + opcode : A_PUSHF; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #210#1#156; + flags : if_186 + ), + ( + opcode : A_PUSHFD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#156; + flags : if_386 + ), + ( + opcode : A_PUSHFW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#156; + flags : if_186 + ), + ( + opcode : A_PXOR; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#239#72; + flags : if_pent or if_mmx or if_sm + ), + ( + opcode : A_PXOR; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#239#72; + flags : if_pent or if_mmx + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#130; + flags : if_8086 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#130; + flags : if_8086 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#130#21; + flags : if_186 or if_sb + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#130; + flags : if_8086 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#130; + flags : if_8086 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#130#21; + flags : if_186 or if_sb + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#130; + flags : if_386 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#130; + flags : if_386 + ), + ( + opcode : A_RCL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#130#21; + flags : if_386 or if_sb + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#131; + flags : if_8086 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#131; + flags : if_8086 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#131#21; + flags : if_186 or if_sb + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#131; + flags : if_8086 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#131; + flags : if_8086 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#131#21; + flags : if_186 or if_sb + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#131; + flags : if_386 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#131; + flags : if_386 + ), + ( + opcode : A_RCR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#131#21; + flags : if_386 or if_sb + ), + ( + opcode : A_RDSHR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#54; + flags : if_p6 or if_cyrix or if_smm + ), + ( + opcode : A_RDMSR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#50; + flags : if_pent or if_priv + ), + ( + opcode : A_RDPMC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#51; + flags : if_p6 + ), + ( + opcode : A_RDTSC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#49; + flags : if_pent + ), + ( + opcode : A_REP; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#243; + flags : if_8086 or if_pre + ), + ( + opcode : A_REPE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#243; + flags : if_8086 or if_pre + ), + ( + opcode : A_REPNE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#242; + flags : if_8086 or if_pre + ), + ( + opcode : A_REPNZ; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#242; + flags : if_8086 or if_pre + ), + ( + opcode : A_REPZ; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#243; + flags : if_8086 or if_pre + ), + ( + opcode : A_RET; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#195; + flags : if_8086 + ), + ( + opcode : A_RET; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#194#24; + flags : if_8086 or if_sw + ), + ( + opcode : A_RETF; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#203; + flags : if_8086 + ), + ( + opcode : A_RETF; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#202#24; + flags : if_8086 or if_sw + ), + ( + opcode : A_RETN; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#195; + flags : if_8086 + ), + ( + opcode : A_RETN; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #1#194#24; + flags : if_8086 or if_sw + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#128; + flags : if_8086 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#128; + flags : if_8086 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#128#21; + flags : if_186 or if_sb + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#128; + flags : if_8086 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#128; + flags : if_8086 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#128#21; + flags : if_186 or if_sb + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#128; + flags : if_386 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#128; + flags : if_386 + ), + ( + opcode : A_ROL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#128#21; + flags : if_386 or if_sb + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#129; + flags : if_8086 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#129; + flags : if_8086 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#129#21; + flags : if_186 or if_sb + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#129; + flags : if_8086 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#129; + flags : if_8086 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#129#21; + flags : if_186 or if_sb + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#129; + flags : if_386 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#129; + flags : if_386 + ), + ( + opcode : A_ROR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#129#21; + flags : if_386 or if_sb + ), + ( + opcode : A_RSDC; + ops : 2; + optypes : (ot_reg_sreg,ot_memory or ot_bits80,ot_none); + code : #193#2#15#121#65; + flags : if_486 or if_cyrix or if_smm + ), + ( + opcode : A_RSLDT; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#2#15#123#128; + flags : if_486 or if_cyrix or if_smm + ), + ( + opcode : A_RSM; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#170; + flags : if_pent or if_smm + ), + ( + opcode : A_SAHF; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#158; + flags : if_8086 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#132; + flags : if_8086 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#132; + flags : if_8086 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#132#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#132; + flags : if_8086 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#132; + flags : if_8086 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#132#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#132; + flags : if_386 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#132; + flags : if_386 + ), + ( + opcode : A_SAL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#132#21; + flags : if_386 or if_sb + ), + ( + opcode : A_SALC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#214; + flags : if_8086 or if_undoc + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#135; + flags : if_8086 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#135; + flags : if_8086 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#135#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#135; + flags : if_8086 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#135; + flags : if_8086 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#135#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#135; + flags : if_386 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#135; + flags : if_386 + ), + ( + opcode : A_SAR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#135#21; + flags : if_386 or if_sb + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#24#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#24#65; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#25#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#25#65; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#25#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#25#65; + flags : if_386 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#26#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#26#72; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#27#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#27#72; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#27#72; + flags : if_386 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#27#72; + flags : if_386 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#131#13; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#131#13; + flags : if_8086 + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#28#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#29#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#29#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#131#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#131#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#131#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#131#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#131#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SBB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#131#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SCASB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#1#174; + flags : if_8086 + ), + ( + opcode : A_SCASD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#209#1#175; + flags : if_386 + ), + ( + opcode : A_SCASW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #218#208#1#175; + flags : if_8086 + ), + ( + opcode : A_SEGCS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#46; + flags : if_8086 or if_pre + ), + ( + opcode : A_SEGDS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#62; + flags : if_8086 or if_pre + ), + ( + opcode : A_SEGES; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#38; + flags : if_8086 or if_pre + ), + ( + opcode : A_SEGFS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#100; + flags : if_8086 or if_pre + ), + ( + opcode : A_SEGGS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#101; + flags : if_8086 or if_pre + ), + ( + opcode : A_SEGSS; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#54; + flags : if_8086 or if_pre + ), + ( + opcode : A_SGDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#128; + flags : if_286 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#132; + flags : if_8086 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#132; + flags : if_8086 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#132#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#132; + flags : if_8086 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#132; + flags : if_8086 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#132#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#132; + flags : if_386 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#132; + flags : if_386 + ), + ( + opcode : A_SHL; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#132#21; + flags : if_386 or if_sb + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_memory,ot_reg16,ot_immediate); + code : #192#208#2#15#164#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_immediate); + code : #192#208#2#15#164#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_memory,ot_reg32,ot_immediate); + code : #192#209#2#15#164#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_immediate); + code : #192#209#2#15#164#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_memory,ot_reg16,ot_reg_cl); + code : #192#208#2#15#165#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_reg_cl); + code : #192#208#2#15#165#65; + flags : if_386 + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_memory,ot_reg32,ot_reg_cl); + code : #192#209#2#15#165#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SHLD; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_reg_cl); + code : #192#209#2#15#165#65; + flags : if_386 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_unity,ot_none); + code : #192#1#208#133; + flags : if_8086 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_reg_cl,ot_none); + code : #192#1#210#133; + flags : if_8086 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#192#133#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_unity,ot_none); + code : #208#192#1#209#133; + flags : if_8086 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_reg_cl,ot_none); + code : #208#192#1#211#133; + flags : if_8086 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#193#133#21; + flags : if_186 or if_sb + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_unity,ot_none); + code : #209#192#1#209#133; + flags : if_386 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_reg_cl,ot_none); + code : #209#192#1#211#133; + flags : if_386 + ), + ( + opcode : A_SHR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#193#133#21; + flags : if_386 or if_sb + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_memory,ot_reg16,ot_immediate); + code : #192#208#2#15#172#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_immediate); + code : #192#208#2#15#172#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_memory,ot_reg32,ot_immediate); + code : #192#209#2#15#172#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_immediate); + code : #192#209#2#15#172#65#22; + flags : if_386 or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_memory,ot_reg16,ot_reg_cl); + code : #192#208#2#15#173#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_reg16,ot_reg16,ot_reg_cl); + code : #192#208#2#15#173#65; + flags : if_386 + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_memory,ot_reg32,ot_reg_cl); + code : #192#209#2#15#173#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SHRD; + ops : 3; + optypes : (ot_reg32,ot_reg32,ot_reg_cl); + code : #192#209#2#15#173#65; + flags : if_386 + ), + ( + opcode : A_SIDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#129; + flags : if_286 + ), + ( + opcode : A_SLDT; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#128; + flags : if_286 + ), + ( + opcode : A_SLDT; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#128; + flags : if_286 + ), + ( + opcode : A_SLDT; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#128; + flags : if_286 + ), + ( + opcode : A_SMI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#241; + flags : if_386 or if_undoc + ), + ( + opcode : A_SMINT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#56; + flags : if_p6 or if_cyrix + ), + ( + opcode : A_SMINTOLD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#126; + flags : if_486 or if_cyrix + ), + ( + opcode : A_SMSW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#1#132; + flags : if_286 + ), + ( + opcode : A_SMSW; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#2#15#1#132; + flags : if_286 + ), + ( + opcode : A_SMSW; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#2#15#1#132; + flags : if_286 + ), + ( + opcode : A_STC; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#249; + flags : if_8086 + ), + ( + opcode : A_STD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#253; + flags : if_8086 + ), + ( + opcode : A_STI; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#251; + flags : if_8086 + ), + ( + opcode : A_STOSB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#170; + flags : if_8086 + ), + ( + opcode : A_STOSD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #209#1#171; + flags : if_386 + ), + ( + opcode : A_STOSW; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #208#1#171; + flags : if_8086 + ), + ( + opcode : A_STR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#129; + flags : if_286 or if_prot + ), + ( + opcode : A_STR; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#129; + flags : if_286 or if_prot + ), + ( + opcode : A_STR; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#129; + flags : if_286 or if_prot + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#40#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#40#65; + flags : if_8086 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#41#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#41#65; + flags : if_8086 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#41#65; + flags : if_386 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#41#65; + flags : if_386 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#42#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#42#72; + flags : if_8086 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#43#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#43#72; + flags : if_8086 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#43#72; + flags : if_386 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#43#72; + flags : if_386 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#133#13; + flags : if_8086 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#133#13; + flags : if_386 + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#44#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#45#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#45#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#133#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#133#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#133#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#133#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#133#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_SUB; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#133#33; + flags : if_386 or if_sm + ), + ( + opcode : A_SVDC; + ops : 2; + optypes : (ot_memory or ot_bits80,ot_reg_sreg,ot_none); + code : #192#2#15#120#65; + flags : if_486 or if_cyrix or if_smm + ), + ( + opcode : A_SVLDT; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#2#15#122#128; + flags : if_486 or if_cyrix or if_smm + ), + ( + opcode : A_SVTS; + ops : 1; + optypes : (ot_memory or ot_bits80,ot_none,ot_none); + code : #192#2#15#124#128; + flags : if_486 or if_cyrix or if_smm + ), + ( + opcode : A_SYSCALL; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#5; + flags : if_p6 or if_amd + ), + ( + opcode : A_SYSENTER; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#52; + flags : if_p6 + ), + ( + opcode : A_SYSEXIT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#54; + flags : if_p6 or if_priv + ), + ( + opcode : A_SYSRET; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#7; + flags : if_p6 or if_priv or if_amd + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#132#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#132#65; + flags : if_8086 + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#133#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#133#65; + flags : if_8086 + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#133#65; + flags : if_386 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#133#65; + flags : if_386 + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#132#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#133#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#133#72; + flags : if_386 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#168#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#169#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#169#33; + flags : if_386 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#246#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#247#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#247#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#246#128#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#247#128#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_TEST; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#247#128#33; + flags : if_386 or if_sm + ), + ( + opcode : A_UD1; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#185; + flags : if_286 or if_undoc + ), + ( + opcode : A_UD2; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#11; + flags : if_286 + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#2#15#16#65; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#2#15#16#65; + flags : if_386 or if_undoc + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#17#65; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#17#65; + flags : if_386 or if_undoc + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#17#65; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#17#65; + flags : if_386 or if_undoc + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#2#15#18#72; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#2#15#18#72; + flags : if_386 or if_undoc + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#19#72; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#19#72; + flags : if_386 or if_undoc + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#19#72; + flags : if_386 or if_undoc or if_sm + ), + ( + opcode : A_UMOV; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#19#72; + flags : if_386 or if_undoc + ), + ( + opcode : A_VERR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#132; + flags : if_286 or if_prot + ), + ( + opcode : A_VERR; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#132; + flags : if_286 or if_prot + ), + ( + opcode : A_VERR; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#132; + flags : if_286 or if_prot + ), + ( + opcode : A_VERW; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#15#133; + flags : if_286 or if_prot + ), + ( + opcode : A_VERW; + ops : 1; + optypes : (ot_memory or ot_bits16,ot_none,ot_none); + code : #192#1#15#15#133; + flags : if_286 or if_prot + ), + ( + opcode : A_VERW; + ops : 1; + optypes : (ot_reg16,ot_none,ot_none); + code : #192#1#15#15#133; + flags : if_286 or if_prot + ), + ( + opcode : A_WAIT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#155; + flags : if_8086 + ), + ( + opcode : A_WBINVD; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#9; + flags : if_486 or if_priv + ), + ( + opcode : A_WRSHR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#55; + flags : if_p6 or if_cyrix or if_smm + ), + ( + opcode : A_WRMSR; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #2#15#48; + flags : if_pent or if_priv + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#2#15#192#65; + flags : if_486 or if_sm + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#2#15#192#65; + flags : if_486 + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#2#15#193#65; + flags : if_486 or if_sm + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#2#15#193#65; + flags : if_486 + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#2#15#193#65; + flags : if_486 or if_sm + ), + ( + opcode : A_XADD; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#2#15#193#65; + flags : if_486 + ), + ( + opcode : A_XBTS; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#2#15#166#72; + flags : if_386 or if_sw or if_undoc + ), + ( + opcode : A_XBTS; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#2#15#166#72; + flags : if_386 or if_undoc + ), + ( + opcode : A_XBTS; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#2#15#166#72; + flags : if_386 or if_sd or if_undoc + ), + ( + opcode : A_XBTS; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#2#15#166#72; + flags : if_386 or if_undoc + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg_ax,ot_reg16,ot_none); + code : #208#9#144; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg_eax,ot_reg32,ot_none); + code : #209#9#144; + flags : if_386 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg16,ot_reg_ax,ot_none); + code : #208#8#144; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg32,ot_reg_eax,ot_none); + code : #209#8#144; + flags : if_386 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#134#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#134#72; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#135#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#135#72; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#135#72; + flags : if_386 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#135#72; + flags : if_386 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#134#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#134#65; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#135#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#135#65; + flags : if_8086 + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#135#65; + flags : if_386 or if_sm + ), + ( + opcode : A_XCHG; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#135#65; + flags : if_386 + ), + ( + opcode : A_XLAT; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#215; + flags : if_8086 + ), + ( + opcode : A_XLATB; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #1#215; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_reg8,ot_none); + code : #192#1#48#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #192#1#48#65; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_reg16,ot_none); + code : #208#192#1#49#65; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#192#1#49#65; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_reg32,ot_none); + code : #209#192#1#49#65; + flags : if_386 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#192#1#49#65; + flags : if_386 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg8,ot_memory,ot_none); + code : #193#1#50#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg8,ot_reg8,ot_none); + code : #193#1#50#72; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#51#72; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#51#72; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#51#72; + flags : if_386 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#51#72; + flags : if_386 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #208#192#1#131#134#13; + flags : if_8086 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate or ot_bits8 or ot_signed,ot_none); + code : #209#192#1#131#134#13; + flags : if_386 + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg_al,ot_immediate,ot_none); + code : #1#52#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg_ax,ot_immediate,ot_none); + code : #208#1#53#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_reg_eax,ot_immediate,ot_none); + code : #209#1#53#33; + flags : if_386 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_regmem or ot_bits8,ot_immediate,ot_none); + code : #192#1#128#134#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_regmem or ot_bits16,ot_immediate,ot_none); + code : #208#192#1#129#134#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_regmem or ot_bits32,ot_immediate,ot_none); + code : #209#192#1#129#134#33; + flags : if_386 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits8,ot_none); + code : #192#1#128#134#17; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits16,ot_none); + code : #208#192#1#129#134#25; + flags : if_8086 or if_sm + ), + ( + opcode : A_XOR; + ops : 2; + optypes : (ot_memory,ot_immediate or ot_bits32,ot_none); + code : #209#192#1#129#134#33; + flags : if_386 or if_sm + ), + ( + opcode : A_CMOVcc; + ops : 2; + optypes : (ot_reg16,ot_memory,ot_none); + code : #208#193#1#15#216#64#72; + flags : if_p6 or if_sm + ), + ( + opcode : A_CMOVcc; + ops : 2; + optypes : (ot_reg16,ot_reg16,ot_none); + code : #208#193#1#15#216#64#72; + flags : if_p6 + ), + ( + opcode : A_CMOVcc; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #209#193#1#15#216#64#72; + flags : if_p6 or if_sm + ), + ( + opcode : A_CMOVcc; + ops : 2; + optypes : (ot_reg32,ot_reg32,ot_none); + code : #209#193#1#15#216#64#72; + flags : if_p6 + ), + ( + opcode : A_Jcc; + ops : 1; + optypes : (ot_immediate or ot_near,ot_none,ot_none); + code : #210#1#15#216#128#52; + flags : if_386 or if_pass2 + ), + ( + opcode : A_Jcc; + ops : 1; + optypes : (ot_immediate or ot_bits16 or ot_near,ot_none,ot_none); + code : #208#1#15#216#128#52; + flags : if_386 or if_pass2 + ), + ( + opcode : A_Jcc; + ops : 1; + optypes : (ot_immediate or ot_bits32 or ot_near,ot_none,ot_none); + code : #209#1#15#216#128#52; + flags : if_386 or if_pass2 + ), + ( + opcode : A_Jcc; + ops : 1; + optypes : (ot_immediate,ot_none,ot_none); + code : #216#112#40; + flags : if_8086 + ), + ( + opcode : A_Jcc; + ops : 1; + optypes : (ot_immediate or ot_short,ot_none,ot_none); + code : #216#112#40; + flags : if_8086 + ), + ( + opcode : A_SETcc; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#1#15#216#144#128; + flags : if_386 or if_sb + ), + ( + opcode : A_SETcc; + ops : 1; + optypes : (ot_reg8,ot_none,ot_none); + code : #192#1#15#216#144#128; + flags : if_386 + ), + ( + opcode : A_ADDPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#88#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ADDPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#88#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ADDSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#88#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ADDSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#88#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ANDNPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#85#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ANDNPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#85#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ANDPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#84#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ANDPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#84#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPEQPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#0; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPEQPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#0; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPEQSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#0; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPEQSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#0; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLEPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#2; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLEPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#2; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLESS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#2; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLESS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#2; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLTPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#1; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLTPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#1; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLTSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#1; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPLTSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#1; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNEQPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#4; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNEQPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#4; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNEQSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#4; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNEQSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#4; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLEPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#6; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLEPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#6; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLESS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#6; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLESS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#6; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLTPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#5; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLTPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#5; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLTSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#5; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPNLTSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#5; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPORDPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#7; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPORDPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#7; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPORDSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#7; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPORDSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#7; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPUNORDPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#194#72#1#3; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPUNORDPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#194#72#1#3; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPUNORDSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#194#72#1#3; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPUNORDSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#194#72#1#3; + flags : if_katmai or if_sse + ), + ( + opcode : A_CMPPS; + ops : 3; + optypes : (ot_xmmreg,ot_memory,ot_immediate); + code : #193#217#2#15#194#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_CMPPS; + ops : 3; + optypes : (ot_xmmreg,ot_xmmreg,ot_immediate); + code : #217#2#15#194#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_CMPSS; + ops : 3; + optypes : (ot_xmmreg,ot_memory,ot_immediate); + code : #193#219#2#15#194#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_CMPSS; + ops : 3; + optypes : (ot_xmmreg,ot_xmmreg,ot_immediate); + code : #219#2#15#194#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_COMISS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#47#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_COMISS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#47#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CVTPI2PS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#42#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTPI2PS; + ops : 2; + optypes : (ot_xmmreg,ot_mmxreg,ot_none); + code : #217#2#15#42#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTPS2PI; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#217#2#15#45#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTPS2PI; + ops : 2; + optypes : (ot_mmxreg,ot_xmmreg,ot_none); + code : #217#2#15#45#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTSI2SS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#42#72; + flags : if_katmai or if_sse or if_sd or if_ar1 + ), + ( + opcode : A_CVTSI2SS; + ops : 2; + optypes : (ot_xmmreg,ot_reg32,ot_none); + code : #219#2#15#42#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CVTSS2SI; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #193#219#2#15#45#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CVTSS2SI; + ops : 2; + optypes : (ot_reg32,ot_xmmreg,ot_none); + code : #219#2#15#45#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CVTTPS2PI; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#217#2#15#44#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTTPS2PI; + ops : 2; + optypes : (ot_mmxreg,ot_xmmreg,ot_none); + code : #217#2#15#44#72; + flags : if_katmai or if_sse or if_mmx + ), + ( + opcode : A_CVTTSS2SI; + ops : 2; + optypes : (ot_reg32,ot_memory,ot_none); + code : #193#219#2#15#44#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_CVTTSS2SI; + ops : 2; + optypes : (ot_reg32,ot_xmmreg,ot_none); + code : #219#2#15#44#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_DIVPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#94#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_DIVPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#94#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_DIVSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#94#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_DIVSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#94#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_LDMXCSR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#174#130; + flags : if_katmai or if_sse or if_sd + ), + ( + opcode : A_MAXPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#95#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MAXPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#95#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MAXSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#95#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MAXSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#95#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MINPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#93#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MINPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#93#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MINSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#93#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MINSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#93#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVAPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#40#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVAPS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #192#2#15#41#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVAPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#40#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVAPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#41#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVHPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#22#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVHPS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #192#2#15#23#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVHPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#22#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVLHPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#22#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVLPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#18#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVLPS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #192#2#15#19#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVLPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#18#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVHLPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#18#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVMSKPS; + ops : 2; + optypes : (ot_reg32,ot_xmmreg,ot_none); + code : #2#15#80#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVNTPS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #2#15#43#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#16#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVSS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #192#219#2#15#17#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#16#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#17#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVUPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#16#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVUPS; + ops : 2; + optypes : (ot_memory,ot_xmmreg,ot_none); + code : #192#217#2#15#17#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVUPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#16#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MOVUPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#17#65; + flags : if_katmai or if_sse + ), + ( + opcode : A_MULPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#89#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MULPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#89#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MULSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#89#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_MULSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#89#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ORPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#86#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_ORPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#86#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RCPPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#83#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RCPPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#83#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RCPSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#83#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RCPSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#83#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RSQRTPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#82#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RSQRTPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#82#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RSQRTSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#82#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_RSQRTSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#82#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SHUFPS; + ops : 3; + optypes : (ot_xmmreg,ot_memory,ot_immediate); + code : #193#2#15#198#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_SHUFPS; + ops : 3; + optypes : (ot_xmmreg,ot_xmmreg,ot_immediate); + code : #2#15#198#72#18; + flags : if_katmai or if_sse or if_sb or if_ar2 + ), + ( + opcode : A_SQRTPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#81#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SQRTPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#81#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SQRTSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#81#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SQRTSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#81#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_STMXCSR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#174#131; + flags : if_katmai or if_sse or if_sd + ), + ( + opcode : A_SUBPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#217#2#15#92#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SUBPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #217#2#15#92#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SUBSS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#219#2#15#92#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_SUBSS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #219#2#15#92#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UCOMISS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#46#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UCOMISS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#46#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UNPCKHPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#21#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UNPCKHPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#21#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UNPCKLPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#20#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_UNPCKLPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#20#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_XORPS; + ops : 2; + optypes : (ot_xmmreg,ot_memory,ot_none); + code : #193#2#15#87#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_XORPS; + ops : 2; + optypes : (ot_xmmreg,ot_xmmreg,ot_none); + code : #2#15#87#72; + flags : if_katmai or if_sse + ), + ( + opcode : A_FXRSTOR; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#174#129; + flags : if_p6 or if_sse or if_fpu + ), + ( + opcode : A_FXSAVE; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#174#128; + flags : if_p6 or if_sse or if_fpu + ), + ( + opcode : A_PREFETCHNTA; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#24#128; + flags : if_katmai + ), + ( + opcode : A_PREFETCHT0; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#24#129; + flags : if_katmai + ), + ( + opcode : A_PREFETCHT1; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#24#130; + flags : if_katmai + ), + ( + opcode : A_PREFETCHT2; + ops : 1; + optypes : (ot_memory,ot_none,ot_none); + code : #192#2#15#24#131; + flags : if_katmai + ), + ( + opcode : A_SFENCE; + ops : 0; + optypes : (ot_none,ot_none,ot_none); + code : #3#15#174#248; + flags : if_katmai + ), + ( + opcode : A_MASKMOVQ; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#247#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_MOVNTQ; + ops : 2; + optypes : (ot_memory,ot_mmxreg,ot_none); + code : #2#15#231#65; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PAVGB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#224#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PAVGB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#224#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PAVGW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#227#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PAVGW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#227#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PEXTRW; + ops : 3; + optypes : (ot_reg32,ot_mmxreg,ot_immediate); + code : #2#15#197#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PINSRW; + ops : 3; + optypes : (ot_mmxreg,ot_reg16,ot_immediate); + code : #2#15#196#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PINSRW; + ops : 3; + optypes : (ot_mmxreg,ot_reg32,ot_immediate); + code : #2#15#196#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PINSRW; + ops : 3; + optypes : (ot_mmxreg,ot_memory,ot_immediate); + code : #193#2#15#196#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PINSRW; + ops : 3; + optypes : (ot_mmxreg,ot_memory or ot_bits16,ot_immediate); + code : #193#2#15#196#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PMAXSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#238#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMAXSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#238#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PMAXUB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#222#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMAXUB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#222#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PMINSW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#234#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMINSW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#234#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PMINUB; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#218#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMINUB; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#218#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PMOVMSKB; + ops : 2; + optypes : (ot_reg32,ot_mmxreg,ot_none); + code : #2#15#215#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMULHUW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#228#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PMULHUW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#228#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PSADBW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#246#72; + flags : if_katmai or if_mmx + ), + ( + opcode : A_PSADBW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#246#72; + flags : if_katmai or if_mmx or if_sm + ), + ( + opcode : A_PSHUFW; + ops : 3; + optypes : (ot_mmxreg,ot_mmxreg,ot_immediate); + code : #2#15#112#72#18; + flags : if_katmai or if_mmx or if_sb or if_ar2 + ), + ( + opcode : A_PSHUFW; + ops : 3; + optypes : (ot_mmxreg,ot_memory,ot_immediate); + code : #193#2#15#112#72#18; + flags : if_katmai or if_mmx or if_sm2 or if_sb or if_ar2 + ), + ( + opcode : A_PFNACC; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#138; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFNACC; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#138; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PFPNACC; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#142; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PFPNACC; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#142; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PI2FW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#12; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PI2FW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#12; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PF2IW; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#28; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PF2IW; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#28; + flags : if_pent or if_3dnow + ), + ( + opcode : A_PSWAPD; + ops : 2; + optypes : (ot_mmxreg,ot_memory,ot_none); + code : #193#2#15#15#72#1#187; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_PSWAPD; + ops : 2; + optypes : (ot_mmxreg,ot_mmxreg,ot_none); + code : #2#15#15#72#1#187; + flags : if_pent or if_3dnow or if_sm + ), + ( + opcode : A_FFREEP; + ops : 1; + optypes : (ot_fpureg,ot_none,ot_none); + code : #1#223#8#192; + flags : if_pent or if_3dnow or if_fpu + ) +); diff --git a/befpc/compiler/impdef.pas b/befpc/compiler/impdef.pas new file mode 100644 index 0000000..ab07662 --- /dev/null +++ b/befpc/compiler/impdef.pas @@ -0,0 +1,146 @@ +unit impdef; +{ +C source code of DEWIN Windows disassembler (written by A. Milukov) was +partially used +} +interface +function makedef(const binname,textname:string):longbool; +implementation +var +f:file; +t:text; +TheWord:array[0..1]of char; +PEoffset:cardinal; +loaded:{$ifdef fpc}longint{$else}integer{$endif}; +FileCreated:longbool; +function DOSstubOK(var x:cardinal):longbool; +begin + blockread(f,TheWord,2,loaded); + if loaded<>2 then + DOSstubOK:=false + else + begin + DOSstubOK:=TheWord='MZ'; + seek(f,$3C); + blockread(f,x,4,loaded); + if(loaded<>4)or(x>filesize(f))then + DOSstubOK:=false; + end; +end; +function isPE(x:cardinal):longbool; +begin + seek(f,x); + blockread(f,TheWord,2,loaded); + isPE:=(loaded=2)and(TheWord='PE'); +end; +var +cstring:array[0..127]of char; + +function GetEdata(PE:cardinal):longbool; +type + TObjInfo=packed record + ObjName:array[0..7]of char; + VirtSize, + VirtAddr, + RawSize, + RawOffset, + Reloc, + LineNum:cardinal; + RelCount, + LineCount:word; + flags:cardinal; + end; +var + i:cardinal; + ObjOfs:cardinal; + Obj:TObjInfo; + APE_obj,APE_Optsize:word; + ExportRVA:cardinal; + delta:cardinal; +procedure ProcessEdata; + var + j:cardinal; + ulongval:cardinal; + ExpDir:packed record + flag, + stamp:cardinal; + Major, + Minor:word; + Name, + Base, + NumFuncs, + NumNames, + AddrFuncs, + AddrNames, + AddrOrds:cardinal; + end; + begin + with Obj do + begin + seek(f,RawOffset+delta); + blockread(f,ExpDir,sizeof(ExpDir)); + seek(f,RawOffset-VirtAddr+ExpDir.Name); + blockread(f,cstring,sizeof(cstring)); + for j:=0 to pred(ExpDir.NumNames)do + begin + seek(f,RawOffset-VirtAddr+ExpDir.AddrNames+j*4); + blockread(f,ulongval,4); + seek(f,RawOffset-VirtAddr+ulongval); + blockread(f,cstring,sizeof(cstring)); + if not FileCreated then + begin + FileCreated:=true; + rewrite(t); + writeln(t,'EXPORTS'); + end; + { do not use the implicit '_' } + writeln(t,cstring,'=',cstring); + end; + end; + end; +begin + GetEdata:=false; + FileCreated:=false; + seek(f,PE+120); + blockread(f,ExportRVA,4); + seek(f,PE+6); + blockread(f,APE_Obj,2); + seek(f,PE+20); + blockread(f,APE_OptSize,2); + ObjOfs:=APE_OptSize+PEoffset+24; + for i:=1 to APE_obj do + begin + seek(f,ObjOfs); + blockread(f,Obj,sizeof(Obj)); + inc(ObjOfs,sizeof(Obj)); + with Obj do + if(VirtAddr<=ExportRva)and(ExportRva'' then + ExtraOptions:=ParaLinkOptions; + if ParaDynamicLinker<>'' then + DynamicLinker:=ParaDynamicLinker; + end; +end; + + +Destructor TLinker.Done; +begin + ObjectFiles.Done; + SharedLibFiles.Done; + StaticLibFiles.Done; +end; + + +Procedure TLinker.SetDefaultInfo; +begin +end; + + +procedure TLinker.AddModuleFiles(hp:pmodule); +var + mask : longint; +begin + with hp^ do + begin + { link unit files } + if (flags and uf_no_link)=0 then + begin + { create mask which unit files need linking } + mask:=link_allways; + { static linking ? } + if (cs_link_static in aktglobalswitches) then + begin + if (flags and uf_static_linked)=0 then + begin + { if smart not avail then try static linking } + if (flags and uf_static_linked)<>0 then + begin + Comment(V_Hint,'unit '+modulename^+' can''t be static linked, switching to smart linking'); + mask:=mask or link_smart; + end + else + Comment(V_Error,'unit '+modulename^+' can''t be smart or static linked'); + end + else + mask:=mask or link_static; + end; + { smart linking ? } + if (cs_link_smart in aktglobalswitches) then + begin + if (flags and uf_smart_linked)=0 then + begin + { if smart not avail then try static linking } + if (flags and uf_static_linked)<>0 then + begin + Comment(V_Hint,'unit '+modulename^+' can''t be smart linked, switching to static linking'); + mask:=mask or link_static; + end + else + Comment(V_Error,'unit '+modulename^+' can''t be smart or static linked'); + end + else + mask:=mask or link_smart; + end; + { shared linking } + if (cs_link_shared in aktglobalswitches) then + begin + if (flags and uf_shared_linked)=0 then + begin + { if shared not avail then try static linking } + if (flags and uf_static_linked)<>0 then + begin + Comment(V_Hint,'unit '+modulename^+' can''t be shared linked, switching to static linking'); + mask:=mask or link_static; + end + else + Comment(V_Error,'unit '+modulename^+' can''t be shared or static linked'); + end + else + mask:=mask or link_shared; + end; + { unit files } + while not linkunitofiles.empty do + AddObject(linkunitofiles.getusemask(mask),path^); + while not linkunitstaticlibs.empty do + AddStaticLibrary(linkunitstaticlibs.getusemask(mask)); + while not linkunitsharedlibs.empty do + AddSharedLibrary(linkunitsharedlibs.getusemask(mask)); + end; + { Other needed .o and libs, specified using $L,$LINKLIB,external } + mask:=link_allways; + while not linkotherofiles.empty do + AddObject(linkotherofiles.Getusemask(mask),path^); + while not linkotherstaticlibs.empty do + AddStaticLibrary(linkotherstaticlibs.Getusemask(mask)); + while not linkothersharedlibs.empty do + AddSharedLibrary(linkothersharedlibs.Getusemask(mask)); + end; +end; + + +Function TLinker.FindUtil(const s:string):string; +var + ldfound : boolean; + LastBin : string; +begin + LastBin:=''; + if utilsdirectory<>'' then + LastBin:=FindFile(s+source_os.exeext,utilsdirectory,ldfound)+s+source_os.exeext; + if LastBin='' then + LastBin:=FindExe(s,ldfound); + if (not ldfound) and not(cs_link_extern in aktglobalswitches) then + begin + Message1(exec_w_util_not_found,s); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + end; + if ldfound then + Message1(exec_t_using_util,LastBin); + FindUtil:=LastBin; +end; + + +{ searches an object file } +function TLinker.FindObjectFile(s:string;const unitpath:string) : string; +var + found : boolean; +begin + findobjectfile:=''; + if s='' then + exit; + if pos('.',s)=0 then + s:=s+target_info.objext; + s:=FixFileName(s); + if FileExists(s) then + begin + Findobjectfile:=s; + exit; + end; + { find object file + 1. specified unit path (if specified) + 2. cwd + 3. unit search path + 4. local object path + 5. global object path + 6. exepath } + found:=false; + if unitpath<>'' then + findobjectfile:=FindFile(s,unitpath,found)+s; + if (not found) then + findobjectfile:=FindFile(s,'.'+DirSep,found)+s; + if (not found) then + findobjectfile:=UnitSearchPath.FindFile(s,found)+s; + if (not found) then + findobjectfile:=current_module^.localobjectsearchpath.FindFile(s,found)+s; + if (not found) then + findobjectfile:=objectsearchpath.FindFile(s,found)+s; + if (not found) then + findobjectfile:=FindFile(s,exepath,found)+s; + if not(cs_link_extern in aktglobalswitches) and (not found) then + Message1(exec_w_objfile_not_found,s); +end; + + +{ searches an library file } +function TLinker.FindLibraryFile(s:string;const ext:string;var found : boolean) : string; +begin + found:=false; + findlibraryfile:=''; + if s='' then + exit; + if pos('.',s)=0 then + s:=s+ext; + if FileExists(s) then + begin + found:=true; + FindLibraryFile:=s; + exit; + end; + { find libary + 1. cwd + 2. local libary dir + 3. global libary dir + 4. exe path of the compiler } + found:=false; + findlibraryfile:=FindFile(s,'.'+DirSep,found)+s; + if (not found) then + findlibraryfile:=current_module^.locallibrarysearchpath.FindFile(s,found)+s; + if (not found) then + findlibraryfile:=librarysearchpath.FindFile(s,found)+s; + if (not found) then + findlibraryfile:=FindFile(s,exepath,found)+s; +end; + + +Procedure TLinker.AddObject(const S,unitpath : String); +begin + ObjectFiles.Insert(FindObjectFile(s,unitpath)); +end; + + +Procedure TLinker.AddSharedLibrary(S:String); +begin + if s='' then + exit; +{ remove prefix 'lib' } + if Copy(s,1,length(target_os.libprefix))=target_os.libprefix then + Delete(s,1,length(target_os.libprefix)); +{ remove extension if any } + if Copy(s,length(s)-length(target_os.sharedlibext)+1,length(target_os.sharedlibext))=target_os.sharedlibext then + Delete(s,length(s)-length(target_os.sharedlibext)+1,length(target_os.sharedlibext)+1); +{ ready to be inserted } + SharedLibFiles.Insert (S); +end; + + +Procedure TLinker.AddStaticLibrary(const S:String); +var + ns : string; + found : boolean; +begin + if s='' then + exit; + ns:=FindLibraryFile(s,target_os.staticlibext,found); + if not(cs_link_extern in aktglobalswitches) and (not found) then + Message1(exec_w_libfile_not_found,s); + StaticLibFiles.Insert(ns); +end; + + +Function TLinker.DoExec(const command,para:string;showinfo,useshell:boolean):boolean; +begin + DoExec:=true; + if not(cs_link_extern in aktglobalswitches) then + begin + swapvectors; +{$ifdef ALWAYSSHELL} + shell(command+' '+para); +{$else} + if useshell then + shell(command+' '+para) + else + exec(command,para); +{$endif} + swapvectors; + if (doserror<>0) then + begin + Message(exec_w_cant_call_linker); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + DoExec:=false; + end + else + if (dosexitcode<>0) then + begin + Message(exec_w_error_while_linking); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + DoExec:=false; + end; + end; +{ Update asmres when externmode is set } + if cs_link_extern in aktglobalswitches then + begin + if showinfo then + begin + if DLLsource then + AsmRes.AddLinkCommand(Command,Para,current_module^.sharedlibfilename^) + else + AsmRes.AddLinkCommand(Command,Para,current_module^.exefilename^); + end + else + AsmRes.AddLinkCommand(Command,Para,''); + end; +end; + + +function TLinker.MakeExecutable:boolean; +begin + MakeExecutable:=false; + Message(exec_e_exe_not_supported); +end; + + +Function TLinker.MakeSharedLibrary:boolean; +begin + MakeSharedLibrary:=false; + Message(exec_e_dll_not_supported); +end; + + +Function TLinker.MakeStaticLibrary:boolean; +var + smartpath, + cmdstr, + binstr : string; + success : boolean; +begin + MakeStaticLibrary:=false; +{ remove the library, to be sure that it is rewritten } + RemoveFile(current_module^.staticlibfilename^); +{ Call AR } + smartpath:=current_module^.outputpath^+FixPath(FixFileName(current_module^.modulename^)+target_info.smartext,false); + SplitBinCmd(target_ar.arcmd,binstr,cmdstr); + Replace(cmdstr,'$LIB',current_module^.staticlibfilename^); + Replace(cmdstr,'$FILES',FixFileName(smartpath+current_module^.asmprefix^+'*'+target_info.objext)); + success:=DoExec(FindUtil(binstr),cmdstr,false,true); +{ Clean up } + if not(cs_asm_leave in aktglobalswitches) then + if not(cs_link_extern in aktglobalswitches) then + begin + while not SmartLinkOFiles.Empty do + RemoveFile(SmartLinkOFiles.Get); + RemoveDir(smartpath); + end + else + begin + AsmRes.AddDeleteCommand(FixFileName(smartpath+current_module^.asmprefix^+'*'+target_info.objext)); + AsmRes.Add('rmdir '+smartpath); + end; + MakeStaticLibrary:=success; +end; + + +{***************************************************************************** + Init/Done +*****************************************************************************} + +procedure InitLinker; +begin + case target_info.target of +{$ifdef i386} + {$ifndef NOTARGETLINUX} + target_i386_linux : + linker:=new(plinkerlinux,Init); + {$endif} + {$ifndef NOTARGETWIN32} + target_i386_Win32 : + linker:=new(plinkerwin32,Init); + {$endif} + {$ifndef NOTARGETBEOS} + target_i386_beos : + linker:=new(plinkerbeos,Init); + {$endif} + {$ifndef NOTARGETGO32V1} + target_i386_Go32v1 : + linker:=new(plinkergo32v1,Init); + {$endif} + {$ifndef NOTARGETGO32V2} + target_i386_Go32v2 : + linker:=new(plinkergo32v2,Init); + {$endif} + {$ifndef NOTARGETOS2} + target_i386_os2 : + linker:=new(plinkeros2,Init); + {$endif} +{$endif i386} +{$ifdef m68k} + {$ifndef NOTARGETPALMOS} + target_m68k_palmos: + linker:=new(plinker,Init); + {$endif} + {$ifndef NOTARGETLINUX} + target_m68k_linux : + linker:=new(plinkerlinux,Init); + {$endif} +{$endif m68k} +{$ifdef alpha} + {$ifndef NOTARGETLINUX} + target_alpha_linux : + linker:=new(plinkerlinux,Init); + {$endif} +{$endif alpha} +{$ifdef powerpc} + {$ifndef NOTARGETLINUX} + target_powerpc_linux : + linker:=new(plinkerlinux,Init); + {$endif} +{$endif powerpc} + else + linker:=new(plinker,Init); + end; +end; + + +procedure DoneLinker; +begin + if assigned(linker) then + dispose(linker,done); +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.90 2000/07/08 20:43:37 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.89 2000/06/28 03:34:06 hajny + * little corrections for EMX resources + + Revision 1.88 2000/05/17 18:30:35 peter + * removed wrong warning for library finding + + Revision 1.87 2000/05/03 16:11:57 peter + * also allow smartlinking for main programs + + Revision 1.86 2000/04/14 11:16:10 pierre + * partial linklib change + I could not use Pavel's code because it broke the current way + linklib is used, which is messy :( + + add postw32 call if external linking on win32 + + Revision 1.85 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.84 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.83 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.82 2000/01/14 14:40:37 pierre + * use ./ instead of . to look into startup dir + + Revision 1.81 2000/01/12 10:38:18 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.80 2000/01/11 09:52:06 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.79 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.78 1999/11/22 22:22:30 pierre + * Give better info in script + + Revision 1.77 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.76 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.75 1999/10/26 12:25:04 peter + * fixed os2 linker + + Revision 1.74 1999/10/21 14:29:34 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + + Revision 1.72 1999/09/16 23:05:52 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.71 1999/09/16 11:34:56 pierre + * typo correction + + Revision 1.70 1999/09/15 22:09:16 florian + + rtti is now automatically generated for published classes, i.e. + they are handled like an implicit property + + Revision 1.69 1999/09/15 20:24:56 daniel + + Dw switch now does something. + + Revision 1.68 1999/08/18 17:05:53 florian + + implemented initilizing of data for the new code generator + so it should compile now simple programs + + Revision 1.67 1999/08/16 15:35:23 pierre + * fix for DLL relocation problems + * external bss vars had wrong stabs for pecoff + + -WB11000000 to specify default image base, allows to + load several DLLs with debugging info included + (relocatable DLL are stripped because the relocation + of the .Stab section is misplaced by ldw) + + Revision 1.66 1999/08/11 17:26:34 peter + * tlinker object is now inherited for win32 and dos + * postprocessexecutable is now a method of tlinker + + Revision 1.65 1999/08/10 12:51:16 pierre + * bind_win32_dll removed (Relocsection used instead) + * now relocsection is true by default ! (needs dlltool + for DLL generation) + + Revision 1.64 1999/07/30 23:19:45 peter + * fixed placing of dynamiclinker in link.res (should be the last after + all other libraries) + + Revision 1.63 1999/07/29 01:31:39 peter + * fixed shared library linking for glibc2 systems + + Revision 1.62 1999/07/27 11:05:51 peter + * glibc 2.1.2 support + +} diff --git a/befpc/compiler/make.cmd b/befpc/compiler/make.cmd new file mode 100755 index 0000000..3cf59da --- /dev/null +++ b/befpc/compiler/make.cmd @@ -0,0 +1,65 @@ +@echo off +rem $id: make.cmd,v $ +rem +rem ************************Make batchfile for OS/2**************************** +rem * Purpose: The makefile contains a lot of Unix commands. While it is * +rem * possible to install for example a bash shell under OS/2 * +rem * a batch file is much easier. * +rem * * +rem * Copyright (c) 1998-2000 by Daniel Mantione, developer of Free Pascal * +rem *************************************************************************** + +goto %1 + +:clean +pushd +\pp\rtl\ +del /s *.ppo *.so2 *.oo2 *.ppu *.s *.o *.pp1 *.s1 *.o1>&dev\nul +popd +del *.ppo *.so2 *.oo2 *.ppu *.s *.o *.pp1 *.s1 *.o1>&dev\nul +goto eind + +:prtx +pushd +\pp\rtl\os2\ +iff not exist prt0.oo2 then + as -o prt0.oo2 prt0.as +endiff +iff not exist prt1.oo2 then + as -o prt1.oo2 prt1.as +endiff +iff not exist code2.oo2 then + as -o code2.oo2 code2.as +endiff +iff not exist code3.oo2 then + as -o code3.oo2 code3.as +endiff +popd +goto eind + +:compiler +call make prtx +iff "%2"=="" then + ppos2 pp.pas +else + %2 pp.pas +endiff +goto eind + +:remake +call make clean +call make compiler %2 +goto eind + +:cycle +call make remake %2 +move pp.exe pp1.exe +call make remake pp1.exe +move pp.exe pp2.exe +call make remake pp2.exe +move pp.exe pp3.exe +goto eind + +$log: make.cmd,v$ + +:eind diff --git a/befpc/compiler/messages.pas b/befpc/compiler/messages.pas new file mode 100644 index 0000000..917bb20 --- /dev/null +++ b/befpc/compiler/messages.pas @@ -0,0 +1,459 @@ +{ + $Id: messages.pas,v 1.1.1.1 2001-07-23 17:16:39 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements the message object + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit Messages; +interface + +const + maxmsgidxparts = 20; + +type + ppchar=^pchar; + + TArrayOfPChar = array[0..1000] of pchar; + PArrayOfPChar = ^TArrayOfPChar; + + PMessage=^TMessage; + TMessage=object + msgfilename : string; + msgallocsize, + msgsize, + msgparts, + msgs : longint; + msgtxt : pchar; + msgidx : array[1..maxmsgidxparts] of PArrayOfPChar; + msgidxmax : array[1..maxmsgidxparts] of longint; + constructor Init(n:longint;const idxmax:array of longint); + destructor Done; + function LoadIntern(p:pointer;n:longint):boolean; + function LoadExtern(const fn:string):boolean; + procedure CreateIdx; + function GetPChar(nr:longint):pchar; + function Get(nr:longint):string; + function Get3(nr:longint;const s1,s2,s3:string):string; + function Get2(nr:longint;const s1,s2:string):string; + function Get1(nr:longint;const s1:string):string; + end; + +{ this will read a line until #10 or #0 and also increase p } +function GetMsgLine(var p:pchar):string; + + +implementation + +uses + globals,crc, +{$ifdef DELPHI} + sysutils; +{$else DELPHI} + strings; +{$endif DELPHI} + +constructor TMessage.Init(n:longint;const idxmax:array of longint); +var + i : longint; +begin + msgtxt:=nil; + msgsize:=0; + msgparts:=n; + if n<>high(idxmax)+1 then + fail; + for i:=1to n do + begin + msgidxmax[i]:=idxmax[i-1]; + getmem(msgidx[i],msgidxmax[i]*4); + fillchar(msgidx[i]^,msgidxmax[i]*4,0); + end; +end; + + +destructor TMessage.Done; +var + i : longint; +begin + for i:=1to msgparts do + freemem(msgidx[i],msgidxmax[i]*4); + if msgallocsize>0 then + begin + freemem(msgtxt,msgsize); + msgallocsize:=0; + end; + msgtxt:=nil; + msgsize:=0; + msgparts:=0; +end; + + +function TMessage.LoadIntern(p:pointer;n:longint):boolean; +begin + msgtxt:=pchar(p); + msgsize:=n; + msgallocsize:=0; + CreateIdx; + LoadIntern:=true; +end; + + +function TMessage.LoadExtern(const fn:string):boolean; + +{$ifndef FPC} + procedure readln(var t:text;var s:string); + var + c : char; + i : longint; + begin + c:=#0; + i:=0; + while (not eof(t)) and (c<>#10) do + begin + read(t,c); + if c<>#10 then + begin + inc(i); + s[i]:=c; + end; + end; + if (i>0) and (s[i]=#13) then + dec(i); + s[0]:=chr(i); + end; +{$endif} + +const + bufsize=8192; +var + f : text; + error,multiline : boolean; + code : word; + numpart,numidx, + line,i,j,num : longint; + ptxt : pchar; + number, + s,s1 : string; + buf : pointer; + + procedure err(const msgstr:string); + begin + writeln('error in line ',line,': ',msgstr); + error:=true; + end; + +begin + LoadExtern:=false; + getmem(buf,bufsize); +{Read the message file} + assign(f,fn); + {$I-} + reset(f); + {$I+} + if ioresult<>0 then + begin + WriteLn('*** message file '+fn+' not found ***'); + exit; + end; + settextbuf(f,buf^,bufsize); +{ First parse the file and count bytes needed } + error:=false; + line:=0; + multiline:=false; + msgsize:=0; + while not eof(f) do + begin + readln(f,s); + inc(line); + if multiline then + begin + if s=']' then + multiline:=false + else + inc(msgsize,length(s)+1); { +1 for linebreak } + end + else + begin + if (s<>'') and not(s[1] in ['#',';','%']) then + begin + i:=pos('=',s); + if i>0 then + begin + j:=i+1; + if not(s[j] in ['0'..'9']) then + err('no number found') + else + begin + while (s[j] in ['0'..'9']) do + inc(j); + end; + if j-i-1<>5 then + err('number length is not 5'); + number:=Copy(s,i+1,j-i-1); + { update the max index } + val(number,num,code); + numpart:=num div 1000; + numidx:=num mod 1000; + { check range } + if numpart > msgparts then + err('number is to large') + else + if numidx >= msgidxmax[numpart] then + err('index is to large'); + if s[j+1]='[' then + begin + inc(msgsize,j-i); + multiline:=true + end + else + inc(msgsize,length(s)-i+1); + end + else + err('no = found'); + end; + end; + end; + if multiline then + err('still in multiline mode'); + if error then + begin + freemem(buf,bufsize); + close(f); + exit; + end; +{ now read the buffer in mem } + msgallocsize:=msgsize; + getmem(msgtxt,msgallocsize); + ptxt:=msgtxt; + reset(f); + while not eof(f) do + begin + readln(f,s); + if multiline then + begin + if s=']' then + begin + multiline:=false; + { overwrite last eol } + dec(ptxt); + ptxt^:=#0; + inc(ptxt); + end + else + begin + move(s[1],ptxt^,length(s)); + inc(ptxt,length(s)); + ptxt^:=#10; + inc(ptxt); + end; + end + else + begin + if (s<>'') and not(s[1] in ['#',';','%']) then + begin + i:=pos('=',s); + if i>0 then + begin + j:=i+1; + while (s[j] in ['0'..'9']) do + inc(j); + { multiline start then no txt } + if s[j+1]='[' then + begin + s1:=Copy(s,i+1,j-i); + move(s1[1],ptxt^,length(s1)); + inc(ptxt,length(s1)); + multiline:=true; + end + else + begin + { txt including number } + s1:=Copy(s,i+1,255); + move(s1[1],ptxt^,length(s1)); + inc(ptxt,length(s1)); + ptxt^:=#0; + inc(ptxt); + end; + end; + end; + end; + end; + close(f); + freemem(buf,bufsize); +{ now we can create the index } + CreateIdx; + LoadExtern:=true; +end; + + +procedure TMessage.CreateIdx; +var + hp1, + hp,hpend : pchar; + code : word; + num : longint; + number : string[5]; + i : longint; + numpart,numidx : longint; +begin + { clear } + for i:=1to msgparts do + fillchar(msgidx[i]^,msgidxmax[i]*4,0); + { process msgtxt buffer } + number:='00000'; + hp:=msgtxt; + hpend:=@msgtxt[msgsize]; + while (hp s1 } + i:=pos('$1',s); + if i>0 then + begin + Delete(s,i,2); + Insert(s1,s,i); + end; +{ $2 -> s2 } + i:=pos('$2',s); + if i>0 then + begin + Delete(s,i,2); + Insert(s2,s,i); + end; +{ $3 -> s3 } + i:=pos('$3',s); + if i>0 then + begin + Delete(s,i,2); + Insert(s3,s,i); + end; + Get3:=s; +end; + + +function TMessage.Get2(nr:longint;const s1,s2:string):string; +begin + Get2:=Get3(nr,s1,s2,''); +end; + + +function TMessage.Get1(nr:longint;const s1:string):string; +begin + Get1:=Get3(nr,s1,'',''); +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.16 2000/06/30 20:23:36 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.15 2000/06/18 18:14:21 peter + * only replace the $1,$2,$3 once, so it doesn't loop when the + value to replace with contains $1,$2 or $3 + + Revision 1.14 2000/05/23 20:32:11 peter + * fixed wrong code not detected due a bug in FPC + + Revision 1.13 2000/05/15 14:07:33 pierre + + calculate CRC value and check if consistant + + Revision 1.12 2000/03/01 22:29:18 peter + * message files are check for amount of msgs found. If not correct a + line is written to stdout and switched to internal messages + + Revision 1.11 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.10 2000/01/23 16:32:08 peter + * fixed wrong freemem size when loading message file + + Revision 1.9 2000/01/07 01:14:27 peter + * updated copyright to 2000 + +} \ No newline at end of file diff --git a/befpc/compiler/msgidx.inc b/befpc/compiler/msgidx.inc new file mode 100644 index 0000000..16eaebb --- /dev/null +++ b/befpc/compiler/msgidx.inc @@ -0,0 +1,545 @@ +const + general_t_compilername=01000; + general_d_sourceos=01001; + general_i_targetos=01002; + general_t_exepath=01003; + general_t_unitpath=01004; + general_t_includepath=01005; + general_t_librarypath=01006; + general_t_objectpath=01007; + general_i_abslines_compiled=01008; + general_f_no_memory_left=01009; + general_i_writingresourcefile=01010; + general_e_errorwritingresourcefile=01011; + scan_f_end_of_file=02000; + scan_f_string_exceeds_line=02001; + scan_f_illegal_char=02002; + scan_f_syn_expected=02003; + scan_t_start_include_file=02004; + scan_w_comment_level=02005; + scan_n_far_directive_ignored=02006; + scan_n_stack_check_global_under_linux=02007; + scan_n_ignored_switch=02008; + scan_w_illegal_switch=02009; + scan_w_switch_is_global=02010; + scan_e_illegal_char_const=02011; + scan_f_cannot_open_input=02012; + scan_f_cannot_open_includefile=02013; + scan_e_too_much_endifs=02014; + scan_w_only_pack_records=02015; + scan_w_only_pack_enum=02016; + scan_e_endif_expected=02017; + scan_e_preproc_syntax_error=02018; + scan_e_error_in_preproc_expr=02019; + scan_w_macro_cut_after_255_chars=02020; + scan_e_endif_without_if=02021; + scan_f_user_defined=02022; + scan_e_user_defined=02023; + scan_w_user_defined=02024; + scan_n_user_defined=02025; + scan_h_user_defined=02026; + scan_i_user_defined=02027; + scan_e_keyword_cant_be_a_macro=02028; + scan_f_macro_buffer_overflow=02029; + scan_w_macro_deep_ten=02030; + scan_e_wrong_styled_switch=02031; + scan_d_handling_switch=02032; + scan_c_endif_found=02033; + scan_c_ifdef_found=02034; + scan_c_ifopt_found=02035; + scan_c_if_found=02036; + scan_c_ifndef_found=02037; + scan_c_else_found=02038; + scan_c_skipping_until=02039; + scan_i_press_enter=02040; + scan_w_unsupported_switch=02041; + scan_w_illegal_directive=02042; + scan_t_back_in=02043; + scan_w_unsupported_app_type=02044; + scan_w_app_type_not_support=02045; + scan_w_decription_not_support=02046; + scan_n_version_not_support=02047; + scan_n_only_exe_version=02048; + scan_w_wrong_version_ignored=02049; + scan_w_unsupported_asmmode_specifier=02050; + scan_w_no_asm_reader_switch_inside_asm=02051; + scan_e_wrong_switch_toggle=02052; + scan_e_resourcefiles_not_supported=02053; + scan_w_include_env_not_found=02054; + scan_e_invalid_maxfpureg_value=02055; + scan_w_only_one_resourcefile_supported=02056; + parser_e_syntax_error=03000; + parser_w_proc_far_ignored=03001; + parser_w_proc_near_ignored=03002; + parser_w_proc_interrupt_ignored=03003; + parser_e_dont_nest_interrupt=03004; + parser_w_proc_directive_ignored=03005; + parser_e_no_overload_for_all_procs=03006; + parser_e_no_dll_file_specified=03007; + parser_e_export_name_double=03008; + parser_e_export_ordinal_double=03009; + parser_e_export_invalid_index=03010; + parser_w_parser_reloc_no_debug=03011; + parser_w_parser_win32_debug_needs_WN=03012; + parser_e_constructorname_must_be_init=03013; + parser_e_destructorname_must_be_done=03014; + parser_e_illegal_open_parameter=03015; + parser_e_proc_inline_not_supported=03016; + parser_w_priv_meth_not_virtual=03017; + parser_w_constructor_should_be_public=03018; + parser_w_destructor_should_be_public=03019; + parser_n_only_one_destructor=03020; + parser_e_no_local_objects=03021; + parser_f_no_anonym_objects=03022; + parser_object_has_no_vmt=03023; + parser_e_illegal_parameter_list=03024; + parser_e_wrong_parameter_type=03025; + parser_e_wrong_parameter_size=03026; + parser_e_overloaded_no_procedure=03027; + parser_e_overloaded_have_same_parameters=03028; + parser_e_header_dont_match_forward=03029; + parser_e_header_different_var_names=03030; + parser_n_duplicate_enum=03031; + parser_n_interface_name_diff_implementation_name=03032; + parser_e_no_with_for_variable_in_other_segments=03033; + parser_e_too_much_lexlevel=03034; + parser_e_range_check_error=03035; + parser_w_range_check_error=03036; + parser_e_double_caselabel=03037; + parser_e_case_lower_less_than_upper_bound=03038; + parser_e_type_const_not_possible=03039; + parser_e_no_overloaded_procvars=03040; + parser_e_invalid_string_size=03041; + parser_w_use_extended_syntax_for_objects=03042; + parser_w_no_new_dispose_on_void_pointers=03043; + parser_e_no_new_dispose_on_void_pointers=03044; + parser_e_class_id_expected=03045; + parser_e_no_type_not_allowed_here=03046; + parser_e_methode_id_expected=03047; + parser_e_header_dont_match_any_member=03048; + parser_p_procedure_start=03049; + parser_e_error_in_real=03050; + parser_e_fail_only_in_constructor=03051; + parser_e_no_paras_for_destructor=03052; + parser_e_only_class_methods_via_class_ref=03053; + parser_e_only_class_methods=03054; + parser_e_case_mismatch=03055; + parser_e_illegal_symbol_exported=03056; + parser_w_should_use_override=03057; + parser_e_nothing_to_be_overridden=03058; + parser_e_no_procedure_to_access_property=03059; + parser_w_stored_not_implemented=03060; + parser_e_ill_property_access_sym=03061; + parser_e_cant_access_protected_member=03062; + parser_e_cant_access_private_member=03063; + parser_w_overloaded_are_not_both_virtual=03064; + parser_w_overloaded_are_not_both_non_virtual=03065; + parser_e_overloaded_methodes_not_same_ret=03066; + parser_e_dont_nest_export=03067; + parser_e_methods_dont_be_export=03068; + parser_e_call_by_ref_without_typeconv=03069; + parser_e_no_super_class=03070; + parser_e_self_not_in_method=03071; + parser_e_generic_methods_only_in_methods=03072; + parser_e_illegal_colon_qualifier=03073; + parser_e_illegal_set_expr=03074; + parser_e_pointer_to_class_expected=03075; + parser_e_expr_have_to_be_constructor_call=03076; + parser_e_expr_have_to_be_destructor_call=03077; + parser_e_invalid_record_const=03078; + parser_e_false_with_expr=03079; + parser_e_void_function=03080; + parser_e_constructors_always_objects=03081; + parser_e_operator_not_overloaded=03082; + parser_e_no_such_assignment=03083; + parser_e_overload_impossible=03084; + parser_e_no_reraise_possible=03085; + parser_e_no_new_or_dispose_for_classes=03086; + parser_e_asm_incomp_with_function_return=03087; + parser_e_procedure_overloading_is_off=03088; + parser_e_overload_operator_failed=03089; + parser_e_comparative_operator_return_boolean=03090; + parser_e_only_virtual_methods_abstract=03091; + parser_f_unsupported_feature=03092; + parser_e_mix_of_classes_and_objects=03093; + parser_w_unknown_proc_directive_ignored=03094; + parser_e_absolute_only_one_var=03095; + parser_e_absolute_only_to_var_or_const=03096; + parser_e_initialized_only_one_var=03097; + parser_e_abstract_no_definition=03098; + parser_e_overloaded_must_be_all_global=03099; + parser_w_virtual_without_constructor=03100; + parser_m_macro_defined=03101; + parser_m_macro_undefined=03102; + parser_m_macro_set_to=03103; + parser_i_compiling=03104; + parser_u_parsing_interface=03105; + parser_u_parsing_implementation=03106; + parser_d_compiling_second_time=03107; + parser_e_no_paras_allowed=03108; + parser_e_no_property_found_to_override=03109; + parser_e_only_one_default_property=03110; + parser_e_property_need_paras=03111; + parser_e_constructor_cannot_be_not_virtual=03112; + parser_e_no_default_property_available=03113; + parser_e_cant_have_published=03114; + parser_e_forward_declaration_must_be_resolved=03115; + parser_e_no_local_operator=03116; + parser_e_proc_dir_not_allowed_in_interface=03117; + parser_e_proc_dir_not_allowed_in_implementation=03118; + parser_e_proc_dir_not_allowed_in_procvar=03119; + parser_e_function_already_declared_public_forward=03120; + parser_e_not_external_and_export=03121; + parser_e_name_keyword_expected=03122; + parser_w_not_supported_for_inline=03123; + parser_w_inlining_disabled=03124; + parser_i_writing_browser_log=03125; + parser_h_maybe_deref_caret_missing=03126; + parser_f_assembler_reader_not_supported=03127; + parser_e_proc_dir_conflict=03128; + parser_e_call_convention_dont_match_forward=03129; + parser_e_register_calling_not_supported=03130; + parser_e_property_cant_have_a_default_value=03131; + parser_e_property_default_value_must_const=03132; + parser_e_cant_publish_that=03133; + parser_e_cant_publish_that_property=03134; + parser_w_empty_import_name=03135; + parser_e_empty_import_name=03136; + parser_e_used_proc_name_changed=03137; + parser_e_division_by_zero=03138; + parser_e_invalid_float_operation=03139; + parser_e_array_lower_less_than_upper_bound=03140; + parser_w_string_too_long=03141; + parser_e_string_larger_array=03142; + parser_e_ill_msg_expr=03143; + parser_e_ill_msg_param=03144; + parser_e_duplicate_message_label=03145; + parser_e_self_in_non_message_handler=03146; + parser_e_threadvars_only_sg=03147; + parser_f_direct_assembler_not_allowed=03148; + parser_w_no_objpas_use_mode=03149; + parser_e_no_object_override=03150; + parser_e_cant_use_inittable_here=03151; + parser_e_resourcestring_only_sg=03152; + parser_e_exit_with_argument_not__possible=03153; + parser_e_stored_property_must_be_boolean=03154; + parser_e_ill_property_storage_sym=03155; + parser_e_only_publishable_classes_can__be_published=03156; + parser_e_proc_directive_expected=03157; + parser_e_invalid_property_index_value=03158; + parser_e_procname_to_short_for_export=03159; + parser_e_dlltool_unit_var_problem=03160; + parser_e_dlltool_unit_var_problem2=03161; + type_e_mismatch=04000; + type_e_incompatible_types=04001; + type_e_not_equal_types=04002; + type_e_type_id_expected=04003; + type_e_variable_id_expected=04004; + type_e_integer_expr_expected=04005; + type_e_boolean_expr_expected=04006; + type_e_ordinal_expr_expected=04007; + type_e_pointer_type_expected=04008; + type_e_class_type_expected=04009; + type_e_varid_or_typeid_expected=04010; + type_e_cant_eval_constant_expr=04011; + type_e_set_element_are_not_comp=04012; + type_e_set_operation_unknown=04013; + type_w_convert_real_2_comp=04014; + type_h_use_div_for_int=04015; + type_e_strict_var_string_violation=04016; + type_e_succ_and_pred_enums_with_assign_not_possible=04017; + type_e_cant_read_write_type=04018; + type_e_no_readln_writeln_for_typed_file=04019; + type_e_no_read_write_for_untyped_file=04020; + type_e_typeconflict_in_set=04021; + type_w_maybe_wrong_hi_lo=04022; + type_e_integer_or_real_expr_expected=04023; + type_e_wrong_type_in_array_constructor=04024; + type_e_wrong_parameter_type=04025; + type_e_no_method_and_procedure_not_compatible=04026; + type_e_wrong_math_argument=04027; + type_e_no_addr_of_constant=04028; + type_e_argument_cant_be_assigned=04029; + type_e_cannot_local_proc_to_procvar=04030; + type_e_no_assign_to_addr=04031; + type_e_no_assign_to_const=04032; + sym_e_id_not_found=05000; + sym_f_internal_error_in_symtablestack=05001; + sym_e_duplicate_id=05002; + sym_h_duplicate_id_where=05003; + sym_e_unknown_id=05004; + sym_e_forward_not_resolved=05005; + sym_f_id_already_typed=05006; + sym_e_error_in_type_def=05007; + sym_e_type_id_not_defined=05008; + sym_e_forward_type_not_resolved=05009; + sym_e_only_static_in_static=05010; + sym_e_invalid_call_tvarsymmangledname=05011; + sym_f_type_must_be_rec_or_class=05012; + sym_e_no_instance_of_abstract_object=05013; + sym_w_label_not_defined=05014; + sym_e_label_used_and_not_defined=05015; + sym_e_ill_label_decl=05016; + sym_e_goto_and_label_not_supported=05017; + sym_e_label_not_found=05018; + sym_e_id_is_no_label_id=05019; + sym_e_label_already_defined=05020; + sym_e_ill_type_decl_set=05021; + sym_e_class_forward_not_resolved=05022; + sym_n_unit_not_used=05023; + sym_h_para_identifier_not_used=05024; + sym_n_local_identifier_not_used=05025; + sym_h_para_identifier_only_set=05026; + sym_n_local_identifier_only_set=05027; + sym_h_local_symbol_not_used=05028; + sym_n_private_identifier_not_used=05029; + sym_n_private_identifier_only_set=05030; + sym_n_private_method_not_used=05031; + sym_e_set_expected=05032; + sym_w_function_result_not_set=05033; + sym_w_wrong_C_pack=05034; + sym_e_illegal_field=05035; + sym_n_uninitialized_local_variable=05036; + sym_n_uninitialized_variable=05037; + sym_e_id_no_member=05038; + sym_b_param_list=05039; + sym_e_segment_too_large=05040; + cg_e_break_not_allowed=06000; + cg_e_continue_not_allowed=06001; + cg_e_too_complex_expr=06002; + cg_e_illegal_expression=06003; + cg_e_invalid_integer=06004; + cg_e_invalid_qualifier=06005; + cg_e_upper_lower_than_lower=06006; + cg_e_illegal_count_var=06007; + cg_e_cant_choose_overload_function=06008; + cg_e_parasize_too_big=06009; + cg_e_illegal_type_conversion=06010; + cg_d_pointer_to_longint_conv_not_portable=06011; + cg_e_file_must_call_by_reference=06012; + cg_e_cant_use_far_pointer_there=06013; + cg_e_var_must_be_reference=06014; + cg_e_dont_call_exported_direct=06015; + cg_w_member_cd_call_from_method=06016; + cg_n_inefficient_code=06017; + cg_w_unreachable_code=06018; + cg_e_stackframe_with_esp=06019; + cg_e_cant_call_abstract_method=06020; + cg_f_internal_error_in_getfloatreg=06021; + cg_f_unknown_float_type=06022; + cg_f_secondvecn_base_defined_twice=06023; + cg_f_extended_cg68k_not_supported=06024; + cg_f_32bit_not_supported_in_68000=06025; + cg_f_internal_error_in_secondinline=06026; + cg_d_register_weight=06027; + cg_e_stacklimit_in_local_routine=06028; + cg_d_stackframe_omited=06029; + cg_w_64bit_range_check_not_supported=06030; + cg_e_unable_inline_object_methods=06031; + cg_e_unable_inline_procvar=06032; + cg_e_no_code_for_inline_stored=06033; + cg_e_no_call_to_interrupt=06034; + cg_e_can_access_element_zero=06035; + cg_e_include_not_implemented=06036; + cg_e_cannot_call_cons_dest_inside_with=06037; + cg_e_cannot_call_message_direct=06038; + cg_e_goto_inout_of_exception_block=06039; + cg_e_control_flow_outside_finally=06040; + asmr_d_start_reading=07000; + asmr_d_finish_reading=07001; + asmr_e_none_label_contain_at=07002; + asmr_w_override_op_not_supported=07003; + asmr_e_building_record_offset=07004; + asmr_e_offset_without_identifier=07005; + asmr_e_type_without_identifier=07006; + asmr_e_no_local_or_para_allowed=07007; + asmr_e_need_offset=07008; + asmr_e_need_dollar=07009; + asmr_e_cant_have_multiple_relocatable_symbols=07010; + asmr_e_only_add_relocatable_symbol=07011; + asmr_e_invalid_constant_expression=07012; + asmr_e_relocatable_symbol_not_allowed=07013; + asmr_e_invalid_reference_syntax=07014; + asmr_e_local_para_unreachable=07015; + asmr_e_local_label_not_allowed_as_ref=07016; + asmr_e_wrong_base_index=07017; + asmr_w_possible_object_field_bug=07018; + asmr_e_wrong_scale_factor=07019; + asmr_e_multiple_index=07020; + asmr_e_invalid_operand_type=07021; + asmr_e_invalid_string_as_opcode_operand=07022; + asmr_w_CODE_and_DATA_not_supported=07023; + asmr_e_null_label_ref_not_allowed=07024; + asmr_e_expr_zero_divide=07025; + asmr_e_expr_illegal=07026; + asmr_e_escape_seq_ignored=07027; + asmr_e_invalid_symbol_ref=07028; + asmr_w_fwait_emu_prob=07029; + asmr_w_fadd_to_faddp=07030; + asmr_w_enter_not_supported_by_linux=07031; + asmr_w_calling_overload_func=07032; + asmr_e_unsupported_symbol_type=07033; + asmr_e_constant_out_of_bounds=07034; + asmr_e_error_converting_decimal=07035; + asmr_e_error_converting_octal=07036; + asmr_e_error_converting_binary=07037; + asmr_e_error_converting_hexadecimal=07038; + asmr_h_direct_global_to_mangled=07039; + asmr_w_direct_global_is_overloaded_func=07040; + asmr_e_cannot_use_SELF_outside_a_method=07041; + asmr_e_cannot_use_OLDEBP_outside_nested_procedure=07042; + asmr_e_void_function=07043; + asmr_e_SEG_not_supported=07044; + asmr_e_size_suffix_and_dest_dont_match=07045; + asmr_w_size_suffix_and_dest_dont_match=07046; + asmr_e_syntax_error=07047; + asmr_e_invalid_opcode_and_operand=07048; + asmr_e_syn_operand=07049; + asmr_e_syn_constant=07050; + asmr_e_invalid_string_expression=07051; + asmr_w_const32bit_for_address=07052; + asmr_e_unknown_opcode=07053; + asmr_e_invalid_or_missing_opcode=07054; + asmr_e_invalid_prefix_and_opcode=07055; + asmr_e_invalid_override_and_opcode=07056; + asmr_e_too_many_operands=07057; + asmr_w_near_ignored=07058; + asmr_w_far_ignored=07059; + asmr_e_dup_local_sym=07060; + asmr_e_unknown_local_sym=07061; + asmr_e_unknown_label_identifier=07062; + asmr_e_invalid_register=07063; + asmr_e_invalid_fpu_register=07064; + asmr_e_nor_not_supported=07065; + asmr_w_modulo_not_supported=07066; + asmr_e_invalid_float_const=07067; + asmr_e_invalid_float_expr=07068; + asmr_e_wrong_sym_type=07069; + asmr_e_cannot_index_relative_var=07070; + asmr_e_invalid_seg_override=07071; + asmr_w_id_supposed_external=07072; + asmr_e_string_not_allowed_as_const=07073; + asmr_e_no_var_type_specified=07074; + asmr_w_assembler_code_not_returned_to_text=07075; + asmr_e_not_directive_or_local_symbol=07076; + asmr_w_using_defined_as_local=07077; + asmr_e_dollar_without_identifier=07078; + asmr_w_32bit_const_for_address=07079; + asmr_n_align_is_target_specific=07080; + asmr_e_cannot_access_field_directly_for_parameters=07081; + asmr_e_cannot_access_object_field_directly=07082; + asmw_f_too_many_asm_files=08000; + asmw_f_assembler_output_not_supported=08001; + asmw_f_comp_not_supported=08002; + asmw_f_direct_not_supported=08003; + asmw_e_alloc_data_only_in_bss=08004; + asmw_f_no_binary_writer_selected=08005; + asmw_e_opcode_not_in_table=08006; + asmw_e_invalid_opcode_and_operands=08007; + asmw_e_16bit_not_supported=08008; + asmw_e_invalid_effective_address=08009; + asmw_e_immediate_or_reference_expected=08010; + asmw_e_value_exceeds_bounds=08011; + asmw_e_short_jmp_out_of_range=08012; + asmw_e_undefined_label=08013; + exec_w_source_os_redefined=09000; + exec_i_assembling_pipe=09001; + exec_d_cant_create_asmfile=09002; + exec_e_cant_create_objectfile=09003; + exec_e_cant_create_archivefile=09004; + exec_w_assembler_not_found=09005; + exec_t_using_assembler=09006; + exec_w_error_while_assembling=09007; + exec_w_cant_call_assembler=09008; + exec_i_assembling=09009; + exec_i_assembling_smart=09010; + exec_w_objfile_not_found=09011; + exec_w_libfile_not_found=09012; + exec_w_error_while_linking=09013; + exec_w_cant_call_linker=09014; + exec_i_linking=09015; + exec_w_util_not_found=09016; + exec_t_using_util=09017; + exec_e_exe_not_supported=09018; + exec_e_dll_not_supported=09019; + exec_i_closing_script=09020; + exec_w_res_not_found=09021; + exec_i_compilingresource=09022; + execinfo_f_cant_process_executable=09023; + execinfo_f_cant_open_executable=09024; + execinfo_x_codesize=09025; + execinfo_x_initdatasize=09026; + execinfo_x_uninitdatasize=09027; + execinfo_x_stackreserve=09028; + execinfo_x_stackcommit=09029; + unit_t_unitsearch=10000; + unit_t_ppu_loading=10001; + unit_u_ppu_name=10002; + unit_u_ppu_flags=10003; + unit_u_ppu_crc=10004; + unit_u_ppu_time=10005; + unit_u_ppu_file_too_short=10006; + unit_u_ppu_invalid_header=10007; + unit_u_ppu_invalid_version=10008; + unit_u_ppu_invalid_processor=10009; + unit_u_ppu_invalid_target=10010; + unit_u_ppu_source=10011; + unit_u_ppu_write=10012; + unit_f_ppu_cannot_write=10013; + unit_f_ppu_read_error=10014; + unit_f_ppu_read_unexpected_end=10015; + unit_f_ppu_invalid_entry=10016; + unit_f_ppu_dbx_count_problem=10017; + unit_e_illegal_unit_name=10018; + unit_f_too_much_units=10019; + unit_f_circular_unit_reference=10020; + unit_f_cant_compile_unit=10021; + unit_f_cant_find_ppu=10022; + unit_w_unit_name_error=10023; + unit_f_unit_name_error=10024; + unit_w_switch_us_missed=10025; + unit_f_errors_in_unit=10026; + unit_u_load_unit=10027; + unit_u_recompile_crc_change=10028; + unit_u_recompile_source_found_alone=10029; + unit_u_recompile_staticlib_is_older=10030; + unit_u_recompile_sharedlib_is_older=10031; + unit_u_recompile_obj_and_asm_older=10032; + unit_u_recompile_obj_older_than_asm=10033; + unit_u_start_parse_interface=10034; + unit_u_start_parse_implementation=10035; + unit_u_second_load_unit=10036; + unit_u_check_time=10037; + option_usage=11000; + option_only_one_source_support=11001; + option_def_only_for_os2=11002; + option_no_nested_response_file=11003; + option_no_source_found=11004; + option_no_option_found=11005; + option_illegal_para=11006; + option_help_pages_para=11007; + option_too_many_cfg_files=11008; + option_unable_open_file=11009; + option_reading_further_from=11010; + option_target_is_already_set=11011; + option_no_shared_lib_under_dos=11012; + option_too_many_ifdef=11013; + option_too_many_endif=11014; + option_too_less_endif=11015; + option_no_debug_support=11016; + option_no_debug_support_recompile_fpc=11017; + option_obsolete_switch=11018; + option_obsolete_switch_use_new=11019; + option_switch_bin_to_src_assembler=11020; + option_incompatible_asm=11021; + option_asm_forced=11022; + option_logo=11023; + option_info=11024; + option_help_pages=11025; + + MsgTxtSize = 30122; + + MsgIdxMax : array[1..20] of longint=( + 12,57,162,33,41,41,83,14,30,38, + 26,1,1,1,1,1,1,1,1,1 + ); diff --git a/befpc/compiler/msgtxt.inc b/befpc/compiler/msgtxt.inc new file mode 100644 index 0000000..076aafa --- /dev/null +++ b/befpc/compiler/msgtxt.inc @@ -0,0 +1,740 @@ +{$ifdef Delphi} +const msgtxt : array[0..000125] of string[240]=( +{$else Delphi} +const msgtxt : array[0..000125,1..240] of char=( +{$endif Delphi} + '01000_T_Compiler: $1'#000+ + '01001_D_Compiler OS: $1'#000+ + '01002_I_Target OS: $1'#000+ + '01003_T_Using executable path: $1'#000+ + '01004_T_Using unit path: $1'#000+ + '01005_T_Using include path: $1'#000+ + '01006_T_Using library path: $1'#000+ + '01007_T_Using object path: $1'#000+ + '01008_I_$1 Lines co','mpiled, $2 sec'#000+ + '01009_F_No memory left'#000+ + '01010_I_Writing Resource String Table file: $1'#000+ + '01011_E_Writing Resource String Table file: $1'#000+ + '02000_F_Unexpected end of file'#000+ + '02001_F_String exceeds line'#000+ + '02002_F_illegal character $1 ($2)'#000+ + '02003_F_Syntax ','error, $1 expected but $2 found'#000+ + '02004_T_Start reading includefile $1'#000+ + '02005_W_Comment level $1 found'#000+ + '02006_N_$F directive (FAR) ignored'#000+ + '02007_N_Stack check is global under Linux'#000+ + '02008_N_Ignored compiler switch $1'#000+ + '02009_W_Illegal compiler swi','tch $1'#000+ + '02010_W_This compiler switch has a global effect'#000+ + '02011_E_Illegal char constant'#000+ + '02012_F_Can'#039't open file $1'#000+ + '02013_F_Can'#039't open include file $1'#000+ + '02014_E_Too many $ENDIFs or $ELSEs'#000+ + '02015_W_Records fields can be aligned to 1,2,4,8,16 or 32',' bytes only'+ + #000+ + '02016_W_Enumerated can be saved in 1,2 or 4 bytes only'#000+ + '02017_E_$ENDIF expected for $1 $2 defined in line $3'#000+ + '02018_E_Syntax error while parsing a conditional compiling expression'#000+ + '02019_E_Evaluating a conditional compiling express','ion'#000+ + '02020_W_Macro contents is cut after char 255 to evalute expression'#000+ + '02021_E_ENDIF without IF(N)DEF'#000+ + '02022_F_User defined: $1'#000+ + '02023_E_User defined: $1'#000+ + '02024_W_User defined: $1'#000+ + '02025_N_User defined: $1'#000+ + '02026_H_User defined: $1'#000+ + '02027_I_User ','defined: $1'#000+ + '02028_E_Keyword redefined as macro has no effect'#000+ + '02029_F_Macro buffer overflow while reading or expanding a macro'#000+ + '02030_W_Extension of macros exceeds a deep of 16.'#000+ + '02031_E_compiler switches aren'#039't allowed in (* ... *) styled com','m'+ + 'ents'#000+ + '02032_D_Handling switch "$1"'#000+ + '02033_C_ENDIF $1 found'#000+ + '02034_C_IFDEF $1 found, $2'#000+ + '02035_C_IFOPT $1 found, $2'#000+ + '02036_C_IF $1 found, $2'#000+ + '02037_C_IFNDEF $1 found, $2'#000+ + '02038_C_ELSE $1 found, $2'#000+ + '02039_C_Skipping until...'#000+ + '02040_I_Press t','o continue'#000+ + '02041_W_Unsupported switch $1'#000+ + '02042_W_Illegal compiler directive $1'#000+ + '02043_T_Back in $1'#000+ + '02044_W_Unsupported application type: $1'#000+ + '02045_W_APPTYPE isn'#039't support by the target OS'#000+ + '02046_W_DESCRIPTION is only supported for OS2 and Win3','2'#000+ + '02047_N_VERSION is not supported by target OS.'#000+ + '02048_N_VERSION only for exes or DLLs'#000+ + '02049_W_Wrong format for VERSION directive $1'#000+ + '02050_W_Unsupported assembler style specified $1'#000+ + '02051_W_ASM reader switch is not possible inside asm state','ment, $1 w'+ + 'ill be effective only for next'#000+ + '02052_E_Wrong switch toggle, use ON/OFF or +/-'#000+ + '02053_E_Resource files are not supported for this target'#000+ + '02054_W_Include environment $1 not found in environment'#000+ + '02055_E_Illegal value for FPU register ','limit'#000+ + '02056_W_Only one resource file is supported for this target'#000+ + '03000_E_Parser - Syntax Error'#000+ + '03001_W_Procedure type FAR ignored'#000+ + '03002_W_Procedure type NEAR ignored'#000+ + '03003_W_Procedure type INTERRUPT ignored for not i386'#000+ + '03004_E_INTERRUPT p','rocedure can'#039't be nested'#000+ + '03005_W_Procedure type $1 ignored'#000+ + '03006_E_Not all declarations of $1 are declared with OVERLOAD'#000+ + '03007_E_No DLL File specified'#000+ + '03008_E_Duplicate exported function name $1'#000+ + '03009_E_Duplicate exported function index $1'#000, + '03010_E_Invalid index for exported function'#000+ + '03011_W_Relocatable DLL or executable $1 debug info does not work, dis'+ + 'abled.'#000+ + '03012_W_To allow debugging for win32 code you need to disable relocati'+ + 'on with -WN option'#000+ + '03013_E_Constructor name must ','be INIT'#000+ + '03014_E_Destructor name must be DONE'#000+ + '03015_E_Illegal open parameter'#000+ + '03016_E_Procedure type INLINE not supported'#000+ + '03017_W_Private methods shouldn'#039't be VIRTUAL'#000+ + '03018_W_Constructor should be public'#000+ + '03019_W_Destructor should be public'#000+ + '03','020_N_Class should have one destructor only'#000+ + '03021_E_Local class definitions are not allowed'#000+ + '03022_F_Anonym class definitions are not allowed'#000+ + '03023_E_The object $1 has no VMT'#000+ + '03024_E_Illegal parameter list'#000+ + '03025_E_Wrong parameter type specif','ied for arg no. $1'#000+ + '03026_E_Wrong amount of parameters specified'#000+ + '03027_E_overloaded identifier $1 isn'#039't a function'#000+ + '03028_E_overloaded functions have the same parameter list'#000+ + '03029_E_function header doesn'#039't match the forward declaration $1'#000+ + '030','30_E_function header $1 doesn'#039't match forward : var name chan'+ + 'ges $2 => $3'#000+ + '03031_N_Values in enumeration types have to be ascending'#000+ + '03032_N_Interface and implementation names are different $1 => $2'#000+ + '03033_E_With can not be used for variables ','in a different segment'#000+ + '03034_E_function nesting > 31'#000+ + '03035_E_range check error while evaluating constants'#000+ + '03036_W_range check error while evaluating constants'#000+ + '03037_E_duplicate case label'#000+ + '03038_E_Upper bound of case range is less than lower',' bound'#000+ + '03039_E_typed constants of classes are not allowed'#000+ + '03040_E_functions variables of overloaded functions are not allowed'#000+ + '03041_E_string length must be a value from 1 to 255'#000+ + '03042_W_use extended syntax of NEW and DISPOSE for instances o','f obje'+ + 'cts'#000+ + '03043_W_use of NEW or DISPOSE for untyped pointers is meaningless'#000+ + '03044_E_use of NEW or DISPOSE is not possible for untyped pointers'#000+ + '03045_E_class identifier expected'#000+ + '03046_E_type identifier not allowed here'#000+ + '03047_E_method identif','ier expected'#000+ + '03048_E_function header doesn'#039't match any method of this class'#000+ + '03049_P_procedure/function $1'#000+ + '03050_E_Illegal floating point constant'#000+ + '03051_E_FAIL can be used in constructors only'#000+ + '03052_E_Destructors can'#039't have parameters'#000+ + '03053_','E_Only class methods can be referred with class references'#000+ + '03054_E_Only class methods can be accessed in class methods'#000+ + '03055_E_Constant and CASE types do not match'#000+ + '03056_E_The symbol can'#039't be exported from a library'#000+ + '03057_W_An inherited met','hod is hidden by $1'#000+ + '03058_E_There is no method in an ancestor class to be overridden: $1'#000+ + '03059_E_No member is provided to access property'#000+ + '03060_W_Stored prorperty directive is not yet implemented'#000+ + '03061_E_Illegal symbol for property access'#000+ + '0','3062_E_Cannot access a protected field of an object here'#000+ + '03063_E_Cannot access a private field of an object here'#000+ + '03064_W_overloaded method of virtual method should be virtual: $1'#000+ + '03065_W_overloaded method of non-virtual method should be non','-virtua'+ + 'l: $1'#000+ + '03066_E_overloaded methods which are virtual must have the same return'+ + ' type: $1'#000+ + '03067_E_EXPORT declared functions can'#039't be nested'#000+ + '03068_E_methods can'#039't be EXPORTed'#000+ + '03069_E_call by var parameters have to match exactly: Got $1 ex','pecte'+ + 'd $2'#000+ + '03070_E_Class isn'#039't a parent class of the current class'#000+ + '03071_E_SELF is only allowed in methods'#000+ + '03072_E_methods can be only in other methods called direct with type i'+ + 'dentifier of the class'#000+ + '03073_E_Illegal use of '#039':'#039#000+ + '03074_E_range ','check error in set constructor or duplicate set elemen'+ + 't'#000+ + '03075_E_Pointer to object expected'#000+ + '03076_E_Expression must be constructor call'#000+ + '03077_E_Expression must be destructor call'#000+ + '03078_E_Illegal order of record elements'#000+ + '03079_E_Expression ty','pe must be class or record type'#000+ + '03080_E_Procedures can'#039't return a value'#000+ + '03081_E_constructors and destructors must be methods'#000+ + '03082_E_Operator is not overloaded'#000+ + '03083_E_Impossible to overload assignment for equal types'#000+ + '03084_E_Impossible ope','rator overload'#000+ + '03085_E_Re-raise isn'#039't possible there'#000+ + '03086_E_The extended syntax of new or dispose isn'#039't allowed for a '+ + 'class'#000+ + '03087_E_Assembler incompatible with function return type'#000+ + '03088_E_Procedure overloading is switched off'#000+ + '03089_E_It i','s not possible to overload this operator (overload = ins'+ + 'tead)'#000+ + '03090_E_Comparative operator must return a boolean value'#000+ + '03091_E_Only virtual methods can be abstract'#000+ + '03092_F_Use of unsupported feature!'#000+ + '03093_E_The mix of CLASSES and OBJECTS i','sn'#039't allowed'#000+ + '03094_W_Unknown procedure directive had to be ignored: $1'#000+ + '03095_E_absolute can only be associated to ONE variable'#000+ + '03096_E_absolute can only be associated a var or const'#000+ + '03097_E_Only ONE variable can be initialized'#000+ + '03098_E_Abstr','act methods shouldn'#039't have any definition (with fun'+ + 'ction body)'#000+ + '03099_E_This overloaded function can'#039't be local (must be exported)'+ + #000+ + '03100_W_Virtual methods are used without a constructor in $1'#000+ + '03101_M_Macro defined: $1'#000+ + '03102_M_Macro undefined',': $1'#000+ + '03103_M_Macro $1 set to $2'#000+ + '03104_I_Compiling $1'#000+ + '03105_U_Parsing interface of unit $1'#000+ + '03106_U_Parsing implementation of $1'#000+ + '03107_D_Compiling $1 for the second time'#000+ + '03108_E_Array properties aren'#039't allowed here'#000+ + '03109_E_No property found t','o override'#000+ + '03110_E_Only one default property is allowed, found inherited default '+ + 'property in class $1'#000+ + '03111_E_The default property must be an array property'#000+ + '03112_E_Virtual constructors are only supported in class object model'#000+ + '03113_E_No de','fault property available'#000+ + '03114_E_The class can'#039't have a published section, use the {$M+} sw'+ + 'itch'#000+ + '03115_E_Forward declaration of class $1 must be resolved here to use t'+ + 'he class as ancestor'#000+ + '03116_E_Local operators not supported'#000+ + '03117_E_Procedu','re directive $1 not allowed in interface section'#000+ + '03118_E_Procedure directive $1 not allowed in implementation section'#000+ + '03119_E_Procedure directive $1 not allowed in procvar declaration'#000+ + '03120_E_Function is already declared Public/Forward $1'#000+ + '0','3121_E_Can'#039't use both EXPORT and EXTERNAL'#000+ + '03122_E_NAME keyword expected'#000+ + '03123_W_$1 not yet supported inside inline procedure/function'#000+ + '03124_W_Inlining disabled'#000+ + '03125_I_Writing Browser log $1'#000+ + '03126_H_may be pointer dereference is missing'#000+ + '031','27_F_Selected assembler reader not supported'#000+ + '03128_E_Procedure directive $1 has conflicts with other directives'#000+ + '03129_E_Calling convention doesn'#039't match forward'#000+ + '03130_E_Register calling (fastcall) not supported'#000+ + '03131_E_Property can'#039't have a',' default value'#000+ + '03132_E_The default value of a property must be constant'#000+ + '03133_E_Symbol can'#039't be published, can be only a class'#000+ + '03134_E_That kind of property can'#039't be published'#000+ + '03135_W_Empty import name specified'#000+ + '03136_W_An import name is re','quired'#000+ + '03137_E_Function internal name changed after use of function'#000+ + '03138_E_Division by zero'#000+ + '03139_E_Invalid floating point operation'#000+ + '03140_E_Upper bound of range is less than lower bound'#000+ + '03141_W_string "$1" is longer than $2'#000+ + '03142_E_string',' length is larger than array of char length'#000+ + '03143_E_Illegal expression after message directive'#000+ + '03144_E_Message handlers can take only one call by ref. parameter'#000+ + '03145_E_Duplicate message label: $1'#000+ + '03146_E_Self can be only an explicit parame','ter in message handlers'#000+ + '03147_E_Threadvars can be only static or global'#000+ + '03148_F_Direct assembler not supported for binary output format'#000+ + '03149_W_Don'#039't load OBJPAS unit manual, use {$mode objfpc} or {$mod'+ + 'e delphi} instead'#000+ + '03150_E_OVERRIDE can',#039't be used in objects'#000+ + '03151_E_Data types which requires initialization/finalization can'#039't'+ + ' be used in variant records'#000+ + '03152_E_Resourcestrings can be only static or global'#000+ + '03153_E_Exit with argument can'#039't be used here'#000+ + '03154_E_The type of the ','storage symbol must be boolean'#000+ + '03155_E_This symbol isn'#039't allowed as storage symbol'#000+ + '03156_E_Only class which are compiled in $M+ mode can be published'#000+ + '03157_E_Procedure directive expected'#000+ + '03158_E_The value for a property index must be of an ','ordinal type'#000+ + '03159_E_Procedure name to short to be exported'#000+ + '03160_E_No DEFFILE entry can be generated for unit global vars'#000+ + '03161_E_Compile without -WD option'#000+ + '04000_E_Type mismatch'#000+ + '04001_E_Incompatible types: got "$1" expected "$2"'#000+ + '04002_E_T','ype mismatch between $1 and $2'#000+ + '04003_E_Type identifier expected'#000+ + '04004_E_Variable identifier expected'#000+ + '04005_E_Integer expression expected, but got "$1"'#000+ + '04006_E_Boolean expression expected, but got "$1"'#000+ + '04007_E_Ordinal expression expected'#000+ + '040','08_E_pointer type expected, but got "$1"'#000+ + '04009_E_class type expected, but got "$1"'#000+ + '04010_E_Variable or type indentifier expected'#000+ + '04011_E_Can'#039't evaluate constant expression'#000+ + '04012_E_Set elements are not compatible'#000+ + '04013_E_Operation not implem','ented for sets'#000+ + '04014_W_Automatic type conversion from floating type to COMP which is '+ + 'an integer type'#000+ + '04015_H_use DIV instead to get an integer result'#000+ + '04016_E_string types doesn'#039't match, because of $V+ mode'#000+ + '04017_E_succ or pred on enums with',' assignments not possible'#000+ + '04018_E_Can'#039't read or write variables of this type'#000+ + '04019_E_Can'#039't use readln or writeln on typed file'#000+ + '04020_E_Can'#039't use read or write on untyped file.'#000+ + '04021_E_Type conflict between set elements'#000+ + '04022_W_lo/hi(dword/q','word) returns the upper/lower word/dword'#000+ + '04023_E_Integer or real expression expected'#000+ + '04024_E_Wrong type $1 in array constructor'#000+ + '04025_E_Incompatible type for arg no. $1: Got $2, expected $3'#000+ + '04026_E_Method (variable) and Procedure (variable)',' are not compatibl'+ + 'e'#000+ + '04027_E_Illegal constant passed to internal math function'#000+ + '04028_E_Can'#039't get the address of constants'#000+ + '04029_E_Argument can'#039't be assigned to'#000+ + '04030_E_Can'#039't assign local procedure/function to procedure variabl'+ + 'e'#000+ + '04031_E_Can'#039't',' assign values to an address'#000+ + '04032_E_Can'#039't assign values to const variable'#000+ + '05000_E_Identifier not found $1'#000+ + '05001_F_Internal Error in SymTableStack()'#000+ + '05002_E_Duplicate identifier $1'#000+ + '05003_H_Identifier already defined in $1 at line $2'#000+ + '05004_E','_Unknown identifier $1'#000+ + '05005_E_Forward declaration not solved $1'#000+ + '05006_F_Identifier type already defined as type'#000+ + '05007_E_Error in type definition'#000+ + '05008_E_Type identifier not defined'#000+ + '05009_E_Forward type not resolved $1'#000+ + '05010_E_Only static v','ariables can be used in static methods or outsi'+ + 'de methods'#000+ + '05011_E_Invalid call to tvarsym.mangledname()'#000+ + '05012_F_record or class type expected'#000+ + '05013_E_Instances of classes or objects with an abstract method are no'+ + 't allowed'#000+ + '05014_W_Label not ','defined $1'#000+ + '05015_E_Label used but not defined $1'#000+ + '05016_E_Illegal label declaration'#000+ + '05017_E_GOTO and LABEL are not supported (use switch -Sg)'#000+ + '05018_E_Label not found'#000+ + '05019_E_identifier isn'#039't a label'#000+ + '05020_E_label already defined'#000+ + '05021_E_ille','gal type declaration of set elements'#000+ + '05022_E_Forward class definition not resolved $1'#000+ + '05023_H_Unit $1 not used in $2'#000+ + '05024_H_Parameter $1 not used'#000+ + '05025_N_Local variable $1 not used'#000+ + '05026_H_Value parameter $1 is assigned but never used'#000+ + '0502','7_N_Local variable $1 is assigned but never used'#000+ + '05028_H_Local $1 $2 is not used'#000+ + '05029_N_Private field $1.$2 is never used'#000+ + '05030_N_Private field $1.$2 is assigned but never used'#000+ + '05031_N_Private method $1.$2 never used'#000+ + '05032_E_Set type expec','ted'#000+ + '05033_W_Function result does not seem to be set'#000+ + '05034_W_Type $1 is not aligned correctly in current record for C'#000+ + '05035_E_Unknown record field identifier $1'#000+ + '05036_W_Local variable $1 does not seem to be initialized'#000+ + '05037_W_Variable $1 do','es not seem to be initialized'#000+ + '05038_E_identifier idents no member $1'#000+ + '05039_B_Found declaration: $1'#000+ + '05040_E_Data segment too large (max. 2GB)'#000+ + '06000_E_BREAK not allowed'#000+ + '06001_E_CONTINUE not allowed'#000+ + '06002_E_Expression too complicated - FPU sta','ck overflow'#000+ + '06003_E_Illegal expression'#000+ + '06004_E_Invalid integer expression'#000+ + '06005_E_Illegal qualifier'#000+ + '06006_E_High range limit < low range limit'#000+ + '06007_E_Illegal counter variable'#000+ + '06008_E_Can'#039't determine which overloaded function to call'#000+ + '06009_','E_Parameter list size exceeds 65535 bytes'#000+ + '06010_E_Illegal type conversion'#000+ + '06011_D_Conversion between ordinals and pointers is not portable acros'+ + 's platforms'#000+ + '06012_E_File types must be var parameters'#000+ + '06013_E_The use of a far pointer isn'#039't all','owed there'#000+ + '06014_E_illegal call by reference parameters'#000+ + '06015_E_EXPORT declared functions can'#039't be called'#000+ + '06016_W_Possible illegal call of constructor or destructor (doesn'#039't'+ + ' match to this context)'#000+ + '06017_N_Inefficient code'#000+ + '06018_W_unreachabl','e code'#000+ + '06019_E_procedure call with stackframe ESP/SP'#000+ + '06020_E_Abstract methods can'#039't be called directly'#000+ + '06021_F_Internal Error in getfloatreg(), allocation failure'#000+ + '06022_F_Unknown float type'#000+ + '06023_F_SecondVecn() base defined twice'#000+ + '06024_F_Ex','tended cg68k not supported'#000+ + '06025_F_32-bit unsigned not supported in MC68000 mode'#000+ + '06026_F_Internal Error in secondinline()'#000+ + '06027_D_Register $1 weight $2 $3'#000+ + '06028_E_Stack limit excedeed in local routine'#000+ + '06029_D_Stack frame is omitted'#000+ + '06030_W_','Range check for 64 bit integers is not supported on this tar'+ + 'get'#000+ + '06031_E_Object or class methods can'#039't be inline.'#000+ + '06032_E_Procvar calls can'#039't be inline.'#000+ + '06033_E_No code for inline procedure stored'#000+ + '06034_E_Direct call of interrupt procedure $','1 is not possible'#000+ + '06035_E_Element zero of an ansi/wide- or longstring can'#039't be acces'+ + 'sed, use (set)length instead'#000+ + '06036_E_Include and exclude not implemented in this case'#000+ + '06037_E_Constructors or destructors can not be called inside a '#039'wi'+ + 'th'#039' ','clause'#000+ + '06038_E_Cannot call message handler method directly'#000+ + '06039_E_Jump in or outside of an exception block'#000+ + '06040_E_Control flow statements aren'#039't allowed in a finally block'#000+ + '07000_D_Starting $1 styled assembler parsing'#000+ + '07001_D_Finished $1 s','tyled assembler parsing'#000+ + '07002_E_Non-label pattern contains @'#000+ + '07003_W_Override operator not supported'#000+ + '07004_E_Error building record offset'#000+ + '07005_E_OFFSET used without identifier'#000+ + '07006_E_TYPE used without identifier'#000+ + '07007_E_Cannot use local v','ariable or parameters here'#000+ + '07008_E_need to use OFFSET here'#000+ + '07009_E_need to use $ here'#000+ + '07010_E_Cannot use multiple relocatable symbols'#000+ + '07011_E_Relocatable symbol can only be added'#000+ + '07012_E_Invalid constant expression'#000+ + '07013_E_Relocatable symbo','l is not allowed'#000+ + '07014_E_Invalid reference syntax'#000+ + '07015_E_You can not reach $1 from that code'#000+ + '07016_E_Local symbols/labels aren'#039't allowed as references'#000+ + '07017_E_Invalid base and index register usage'#000+ + '07018_W_Possible error in object field han','dling'#000+ + '07019_E_Wrong scale factor specified'#000+ + '07020_E_Multiple index register usage'#000+ + '07021_E_Invalid operand type'#000+ + '07022_E_Invalid string as opcode operand: $1'#000+ + '07023_W_@CODE and @DATA not supported'#000+ + '07024_E_Null label references are not allowed'#000+ + '0','7025_E_Divide by zero in asm evaluator'#000+ + '07026_E_Illegal expression'#000+ + '07027_E_escape sequence ignored: $1'#000+ + '07028_E_Invalid symbol reference'#000+ + '07029_W_Fwait can cause emulation problems with emu387'#000+ + '07030_W_FADD without operand translated into FADDP',#000+ + '07031_W_ENTER instruction is not supported by Linux kernel'#000+ + '07032_W_Calling an overload function in assembler'#000+ + '07033_E_Unsupported symbol type for operand'#000+ + '07034_E_Constant value out of bounds'#000+ + '07035_E_Error converting decimal $1'#000+ + '07036_E_Error',' converting octal $1'#000+ + '07037_E_Error converting binary $1'#000+ + '07038_E_Error converting hexadecimal $1'#000+ + '07039_H_$1 translated to $2'#000+ + '07040_W_$1 is associated to an overloaded function'#000+ + '07041_E_Cannot use SELF outside a method'#000+ + '07042_E_Cannot use OLDEB','P outside a nested procedure'#000+ + '07043_W_Procedures can'#039't return any value in asm code'#000+ + '07044_E_SEG not supported'#000+ + '07045_E_Size suffix and destination or source size do not match'#000+ + '07046_W_Size suffix and destination or source size do not match'#000+ + '070','47_E_Assembler syntax error'#000+ + '07048_E_Invalid combination of opcode and operands'#000+ + '07049_E_Assemler syntax error in operand'#000+ + '07050_E_Assemler syntax error in constant'#000+ + '07051_E_Invalid String expression'#000+ + '07052_bit constant created for address'#000+ + '07053','_E_Unrecognized opcode $1'#000+ + '07054_E_Invalid or missing opcode'#000+ + '07055_E_Invalid combination of prefix and opcode: $1'#000+ + '07056_E_Invalid combination of override and opcode: $1'#000+ + '07057_E_Too many operands on line'#000+ + '07058_W_NEAR ignored'#000+ + '07059_W_FAR ignor','ed'#000+ + '07060_E_Duplicate local symbol $1'#000+ + '07061_E_Undefined local symbol $1'#000+ + '07062_E_Unknown label identifier $1'#000+ + '07063_E_Invalid register name'#000+ + '07064_E_Invalid floating point register name'#000+ + '07065_E_NOR not supported'#000+ + '07066_W_Modulo not supported'#000+ + '070','67_E_Invalid floating point constant $1'#000+ + '07068_E_Invalid floating point expression'#000+ + '07069_E_Wrong symbol type'#000+ + '07070_E_Cannot index a local var or parameter with a register'#000+ + '07071_E_Invalid segment override expression'#000+ + '07072_W_Identifier $1 supp','osed external'#000+ + '07073_E_Strings not allowed as constants'#000+ + '07074_No type of variable specified'#000+ + '07075_E_assembler code not returned to text section'#000+ + '07076_E_Not a directive or local symbol $1'#000+ + '07077_E_Using a defined name as a local label'#000+ + '07078_E_','Dollar token is used without an identifier'#000+ + '07079_W_32bit constant created for address'#000+ + '07080_N_.align is target specific, use .balign or .p2align'#000+ + '07081_E_Can'#039't access fields directly for parameters'#000+ + '07082_E_Can'#039't access fields of objects/clas','ses directly'#000+ + '08000_F_Too many assembler files'#000+ + '08001_F_Selected assembler output not supported'#000+ + '08002_F_Comp not supported'#000+ + '08003_F_Direct not support for binary writers'#000+ + '08004_E_Allocating of data is only allowed in bss section'#000+ + '08005_F_No bina','ry writer selected'#000+ + '08006_E_Asm: Opcode $1 not in table'#000+ + '08007_E_Asm: $1 invalid combination of opcode and operands'#000+ + '08008_E_Asm: 16 Bit references not supported'#000+ + '08009_E_Asm: Invalid effective address'#000+ + '08010_E_Asm: Immediate or reference expect','ed'#000+ + '08011_E_Asm: $1 value exceeds bounds $2'#000+ + '08012_E_Asm: Short jump is out of range $1'#000+ + '08013_E_Asm: Undefined label $1'#000+ + '09000_W_Source operating system redefined'#000+ + '09001_I_Assembling (pipe) $1'#000+ + '09002_E_Can'#039't create assember file: $1'#000+ + '09003_E_Can'#039,'t create object file: $1'#000+ + '09004_E_Can'#039't create archive file: $1'#000+ + '09005_W_Assembler $1 not found, switching to external assembling'#000+ + '09006_T_Using assembler: $1'#000+ + '09007_W_Error while assembling exitcode $1'#000+ + '09008_W_Can'#039't call the assembler, error $','1 switching to external'+ + ' assembling'#000+ + '09009_I_Assembling $1'#000+ + '09010_I_Assembling smartlink $1'#000+ + '09011_W_Object $1 not found, Linking may fail !'#000+ + '09012_W_Library $1 not found, Linking may fail !'#000+ + '09013_W_Error while linking'#000+ + '09014_W_Can'#039't call the lin','ker, switching to external linking'#000+ + '09015_I_Linking $1'#000+ + '09016_W_Util $1 not found, switching to external linking'#000+ + '09017_T_Using util $1'#000+ + '09018_E_Creation of Executables not supported'#000+ + '09019_E_Creation of Dynamic/Shared Libraries not supported'#000+ + '09','020_I_Closing script $1'#000+ + '09021_W_resource compiler not found, switching to external mode'#000+ + '09022_I_Compiling resource $1'#000+ + '09023_F_Can'#039't post process executable $1'#000+ + '09024_F_Can'#039't open executable $1'#000+ + '09025_X_Size of Code: $1 bytes'#000+ + '09026_X_Size of i','nitialized data: $1 bytes'#000+ + '09027_X_Size of uninitialized data: $1 bytes'#000+ + '09028_X_Stack space reserved: $1 bytes'#000+ + '09029_X_Stack space commited: $1 bytes'#000+ + '10000_T_Unitsearch: $1'#000+ + '10001_T_PPU Loading $1'#000+ + '10002_U_PPU Name: $1'#000+ + '10003_U_PPU Flags: $1'#000+ + '10','004_U_PPU Crc: $1'#000+ + '10005_U_PPU Time: $1'#000+ + '10006_U_PPU File too short'#000+ + '10007_U_PPU Invalid Header (no PPU at the begin)'#000+ + '10008_U_PPU Invalid Version $1'#000+ + '10009_U_PPU is compiled for an other processor'#000+ + '10010_U_PPU is compiled for an other target'#000+ + '100','11_U_PPU Source: $1'#000+ + '10012_U_Writing $1'#000+ + '10013_F_Can'#039't Write PPU-File'#000+ + '10014_F_Error reading PPU-File'#000+ + '10015_F_unexpected end of PPU-File'#000+ + '10016_F_Invalid PPU-File entry: $1'#000+ + '10017_F_PPU Dbx count problem'#000+ + '10018_E_Illegal unit name: $1'#000+ + '10019_F_Too',' much units'#000+ + '10020_F_Circular unit reference between $1 and $2'#000+ + '10021_F_Can'#039't compile unit $1, no sources available'#000+ + '10022_F_Can'#039't find unit $1'#000+ + '10023_W_Unit $1 was not found but $2 exists'#000+ + '10024_F_Unit $1 searched but $2 found'#000+ + '10025_W_Compiling',' the system unit requires the -Us switch'#000+ + '10026_F_There were $1 errors compiling module, stopping'#000+ + '10027_U_Load from $1 ($2) unit $3'#000+ + '10028_U_Recompiling $1, checksum changed for $2'#000+ + '10029_U_Recompiling $1, source found only'#000+ + '10030_U_Recompiling',' unit, static lib is older than ppufile'#000+ + '10031_U_Recompiling unit, shared lib is older than ppufile'#000+ + '10032_U_Recompiling unit, obj and asm are older than ppufile'#000+ + '10033_U_Recompiling unit, obj is older than asm'#000+ + '10034_U_Parsing interface of $1'#000, + '10035_U_Parsing implementation of $1'#000+ + '10036_U_Second load for unit $1'#000+ + '10037_U_PPU Check file $1 time $2'#000+ + '11000_$1 [options] [options]'#000+ + '11001_W_Only one source file supported'#000+ + '11002_W_DEF file can be created only for OS/2'#000+ + '11003_E_nes','ted response files are not supported'#000+ + '11004_F_No source file name in command line'#000+ + '11005_N_No option inside $1 config file'#000+ + '11006_E_Illegal parameter: $1'#000+ + '11007_H_-? writes help pages'#000+ + '11008_F_Too many config files nested'#000+ + '11009_F_Unable to open ','file $1'#000+ + '11010_N_Reading further options from $1'#000+ + '11011_W_Target is already set to: $1'#000+ + '11012_W_Shared libs not supported on DOS platform, reverting to static'+ + #000+ + '11013_F_too many IF(N)DEFs'#000+ + '11014_F_too many ENDIFs'#000+ + '11015_F_open conditional at the e','nd of the file'#000+ + '11016_W_Debug information generation is not supported by this executab'+ + 'le'#000+ + '11017_H_Try recompiling with -dGDB'#000+ + '11018_E_You are using the obsolete switch $1'#000+ + '11019_E_You are using the obsolete switch $1, please use $2'#000+ + '11020_N_Swit','ching assembler to default source writing assembler'#000+ + '11021_W_Assembler output selected "$1" is not compatible with "$2"'#000+ + '11022_W_"$1" assembler use forced'#000+ + '11023_Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#010+ + 'Copyright (c) 1993','-2000 by Florian Klaempfl'#000+ + '11024_Free Pascal Compiler version $FPCVER'#010+ + #010+ + 'Compiler Date : $FPCDATE'#010+ + 'Compiler Target: $FPCTARGET'#010+ + #010+ + 'This program comes under the GNU General Public Licence'#010+ + 'For more information read COPYING.FPC'#010+ + #010+ + 'Report bugs,suggesti','ons etc to:'#010+ + ' bugrep@freepascal.org'#000+ + '11025_**0*_put + after a boolean switch option to enable it, - to disa'+ + 'ble it'#010+ + '**1a_the compiler doesn'#039't delete the generated assembler file'#010+ + '**2al_list sourcecode lines in assembler file'#010+ + '**2a','r_list register allocation/release info in assembler file'#010+ + '**2at_list temp allocation/release info in assembler file'#010+ + '**1b_generate browser info'#010+ + '**2bl_generate local symbol info'#010+ + '**1B_build all modules'#010+ + '**1C_code generation options:'#010+ + '**2CD_cr','eate also dynamic library (not supported)'#010+ + '**2Ch_ bytes heap (between 1023 and 67107840)'#010+ + '**2Ci_IO-checking'#010+ + '**2Cn_omit linking stage'#010+ + '**2Co_check overflow of integer operations'#010+ + '**2Cr_range checking'#010+ + '**2Cs_set stack size to '#010+ + '**2Ct_st','ack checking'#010+ + '**2CX_create also smartlinked library'#010+ + '**1d_defines the symbol '#010+ + '*O1D_generate a DEF file'#010+ + '*O2Dd_set description to '#010+ + '*O2Dw_PM application'#010+ + '**1e_set path to executable'#010+ + '**1E_same as -Cn'#010+ + '**1F_set file names and paths',':'#010+ + '**2FD_sets the directory where to search for compiler utilities'#010+ + '**2Fe_redirect error output to '#010+ + '**2FE_set exe/unit output path to '#010+ + '**2Fi_adds to include path'#010+ + '**2Fl_adds to library path'#010+ + '*L2FL_uses as dyn','amic linker'#010+ + '**2Fo_adds to object path'#010+ + '**2Fr_load error message file '#010+ + '**2Fu_adds to unit path'#010+ + '**2FU_set unit output path to , overrides -FE'#010+ + '*g1g_generate debugger information:'#010+ + '*g2gg_use gsym'#010+ + '*g2gd_use dbx'#010+ + '*g2gh_use ','heap trace unit (for memory leak debugging)'#010+ + '*g2gl_use line info unit to show more info for backtraces'#010+ + '*g2gc_generate checks for pointers'#010+ + '**1i_information'#010+ + '**2iD_return compiler date'#010+ + '**2iV_return compiler version'#010+ + '**2iSO_return compiler OS'#010+ + '**2','iSP_return compiler processor'#010+ + '**2iTO_return target OS'#010+ + '**2iTP_return target processor'#010+ + '**1I_adds to include path'#010+ + '**1k_Pass to the linker'#010+ + '**1l_write logo'#010+ + '**1n_don'#039't read the default config file'#010+ + '**1o_change the name of the exec','utable produced to '#010+ + '**1pg_generate profile code for gprof (defines FPC_PROFILE)'#010+ + '*L1P_use pipes instead of creating temporary assembler files'#010+ + '**1S_syntax options:'#010+ + '**2S2_switch some Delphi 2 extensions on'#010+ + '**2Sc_supports operators like C',' (*=,+=,/= and -=)'#010+ + '**2sa_include assertion code.'#010+ + '**2Sd_tries to be Delphi compatible'#010+ + '**2Se_compiler stops after the errors (default is 1)'#010+ + '**2Sg_allow LABEL and GOTO'#010+ + '**2Sh_Use ansistrings'#010+ + '**2Si_support C++ styled INLINE'#010+ + '**2Sm_support ','macros like C (global)'#010+ + '**2So_tries to be TP/BP 7.0 compatible'#010+ + '**2Sp_tries to be gpc compatible'#010+ + '**2Ss_constructor name must be init (destructor must be done)'#010+ + '**2St_allow static keyword in objects'#010+ + '**1s_don'#039't call assembler and linker (only wi','th -a)'#010+ + '**1u_undefines the symbol '#010+ + '**1U_unit options:'#010+ + '**2Un_don'#039't check the unit name'#010+ + '**2Us_compile a system unit'#010+ + '**1v_Be verbose. is a combination of the following letters:'#010+ + '**2*_e : Show errors (default) d : Show debug in','fo'#010+ + '**2*_w : Show warnings u : Show unit info'#010+ + '**2*_n : Show notes t : Show tried/used files'#010+ + '**2*_h : Show hints m : Show defined macros'#010+ + '**2*_i : Show general info p : Show compiled pr','ocedures'#010+ + '**2*_l : Show linenumbers c : Show conditionals'#010+ + '**2*_a : Show everything 0 : Show nothing (except errors)'#010+ + '**2*_b : Show all procedure r : Rhide/GCC compatibility mode'#010+ + '**2*_ declarations if an erro','r x : Executable info (Win32 only'+ + ')'#010+ + '**2*_ occurs'#010+ + '**1X_executable options:'#010+ + '*L2Xc_link with the c library'#010+ + '**2Xs_strip all symbols from executable'#010+ + '**2XD_try to link dynamic (defines FPC_LINK_DYNAMIC)'#010+ + '**2XS_try to link static (def','ault) (defines FPC_LINK_STATIC)'#010+ + '**2XX_try to link smart (defines FPC_LINK_SMART)'#010+ + '**0*_Processor specific options:'#010+ + '3*1A_output format:'#010+ + '3*2Aas_assemble using GNU AS'#010+ + '3*2Aasaout_assemble using GNU AS for aout (Go32v1)'#010+ + '3*2Anasmcoff','_coff (Go32v2) file using Nasm'#010+ + '3*2Anasmelf_elf32 (Linux) file using Nasm'#010+ + '3*2Anasmobj_obj file using Nasm'#010+ + '3*2Amasm_obj file using Masm (Microsoft)'#010+ + '3*2Atasm_obj file using Tasm (Borland)'#010+ + '3*2Acoff_coff (Go32v2) using internal writer'#010+ + '3*2Apecoff','_pecoff (Win32) using internal writer'#010+ + '3*1R_assembler reading style:'#010+ + '3*2Ratt_read AT&T style assembler'#010+ + '3*2Rintel_read Intel style assembler'#010+ + '3*2Rdirect_copy assembler text directly to assembler file'#010+ + '3*1O_optimizations:'#010+ + '3*2Og_generate sm','aller code'#010+ + '3*2OG_generate faster code (default)'#010+ + '3*2Or_keep certain variables in registers'#010+ + '3*2Ou_enable uncertain optimizations (see docs)'#010+ + '3*2O1_level 1 optimizations (quick optimizations)'#010+ + '3*2O2_level 2 optimizations (-O1 + slower optimizati','ons)'#010+ + '3*2O3_level 3 optimizations (same as -O2u)'#010+ + '3*2Op_target processor:'#010+ + '3*3Op1_set target processor to 386/486'#010+ + '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#010+ + '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#010+ + '3*1T_Target op','erating system:'#010+ + '3*2TGO32V1_version 1 of DJ Delorie DOS extender'#010+ + '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#010+ + '3*2TLINUX_Linux'#010+ + '3*2TOS2_OS/2 2.x'#010+ + '3*2TWin32_Windows 32 Bit'#010+ + '3*1W_Win32 target options'#010+ + '3*2WB_Set Image base to Hexadecimal value'#010+ + '3*2WC_Specify console type application'#010+ + '3*2WD_Use DEFFILE to export functions of DLL or EXE'#010+ + '3*2WG_Specify graphic type application'#010+ + '3*2WN_Do not generate relocation code (necessary for debugging)'#010+ + '3*2WR_Generate relocation code'#010+ + '6*1A','_output format'#010+ + '6*2Aas_Unix o-file using GNU AS'#010+ + '6*2Agas_GNU Motorola assembler'#010+ + '6*2Amit_MIT Syntax (old GAS)'#010+ + '6*2Amot_Standard Motorola assembler'#010+ + '6*1O_optimizations:'#010+ + '6*2Oa_turn on the optimizer'#010+ + '6*2Og_generate smaller code'#010+ + '6*2OG_generate faster',' code (default)'#010+ + '6*2Ox_optimize maximum (still BUGGY!!!)'#010+ + '6*2O2_set target processor to a MC68020+'#010+ + '6*1R_assembler reading style:'#010+ + '6*2RMOT_read motorola style assembler'#010+ + '6*1T_Target operating system:'#010+ + '6*2TAMIGA_Commodore Amiga'#010+ + '6*2TATARI_Ata','ri ST/STe/TT'#010+ + '6*2TMACOS_Macintosh m68k'#010+ + '6*2TLINUX_Linux-68k'#010+ + '**1*_'#010+ + '**1?_shows this help'#010+ + '**1h_shows this help without waiting'#000 +); diff --git a/befpc/compiler/og386.pas b/befpc/compiler/og386.pas new file mode 100644 index 0000000..978eacd --- /dev/null +++ b/befpc/compiler/og386.pas @@ -0,0 +1,301 @@ +{ + $Id: og386.pas,v 1.1.1.1 2001-07-23 17:16:41 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + Contains the base stuff for 386 binary object file writers + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit og386; + + interface + uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + owbase,owar, + systems,cpubase,aasm; + + type + tsecsize = array[tsection] of longint; + + relative_type = (relative_false,relative_true,relative_rva); + + pobjectalloc = ^tobjectalloc; + tobjectalloc = object + currsec : tsection; + secsize : tsecsize; + constructor init; + destructor done; + procedure setsection(sec:tsection); + function sectionsize:longint; + procedure sectionalloc(l:longint); + procedure sectionalign(l:longint); + procedure staballoc(p:pchar); + procedure resetsections; + end; + + pobjectoutput = ^tobjectoutput; + tobjectoutput = object + smarthcount : longint; + objsmart : boolean; + writer : pobjectwriter; + path : pathstr; + ObjFile : string; + place : tcutplace; + currsec : tsection; + constructor init(smart:boolean); + destructor done;virtual; + { Writing } + procedure NextSmartName; + procedure initwriting(Aplace:tcutplace);virtual; + procedure donewriting;virtual; + procedure setsectionsizes(var s:tsecsize);virtual; + procedure writebytes(var data;len:longint);virtual; + procedure writealloc(len:longint);virtual; + procedure writealign(len:longint);virtual; + procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);virtual; + procedure writesymbol(p:pasmsymbol);virtual; + procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual; + procedure writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol; + nidx,nother,line:longint;reloc:boolean);virtual; + procedure defaultsection(sec:tsection); + end; + + var + objectalloc : pobjectalloc; + objectoutput : pobjectoutput; + + implementation + + uses + strings,comphook, + globtype,globals,verbose,files, + assemble; + + +{**************************************************************************** + tobjectoutput +****************************************************************************} + + constructor tobjectalloc.init; + begin + end; + + + destructor tobjectalloc.done; + begin + end; + + + procedure tobjectalloc.setsection(sec:tsection); + begin + currsec:=sec; + end; + + + procedure tobjectalloc.resetsections; + begin + FillChar(secsize,sizeof(secsize),0); + end; + + + procedure tobjectalloc.sectionalloc(l:longint); + begin + inc(secsize[currsec],l); + end; + + + procedure tobjectalloc.sectionalign(l:longint); + begin + if (secsize[currsec] mod l)<>0 then + inc(secsize[currsec],l-(secsize[currsec] mod l)); + end; + + + procedure tobjectalloc.staballoc(p:pchar); + begin + inc(secsize[sec_stab]); + if assigned(p) and (p[0]<>#0) then + inc(secsize[sec_stabstr],strlen(p)+1); + end; + + + function tobjectalloc.sectionsize:longint; + begin + sectionsize:=secsize[currsec]; + end; + + + +{**************************************************************************** + tobjectoutput +****************************************************************************} + + constructor tobjectoutput.init(smart:boolean); + begin + smarthcount:=0; + objsmart:=smart; + objfile:=current_module^.objfilename^; + { Which path will be used ? } + if objsmart and + (cs_asm_leave in aktglobalswitches) then + begin + path:=current_module^.path^+FixFileName(current_module^.modulename^)+target_info.smartext; + {$I-} + mkdir(path); + {$I+} + if ioresult<>0 then; + path:=FixPath(path,false); + end + else + path:=current_module^.path^; + { init writer } + if objsmart and + not(cs_asm_leave in aktglobalswitches) then + writer:=New(parobjectwriter,Init(current_module^.staticlibfilename^)) + else + writer:=New(pobjectwriter,Init); + end; + + + destructor tobjectoutput.done; + begin + Dispose(writer,done); + end; + + + procedure tobjectoutput.NextSmartName; + var + s : string; + begin + inc(SmartLinkFilesCnt); + if SmartLinkFilesCnt>999999 then + Message(asmw_f_too_many_asm_files); + if (cs_asm_leave in aktglobalswitches) then + s:=current_module^.asmprefix^ + else + s:=current_module^.modulename^; + case place of + cut_begin : + begin + inc(smarthcount); + s:=s+tostr(smarthcount)+'h'; + end; + cut_normal : + s:=s+tostr(smarthcount)+'s'; + cut_end : + s:=s+tostr(smarthcount)+'t'; + end; + ObjFile:=Path+FixFileName(s+tostr(SmartLinkFilesCnt)+target_info.objext) + end; + + + procedure tobjectoutput.initwriting(Aplace:tcutplace); + begin + place:=Aplace; + if objsmart then + NextSmartName; + writer^.create(objfile); + end; + + + procedure tobjectoutput.donewriting; + begin + writer^.close; + end; + + procedure tobjectoutput.setsectionsizes(var s:tsecsize); + begin + end; + + procedure tobjectoutput.defaultsection(sec:tsection); + begin + currsec:=sec; + end; + + procedure tobjectoutput.writesymbol(p:pasmsymbol); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writebytes(var data;len:longint); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writealloc(len:longint); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writealign(len:longint); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean); + begin + Do_halt(211); + end; + + procedure tobjectoutput.writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol; + nidx,nother,line:longint;reloc:boolean); + begin + Do_halt(211); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.18 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.17 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.16 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.15 1999/11/08 10:37:12 peter + * filename fixes for win32 imports for units with multiple needed dll's + + Revision 1.14 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.13 1999/11/02 15:06:57 peter + * import library fixes for win32 + * alignment works again + + Revision 1.12 1999/09/07 15:22:20 pierre + * runerror => do_halt + + Revision 1.11 1999/08/04 00:23:04 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} diff --git a/befpc/compiler/og386cff.pas b/befpc/compiler/og386cff.pas new file mode 100644 index 0000000..a5c350a --- /dev/null +++ b/befpc/compiler/og386cff.pas @@ -0,0 +1,1060 @@ +{ + $Id: og386cff.pas,v 1.1.1.1 2001-07-23 17:16:41 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman and Pierre Muller + + Contains the 386 binary coff writer + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit og386cff; + +{ + Notes on COFF: + + (0) When I say `standard COFF' below, I mean `COFF as output and + used by DJGPP'. I assume DJGPP gets it right. + + (1) Win32 appears to interpret the term `relative relocation' + differently from standard COFF. Standard COFF understands a + relative relocation to mean that during relocation you add the + address of the symbol you're referencing, and subtract the base + address of the section you're in. Win32 COFF, by contrast, seems + to add the address of the symbol and then subtract the address + of THE BYTE AFTER THE RELOCATED DWORD. Hence the two formats are + subtly incompatible. + + (2) Win32 doesn't bother putting any flags in the header flags + field (at offset 0x12 into the file). + + (3) Win32 uses some extra flags into the section header table: + it defines flags 0x80000000 (writable), 0x40000000 (readable) + and 0x20000000 (executable), and uses them in the expected + combinations. It also defines 0x00100000 through 0x00700000 for + section alignments of 1 through 64 bytes. + + (4) Both standard COFF and Win32 COFF seem to use the DWORD + field directly after the section name in the section header + table for something strange: they store what the address of the + section start point _would_ be, if you laid all the sections end + to end starting at zero. Dunno why. Microsoft's documentation + lists this field as "Virtual Size of Section", which doesn't + seem to fit at all. In fact, Win32 even includes non-linked + sections such as .drectve in this calculation. + + (5) Standard COFF does something very strange to common + variables: the relocation point for a common variable is as far + _before_ the variable as its size stretches out _after_ it. So + we must fix up common variable references. Win32 seems to be + sensible on this one. +} + interface + + uses + cobjects, + systems,cpubase,aasm,og386; + + type + preloc = ^treloc; + treloc = packed record + next : preloc; + address : longint; + symbol : pasmsymbol; + section : tsection; { only used if symbol=nil } + relative : relative_type; + end; + + psymbol = ^tsymbol; + tsymbol = packed record + name : string[8]; + strpos : longint; + section : tsection; + value : longint; + typ : TAsmsymtype; + end; + + pcoffsection = ^tcoffsection; + tcoffsection = object + index : tsection; + secidx : longint; + data : PDynamicArray; + size, + fillsize, + mempos, + len, + datapos, + relocpos, + nrelocs, + align, + flags : longint; + relochead : PReloc; + reloctail : ^PReloc; + constructor init(sec:TSection;Aflags:longint); + destructor done; + procedure write(var d;l:longint); + procedure alloc(l:longint); + procedure addsymreloc(ofs:longint;p:pasmsymbol;relative:relative_type); + procedure addsectionreloc(ofs:longint;sec:tsection;relative:relative_type); + end; + + pgenericcoffoutput = ^tgenericcoffoutput; + tgenericcoffoutput = object(tobjectoutput) + win32 : boolean; + sects : array[TSection] of PCoffSection; + strs, + syms : Pdynamicarray; + initsym : longint; + constructor init(smart:boolean); + destructor done;virtual; + procedure initwriting(Aplace:tcutplace);virtual; + procedure donewriting;virtual; + procedure setsectionsizes(var s:tsecsize);virtual; + procedure writebytes(var data;len:longint);virtual; + procedure writealloc(len:longint);virtual; + procedure writealign(len:longint);virtual; + procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);virtual; + procedure writesymbol(p:pasmsymbol);virtual; + procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual; + procedure writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol; + nidx,nother,line:longint;reloc:boolean);virtual; + function text_flags : longint;virtual; + function data_flags : longint;virtual; + function bss_flags : longint;virtual; + function idata_flags : longint;virtual; + function edata_flags : longint;virtual; + private + procedure createsection(sec:tsection); + procedure write_relocs(s:pcoffsection); + procedure write_symbol(const name:string;strpos,value,section,typ,aux:longint); + procedure write_symbols; + procedure writetodisk; + end; + + pdjgppcoffoutput = ^tdjgppcoffoutput; + tdjgppcoffoutput = object(tgenericcoffoutput) + constructor init(smart:boolean); + function text_flags : longint;virtual; + function data_flags : longint;virtual; + function bss_flags : longint;virtual; + end; + + pwin32coffoutput = ^twin32coffoutput; + twin32coffoutput = object(tgenericcoffoutput) + constructor init(smart:boolean); + function text_flags : longint;virtual; + function data_flags : longint;virtual; + function bss_flags : longint;virtual; + function idata_flags : longint;virtual; + function edata_flags : longint;virtual; + end; + + implementation + + uses + strings,verbose, + globtype,globals,files; + + type + { Structures which are written directly to the output file } + coffheader=packed record + mach : word; + nsects : word; + time : longint; + sympos : longint; + syms : longint; + opthdr : word; + flag : word; + end; + coffsechdr=packed record + name : array[0..7] of char; + vsize : longint; + rvaofs : longint; + datalen : longint; + datapos : longint; + relocpos : longint; + lineno1 : longint; + nrelocs : word; + lineno2 : word; + flags : longint; + end; + coffsectionrec=packed record + len : longint; + nrelocs : word; + empty : array[0..11] of char; + end; + coffreloc=packed record + address : longint; + sym : longint; + relative : word; + end; + coffsymbol=packed record + name : array[0..3] of char; { real is [0..7], which overlaps the strpos ! } + strpos : longint; + value : longint; + section : integer; + empty : integer; + typ : byte; + aux : byte; + end; + pcoffstab=^coffstab; + coffstab=packed record + strpos : longint; + ntype : byte; + nother : byte; + ndesc : word; + nvalue : longint; + end; + + +{**************************************************************************** + TSection +****************************************************************************} + + constructor tcoffsection.init(sec:TSection;Aflags:longint); + begin + index:=sec; + secidx:=0; + flags:=AFlags; + { alignment after section } + case sec of + sec_code, + sec_data, + sec_bss : + align:=4; + else + align:=1; + end; + { filled after pass 1 } + size:=0; + fillsize:=0; + mempos:=0; + { pass 2 data } + relocHead:=nil; + relocTail:=@relocHead; + Len:=0; + NRelocs:=0; + if sec=sec_bss then + data:=nil + else + new(Data,Init(1,8192)); + end; + + + destructor tcoffsection.done; + begin + if assigned(Data) then + dispose(Data,done); + end; + + + procedure tcoffsection.write(var d;l:longint); + begin + if not assigned(Data) then + Internalerror(3334441); + Data^.write(d,l); + inc(len,l); + end; + + + procedure tcoffsection.alloc(l:longint); + begin + if assigned(Data) then + Internalerror(3334442); + inc(len,l); + end; + + + procedure tcoffsection.addsymreloc(ofs:longint;p:pasmsymbol;relative:relative_type); + var + r : PReloc; + begin + new(r); + reloctail^:=r; + reloctail:=@r^.next; + r^.next:=nil; + r^.address:=ofs+mempos; + r^.symbol:=p; + r^.section:=sec_none; + r^.relative:=relative; + inc(nrelocs); + end; + + + procedure tcoffsection.addsectionreloc(ofs:longint;sec:tsection;relative:relative_type); + var + r : PReloc; + begin + new(r); + reloctail^:=r; + reloctail:=@r^.next; + r^.next:=nil; + r^.address:=ofs+mempos; + r^.symbol:=nil; + r^.section:=sec; + r^.relative:=relative; + inc(nrelocs); + end; + + +{**************************************************************************** + Genericcoffoutput +****************************************************************************} + + const +{$ifdef TP} + symbolresize = 50; + strsresize = 200; +{$else} + symbolresize = 200; + strsresize = 8192; +{$endif} + + constructor tgenericcoffoutput.init(smart:boolean); + begin + inherited init(smart); + end; + + + destructor tgenericcoffoutput.done; + begin + inherited done; + end; + + + procedure tgenericcoffoutput.initwriting(Aplace:tcutplace); + var + s : string; + begin + inherited initwriting(Aplace); + { reset } + initsym:=0; + new(syms,init(sizeof(TSymbol),symbolresize)); + new(strs,init(1,strsresize)); + FillChar(Sects,sizeof(Sects),0); + { we need at least the following 3 sections } + createsection(sec_code); + createsection(sec_data); + createsection(sec_bss); + if (cs_gdb_lineinfo in aktglobalswitches) or + (cs_debuginfo in aktmoduleswitches) then + begin + createsection(sec_stab); + createsection(sec_stabstr); + writestabs(sec_none,0,nil,0,0,0,false); + { write zero pchar and name together (PM) } + s:=#0+SplitFileName(current_module^.mainsource^)+#0; + sects[sec_stabstr]^.write(s[1],length(s)); + end; + end; + + + procedure tgenericcoffoutput.donewriting; + var + sec : tsection; + begin + { Only write the .o if there are no errors } + if errorcount=0 then + writetodisk; + dispose(syms,done); + dispose(strs,done); + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + dispose(sects[sec],done); + inherited donewriting; + end; + + + function tgenericcoffoutput.text_flags : longint; + begin + text_flags:=0; + end; + + function tgenericcoffoutput.data_flags : longint; + begin + data_flags:=0; + end; + + function tgenericcoffoutput.bss_flags : longint; + begin + bss_flags:=0; + end; + + function tgenericcoffoutput.edata_flags : longint; + begin + edata_flags:=0; + end; + + function tgenericcoffoutput.idata_flags : longint; + begin + idata_flags:=0; + end; + + + procedure tgenericcoffoutput.createsection(sec:TSection); + var + Aflags : longint; + begin + Aflags:=0; + case sec of + sec_code : + Aflags:=text_flags; + sec_data : + Aflags:=data_flags; + sec_bss : + Aflags:=bss_flags; + sec_idata2, + sec_idata4, + sec_idata5, + sec_idata6, + sec_idata7 : + Aflags:=idata_flags; + sec_edata : + Aflags:=edata_flags; + else + Aflags:=0; + end; + sects[sec]:=new(PcoffSection,init(Sec,Aflags)); + end; + + + procedure tgenericcoffoutput.writesymbol(p:pasmsymbol); + var + pos : longint; + sym : tsymbol; + s : string; + begin + { already written ? } + if p^.idx<>-1 then + exit; + { be sure that the section will exists } + if (p^.section<>sec_none) and not(assigned(sects[p^.section])) then + createsection(p^.section); + { symbolname } + pos:=strs^.usedsize+4; + s:=p^.name; + if length(s)>8 then + begin + if length(s)<255 then + s:=s+#0; + strs^.write(s[1],length(s)); + { if the length is 255 we need to addd the terminal #0 + separately bug report from Florian 20/6/2000 } + if length(s)=255 then + begin + s:=#0; + strs^.write(s[1],length(s)); + end; + end + else + pos:=-1; + FillChar(sym,sizeof(sym),0); + sym.strpos:=pos; + if pos=-1 then + sym.name:=s; + sym.value:=p^.size; + sym.typ:=p^.typ; + { if local of global then set the section value to the address + of the symbol } + if p^.typ in [AS_LOCAL,AS_GLOBAL] then + begin + sym.section:=p^.section; + sym.value:=p^.address+sects[p^.section]^.mempos; + end; + { update the asmsymbol index } + p^.idx:=syms^.count; + { store the symbol, but not the local ones (PM) } + if (p^.typ<>AS_LOCAL) or ((copy(s,1,2)<>'.L') and + ((copy(s,1,1)<>'L') or not win32)) then + syms^.write(sym,1); + { make the exported syms known to the objectwriter + (needed for .a generation) } + if (p^.typ=AS_GLOBAL) or + ((p^.typ=AS_EXTERNAL) and (sym.value=p^.size) and (sym.value>0)) then + writer^.writesym(p^.name); + end; + + + procedure tgenericcoffoutput.writebytes(var data;len:longint); + begin + if not assigned(sects[currsec]) then + createsection(currsec); + sects[currsec]^.write(data,len); + end; + + + procedure tgenericcoffoutput.writealloc(len:longint); + begin + if not assigned(sects[currsec]) then + createsection(currsec); + sects[currsec]^.alloc(len); + end; + + + procedure tgenericcoffoutput.writealign(len:longint); + var modulo : longint; + begin + if not assigned(sects[currsec]) then + createsection(currsec); + modulo:=sects[currsec]^.len mod len; + if modulo > 0 then + sects[currsec]^.alloc(len-modulo); + end; + + + procedure tgenericcoffoutput.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type); + var + symaddr : longint; + begin + if not assigned(sects[currsec]) then + createsection(currsec); + if assigned(p) then + begin + { real address of the symbol } + symaddr:=p^.address; + if p^.section<>sec_none then + inc(symaddr,sects[p^.section]^.mempos); + { no symbol relocation need inside a section } + if p^.section=currsec then + begin + case relative of + relative_false : + begin + sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec,relative_false); + inc(data,symaddr); + end; + relative_true : + begin + inc(data,symaddr-len-sects[currsec]^.len); + end; + relative_rva : + begin + { don't know if this can happens !! } + { does this work ?? } + sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec,relative_rva); + inc(data,symaddr); + end; + end; + end + else + begin + writesymbol(p); + if (p^.section<>sec_none) and (relative<>relative_true) then + sects[currsec]^.addsectionreloc(sects[currsec]^.len,p^.section,relative) + else + sects[currsec]^.addsymreloc(sects[currsec]^.len,p,relative); + if not win32 then {seems wrong to me (PM) } + inc(data,symaddr) + else + if (relative<>relative_true) and (p^.section<>sec_none) then + inc(data,symaddr); + if relative=relative_true then + begin + if win32 then + dec(data,len-4) + else + dec(data,len+sects[currsec]^.len); + end; + end; + end; + sects[currsec]^.write(data,len); + end; + + + procedure tgenericcoffoutput.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc : boolean); + var + stab : coffstab; + s : tsection; + begin + { This is wrong because + sec_none is used only for external bss + if section=sec_none then + s:=currsec + else } + s:=section; + { local var can be at offset -1 !! PM } + if reloc then + begin + if (offset=-1) then + begin + if s=sec_none then + offset:=0 + else + offset:=sects[s]^.len; + end; + if (s<>sec_none) then + inc(offset,sects[s]^.mempos); + end; + fillchar(stab,sizeof(coffstab),0); + if assigned(p) and (p[0]<>#0) then + begin + stab.strpos:=sects[sec_stabstr]^.len; + sects[sec_stabstr]^.write(p^,strlen(p)+1); + end; + stab.ntype:=nidx; + stab.ndesc:=line; + stab.nother:=nother; + stab.nvalue:=offset; + sects[sec_stab]^.write(stab,sizeof(stab)); + { when the offset is not 0 then write a relocation, take also the + hdrstab into account with the offset } + if reloc then + if DLLSource and RelocSection then + { avoid relocation in the .stab section + because it ends up in the .reloc section instead } + sects[sec_stab]^.addsectionreloc(sects[sec_stab]^.len-4,s,relative_rva) + else + sects[sec_stab]^.addsectionreloc(sects[sec_stab]^.len-4,s,relative_false); + end; + + + procedure tgenericcoffoutput.writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol; + nidx,nother,line:longint;reloc:boolean); + var + stab : coffstab; + s : tsection; + begin + { This is wrong because + sec_none is used only for external bss + if section=sec_none then + s:=currsec + else } + s:=section; + { do not use the size stored in offset field + this is DJGPP specific ! PM } + if win32 then + offset:=0; + { local var can be at offset -1 !! PM } + if reloc then + begin + if (offset=-1) then + begin + if s=sec_none then + offset:=0 + else + offset:=sects[s]^.len; + end; + if (s<>sec_none) then + inc(offset,sects[s]^.mempos); + end; + fillchar(stab,sizeof(coffstab),0); + if assigned(p) and (p[0]<>#0) then + begin + stab.strpos:=sects[sec_stabstr]^.len; + sects[sec_stabstr]^.write(p^,strlen(p)+1); + end; + stab.ntype:=nidx; + stab.ndesc:=line; + stab.nother:=nother; + stab.nvalue:=offset; + sects[sec_stab]^.write(stab,sizeof(stab)); + { when the offset is not 0 then write a relocation, take also the + hdrstab into account with the offset } + if reloc then + if DLLSource and RelocSection then + { avoid relocation in the .stab section + because it ends up in the .reloc section instead } + sects[sec_stab]^.addsymreloc(sects[sec_stab]^.len-4,ps,relative_rva) + else + sects[sec_stab]^.addsymreloc(sects[sec_stab]^.len-4,ps,relative_false); + end; + + + procedure tgenericcoffoutput.write_relocs(s:pcoffsection); + var + rel : coffreloc; + hr,r : preloc; + begin + r:=s^.relochead; + while assigned(r) do + begin + rel.address:=r^.address; + if assigned(r^.symbol) then + begin + if (r^.symbol^.typ=AS_LOCAL) then + rel.sym:=2*sects[r^.symbol^.section]^.secidx + else + begin + if r^.symbol^.idx=-1 then + internalerror(4321); + rel.sym:=r^.symbol^.idx+initsym; + end; + end + else if r^.section<>sec_none then + rel.sym:=2*sects[r^.section]^.secidx + else + rel.sym:=0; + case r^.relative of + relative_true : rel.relative:=$14; + relative_false : rel.relative:=$6; + relative_rva : rel.relative:=$7; + end; + writer^.write(rel,sizeof(rel)); + { goto next and dispose this reloc } + hr:=r; + r:=r^.next; + dispose(hr); + end; + end; + + + procedure tgenericcoffoutput.write_symbol(const name:string;strpos,value,section,typ,aux:longint); + var + sym : coffsymbol; + begin + FillChar(sym,sizeof(sym),0); + if strpos=-1 then + move(name[1],sym.name,length(name)) + else + sym.strpos:=strpos; + sym.value:=value; + sym.section:=section; + sym.typ:=typ; + sym.aux:=aux; + writer^.write(sym,sizeof(sym)); + end; + + + procedure tgenericcoffoutput.write_symbols; + var + filename : string[18]; + sec : tsection; + sectionval, + i : longint; + globalval : byte; + secrec : coffsectionrec; + sym : tsymbol; + begin + { The `.file' record, and the file name auxiliary record. } + write_symbol ('.file', -1, 0, -2, $67, 1); + fillchar(filename,sizeof(filename),0); + filename:=SplitFileName(current_module^.mainsource^); + writer^.write(filename[1],sizeof(filename)-1); + { The section records, with their auxiliaries, also store the + symbol index } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + write_symbol(target_asm.secnames[sec],-1,sects[sec]^.mempos,sects[sec]^.secidx,3,1); + fillchar(secrec,sizeof(secrec),0); + secrec.len:=sects[sec]^.len; + secrec.nrelocs:=sects[sec]^.nrelocs; + writer^.write(secrec,sizeof(secrec)); + end; + { The real symbols. } + syms^.seek(0); + for i:=1 to syms^.count do + begin + syms^.read(sym,1); + if sym.typ=AS_LOCAL then + globalval:=3 + else + globalval:=2; + if assigned(sects[sym.section]) then + sectionval:=sects[sym.section]^.secidx + else + sectionval:=0; + write_symbol(sym.name,sym.strpos,sym.value,sectionval,globalval,0); + end; + end; + + + procedure tgenericcoffoutput.setsectionsizes(var s:tsecsize); + var + align, + mempos : longint; + sec : tsection; + begin + { multiply stab with real size } + s[sec_stab]:=s[sec_stab]*sizeof(coffstab); + { if debug then also count header stab } + if (cs_gdb_lineinfo in aktglobalswitches) or + (cs_debuginfo in aktmoduleswitches) then + begin + inc(s[sec_stab],sizeof(coffstab)); + inc(s[sec_stabstr],length(SplitFileName(current_module^.mainsource^))+2); + end; + { fix all section } + mempos:=0; + for sec:=low(tsection) to high(tsection) do + begin + if (s[sec]>0) and (not assigned(sects[sec])) then + createsection(sec); + if assigned(sects[sec]) then + begin + sects[sec]^.size:=s[sec]; + sects[sec]^.mempos:=mempos; + { calculate the alignment } + align:=sects[sec]^.align; + sects[sec]^.fillsize:=align-(sects[sec]^.size and (align-1)); + if sects[sec]^.fillsize=align then + sects[sec]^.fillsize:=0; + { next section position, not for win32 which uses + relative addresses } + if not win32 then + inc(mempos,sects[sec]^.size+sects[sec]^.fillsize); + end; + end; + end; + + + procedure tgenericcoffoutput.writetodisk; + var + datapos,secidx, + nsects,sympos,i : longint; + gotreloc : boolean; + sec : tsection; + header : coffheader; + sechdr : coffsechdr; + empty : array[0..15] of byte; + begin + { calc amount of sections we have and align sections at 4 bytes } + fillchar(empty,sizeof(empty),0); + nsects:=0; + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin +{$ifdef EXTDEBUG} + { check if the section is still the same size } + if (sects[sec]^.len<>sects[sec]^.size) then + Comment(V_Warning,'Size of section changed '+ + tostr(sects[sec]^.size)+'->'+tostr(sects[sec]^.len)+ + ' ['+target_asm.secnames[sec]+']'); +{$endif EXTDEBUG} + { fill with zero } + if sects[sec]^.fillsize>0 then + begin + if assigned(sects[sec]^.data) then + sects[sec]^.write(empty,sects[sec]^.fillsize) + else + sects[sec]^.alloc(sects[sec]^.fillsize); + end; + inc(nsects); + end; + { Calculate the filepositions } + datapos:=sizeof(coffheader)+sizeof(coffsechdr)*nsects; + initsym:=2; { 2 for the file } + { sections first } + secidx:=0; + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + inc(secidx); + sects[sec]^.secidx:=secidx; + sects[sec]^.datapos:=datapos; + if assigned(sects[sec]^.data) then + inc(datapos,sects[sec]^.len); + inc(initsym,2); { 2 for each section } + end; + { relocs } + gotreloc:=false; + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + sects[sec]^.relocpos:=datapos; + inc(datapos,10*sects[sec]^.nrelocs); + if (not gotreloc) and (sects[sec]^.nrelocs>0) then + gotreloc:=true; + end; + { symbols } + sympos:=datapos; + { COFF header } + fillchar(header,sizeof(coffheader),0); + header.mach:=$14c; + header.nsects:=nsects; + header.sympos:=sympos; + header.syms:=syms^.count+initsym; + if gotreloc then + header.flag:=$104 + else + header.flag:=$105; + writer^.write(header,sizeof(header)); + { Section headers } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + fillchar(sechdr,sizeof(sechdr),0); + move(target_asm.secnames[sec][1],sechdr.name,length(target_asm.secnames[sec])); + if not win32 then + begin + sechdr.rvaofs:=sects[sec]^.mempos; + sechdr.vsize:=sects[sec]^.mempos; + end + else + begin + if sec=sec_bss then + sechdr.vsize:=sects[sec]^.len; + end; + sechdr.datalen:=sects[sec]^.len; + if (sects[sec]^.len>0) and assigned(sects[sec]^.data) then + sechdr.datapos:=sects[sec]^.datapos; + sechdr.relocpos:=sects[sec]^.relocpos; + sechdr.nrelocs:=sects[sec]^.nrelocs; + sechdr.flags:=sects[sec]^.flags; + writer^.write(sechdr,sizeof(sechdr)); + end; + { Sections } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) and + assigned(sects[sec]^.data) then + begin + { For the stab section we need an HdrSym which can now be + calculated more easily } + if sec=sec_stab then + begin + pcoffstab(sects[sec_stab]^.data^.data)^.nvalue:=sects[sec_stabstr]^.len; + pcoffstab(sects[sec_stab]^.data^.data)^.strpos:=1; + pcoffstab(sects[sec_stab]^.data^.data)^.ndesc:= + (sects[sec_stab]^.len div sizeof(coffstab))-1{+1 according to gas output PM}; + end; + writer^.write(sects[sec]^.data^.data^,sects[sec]^.data^.usedsize); + end; + { Relocs } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + write_relocs(sects[sec]); + { Symbols } + write_symbols; + { Strings } + i:=strs^.usedsize+4; + writer^.write(i,4); + writer^.write(strs^.data^,strs^.usedsize); + end; + + +{**************************************************************************** + DJGppcoffoutput +****************************************************************************} + + constructor tdjgppcoffoutput.init(smart:boolean); + begin + inherited init(smart); + win32:=false; + end; + + function tdjgppcoffoutput.text_flags : longint; + begin + text_flags:=$20; + end; + + function tdjgppcoffoutput.data_flags : longint; + begin + data_flags:=$40; + end; + + function tdjgppcoffoutput.bss_flags : longint; + begin + bss_flags:=$80; + end; + + +{**************************************************************************** + Win32coffoutput +****************************************************************************} + + constructor twin32coffoutput.init(smart:boolean); + begin + inherited init(smart); + win32:=true; + end; + + function twin32coffoutput.text_flags : longint; + begin + text_flags:=$60000020; { same as as 2.9.1 } + end; + + function twin32coffoutput.data_flags : longint; + begin + data_flags:=$c0300040; + end; + + function twin32coffoutput.bss_flags : longint; + begin + bss_flags:=$c0300080; + end; + + function twin32coffoutput.edata_flags : longint; + begin + edata_flags:=$c0300040; + end; + + function twin32coffoutput.idata_flags : longint; + begin + idata_flags:=$40000000; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.24 2000/06/21 20:56:37 pierre + * fix the problem of long mangledname in internal writer + + Revision 1.23 2000/04/12 12:42:29 pierre + * fix the -g-l option + + Revision 1.22 2000/03/10 16:05:28 pierre + * check that symbol is in object + + Revision 1.21 2000/03/10 09:15:54 pierre + * rva relocation bug fixed + + Revision 1.20 2000/03/09 14:29:47 pierre + * fix for the stab section size changes with smartlinking + + Revision 1.19 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.18 2000/01/12 10:38:18 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.17 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.16 1999/12/20 22:29:26 pierre + * relocation with debug info in rva (only with internal compiler) + + Revision 1.15 1999/11/30 10:40:43 peter + + ttype, tsymlist + + Revision 1.14 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.13 1999/11/02 15:06:57 peter + * import library fixes for win32 + * alignment works again + + Revision 1.12 1999/08/16 15:35:25 pierre + * fix for DLL relocation problems + * external bss vars had wrong stabs for pecoff + + -WB11000000 to specify default image base, allows to + load several DLLs with debugging info included + (relocatable DLL are stripped because the relocation + of the .Stab section is misplaced by ldw) + + Revision 1.11 1999/08/11 17:17:38 peter + * fixed rva writting for section relocs + * fixed section flags for edata and idata + + Revision 1.10 1999/08/04 00:23:05 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/og386dbg.pas b/befpc/compiler/og386dbg.pas new file mode 100644 index 0000000..08b95b2 --- /dev/null +++ b/befpc/compiler/og386dbg.pas @@ -0,0 +1,196 @@ +{ + $Id: og386dbg.pas,v 1.1.1.1 2001-07-23 17:16:41 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + Contains the 386 binary writer for debugging purposes + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit og386dbg; + + interface + uses + systems,aasm,cpubase,og386; + + type + pdbgoutput = ^tdbgoutput; + tdbgoutput = object(tobjectoutput) + nsyms : longint; + rawidx : longint; + constructor init(smart:boolean); + destructor done;virtual; + procedure initwriting(Aplace:tcutplace);virtual; + procedure donewriting;virtual; + procedure writebytes(var data;len:longint);virtual; + procedure writealloc(len:longint);virtual; + procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);virtual; + procedure writesymbol(p:pasmsymbol);virtual; + procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual; + end; + + implementation + +{**************************************************************************** + Tdbgoutput +****************************************************************************} + + constructor tdbgoutput.init(smart:boolean); + begin + inherited init(smart); + rawidx:=-1; + nsyms:=0; + end; + + + destructor tdbgoutput.done; + begin + end; + + + procedure tdbgoutput.initwriting(Aplace:tcutplace); + begin + inherited initwriting(Aplace); + writeln('initwriting '+Objfile); + end; + + + procedure tdbgoutput.donewriting; + begin + if rawidx<>-1 then + begin + writeln; + rawidx:=-1; + end; + writeln('donewriting'); + end; + + + procedure tdbgoutput.writesymbol(p:pasmsymbol); + begin + if rawidx<>-1 then + begin + writeln; + rawidx:=-1; + end; + p^.idx:=nsyms; + write('symbol [',nsyms,'] '+p^.name+' (',target_asm.secnames[p^.section],',',p^.address,',',p^.size,','); + case p^.typ of + AS_LOCAL : + writeln('local)'); + AS_GLOBAL : + writeln('global)'); + AS_EXTERNAL : + writeln('extern)'); + else + writeln('unknown)'); + end; + inc(nsyms); + end; + + + procedure tdbgoutput.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type); + begin + if rawidx<>-1 then + begin + writeln; + rawidx:=-1; + end; + if assigned(p) then + write('reloc: ',data,' [',target_asm.secnames[p^.section],',',p^.address,']') + else + write('reloc: ',data); + case relative of + relative_true : writeln(' relative'); + relative_false: writeln(' not relative'); + relative_rva : writeln(' relative virtual address'); + end; + end; + + + procedure tdbgoutput.writebytes(var data;len:longint); + + function hexstr(val : longint;cnt : byte) : string; + const + HexTbl : array[0..15] of char='0123456789ABCDEF'; + var + i : longint; + begin + hexstr[0]:=char(cnt); + for i:=cnt downto 1 do + begin + hexstr[i]:=hextbl[val and $f]; + val:=val shr 4; + end; + end; + + var + p : pchar; + i : longint; + begin + if len=0 then + exit; + p:=@data; + if rawidx=-1 then + begin + write('raw: '); + rawidx:=0; + end; + for i:=1to len do + begin + if rawidx>=16 then + begin + writeln; + write('raw: '); + rawidx:=0; + end; + write(hexstr(ord(p[i-1]),2),' '); + inc(rawidx); + end; + end; + + procedure tdbgoutput.writealloc(len:longint); + begin + writeln('alloc: ',len); + end; + + procedure tdbgoutput.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean); + begin + writeln('stabs: ',line,',',nidx,'"',p,'"'); + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.8 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.7 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.6 1999/11/02 15:06:57 peter + * import library fixes for win32 + * alignment works again + + Revision 1.5 1999/08/04 00:23:06 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} diff --git a/befpc/compiler/og386elf.pas b/befpc/compiler/og386elf.pas new file mode 100644 index 0000000..8ea56b7 --- /dev/null +++ b/befpc/compiler/og386elf.pas @@ -0,0 +1,821 @@ +{ + $Id: og386elf.pas,v 1.1.1.1 2001-07-23 17:16:41 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + Contains the binary elf writer + + * This code was inspired by the NASM sources + The Netwide Assembler is copyright (C) 1996 Simon Tatham and + Julian Hall. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit og386elf; + + interface + + uses + cobjects,og386,cpubase,aasm; + + const + R_386_32 = 1; { ordinary absolute relocation } + R_386_PC32 = 2; { PC-relative relocation } + R_386_GOT32 = 3; { an offset into GOT } + R_386_PLT32 = 4; { a PC-relative offset into PLT } + R_386_GOTOFF = 9; { an offset from GOT base } + R_386_GOTPC = 10; { a PC-relative offset _to_ GOT } + + SHT_PROGBITS = 1; + SHT_NOBITS = 8; + + SHF_WRITE = 1; + SHF_ALLOC = 2; + SHF_EXECINSTR = 4; + + type + telf32header=packed record + magic0123 : longint; + file_class : byte; + data_encoding : byte; + file_version : byte; + padding : array[$07..$0f] of byte; + e_type : word; + e_machine : word; + e_version : longint; + e_entry : longint; // entrypoint + e_phoff : longint; // program header offset + e_shoff : longint; // sections header offset + e_flags : longint; + e_ehsize : word; // elf header size in bytes + e_phentsize : word; // size of an entry in the program header array + e_phnum : word; // 0..e_phnum-1 of entrys + e_shentsize : word; // size of an entry in sections header array + e_shnum : word; // 0..e_shnum-1 of entrys + e_shstrndx : word; // index of string section header + end; + + telf32sechdr=packed record + sh_name : longint; + sh_type : longint; + sh_flags : longint; + sh_addr : longint; + sh_offset : longint; + sh_size : longint; + sh_link : longint; + sh_info : longint; + sh_addralign : longint; + sh_entsize : longint; + end; + + + preloc = ^treloc; + treloc = packed record + next : preloc; + address : longint; + symbol : pasmsymbol; + {section : tsection;} { only used if symbol=nil } + typ : byte; + end; + + psymbol = ^tsymbol; + tsymbol = packed record + strpos : longint; + section : longint; + value : longint; + typ : TAsmsymtype; + size : longint; + globnum : longint; + next, + nextfwd : psymbol; + end; + + pelfsection = ^telfsection; + telfsection = object + index : tsection; + name : string[16]; + elftype, + elfflags, + align : longint; + data : PDynamicArray; + len, + pos, + nrelocs : longint; + relochead : PReloc; + reloctail : ^PReloc; + + rel : PDynamicArray; + gsyms : PSymbol; + + constructor init(sec:TSection;Atype,Aflags,Aalign:longint); + constructor initname(const Aname:string;Atype,Aflags,Aalign:longint); + destructor done; + procedure write(var d;l:longint); + procedure alloc(l:longint); + procedure addsymreloc(ofs:longint;p:pasmsymbol;relative:relative_type); + procedure addsectionreloc(ofs:longint;sec:tsection); + end; + + pelfoutput = ^telfoutput; + telfoutput = object(tobjectoutput) + sects : array[TSection] of PElfSection; + symtab_sect, + strtab_sect, + shstrtab_sect, + gotpc_sect, + gotoff_sect, + got_sect, + plt_sect, + sym_sect : PElfSection; + strs, + syms : Pdynamicarray; + initsym : longint; + constructor init; + destructor done;virtual; + procedure initwriting;virtual; + procedure donewriting;virtual; + procedure writebytes(var data;len:longint);virtual; + procedure writealloc(len:longint);virtual; + procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);virtual; + procedure writesymbol(p:pasmsymbol);virtual; + procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual; + private + procedure createsection(sec:tsection;const name:string); + procedure write_relocs(s:pcoffsection); + procedure write_symbol(const name:string;strpos,value,section,typ,aux:longint); + procedure write_symbols; + procedure writetodisk; + end; + + + implementation + + uses + strings,verbose, + globtype,globals,files; + + type + { Structures which are written directly to the output file } + + + const + sec_2_str : array[tsection] of string[8]=('', + '.text','.data','.bss', + '.stab','.stabstr', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '' + ); + + +{**************************************************************************** + TSection +****************************************************************************} + + constructor telfsection.init(sec:TSection;Atype,Aflags,Aalign:longint); + begin + index:=sec; + name:=sec_2_str[sec]; + elftype:=AType; + elfflags:=AFlags; + align:=Aalign; + relocHead:=nil; + relocTail:=@relocHead; + Len:=0; + Pos:=0; + NRelocs:=0; + if sec=sec_bss then + data:=nil + else + new(Data,Init(1,8192)); + new(rel,Init(1,8192)); + gsyms:=nil; + end; + + + constructor initname(const Aname:string;Atype,Aflags,Aalign:longint); + begin + index:=sec_none; + name:=Aname; + elftype:=AType; + elfflags:=AFlags; + align:=Aalign; + relocHead:=nil; + relocTail:=@relocHead; + Len:=0; + Pos:=0; + NRelocs:=0; + new(Data,Init(1,8192)); + new(rel,Init(1,8192)); + gsyms:=nil; + end; + + destructor telfsection.done; + begin + if assigned(Data) then + dispose(Data,done); + if assigned(rel) then + dispose(rel,done); + end; + + + procedure telfsection.write(var d;l:longint); + begin + if not assigned(Data) then + Internalerror(3334441); + Data^.write(d,l); + inc(len,l); + end; + + + procedure telfsection.alloc(l:longint); + begin + if assigned(Data) then + Internalerror(3334442); + inc(len,l); + end; + + + procedure telfsection.addsymreloc(ofs:longint;p:pasmsymbol;typ:byte); + var + r : PReloc; + begin + new(r); + reloctail^:=r; + reloctail:=@r^.next; + r^.next:=nil; + r^.address:=ofs; + r^.symbol:=p; + {r^.section:=sec_none;} + r^.typ:=typ; + inc(nrelocs); + end; + + +{ procedure telfsection.addsectionreloc(ofs:longint;sec:tsection); + var + r : PReloc; + begin + new(r); + reloctail^:=r; + reloctail:=@r^.next; + r^.next:=nil; + r^.address:=ofs; + r^.symbol:=nil; + r^.section:=sec; + r^.relative:=relative_false; + inc(nrelocs); + end; } + + +{**************************************************************************** + Genericcoffoutput +****************************************************************************} + + const +{$ifdef TP} + symbolresize = 50; + strsresize = 200; +{$else} + symbolresize = 200; + strsresize = 8192; +{$endif} + + constructor telfoutputput.init; + begin + inherited init; + end; + + + destructor telfoutputput.done; + begin + inherited done; + end; + + + procedure telfoutputput.initwriting; + var + s : string; + begin + inherited initwriting; + { reset } + initsym:=0; + new(syms,init(sizeof(TSymbol),symbolresize)); + FillChar(Sects,sizeof(Sects),0); + { default sections } + new(symtab_sect,initname('.symtab',2,4)); + new(strtab_sect,initname('.strtab',3,1)); + new(shstrtab_sect,initname('.shstrtab',3,1)); + { we need at least the following sections } + createsection(sec_code); + createsection(sec_data); + createsection(sec_bss); + { create stabs sections if debugging } + if (cs_debuginfo in aktmoduleswitches) then + begin + createsection(sec_stab); + createsection(sec_stabstr); + writestabs(sec_none,0,nil,0,0,0,false); + { write zero pchar and name together (PM) } + s:=#0+SplitFileName(current_module^.mainsource^)+#0; + sects[sec_stabstr]^.write(s[1],length(s)); + end; + end; + + + procedure telfoutputput.donewriting; + var + sec : tsection; + begin + writetodisk; + dispose(syms,done); + dispose(strs,done); + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + dispose(sects[sec],done); + inherited donewriting; + end; + + + procedure telfoutputput.createsection(sec:tsection); + var + Aflags,AType,AAlign : longint; + begin + Aflags:=0; + Atype:=0; + case sec of + sec_code : + begin + Aflags:=SHF_ALLOC or SHF_EXECINSTR; + AType:=SHT_PROGBITS; + AAlign:=16; + end; + sec_data : + begin + Aflags:=SHF_ALLOC or SHF_WRITE; + AType:=SHT_PROGBITS; + AAlign:=4; + end; + sec_bss : + begin + Aflags:=SHF_ALLOC or SHF_WRITE; + AType:=SHT_NOBITS; + AAlign:=4; + end; + end; + sects[sec]:=new(PElfSection,init(Sec,AType,Aflags,AAlign)); + end; + + + procedure telfoutputput.writesymbol(p:pasmsymbol); + var + pos : longint; + sym : tsymbol; + c : char; + s : string; + begin + { already written ? } + if p^.idx<>-1 then + exit; + { be sure that the section will exists } + if (p^.section<>sec_none) and not(assigned(sects[p^.section])) then + createsection(p^.section); + { symbolname } + pos:=strs^.usedsize+4; + c:=#0; + s:=p^.name; + if length(s)>8 then + begin + s:=s+#0; + strs^.write(s[1],length(s)); + end + else + pos:=-1; + FillChar(sym,sizeof(sym),0); + sym.strpos:=pos; + if pos=-1 then + sym.name:=s; + sym.value:=p^.size; + sym.typ:=p^.typ; + { if local of global then set the section value to the address + of the symbol } + if p^.typ in [AS_LOCAL,AS_GLOBAL] then + begin + sym.section:=ord(p^.section); + sym.value:=p^.address; + end; + { update the asmsymbol index } + p^.idx:=syms^.count; + { store the symbol, but not the local ones (PM) } + if (p^.typ<>AS_LOCAL) or ((copy(s,1,2)<>'.L') and + ((copy(s,1,1)<>'L') or not win32)) then + syms^.write(sym,1); + { make the exported syms known to the objectwriter + (needed for .a generation) } + if (p^.typ=AS_GLOBAL) or + ((p^.typ=AS_EXTERNAL) and (sym.value=p^.size) and (sym.value>0)) then + writer^.writesym(p^.name); + end; + + + procedure telfoutputput.writebytes(var data;len:longint); + begin + if not assigned(sects[currsec]) then + createsection(currsec); + sects[currsec]^.write(data,len); + end; + + + procedure telfoutputput.writealloc(len:longint); + begin + if not assigned(sects[currsec]) then + createsection(currsec); + sects[currsec]^.alloc(len); + end; + + + procedure telfoutputput.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type); + begin + if not assigned(sects[currsec]) then + createsection(currsec); + if assigned(p) then + begin + { no symbol relocation need inside a section } + if p^.section=currsec then + begin + if relative=relative_false then + begin + sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec); + inc(data,p^.address); + end + else if relative=relative_true then + begin + inc(data,p^.address-len-sects[currsec]^.len); + end + else if relative=relative_rva then + begin + { don't know if this can happens !! } + { does this work ?? } + sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec); + inc(data,p^.address); + end; + end + else + begin + writesymbol(p); + if (p^.section<>sec_none) and (relative=relative_false) then + begin + sects[currsec]^.addsectionreloc(sects[currsec]^.len,p^.section); + end + else + sects[currsec]^.addsymreloc(sects[currsec]^.len,p,relative); + if not win32 then {seems wrong to me (PM) } + begin + {if p^.section<>sec_none then + this is the cause of the strange + feature see Note (5) before + address contains the size for + global vars switched to common } + inc(data,p^.address); + end + else + if (relative<>relative_true) and (p^.section<>sec_none) then + inc(data,p^.address); + if relative=relative_true then + begin + if win32 then + {inc(data,4-len)} + dec(data,len-4{+p^.address}) + else + dec(data,len+sects[currsec]^.len); + end; + end; + end; + sects[currsec]^.write(data,len); + end; + + + procedure telfoutputput.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc : boolean); + var + stab : coffstab; + s : tsection; + begin + if section=sec_none then + s:=currsec + else + s:=section; + { local var can be at offset -1 !! PM } + if (offset=-1) and reloc then + begin + if s=sec_none then + offset:=0 + else + offset:=sects[s]^.len; + end; + fillchar(stab,sizeof(coffstab),0); + if assigned(p) and (p[0]<>#0) then + begin + stab.strpos:=sects[sec_stabstr]^.len; + sects[sec_stabstr]^.write(p^,strlen(p)+1); + end; + stab.ntype:=nidx; + stab.ndesc:=line; + stab.nother:=nother; + stab.nvalue:=offset; + sects[sec_stab]^.write(stab,sizeof(stab)); + { when the offset is not 0 then write a relocation, take also the + hdrstab into account with the offset } + if reloc then + sects[sec_stab]^.addsectionreloc(sects[sec_stab]^.len-4,s); + end; + + + procedure telfoutputput.write_relocs(s:pcoffsection); + var + rel : coffreloc; + hr,r : preloc; + begin + r:=s^.relochead; + while assigned(r) do + begin + rel.address:=r^.address; + if assigned(r^.symbol) then + begin + if (r^.symbol^.typ=AS_LOCAL) then + rel.sym:=2*ord(r^.symbol^.section) + else + rel.sym:=r^.symbol^.idx+initsym; + end + else + rel.sym:=2*ord(r^.section); + case r^.relative of + relative_true : rel.relative:=$14; + relative_false : rel.relative:=$6; + relative_rva : rel.relative:=$7; + end; + writer^.write(rel,sizeof(rel)); + { goto next and dispose this reloc } + hr:=r; + r:=r^.next; + dispose(hr); + end; + end; + + + procedure telfoutputput.write_symbol(const name:string;strpos,value,section,typ,aux:longint); + var + sym : coffsymbol; + begin + FillChar(sym,sizeof(sym),0); + if strpos=-1 then + move(name[1],sym.name,length(name)) + else + sym.strpos:=strpos; + sym.value:=value; + sym.section:=section; + sym.typ:=typ; + sym.aux:=aux; + writer^.write(sym,sizeof(sym)); + end; + + + procedure telfoutputput.write_symbols; + var + filename : string[18]; + sec : tsection; + i : longint; + globalval : byte; + secrec : coffsectionrec; + sym : tsymbol; + begin + { The `.file' record, and the file name auxiliary record. } + write_symbol ('.file', -1, 0, -2, $67, 1); + fillchar(filename,sizeof(filename),0); + filename:=SplitFileName(current_module^.mainsource^); + writer^.write(filename[1],sizeof(filename)-1); + { The section records, with their auxiliaries } + i:=0; + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + inc(i); + write_symbol(sec_2_str[sec],-1,{sects[sec]^.pos}0,i,3,1); + fillchar(secrec,sizeof(secrec),0); + secrec.len:=sects[sec]^.len; + secrec.nrelocs:=sects[sec]^.nrelocs; + writer^.write(secrec,sizeof(secrec)); + end; + { The real symbols. } + syms^.seek(0); + for i:=1 to syms^.count do + begin + syms^.read(sym,1); + if sym.typ=AS_LOCAL then + globalval:=3 + else + globalval:=2; + write_symbol(sym.name,sym.strpos,sym.value,sym.section,globalval,0); + end; + end; + + + procedure telfoutputput.writetodisk; + var + datapos, + nsects,pos,sympos,i,fillsize : longint; + sec : tsection; + header : coffheader; + sechdr : coffsechdr; + empty : array[0..15] of byte; + begin + { calc amount of sections we have and align sections at 4 bytes } + fillchar(empty,sizeof(empty),0); + nsects:=0; + for sec:=low(tsection) to high(tsection) do + { .stabstr section length must be without alignment !! } + if assigned(sects[sec]) then + begin + { fill with zero } + fillsize:=4-(sects[sec]^.len and 3); + if fillsize<>4 then + begin + if assigned(sects[sec]^.data) then + sects[sec]^.write(empty,fillsize) + else + sects[sec]^.alloc(fillsize); + { .stabstr section length must be without alignment !! } + if (sec=sec_stabstr) then + dec(sects[sec]^.len,fillsize); + end; + inc(nsects); + end; + { Calculate the filepositions } + datapos:=sizeof(coffheader)+sizeof(coffsechdr)*nsects; + pos:=0; + initsym:=2; { 2 for the file } + { sections first } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + sects[sec]^.pos:=pos; + sects[sec]^.datapos:=datapos; + inc(pos,sects[sec]^.len); + if assigned(sects[sec]^.data) then + inc(datapos,sects[sec]^.len); + { align after stabstr section !! } + if (sec=sec_stabstr) and ((sects[sec]^.len and 3)<>0) then + inc(datapos,4-(sects[sec]^.len and 3)); + inc(initsym,2); { 2 for each section } + end; + { relocs } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + sects[sec]^.relocpos:=datapos; + inc(datapos,10*sects[sec]^.nrelocs); + end; + { symbols } + sympos:=datapos; + { COFF header } + fillchar(header,sizeof(coffheader),0); + header.mach:=$14c; + header.nsects:=nsects; + header.sympos:=sympos; + header.syms:=syms^.count+initsym; + if not win32 then + header.flag:=$104; + writer^.write(header,sizeof(header)); + { Section headers } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + begin + fillchar(sechdr,sizeof(sechdr),0); + move(sec_2_str[sec][1],sechdr.name,length(sec_2_str[sec])); + if not win32 then + sechdr.vsize:=sects[sec]^.pos + else if sec=sec_bss then + sechdr.vsize:=sects[sec]^.len; + sechdr.datalen:=sects[sec]^.len; + { apparently win32 asw leaves section at datapos zero } + { this was an error by me (PM) } + if (sects[sec]^.len>0) and assigned(sects[sec]^.data) then + sechdr.datapos:=sects[sec]^.datapos; + sechdr.relocpos:=sects[sec]^.relocpos; + sechdr.nrelocs:=sects[sec]^.nrelocs; + sechdr.flags:=sects[sec]^.flags; + writer^.write(sechdr,sizeof(sechdr)); + end; + { Sections } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) and + assigned(sects[sec]^.data) then + begin + { For the stab section we need an HdrSym which can now be + calculated more easily } + if sec=sec_stab then + begin + pcoffstab(sects[sec_stab]^.data^.data)^.nvalue:=sects[sec_stabstr]^.len; + pcoffstab(sects[sec_stab]^.data^.data)^.strpos:=1; + pcoffstab(sects[sec_stab]^.data^.data)^.ndesc:= + (sects[sec_stab]^.len div sizeof(coffstab))-1{+1 according to gas output PM}; + end; + writer^.write(sects[sec]^.data^.data^,sects[sec]^.data^.usedsize); + end; + { Relocs } + for sec:=low(tsection) to high(tsection) do + if assigned(sects[sec]) then + write_relocs(sects[sec]); + { Symbols } + write_symbols; + { Strings } + i:=strs^.usedsize+4; + writer^.write(i,4); + writer^.write(strs^.data^,strs^.usedsize); + end; + + +{**************************************************************************** + DJGppcoffoutput +****************************************************************************} + + constructor tdjgppcoffoutput.init; + begin + inherited init; + win32:=false; + end; + + function tdjgppcoffoutput.text_flags : longint; + begin + text_flags:=$20; + end; + + function tdjgppcoffoutput.data_flags : longint; + begin + data_flags:=$40; + end; + + function tdjgppcoffoutput.bss_flags : longint; + begin + bss_flags:=$80; + end; + + function tdjgppcoffoutput.info_flags : longint; + begin + writeln('djgpp coff doesn''t support info sections'); + info_flags:=$40; + end; + + +{**************************************************************************** + Win32coffoutput +****************************************************************************} + + constructor twin32coffoutput.init; + begin + inherited init; + win32:=true; + end; + + function twin32coffoutput.text_flags : longint; + begin + text_flags:={ $60500020}$60300020{changed to get same as asw.exe (PM)}; + end; + + function twin32coffoutput.data_flags : longint; + begin + data_flags:=$c0300040; + end; + + function twin32coffoutput.bss_flags : longint; + begin + bss_flags:=$c0300080; + end; + + function twin32coffoutput.info_flags : longint; + begin + info_flags:=$100a00; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.6 2000/03/21 21:36:05 peter + * some more updates + + Revision 1.5 2000/03/19 18:46:50 peter + * some beginning + +} diff --git a/befpc/compiler/options.pas b/befpc/compiler/options.pas new file mode 100644 index 0000000..18b5aee --- /dev/null +++ b/befpc/compiler/options.pas @@ -0,0 +1,1629 @@ +{ + $Id: options.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl and Peter Vreman + + Reads command line options and config files + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit options; + +interface + +uses + globtype,globals,verbose; + +type + POption=^TOption; + TOption=object + FirstPass, + NoPressEnter, + DoWriteLogo : boolean; + FileLevel : longint; + ParaIncludePath, + ParaUnitPath, + ParaObjectPath, + ParaLibraryPath : TSearchPathList; + Constructor Init; + Destructor Done; + procedure WriteLogo; + procedure WriteInfo; + procedure WriteHelpPages; + procedure QuickInfo(const s:string); + procedure IllegalPara(const opt:string); + function Unsetbool(const opts:string; pos: Longint):boolean; + procedure interpret_proc_specific_options(const opt:string);virtual; + procedure interpret_option(const opt :string;ispara:boolean); + procedure Interpret_envvar(const envname : string); + procedure Interpret_file(const filename : string); + procedure Read_Parameters; + procedure parsecmd(cmd:string); + end; + +procedure read_arguments(cmd:string); + + +implementation + +uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + version,systems, + cobjects, + symtable,scanner,link,messages +{$ifdef BrowserLog} + ,browlog +{$endif BrowserLog} +{$ifdef i386} + ,opts386 +{$endif} +{$ifdef m68k} + ,opts68k +{$endif} + ; + +const + page_size = 24; + +var + option : poption; + read_configfile, { read config file, set when a cfgfile is found } + disable_configfile, + target_is_set : boolean; { do not allow contradictory target settings } + asm_is_set : boolean; { -T also change initoutputformat if not set idrectly } + fpcdir, + ppccfg, + msgfilename, + param_file : string; { file to compile specified on the commandline } + +{**************************************************************************** + Defines +****************************************************************************} + +procedure def_symbol(const s : string); +begin + if s='' then + exit; + initdefines.concat(new(pstring_item,init(upper(s)))); +end; + + +procedure undef_symbol(const s : string); +var + item,next : pstring_item; +begin + if s='' then + exit; + item:=pstring_item(initdefines.first); + while assigned(item) do + begin + if (item^.str^=s) then + begin + next:=pstring_item(item^.next); + initdefines.remove(item); + dispose(item,done); + item:=next; + end + else + if item<>pstring_item(item^.next) then + item:=pstring_item(item^.next) + else + break; + end; +end; + + +function check_symbol(const s:string):boolean; +var + hp : pstring_item; +begin + hp:=pstring_item(initdefines.first); + while assigned(hp) do + begin + if (hp^.str^=s) then + begin + check_symbol:=true; + exit; + end; + hp:=pstring_item(hp^.next); + end; + check_symbol:=false; +end; + +procedure MaybeLoadMessageFile; +begin +{ Load new message file } + if (msgfilename<>'') then + begin + if fileexists(msgfilename) then + LoadMsgFile(msgfilename); + msgfilename:=''; + end; +end; + +{**************************************************************************** + Toption +****************************************************************************} + +procedure StopOptions; +begin + if assigned(Option) then + begin + dispose(Option,Done); + Option:=nil; + end; + DoneVerbose; + Stop; +end; + + +procedure Toption.WriteLogo; +var + p : pchar; +begin + MaybeLoadMessageFile; + p:=MessagePchar(option_logo); + while assigned(p) do + Comment(V_Normal,GetMsgLine(p)); +end; + + +procedure Toption.WriteInfo; +var + p : pchar; +begin + MaybeLoadMessageFile; + p:=MessagePchar(option_info); + while assigned(p) do + Comment(V_Normal,GetMsgLine(p)); + StopOptions; +end; + + +procedure Toption.WriteHelpPages; + + function PadEnd(s:string;i:longint):string; + begin + while (length(s)0) then + begin + Comment(V_Normal,''); + inc(Lines); + end; + { page full ? } + if (lines>=page_size) then + begin + if not NoPressEnter then + begin + write('*** press enter ***'); + readln(input); + if upper(input)='Q' then + StopOptions; + end; + lines:=0; + end; + Comment(V_Normal,PadEnd('',ident)+opt+Copy(s,j+1,255)); + LastIdent:=Ident; + inc(Lines); + end; + end; + StopOptions; +end; + + +procedure Toption.QuickInfo(const s:string); +begin + if source_os.newline=#13#10 then + Write(s+#10) + else + Writeln(s); + StopOptions; +end; + + +procedure Toption.IllegalPara(const opt:string); +begin + Message1(option_illegal_para,opt); + Message(option_help_pages_para); + StopOptions; +end; + + +function Toption.Unsetbool(const opts:string; pos: Longint):boolean; +{ checks if the character after pos in Opts is a + or a - and returns resp. + false or true. If it is another character (or none), it also returns false } +begin + UnsetBool := (Length(Opts) > Pos) And (Opts[Succ(Pos)] = '-'); +end; + + +procedure TOption.interpret_proc_specific_options(const opt:string); +begin +end; + + +procedure TOption.interpret_option(const opt:string;ispara:boolean); +var + code : integer; + c : char; + more : string; + major,minor : longint; + error : integer; + j,l : longint; + d : DirStr; + e : ExtStr; +begin + if opt='' then + exit; + + { only parse define,undef,target,verbosity and link options the firsttime } + if firstpass and + not((opt[1]='-') and (opt[2] in ['i','d','v','T','u','n','X'])) then + exit; + + case opt[1] of + '-' : begin + more:=Copy(opt,3,255); + case opt[2] of + '!' : initlocalswitches:=initlocalswitches+[cs_ansistrings]; + '?' : WriteHelpPages; + 'a' : begin + initglobalswitches:=initglobalswitches+[cs_asm_leave]; + for j:=1 to length(more) do + case more[j] of + 'l' : initglobalswitches:=initglobalswitches+[cs_asm_source]; + 'r' : initglobalswitches:=initglobalswitches+[cs_asm_regalloc]; + 't' : initglobalswitches:=initglobalswitches+[cs_asm_tempalloc]; + '-' : initglobalswitches:=initglobalswitches-[cs_asm_leave,cs_asm_source,cs_asm_regalloc]; + else + IllegalPara(opt); + end; + end; + 'A' : begin + if set_string_asm(More) then + begin + initoutputformat:=target_asm.id; + asm_is_set:=true; + end + else + IllegalPara(opt); + end; + 'b' : begin +{$ifdef BrowserLog} + initglobalswitches:=initglobalswitches+[cs_browser_log]; +{$endif} + if More<>'' then + if More='l' then + initmoduleswitches:=initmoduleswitches+[cs_local_browser] + else if More='-' then + begin + initmoduleswitches:=initmoduleswitches-[cs_browser,cs_local_browser]; +{$ifdef BrowserLog} + initglobalswitches:=initglobalswitches-[cs_browser_log]; +{$endif} + end + else if More<>'+' then +{$ifdef BrowserLog} + browserlog.elements_to_list^.insert(more); +{$else} + IllegalPara(opt); +{$endif} + end; + 'B' : if more='' then + do_build:=true + else + if more = '-' then + do_build := False + else + IllegalPara(opt); + 'C' : begin + j := 1; + while j <= length(more) Do + Begin + case more[j] of + 'a' : Simplify_ppu:=true; + 'h' : + begin + val(copy(more,j+1,length(more)-j),heapsize,code); + if (code<>0) or (heapsize>=67107840) or (heapsize<1024) then + IllegalPara(opt); + break; + end; + 'i' : If UnsetBool(More, j) then + Begin + initlocalswitches:=initlocalswitches-[cs_check_io]; + inc(j) + End + else initlocalswitches:=initlocalswitches+[cs_check_io]; + 'n' : If UnsetBool(More, j) then + Begin + initglobalswitches:=initglobalswitches-[cs_link_extern]; + inc(j) + End + Else initglobalswitches:=initglobalswitches+[cs_link_extern]; + 'o' : + If UnsetBool(More, j) then + Begin + initlocalswitches:=initlocalswitches-[cs_check_overflow]; + inc(j); + End + Else + initlocalswitches:=initlocalswitches+[cs_check_overflow]; + 'r' : + If UnsetBool(More, j) then + Begin + initlocalswitches:=initlocalswitches-[cs_check_range]; + inc(j); + End + Else + initlocalswitches:=initlocalswitches+[cs_check_range]; + 'R' : + If UnsetBool(More, j) then + Begin + initlocalswitches:=initlocalswitches-[cs_check_object_ext]; + inc(j); + End + Else + initlocalswitches:=initlocalswitches+[cs_check_object_ext]; + 's' : + begin + val(copy(more,j+1,length(more)-j),stacksize,code); + if (code<>0) or (stacksize>=67107840) or (stacksize<1024) then + IllegalPara(opt); + break; + end; + 't' : + If UnsetBool(More, j) then + Begin + initlocalswitches:=initlocalswitches-[cs_check_stack]; + inc(j) + End + Else + initlocalswitches:=initlocalswitches+[cs_check_stack]; + 'D' : + If UnsetBool(More, j) then + Begin + initmoduleswitches:=initmoduleswitches-[cs_create_dynamic]; + inc(j) + End + Else + initmoduleswitches:=initmoduleswitches+[cs_create_dynamic]; + 'X' : + If UnsetBool(More, j) then + Begin + initmoduleswitches:=initmoduleswitches-[cs_create_smart]; + inc(j) + End + Else + initmoduleswitches:=initmoduleswitches+[cs_create_smart]; + else + IllegalPara(opt); + end; + inc(j); + end; + end; + 'd' : def_symbol(more); + 'D' : begin + initglobalswitches:=initglobalswitches+[cs_link_deffile]; + for j:=1 to length(more) do + case more[j] of + 'd' : begin + description:=Copy(more,j+1,255); + break; + end; + 'v' : begin + dllversion:=Copy(more,j+1,255); + l:=pos('.',dllversion); + dllminor:=0; + error:=0; + if l>0 then + begin + valint(copy(dllversion,l+1,255),minor,error); + if (error=0) and + (minor>=0) and (minor<=$ffff) then + dllminor:=minor + else if error=0 then + error:=1; + end; + if l=0 then l:=256; + dllmajor:=1; + if error=0 then + valint(copy(dllversion,1,l-1),major,error); + if (error=0) and (major>=0) and (major<=$ffff) then + dllmajor:=major + else if error=0 then + error:=1; + if error<>0 then + Message1(scan_w_wrong_version_ignored,dllversion); + break; + end; + 'w' : usewindowapi:=true; + else + IllegalPara(opt); + end; + end; + 'e' : exepath:=FixPath(More,true); + { Just used by RHIDE } + 'E' : if (length(more)=0) or (UnsetBool(More, 0)) then + initglobalswitches:=initglobalswitches+[cs_link_extern] + else + initglobalswitches:=initglobalswitches-[cs_link_extern]; + 'F' : begin + c:=more[1]; + Delete(more,1,1); + case c of + 'D' : begin + if not ispara then + DefaultReplacements(More); + utilsdirectory:=FixPath(More,true); + end; + 'e' : SetRedirectFile(More); + 'E' : OutputExeDir:=FixPath(More,true); + 'i' : if ispara then + ParaIncludePath.AddPath(More,false) + else + includesearchpath.AddPath(More,true); + 'g' : Message2(option_obsolete_switch_use_new,'-Fg','-Fl'); + 'l' : if ispara then + ParaLibraryPath.AddPath(More,false) + else + LibrarySearchPath.AddPath(More,true); + 'L' : if More<>'' then + ParaDynamicLinker:=More + else + IllegalPara(opt); + 'o' : if ispara then + ParaObjectPath.AddPath(More,false) + else + ObjectSearchPath.AddPath(More,true); + 'r' : Msgfilename:=More; + 'u' : if ispara then + ParaUnitPath.AddPath(More,false) + else + unitsearchpath.AddPath(More,true); + 'U' : OutputUnitDir:=FixPath(More,true); + else + IllegalPara(opt); + end; + end; + 'g' : begin + if UnsetBool(More, 0) then + begin + initmoduleswitches:=initmoduleswitches-[cs_debuginfo]; + if (length(More)>1) and (More[2]='l') then + initglobalswitches:=initglobalswitches+[cs_gdb_lineinfo]; + end + else + begin +{$ifdef GDB} + initmoduleswitches:=initmoduleswitches+[cs_debuginfo]; + if not RelocSectionSetExplicitly then + RelocSection:=false; + for j:=1 to length(more) do + case more[j] of + 'd' : initglobalswitches:=initglobalswitches+[cs_gdb_dbx]; + 'g' : initglobalswitches:=initglobalswitches+[cs_gdb_gsym]; + 'h' : initglobalswitches:=initglobalswitches+[cs_gdb_heaptrc]; + 'l' : initglobalswitches:=initglobalswitches+[cs_gdb_lineinfo]; + 'c' : initglobalswitches:=initglobalswitches+[cs_checkpointer]; +{$ifdef EXTDEBUG} + 'p' : only_one_pass:=true; +{$endif EXTDEBUG} + else + IllegalPara(opt); + end; +{$else GDB} + Message(option_no_debug_support); + Message(option_no_debug_support_recompile_fpc); +{$endif GDB} + end; + end; + 'h' : begin + NoPressEnter:=true; + WriteHelpPages; + end; + 'i' : if more='' then + WriteInfo + else + begin + { Specific info, which can be used in Makefiles } + case More[1] of + 'S' : begin + case More[2] of + 'O' : QuickInfo(source_os.shortname); +{$ifdef Delphi !!!!!!!!!} + 'P' : QuickInfo('unknown'); +{$else} + 'P' : QuickInfo(source_cpu_string); +{$endif} + end; + end; + 'T' : begin + case More[2] of + 'O' : QuickInfo(target_os.shortname); + 'P' : QuickInfo(target_cpu_string); + end; + end; + 'V' : QuickInfo(version_string); + 'D' : QuickInfo(date_string); + else + IllegalPara(Opt); + end; + end; + 'I' : if ispara then + ParaIncludePath.AddPath(More,false) + else + includesearchpath.AddPath(More,false); + 'k' : if more<>'' then + ParaLinkOptions:=ParaLinkOptions+' '+More + else + IllegalPara(opt); + 'l' : if more='' then + DoWriteLogo:=true + else + IllegalPara(opt); + 'm' : parapreprocess:=true; + 'n' : if More='' then + begin + read_configfile:=false; + disable_configfile:=true; + end + else + IllegalPara(opt); + 'o' : if More<>'' then + Fsplit(More,d,OutputFile,e) + else + IllegalPara(opt); + 'p' : begin + if UnsetBool(More, 0) then + begin + initmoduleswitches:=initmoduleswitches-[cs_profile]; + undef_symbol('FPC_PROFILE'); + end + else + case more[1] of + 'g' : if (length(opt)=3) and UnsetBool(more, 1) then + begin + initmoduleswitches:=initmoduleswitches-[cs_profile]; + undef_symbol('FPC_PROFILE'); + end + else + begin + initmoduleswitches:=initmoduleswitches+[cs_profile]; + def_symbol('FPC_PROFILE'); + end; + else + IllegalPara(opt); + end; + end; +{$ifdef linux} + 'P' : initglobalswitches:=initglobalswitches+[cs_asm_pipe]; +{$endif} + 's' : initglobalswitches:=initglobalswitches+[cs_asm_extern,cs_link_extern]; + 'S' : begin + for j:=1 to length(more) do + case more[j] of + '2' : initmodeswitches:=objfpcmodeswitches; + 'a' : initlocalswitches:=InitLocalswitches+[cs_do_assertion]; + 'c' : initmoduleswitches:=initmoduleswitches+[cs_support_c_operators]; + 'd' : initmodeswitches:=delphimodeswitches; + 'e' : begin + SetErrorFlags(more); + break; + end; + 'g' : initmoduleswitches:=initmoduleswitches+[cs_support_goto]; + 'h' : initlocalswitches:=initlocalswitches+[cs_ansistrings]; + 'i' : initmoduleswitches:=initmoduleswitches+[cs_support_inline]; + 'm' : initmoduleswitches:=initmoduleswitches+[cs_support_macro]; + 'o': initmodeswitches:=tpmodeswitches; + 'p' : initmodeswitches:=gpcmodeswitches; + 's' : initglobalswitches:=initglobalswitches+[cs_constructor_name]; + 't' : initmoduleswitches:=initmoduleswitches+[cs_static_keyword]; + 'v' : Message1(option_obsolete_switch,'-Sv'); + else + IllegalPara(opt); + end; + end; + 'T' : begin + more:=Upper(More); + if not target_is_set then + begin + { remove old target define } + undef_symbol(target_info.short_name); + { load new target } + if not(set_string_target(More)) then + IllegalPara(opt); + { set new define } + def_symbol(target_info.short_name); + if not asm_is_set then + initoutputformat:=target_asm.id; + target_is_set:=true; + end + else + if More<>target_info.short_name then + Message1(option_target_is_already_set,target_info.short_name); + end; + 'u' : undef_symbol(upper(More)); + 'U' : begin + for j:=1 to length(more) do + case more[j] of +{$ifdef UNITALIASES} + 'a' : begin + AddUnitAlias(Copy(More,j+1,255)); + break; + end; +{$endif UNITALIASES} + 'n' : initglobalswitches:=initglobalswitches-[cs_check_unit_name]; + 'p' : begin + Message2(option_obsolete_switch_use_new,'-Up','-Fu'); + break; + end; + 's' : initmoduleswitches:=initmoduleswitches+[cs_compilesystem]; + else + IllegalPara(opt); + end; + end; + 'v' : if not setverbosity(More) then + IllegalPara(opt); + 'W' : begin + for j:=1 to length(More) do + case More[j] of + 'B': {bind_win32_dll:=true} + begin + { -WB200000 means set prefered base address + to $200000, but does not change relocsection boolean + this way we can create both relocatble and + non relocatable DLL at a specific base address PM } + if (length(More)>j) then + begin + if DLLImageBase=nil then + DLLImageBase:=StringDup(Copy(More,j+1,255)); + end + else + begin + RelocSection:=true; + RelocSectionSetExplicitly:=true; + end; + break; + end; + 'C': apptype:=at_cui; + 'D': ForceDeffileForExport:=true; + 'G': apptype:=at_gui; + 'N': begin + RelocSection:=false; + RelocSectionSetExplicitly:=true; + end; + + 'R': begin + RelocSection:=true; + RelocSectionSetExplicitly:=true; + end; + else + IllegalPara(opt); + end; + end; + 'X' : begin + for j:=1 to length(More) do + case More[j] of + 'c' : initglobalswitches:=initglobalswitches+[cs_link_toc]; + 's' : initglobalswitches:=initglobalswitches+[cs_link_strip]; + 't' : initglobalswitches:=initglobalswitches+[cs_link_staticflag]; + 'D' : begin + def_symbol('FPC_LINK_DYNAMIC'); + undef_symbol('FPC_LINK_SMART'); + undef_symbol('FPC_LINK_STATIC'); + initglobalswitches:=initglobalswitches+[cs_link_shared]; + initglobalswitches:=initglobalswitches-[cs_link_static,cs_link_smart]; + LinkTypeSetExplicitly:=true; + end; + 'S' : begin + def_symbol('FPC_LINK_STATIC'); + undef_symbol('FPC_LINK_SMART'); + undef_symbol('FPC_LINK_DYNAMIC'); + initglobalswitches:=initglobalswitches+[cs_link_static]; + initglobalswitches:=initglobalswitches-[cs_link_shared,cs_link_smart]; + LinkTypeSetExplicitly:=true; + end; + 'X' : begin + def_symbol('FPC_LINK_SMART'); + undef_symbol('FPC_LINK_STATIC'); + undef_symbol('FPC_LINK_DYNAMIC'); + initglobalswitches:=initglobalswitches+[cs_link_smart]; + initglobalswitches:=initglobalswitches-[cs_link_shared,cs_link_static]; + LinkTypeSetExplicitly:=true; + end; + else + IllegalPara(opt); + end; + end; + { give processor specific options a chance } + else + interpret_proc_specific_options(opt); + end; + end; + '@' : begin + Message(option_no_nested_response_file); + StopOptions; + end; + else + begin + if (length(param_file)<>0) then + Message(option_only_one_source_support); + param_file:=opt; + end; + end; +end; + + +procedure Toption.Interpret_file(const filename : string); + + procedure RemoveSep(var fn:string); + var + i : longint; + begin + i:=0; + while (i0) and (fn[i] in [',',' ',#9]) do + dec(i); + fn:=copy(fn,1,i); + end; + + function GetName(var fn:string):string; + var + i : longint; + begin + i:=0; + while (iMaxLevel then + Message(option_too_many_cfg_files); +{ open file } + assign(f,filename); +{$ifdef extdebug} + Comment(V_Info,'trying to open file: '+filename); +{$endif extdebug} + {$I-} + reset(f); + {$I+} + if ioresult<>0 then + begin + Message1(option_unable_open_file,filename); + exit; + end; + fillchar(skip,sizeof(skip),0); + level:=0; + while not eof(f) do + begin + readln(f,opts); + RemoveSep(opts); + if (opts<>'') and (opts[1]<>';') then + begin + if opts[1]='#' then + begin + Delete(opts,1,1); + s:=upper(GetName(opts)); + if (s='SECTION') then + begin + RemoveSep(opts); + s:=upper(GetName(opts)); + if level=0 then + skip[level]:=not (check_symbol(s) or (s='COMMON')); + end + else + if (s='IFDEF') then + begin + RemoveSep(opts); + if Level>=maxlevel then + begin + Message(option_too_many_ifdef); + stopOptions; + end; + inc(Level); + skip[level]:=(skip[level-1] or (not check_symbol(upper(GetName(opts))))); + end + else + if (s='IFNDEF') then + begin + RemoveSep(opts); + if Level>=maxlevel then + begin + Message(option_too_many_ifdef); + stopOptions; + end; + inc(Level); + skip[level]:=(skip[level-1] or (check_symbol(upper(GetName(opts))))); + end + else + if (s='ELSE') then + skip[level]:=skip[level-1] or (not skip[level]) + else + if (s='ENDIF') then + begin + skip[level]:=false; + if Level=0 then + begin + Message(option_too_many_endif); + stopOptions; + end; + dec(level); + end + else + if (not skip[level]) then + begin + if (s='DEFINE') then + begin + RemoveSep(opts); + def_symbol(upper(GetName(opts))); + end + else + if (s='UNDEF') then + begin + RemoveSep(opts); + undef_symbol(upper(GetName(opts))); + end + else + if (s='WRITE') then + begin + Delete(opts,1,1); + WriteLn(opts); + end + else + if (s='INCLUDE') then + begin + Delete(opts,1,1); + Interpret_file(opts); + end; + end; + end + else + begin + if (opts[1]='-') then + begin + if (not skip[level]) then + interpret_option(opts,false); + Option_read:=true; + end + else + Message1(option_illegal_para,opts); + end; + end; + end; + if Level>0 then + Message(option_too_less_endif); + if Not Option_read then + Message1(option_no_option_found,filename); + Close(f); + Dec(FileLevel); +end; + + +procedure Toption.Interpret_envvar(const envname : string); +var + argstart, + env, + pc : pchar; + arglen : longint; + quote : set of char; + hs : string; +begin + env:=GetEnvPChar(envname); + pc:=env; + if assigned(pc) then + begin + repeat + { skip leading spaces } + while pc^ in [' ',#9,#13] do + inc(pc); + case pc^ of + #0 : + break; + '"' : + begin + quote:=['"']; + inc(pc); + end; + '''' : + begin + quote:=['''']; + inc(pc); + end; + else + quote:=[' ',#9,#13]; + end; + { scan until the end of the argument } + argstart:=pc; + while (pc^<>#0) and not(pc^ in quote) do + inc(pc); + { create argument } + arglen:=pc-argstart; + hs[0]:=chr(arglen); + move(argstart^,hs[1],arglen); + interpret_option(hs,true); + { skip quote } + if pc^ in quote then + inc(pc); + until false; + end + else + Message1(option_no_option_found,'(env) '+envname); + FreeEnvPChar(env); +end; + + +procedure toption.read_parameters; +var + opts : string; + paramindex : longint; +begin + paramindex:=0; + while paramindex'') do + begin + while cmd[1]=' ' do + delete(cmd,1,1); + i:=pos(' ',cmd); + if i=0 then + i:=256; + opts:=Copy(cmd,1,i-1); + Delete(cmd,1,i); + case opts[1] of + '@' : + begin + Delete(opts,1,1); + if not firstpass then + Message1(option_reading_further_from,opts); + interpret_file(opts); + end; + '!' : + begin + Delete(opts,1,1); + if not firstpass then + Message1(option_reading_further_from,'(env) '+opts); + interpret_envvar(opts); + end; + '"' : + begin + Delete(opts,1,1); + ps:=pos('"',cmd); + if (i<>256) and (ps>0) then + begin + opts:=opts + ' '+ copy(cmd,1,ps-1); + cmd:=copy(cmd,ps+1,255); + end; + interpret_option(opts,true); + end; + else + interpret_option(opts,true); + end; + end; +end; + + +constructor TOption.Init; +begin + DoWriteLogo:=false; + NoPressEnter:=false; + FirstPass:=false; + FileLevel:=0; + ParaIncludePath.Init; + ParaObjectPath.Init; + ParaUnitPath.Init; + ParaLibraryPath.Init; +end; + + +destructor TOption.Done; +begin + ParaIncludePath.Done; + ParaObjectPath.Done; + ParaUnitPath.Done; + ParaLibraryPath.Done; +end; + + +{**************************************************************************** + Callable Routines +****************************************************************************} + +procedure read_arguments(cmd:string); +var + configpath : pathstr; +begin +{$ifdef Delphi} + option:=new(poption386,Init); +{$endif Delphi} +{$ifdef i386} + option:=new(poption386,Init); +{$endif} +{$ifdef m68k} + option:=new(poption68k,Init); +{$endif} +{$ifdef alpha} + option:=new(poption,Init); +{$endif} +{$ifdef powerpc} + option:=new(poption,Init); +{$endif} +{ Load messages } + if (cmd='') and (paramcount=0) then + Option^.WriteHelpPages; + + disable_configfile:=false; +{ default defines } + def_symbol(target_info.short_name); + def_symbol('FPK'); + def_symbol('FPC'); + def_symbol('VER'+version_nr); + def_symbol('VER'+version_nr+'_'+release_nr); + def_symbol('VER'+version_nr+'_'+release_nr+'_'+patch_nr); +{$ifdef newcg} + def_symbol('WITHNEWCG'); +{$endif} + +{ Temporary defines, until things settle down } + def_symbol('INT64'); + def_symbol('HASRESOURCESTRINGS'); + def_symbol('HASSAVEREGISTERS'); + def_symbol('NEWVMTOFFSET'); + def_symbol('HASINTERNMATH'); + def_symbol('SYSTEMTVARREC'); + def_symbol('INCLUDEOK'); + def_symbol('NEWMM'); + def_symbol('HASWIDECHAR'); + +{$ifdef SUPPORT_FIXED} + def_symbol('HASFIXED'); +{$endif SUPPORT_FIXED} +{$ifdef cardinalmulfix} +{ for the compiler } + def_symbol('CARDINALMULFIX'); +{ for the RTL } + def_symbol('CARDINALMULFIXED'); +{$endif cardinalmulfix} + def_symbol('CORRECTFLDCW'); + def_symbol('ENHANCEDRAISE'); + +{ some stuff for TP compatibility } +{$ifdef i386} + def_symbol('CPU86'); + def_symbol('CPU87'); +{$endif} +{$ifdef m68k} + def_symbol('CPU68'); +{$endif} + +{ new processor stuff } +{$ifdef i386} + def_symbol('CPUI386'); +{$endif} +{$ifdef m68k} + def_symbol('CPU68K'); +{$endif} +{$ifdef ALPHA} + def_symbol('CPUALPHA'); +{$endif} +{$ifdef powerpc} + def_symbol('CPUPOWERPC'); +{$endif} + +{ get default messagefile } +{$ifdef Delphi} + msgfilename:=dmisc.getenv('PPC_ERROR_FILE'); +{$else Delphi} + msgfilename:=dos.getenv('PPC_ERROR_FILE'); +{$endif Delphi} +{ default configfile } + if (cmd<>'') and (cmd[1]='[') then + begin + ppccfg:=Copy(cmd,2,pos(']',cmd)-2); + Delete(cmd,1,pos(']',cmd)); + end + else + begin +{$ifdef i386} + ppccfg:='ppc386.cfg'; +{$endif i386} +{$ifdef m68k} + ppccfg:='ppc.cfg'; +{$endif} +{$ifdef alpha} + ppccfg:='ppcalpha.cfg'; +{$endif} +{$ifdef powerpc} + ppccfg:='ppcppc.cfg'; +{$endif} + end; + +{ Order to read ppc386.cfg: + 1 - current dir + 2 - configpath + 3 - compiler path } +{$ifdef Delphi} + configpath:=FixPath(dmisc.getenv('PPC_CONFIG_PATH'),false); +{$else Delphi} + configpath:=FixPath(dos.getenv('PPC_CONFIG_PATH'),false); +{$endif Delphi} +{$ifdef linux} + if configpath='' then + configpath:='/etc/'; +{$endif} + if ppccfg<>'' then + begin + read_configfile:=true; + if not FileExists(ppccfg) then + begin +{$ifdef linux} + if (dos.getenv('HOME')<>'') and FileExists(FixPath(dos.getenv('HOME'),false)+'.'+ppccfg) then + ppccfg:=FixPath(dos.getenv('HOME'),false)+'.'+ppccfg + else +{$endif} + if FileExists(configpath+ppccfg) then + ppccfg:=configpath+ppccfg + else +{$ifndef linux} + if FileExists(exepath+ppccfg) then + ppccfg:=exepath+ppccfg + else +{$endif} + read_configfile:=false; + end; + end + else + read_configfile:=false; + +{ Read commandline and configfile } + target_is_set:=false; + asm_is_set:=false; + + param_file:=''; + + if read_configfile then + begin + { read the parameters quick, only -v -T } + option^.firstpass:=true; + if cmd<>'' then + option^.parsecmd(cmd) + else + option^.read_parameters; + option^.firstpass:=false; + if read_configfile then + begin +{$ifdef DEBUG} + Comment(V_Debug,'read config file: '+ppccfg); +{$endif DEBUG} + option^.interpret_file(ppccfg); + end; + end; + if cmd<>'' then + option^.parsecmd(cmd) + else + option^.read_parameters; + +{ Stop if errors in options } + if ErrorCount>0 then + StopOptions; + +{ write logo if set } + if option^.DoWriteLogo then + option^.WriteLogo; + +{ Check file to compile } + if param_file='' then + begin + Message(option_no_source_found); + StopOptions; + end; +{$ifndef linux} + param_file:=FixFileName(param_file); +{$endif} + fsplit(param_file,inputdir,inputfile,inputextension); + if inputextension='' then + begin + if FileExists(inputdir+inputfile+target_os.sourceext) then + inputextension:=target_os.sourceext + else + if FileExists(inputdir+inputfile+target_os.pasext) then + inputextension:=target_os.pasext; + end; + +{ Add paths specified with parameters to the searchpaths } + UnitSearchPath.AddList(Option^.ParaUnitPath,true); + ObjectSearchPath.AddList(Option^.ParaObjectPath,true); + IncludeSearchPath.AddList(Option^.ParaIncludePath,true); + LibrarySearchPath.AddList(Option^.ParaLibraryPath,true); + +{ add unit environment and exepath to the unit search path } + if inputdir<>'' then + Unitsearchpath.AddPath(inputdir,true); + if not disable_configfile then +{$ifdef Delphi} + UnitSearchPath.AddPath(dmisc.getenv(target_info.unit_env),false); +{$else} + UnitSearchPath.AddPath(dos.getenv(target_info.unit_env),false); +{$endif Delphi} +{$ifdef linux} + fpcdir:=FixPath(getenv('FPCDIR'),false); + if fpcdir='' then + begin + if PathExists('/boot/fpc/'+version_string) then + fpcdir:='/boot/fpc/'+version_string+'/' + else + fpcdir:='/boot/fpc/'+version_string+'/'; + end; +{ fpcdir:=FixPath(getenv('FPCDIR'),false); + if fpcdir='' then + begin + if PathExists('/usr/local/lib/fpc/'+version_string) then + fpcdir:='/usr/local/lib/fpc/'+version_string+'/' + else + fpcdir:='/usr/lib/fpc/'+version_string+'/'; + end;} +{$else} +{$ifdef beos} + fpcdir:=FixPath(getenv('FPCDIR'),false); + if fpcdir='' then + begin + if PathExists('/boot/fpc/'+version_string) then + fpcdir:='/boot/fpc/'+version_string+'/' + else + fpcdir:='/boot/fpc/'+version_string+'/'; + end; +{$else} + fpcdir:=FixPath(getenv('FPCDIR'),false); + if fpcdir='' then + begin + fpcdir:=ExePath+'../'; + if not(PathExists(fpcdir+'/units')) and + not(PathExists(fpcdir+'/rtl')) then + fpcdir:=fpcdir+'../'; + end; +{$endif beos} +{$endif linux} + { first try development RTL, else use the default installation path } + if not disable_configfile then + begin + if PathExists(FpcDir+'rtl/'+lower(target_info.short_name)) then + UnitSearchPath.AddPath(FpcDir+'rtl/'+lower(target_info.short_name),false) + else + begin + UnitSearchPath.AddPath(FpcDir+'units/'+lower(target_info.short_name),false); + UnitSearchPath.AddPath(FpcDir+'units/'+lower(target_info.short_name)+'/rtl',false); + end; + end; + { Add exepath if the exe is not in the current dir, because that is always searched already } + if ExePath<>GetCurrentDir then + UnitSearchPath.AddPath(ExePath,false); + { Add unit dir to the object and library path } + objectsearchpath.AddList(unitsearchpath,false); + librarysearchpath.AddList(unitsearchpath,false); + +{ switch assembler if it's binary and we got -a on the cmdline } + if (cs_asm_leave in initglobalswitches) and + (target_asm.id in binassem) then + begin + Message(option_switch_bin_to_src_assembler); + set_target_asm(target_info.assemsrc); + initoutputformat:=target_asm.id; + end; + + if (target_asm.supported_target <> target_any) and + (target_asm.supported_target <> target_info.target) then + begin + Message2(option_incompatible_asm,target_asm.idtxt,target_os.name); + { Should we reset to default ??? } + set_target_asm(target_info.assemsrc); + Message1(option_asm_forced,target_asm.idtxt); + initoutputformat:=target_asm.id; + end; + +{ turn off stripping if compiling with debuginfo or profile } + if (cs_debuginfo in initmoduleswitches) or + (cs_profile in initmoduleswitches) then + initglobalswitches:=initglobalswitches-[cs_link_strip]; + + if not LinkTypeSetExplicitly then + begin + if (target_os.id=os_i386_win32) then + begin + def_symbol('FPC_LINK_SMART'); + undef_symbol('FPC_LINK_STATIC'); + undef_symbol('FPC_LINK_DYNAMIC'); + initglobalswitches:=initglobalswitches+[cs_link_smart]; + initglobalswitches:=initglobalswitches-[cs_link_shared,cs_link_static]; + end + else + begin + undef_symbol('FPC_LINK_SMART'); + def_symbol('FPC_LINK_STATIC'); + undef_symbol('FPC_LINK_DYNAMIC'); + initglobalswitches:=initglobalswitches+[cs_link_static]; + initglobalswitches:=initglobalswitches-[cs_link_shared,cs_link_smart]; + end; + end; +{ Set defines depending on the target } + if (target_info.target in [target_i386_GO32V1,target_i386_GO32V2]) then + def_symbol('DPMI'); { MSDOS is not defined in BP when target is DPMI } + + MaybeLoadMessageFile; + + dispose(option,Done); + Option:=nil; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.71 2000/06/30 20:23:38 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.70 2000/06/19 19:57:19 pierre + * smart link is default on win32 + + Revision 1.69 2000/05/23 21:28:22 pierre + + check of compatibility between selected assembler + output and target OS + + Revision 1.68 2000/05/16 20:19:06 pierre + + -CR option to enable check for object virtual method + + Revision 1.67 2000/05/10 13:40:19 peter + * -Se option extended to increase errorcount for + warning,notes or hints + + Revision 1.66 2000/04/24 13:34:29 peter + * added enhancedraise define + + Revision 1.65 2000/04/10 11:36:19 pierre + * get -g-l to work + + Revision 1.64 2000/04/07 14:56:18 peter + * correctfldcw define added + + Revision 1.63 2000/04/05 21:57:34 pierre + * no unitdir automatically added if -n option present + + Revision 1.62 2000/03/13 20:06:59 michael + + Added switch to swicth on assertions. + + Revision 1.61 2000/02/15 14:36:45 florian + * disable FIXED data type per default + + Revision 1.60 2000/02/10 11:45:48 peter + * addpath fixed with list of paths when inserting at the beginning + * if exepath=currentdir then it's not inserted in path list + * searchpaths in ppc386.cfg are now added at the beginning of the + list instead of at the end. (commandline is not changed) + * check paths before inserting in list + + Revision 1.59 2000/02/09 13:22:54 peter + * log truncated + + Revision 1.58 2000/02/09 10:35:48 peter + * -Xt option to link staticly against c libs + + Revision 1.57 2000/02/06 17:20:52 peter + * -gl switch for auto lineinfo including + + Revision 1.56 2000/01/31 15:55:42 peter + * fixed default unit location for linux when fpcdir was not set + + Revision 1.55 2000/01/23 18:20:50 sg + * Fixed typo in line 1375 ("fpidr" instead of "fpcdir") + + Revision 1.54 2000/01/23 16:36:37 peter + * better auto RTL dir detection + + Revision 1.53 2000/01/20 10:36:44 daniel + * also support ; comments in cfg file + + Revision 1.52 2000/01/17 22:50:28 peter + * fixed interpret_envvar whcih crashed when the envvar was not set + * also warn if the envvar is empty (=not set) + + Revision 1.51 2000/01/14 15:33:15 pierre + + parsecmd supports "filename with spaces" for IDE + + Revision 1.50 2000/01/14 14:33:54 pierre + + some warnings for wrong lines inside config files + + Revision 1.49 2000/01/10 11:14:19 peter + * fixed memory leak with options, you must use StopOptions instead of + Stop + * fixed memory leak with forward resolving, make_ref is now false + + Revision 1.48 2000/01/07 22:22:02 marco + * Added $target support for -FD + + Revision 1.47 2000/01/07 01:14:27 peter + * updated copyright to 2000 + + Revision 1.46 2000/01/06 15:48:59 peter + * wildcard support for directory adding, this allows the use of units/* + in ppc386.cfg + + Revision 1.45 1999/12/20 23:23:30 pierre + + $description $version + + Revision 1.44 1999/12/20 21:42:36 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.43 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.42 1999/12/11 18:53:31 jonas + * fixed type conversions of results of operations with cardinals + (between -dcardinalmulfix) + + Revision 1.41 1999/12/10 10:03:54 peter + * fixed parameter orderning + + Revision 1.40 1999/12/08 10:40:01 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.39 1999/12/06 18:21:03 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + +} \ No newline at end of file diff --git a/befpc/compiler/opts386.pas b/befpc/compiler/opts386.pas new file mode 100644 index 0000000..038e517 --- /dev/null +++ b/befpc/compiler/opts386.pas @@ -0,0 +1,134 @@ +{ + $Id: opts386.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + interprets the commandline options which are i386 specific + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit opts386; +interface + +uses + options; + +type + poption386=^toption386; + toption386=object(toption) + procedure interpret_proc_specific_options(const opt:string);virtual; + end; + +implementation + +uses + globtype,systems,globals; + +procedure toption386.interpret_proc_specific_options(const opt:string); +var + j : longint; + More : string; +begin + More:=Upper(copy(opt,3,length(opt)-2)); + case opt[2] of + 'O' : Begin + j := 3; + While (j <= Length(Opt)) Do + Begin + case opt[j] of + '-' : initglobalswitches:=initglobalswitches-[cs_optimize,cs_fastoptimize,cs_slowoptimize,cs_littlesize, + cs_regalloc,cs_uncertainopts,cs_align]; +{$ifdef OPTALIGN} + 'a' : initglobalswitches:=initglobalswitches+[cs_align]; +{$endif OPTALIGN} + 'g' : initglobalswitches:=initglobalswitches+[cs_littlesize]; + 'G' : initglobalswitches:=initglobalswitches-[cs_littlesize]; + 'r' : initglobalswitches:=initglobalswitches+[cs_regalloc]; + 'u' : initglobalswitches:=initglobalswitches+[cs_optimize,cs_uncertainopts]; + '1' : initglobalswitches:=initglobalswitches-[cs_slowoptimize,cs_uncertainopts]+[cs_optimize,cs_fastoptimize]; + '2' : initglobalswitches:=initglobalswitches-[cs_uncertainopts]+[cs_optimize,cs_fastoptimize,cs_slowoptimize]; + '3' : initglobalswitches:=initglobalswitches+[cs_optimize,cs_fastoptimize,cs_slowoptimize,cs_uncertainopts]; + 'p' : + Begin + If j < Length(Opt) Then + Begin + Case opt[j+1] Of + '1': initoptprocessor := Class386; + '2': initoptprocessor := ClassP5; + '3': initoptprocessor := ClassP6 + Else IllegalPara(Opt) + End; + Inc(j); + End + Else IllegalPara(opt) + End; +{$ifdef USECMOV} + 's' : + Begin + If j < Length(Opt) Then + Begin + Case opt[j+1] Of + '3': initspecificoptprocessor:=ClassP6 + Else IllegalPara(Opt) + End; + Inc(j); + End + Else IllegalPara(opt) + End +{$endif USECMOV} + else IllegalPara(opt); + End; + Inc(j) + end; + end; + 'R' : begin + if More='ATT' then + initasmmode:=asmmode_i386_att + else + if More='INTEL' then + initasmmode:=asmmode_i386_intel + else + if More='DIRECT' then + initasmmode:=asmmode_i386_direct + else + IllegalPara(opt); + end; + else + IllegalPara(opt); + end; +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/05/31 06:58:50 florian + * first implementation of -Oa switch + + Revision 1.19 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.18 2000/01/23 21:29:17 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.17 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.16 1999/08/04 13:02:47 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + +} \ No newline at end of file diff --git a/befpc/compiler/opts68k.pas b/befpc/compiler/opts68k.pas new file mode 100644 index 0000000..dd6b3bb --- /dev/null +++ b/befpc/compiler/opts68k.pas @@ -0,0 +1,81 @@ +{ + $Id: opts68k.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + interprets the commandline options which are m68k specific + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + } + +unit opts68k; +interface + +uses + options; + +type + poption68k=^toption68k; + toption68k=object(toption) + procedure interpret_proc_specific_options(const opt:string);virtual; + end; + +implementation + +uses + globtype,systems,globals; + +procedure toption68k.interpret_proc_specific_options(const opt:string); +var + j : longint; + More : string; +begin + More:=Upper(copy(opt,3,length(opt)-2)); + case opt[2] of + 'O' : begin + for j:=3 to length(opt) do + case opt[j] of + '-' : initglobalswitches:=initglobalswitches-[cs_optimize,cs_regalloc,cs_littlesize]; + 'a' : initglobalswitches:=initglobalswitches+[cs_optimize]; + 'g' : initglobalswitches:=initglobalswitches+[cs_littlesize]; + 'G' : initglobalswitches:=initglobalswitches-[cs_littlesize]; + 'x' : initglobalswitches:=initglobalswitches+[cs_optimize,cs_regalloc]; + '2' : initoptprocessor:=MC68020; + else + IllegalPara(opt); + end; + end; + 'R' : begin + if More='MOT' then + initasmmode:=asmmode_m68k_mot + else + IllegalPara(opt); + end; + + else + IllegalPara(opt); + end; +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.8 2000/01/07 01:14:28 peter + * updated copyright to 2000 + +} + diff --git a/befpc/compiler/owar.pas b/befpc/compiler/owar.pas new file mode 100644 index 0000000..a427123 --- /dev/null +++ b/befpc/compiler/owar.pas @@ -0,0 +1,295 @@ +{ + $Id: owar.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + Contains the stuff for writing .a files directly + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit owar; +interface + +uses + cobjects,owbase; + +type + tarhdr=packed record + name : array[0..15] of char; + date : array[0..11] of char; + uid : array[0..5] of char; + gid : array[0..5] of char; + mode : array[0..7] of char; + size : array[0..9] of char; + fmag : array[0..1] of char; + end; + + parobjectwriter=^tarobjectwriter; + tarobjectwriter=object(tobjectwriter) + constructor Init(const Aarfn:string); + destructor Done;virtual; + procedure create(const fn:string);virtual; + procedure close;virtual; + procedure writesym(sym:string);virtual; + procedure write(var b;len:longint);virtual; + private + arfn : string; + arhdr : tarhdr; + symreloc, + symstr, + lfnstr, + ardata, + objdata : PDynamicArray; + objfixup : longint; + objfn : string; + timestamp : string[12]; + procedure createarhdr(fn:string;size:longint;const gid,uid,mode:string); + procedure writear; + end; + + +implementation + +uses + verbose, +{$ifdef Delphi} + dmisc; +{$else Delphi} + dos; +{$endif Delphi} + +const +{$ifdef TP} + symrelocbufsize = 32; + symstrbufsize = 256; + lfnstrbufsize = 256; + arbufsize = 256; + objbufsize = 256; +{$else} + symrelocbufsize = 1024; + symstrbufsize = 8192; + lfnstrbufsize = 4096; + arbufsize = 65536; + objbufsize = 16384; +{$endif} + +{***************************************************************************** + Helpers +*****************************************************************************} + +const + C1970=2440588; + D0=1461; + D1=146097; + D2=1721119; +Function Gregorian2Julian(DT:DateTime):LongInt; +Var + Century,XYear,Month : LongInt; +Begin + Month:=DT.Month; + If Month<=2 Then + Begin + Dec(DT.Year); + Inc(Month,12); + End; + Dec(Month,3); + Century:=(longint(DT.Year Div 100)*D1) shr 2; + XYear:=(longint(DT.Year Mod 100)*D0) shr 2; + Gregorian2Julian:=((((Month*153)+2) div 5)+DT.Day)+D2+XYear+Century; +End; + +function DT2Unix(DT:DateTime):LongInt; +Begin + DT2Unix:=(Gregorian2Julian(DT)-C1970)*86400+(LongInt(DT.Hour)*3600)+(DT.Min*60)+DT.Sec; +end; + + +{***************************************************************************** + TArObjectWriter +*****************************************************************************} + +constructor tarobjectwriter.init(const Aarfn:string); +var + time : datetime; + dummy : word; +begin + arfn:=Aarfn; + new(arData,init(1,arbufsize)); + new(symreloc,init(4,symrelocbufsize)); + new(symstr,init(1,symstrbufsize)); + new(lfnstr,init(1,lfnstrbufsize)); +{ create timestamp } + getdate(time.year,time.month,time.day,dummy); + gettime(time.hour,time.min,time.sec,dummy); + Str(DT2Unix(time),timestamp); +end; + + +destructor tarobjectwriter.done; +begin + if Errorcount=0 then + writear; + dispose(arData,done); + dispose(symreloc,done); + dispose(symstr,done); + dispose(lfnstr,done); +end; + + +procedure tarobjectwriter.createarhdr(fn:string;size:longint;const gid,uid,mode:string); +var + tmp : string[9]; +begin + fillchar(arhdr,sizeof(tarhdr),' '); +{ create ar header } + fn:=fn+'/'; + if length(fn)>16 then + begin + arhdr.name[0]:='/'; + str(lfnstr^.usedsize,tmp); + move(tmp[1],arhdr.name[1],length(tmp)); + fn:=fn+#10; + lfnstr^.write(fn[1],length(fn)); + end + else + move(fn[1],arhdr.name,length(fn)); + { don't write a date if also no gid/uid/mode is specified } + if gid<>'' then + move(timestamp[1],arhdr.date,sizeof(timestamp)); + str(size,tmp); + move(tmp[1],arhdr.size,length(tmp)); + move(gid[1],arhdr.gid,length(gid)); + move(uid[1],arhdr.uid,length(uid)); + move(mode[1],arhdr.mode,length(mode)); + arhdr.fmag:='`'#10; +end; + + +procedure tarobjectwriter.create(const fn:string); +begin + objfn:=fn; + objfixup:=ardata^.usedsize; +{ reset size } + new(objdata,init(1,objbufsize)); +end; + + +procedure tarobjectwriter.close; +begin + objdata^.align(2); +{ fix the size in the header } + createarhdr(objfn,objdata^.usedsize,'42','42','644'); +{ write the header } + ardata^.write(arhdr,sizeof(tarhdr)); +{ write the data of this objfile } + ardata^.write(objdata^.data^,objdata^.usedsize); +{ free this object } + dispose(objdata,done); +end; + + +procedure tarobjectwriter.writesym(sym:string); +begin + sym:=sym+#0; + symreloc^.write(objfixup,1); + symstr^.write(sym[1],length(sym)); +end; + + +procedure tarobjectwriter.write(var b;len:longint); +begin + objdata^.write(b,len); +end; + + +procedure tarobjectwriter.writear; + + function lsb2msb(l:longint):longint; + type + bytearr=array[0..3] of byte; + var + l1 : longint; + begin + bytearr(l1)[0]:=bytearr(l)[3]; + bytearr(l1)[1]:=bytearr(l)[2]; + bytearr(l1)[2]:=bytearr(l)[1]; + bytearr(l1)[3]:=bytearr(l)[0]; + lsb2msb:=l1; + end; + +const + armagic:array[1..8] of char='!'#10; +type + plongint=^longint; +var + arf : file; + fixup, + relocs,i : longint; +begin + assign(arf,arfn); + {$I-} + rewrite(arf,1); + {$I+} + if ioresult<>0 then + begin + Message1(exec_e_cant_create_archivefile,arfn); + exit; + end; + blockwrite(arf,armagic,sizeof(armagic)); + { align first, because we need the size for the fixups of the symbol reloc } + if lfnstr^.usedsize>0 then + lfnstr^.align(2); + if symreloc^.usedsize>0 then + begin + symstr^.align(2); + fixup:=12+sizeof(tarhdr)+symreloc^.usedsize+symstr^.usedsize; + if lfnstr^.usedsize>0 then + inc(fixup,lfnstr^.usedsize+sizeof(tarhdr)); + relocs:=symreloc^.count; + for i:=0to relocs-1 do + plongint(@symreloc^.data[i*4])^:=lsb2msb(plongint(@symreloc^.data[i*4])^+fixup); + createarhdr('',4+symreloc^.usedsize+symstr^.usedsize,'0','0','0'); + blockwrite(arf,arhdr,sizeof(tarhdr)); + relocs:=lsb2msb(relocs); + blockwrite(arf,relocs,4); + blockwrite(arf,symreloc^.data^,symreloc^.usedsize); + blockwrite(arf,symstr^.data^,symstr^.usedsize); + end; + if lfnstr^.usedsize>0 then + begin + createarhdr('/',lfnstr^.usedsize,'','',''); + blockwrite(arf,arhdr,sizeof(tarhdr)); + blockwrite(arf,lfnstr^.data^,lfnstr^.usedsize); + end; + blockwrite(arf,ardata^.data^,ardata^.usedsize); + system.close(arf); +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/04/02 15:22:19 florian + * fixed bug 903: the compiler gives now a nice message if it can't create + the .o file, (same for future .ar) + + Revision 1.6 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.5 2000/01/07 01:14:28 peter + * updated copyright to 2000 + +} \ No newline at end of file diff --git a/befpc/compiler/owbase.pas b/befpc/compiler/owbase.pas new file mode 100644 index 0000000..1c2f836 --- /dev/null +++ b/befpc/compiler/owbase.pas @@ -0,0 +1,168 @@ +{ + $Id: owbase.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + Contains the base stuff for writing for object files to disk + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit owbase; +interface + +type + pobjectwriter=^tobjectwriter; + tobjectwriter=object + constructor Init; + destructor Done;virtual; + procedure create(const fn:string);virtual; + procedure close;virtual; + procedure writesym(sym:string);virtual; + procedure write(var b;len:longint);virtual; + private + f : file; + opened : boolean; + buf : pchar; + bufidx : longint; + size : longint; + procedure writebuf; + end; + + +implementation + +uses + verbose; + +const +{$ifdef TP} + bufsize = 256; +{$else} + bufsize = 32768; +{$endif} + + +constructor tobjectwriter.init; +begin + getmem(buf,bufsize); + bufidx:=0; + opened:=false; + size:=0; +end; + + +destructor tobjectwriter.done; +begin + if opened then + close; + freemem(buf,bufsize); +end; + + +procedure tobjectwriter.create(const fn:string); +begin + assign(f,fn); + {$I-} + rewrite(f,1); + {$I+} + if ioresult<>0 then + begin + Message1(exec_e_cant_create_objectfile,fn); + exit; + end; + bufidx:=0; + size:=0; + opened:=true; +end; + + +procedure tobjectwriter.close; +begin + if bufidx>0 then + writebuf; + system.close(f); +{ Remove if size is 0 } + if size=0 then + begin + {$I-} + system.erase(f); + {$I+} + if ioresult<>0 then; + end; + opened:=false; + size:=0; +end; + + +procedure tobjectwriter.writebuf; +begin + blockwrite(f,buf^,bufidx); + bufidx:=0; +end; + + +procedure tobjectwriter.writesym(sym:string); +begin +end; + + +procedure tobjectwriter.write(var b;len:longint); +var + p : pchar; + left, + idx : longint; +begin + inc(size,len); + p:=pchar(@b); + idx:=0; + while len>0 do + begin + left:=bufsize-bufidx; + if len>left then + begin + move(p[idx],buf[bufidx],left); + dec(len,left); + inc(idx,left); + inc(bufidx,left); + writebuf; + end + else + begin + move(p[idx],buf[bufidx],len); + inc(bufidx,len); + exit; + end; + end; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.6 2000/04/02 15:22:19 florian + * fixed bug 903: the compiler gives now a nice message if it can't create + the .o file, (same for future .ar) + + Revision 1.5 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.4 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.3 2000/01/07 01:14:28 peter + * updated copyright to 2000 + +} \ No newline at end of file diff --git a/befpc/compiler/parser.pas b/befpc/compiler/parser.pas new file mode 100644 index 0000000..015fd9e --- /dev/null +++ b/befpc/compiler/parser.pas @@ -0,0 +1,706 @@ +{ + $Id: parser.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit does the parsing process + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef tp} + {$E+,N+,D+,F+} +{$endif} +unit parser; + +{ Use exception catching so the compiler goes futher after a Stop } +{$ifndef NOUSEEXCEPT} +{$ifdef i386} + {$define USEEXCEPT} +{$endif} + +{$ifdef TP} + {$ifdef DPMI} + {$undef USEEXCEPT} + {$endif} +{$endif} +{$endif ndef NOUSEEXCEPT} + + interface + + procedure preprocess(const filename:string); + procedure compile(const filename:string;compile_system:boolean); + procedure initparser; + procedure doneparser; + + implementation + + uses + globtype,version,tokens,systems, + cobjects,globals,verbose, + symtable,files,aasm, +{$ifndef newcg} + hcodegen, +{$endif newcg} + assemble,link,script,gendef, +{$ifdef BrowserLog} + browlog, +{$endif BrowserLog} +{$ifdef UseExcept} + tpexcept,compiler, +{$endif UseExcept} +{$ifdef newcg} + cgobj, + cgcpu, + { cgbase must be after hcodegen to use the correct procinfo !!! } + cgbase, +{$endif newcg} +{$ifdef GDB} + gdb, +{$endif GDB} + comphook,tree,scanner,pbase,ptype,psystem,pmodules,cresstr; + + + procedure initparser; + begin + { ^M means a string or a char, because we don't parse a } + { type declaration } + ignore_equal:=false; + + { we didn't parse a object or class declaration } + { and no function header } + testcurobject:=0; + + { a long time, this was forgotten } + aktprocsym:=nil; + + current_module:=nil; + compiled_module:=nil; + + loaded_units.init; + + usedunits.init; + + { global switches } + aktglobalswitches:=initglobalswitches; + + { scanner } + c:=#0; + pattern:=''; + orgpattern:=''; + current_scanner:=nil; + + { memory sizes } + if heapsize=0 then + heapsize:=target_info.heapsize; + if maxheapsize=0 then + maxheapsize:=target_info.maxheapsize; + if stacksize=0 then + stacksize:=target_info.stacksize; + + { open assembler response } + AsmRes.Init(outputexedir+'ppas'); + + { open deffile } + DefFile.Init(outputexedir+inputfile+target_os.defext); + + { list of generated .o files, so the linker can remove them } + SmartLinkOFiles.init; + end; + + + procedure doneparser; + begin + { unload units } + loaded_units.done; + usedunits.done; + + { close ppas,deffile } + asmres.done; + deffile.done; + + { free list of .o files } + SmartLinkOFiles.done; + end; + + + procedure default_macros; + var + hp : pstring_item; + begin + { commandline } + hp:=pstring_item(initdefines.first); + while assigned(hp) do + begin + def_macro(hp^.str^); + hp:=pstring_item(hp^.next); + end; + { set macros for version checking } + set_macro('FPC_VERSION',version_nr); + set_macro('FPC_RELEASE',release_nr); + set_macro('FPC_PATCH',patch_nr); + end; + + + procedure preprocess(const filename:string); + var + i : longint; + begin + new(preprocfile,init('pre')); + { default macros } + macros:=new(psymtable,init(macrosymtable)); + macros^.name:=stringdup('Conditionals for '+filename); + default_macros; + { initialize a module } + current_module:=new(pmodule,init(filename,false)); + main_module:=current_module; + { startup scanner, and save in current_module } + current_scanner:=new(pscannerfile,Init(filename)); + current_module^.scanner:=current_scanner; + { loop until EOF is found } + repeat + current_scanner^.readtoken; + preprocfile^.AddSpace; + case token of + _ID : + begin + preprocfile^.Add(orgpattern); + end; + _REALNUMBER, + _INTCONST : + preprocfile^.Add(pattern); + _CSTRING : + begin + i:=0; + while (i 1 we get a nice "unit expected" error + message if we are trying to use a program as unit.} +{$ifdef USEEXCEPT} + if setjmp(recoverpos)=0 then + begin + oldrecoverpos:=recoverpospointer; + recoverpospointer:=@recoverpos; +{$endif USEEXCEPT} + + if (token=_UNIT) or (compile_level>1) then + begin + current_module^.is_unit:=true; + proc_unit; + end + else + proc_program(token=_LIBRARY); +{$ifdef USEEXCEPT} + recoverpospointer:=oldrecoverpos; + end + else + begin + recoverpospointer:=oldrecoverpos; + longjump_used:=true; + end; +{$endif USEEXCEPT} + + { clear memory } +{$ifdef Splitheap} + if testsplit then + begin + { temp heap should be empty after that !!!} + codegen_donemodule; + Releasetempheap; + end; +{$endif Splitheap} + + { restore old state, close trees, > 0.99.5 has heapblocks, so + it's the default to release the trees } + codegen_donemodule; + +{$ifdef newcg} + dispose(cg,done); +{$endif newcg} + + { free ppu } + if assigned(current_module^.ppufile) then + begin + dispose(current_module^.ppufile,done); + current_module^.ppufile:=nil; + end; + { free scanner } + dispose(current_scanner,done); + { restore previous scanner !! } + current_module^.scanner:=prev_scanner; + if assigned(prev_scanner) then + prev_scanner^.invalid:=true; + + { free macros } + {!!! No check for unused macros yet !!! } + dispose(macros,done); + + if (compile_level>1) then + begin +{$ifdef newcg} + cg:=oldcg; +{$endif newcg} +{$ifdef GDB} + dbx_counter:=store_dbx; +{$endif GDB} + { restore scanner } + c:=oldc; + pattern:=oldpattern; + orgpattern:=oldorgpattern; + token:=oldtoken; + idtoken:=oldidtoken; + tokenpos:=oldtokenpos; + block_type:=old_block_type; + current_scanner:=oldcurrent_scanner; + { restore cg } + nextlabelnr:=oldnextlabelnr; + parse_only:=oldparse_only; + { restore asmlists } + exprasmlist:=oldexprasmlist; + datasegment:=olddatasegment; + bsssegment:=oldbsssegment; + codesegment:=oldcodesegment; + consts:=oldconsts; + debuglist:=olddebuglist; + withdebuglist:=oldwithdebuglist; + importssection:=oldimports; + exportssection:=oldexports; + resourcesection:=oldresource; + rttilist:=oldrttilist; + resourcestringlist:=oldresourcestringlist; + asmsymbollist:=oldasmsymbollist; + ResourceStrings:=OldResourceStrings; + { restore symtable state } + refsymtable:=oldrefsymtable; + symtablestack:=oldsymtablestack; + defaultsymtablestack:=olddefaultsymtablestack; + macros:=oldmacros; + aktprocsym:=oldaktprocsym; + procprefix:=oldprocprefix; + move(oldoverloaded_operators,overloaded_operators,sizeof(toverloaded_operators)); + aktlocalswitches:=oldaktlocalswitches; + aktmoduleswitches:=oldaktmoduleswitches; + aktpackrecords:=oldaktpackrecords; + aktpackenum:=oldaktpackenum; + aktmaxfpuregisters:=oldaktmaxfpuregisters; + aktoutputformat:=oldaktoutputformat; + aktoptprocessor:=oldaktoptprocessor; + aktspecificoptprocessor:=oldaktspecificoptprocessor; + aktasmmode:=oldaktasmmode; + aktfilepos:=oldaktfilepos; + aktmodeswitches:=oldaktmodeswitches; + end; + { Shut down things when the last file is compiled } + if (compile_level=1) then + begin + { Close script } + if (not AsmRes.Empty) then + begin + Message1(exec_i_closing_script,AsmRes.Fn); + AsmRes.WriteToDisk; + end; + +{$ifdef USEEXCEPT} + if not longjump_used then +{$endif USEEXCEPT} + { do not create browsers on errors !! } + if status.errorcount=0 then + begin +{$ifdef BrowserLog} + { Write Browser Log } + if (cs_browser_log in aktglobalswitches) and + (cs_browser in aktmoduleswitches) then + begin + if browserlog.elements_to_list^.empty then + begin + Message1(parser_i_writing_browser_log,browserlog.Fname); + WriteBrowserLog; + end + else + browserlog.list_elements; + end; +{$endif BrowserLog} + + { Write Browser Collections } + do_extractsymbolinfo; + end; + + if current_module^.in_second_compile then + begin + current_module^.in_second_compile:=false; + current_module^.in_compile:=true; + end + else + current_module^.in_compile:=false; + + (* Obsolete code aktprocsym + is disposed by the localsymtable disposal (PM) + { Free last aktprocsym } + if assigned(aktprocsym) and (aktprocsym^.owner=nil) then + begin + { init parts are not needed in units !! } + if current_module^.is_unit then + aktprocsym^.definition^.forwarddef:=false; + dispose(aktprocsym,done); + end; *) + end; + + dec(compile_level); + parser_current_file:=prev_name^; + stringdispose(prev_name); + compiled_module:=old_compiled_module; +{$ifdef USEEXCEPT} + if longjump_used then + longjmp(recoverpospointer^,1); +{$endif USEEXCEPT} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.105 2000/06/01 19:09:57 peter + * made resourcestrings OOP so it's easier to handle it per module + + Revision 1.104 2000/05/29 10:04:40 pierre + * New bunch of Gabor changes + + Revision 1.103 2000/05/11 06:52:37 pierre + * fix localswitch problem if compiling objpas + + Revision 1.102 2000/04/24 12:45:44 peter + * made overloaded_operators local per unit, but it still doesn't work + correct + + Revision 1.101 2000/02/18 20:53:15 pierre + * fixes a stabs problem for functions + + includes a stabs local var for with statements + the name is with in lowercase followed by an index + for nested with. + + Withdebuglist added because the stabs declarations of local + var are postponed to end of function. + + Revision 1.100 2000/02/14 20:58:44 marco + * Basic structures for new sethandling implemented. + + Revision 1.99 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.98 2000/01/23 21:29:17 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.97 2000/01/11 09:52:06 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.96 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.95 2000/01/04 15:15:52 florian + + added compiler switch $maxfpuregisters + + fixed a small problem in secondvecn + + Revision 1.94 1999/12/02 17:34:34 peter + * preprocessor support. But it fails on the caret in type blocks + + Revision 1.93 1999/11/24 11:41:03 pierre + * defaultsymtablestack is now restored after parser.compile + + Revision 1.92 1999/11/18 15:34:46 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.91 1999/11/09 23:48:47 pierre + * some DBX work, still does not work + + Revision 1.90 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.89 1999/10/22 10:39:34 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.88 1999/10/12 21:20:45 florian + * new codegenerator compiles again + + Revision 1.87 1999/10/03 19:44:41 peter + * removed objpasunit reference, tvarrec is now searched in systemunit + where it already was located + + Revision 1.86 1999/10/01 08:02:45 peter + * forward type declaration rewritten + + Revision 1.85 1999/09/16 08:02:39 pierre + + old_compiled_module to avoid wrong file info when load PPU files + + Revision 1.84 1999/09/15 22:09:23 florian + + rtti is now automatically generated for published classes, i.e. + they are handled like an implicit property + + Revision 1.83 1999/08/31 15:51:11 pierre + * in_second_compile cleaned up, in_compile and in_second_load added + + Revision 1.82 1999/08/26 20:24:41 michael + + Hopefuly last fixes for resourcestrings + + Revision 1.81 1999/08/04 13:02:48 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.80 1999/08/03 17:09:37 florian + * the alpha compiler can be compiled now + + Revision 1.79 1999/08/01 23:36:40 florian + * some changes to compile the new code generator + +} \ No newline at end of file diff --git a/befpc/compiler/pass_1.pas b/befpc/compiler/pass_1.pas new file mode 100644 index 0000000..5a6bbd7 --- /dev/null +++ b/befpc/compiler/pass_1.pas @@ -0,0 +1,444 @@ +{ + $Id: pass_1.pas,v 1.1.1.1 2001-07-23 17:16:43 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements the first pass of the code generator + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef tp} + {$F+} +{$endif tp} +unit pass_1; +interface + + uses + tree; + + procedure firstpass(var p : ptree); + function do_firstpass(var p : ptree) : boolean; + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + aasm,symtable,types, + htypechk, + tcadd,tccal,tccnv,tccon,tcflw, + tcinl,tcld,tcmat,tcmem,tcset,cpubase,cpuasm +{$ifdef newcg} + ,cgbase + ,tgcpu +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$ifdef m68k} + ,tgen68k +{$endif} +{$endif} + ; + +{***************************************************************************** + FirstPass +*****************************************************************************} + + type + firstpassproc = procedure(var p : ptree); + + procedure firstnothing(var p : ptree); + begin + p^.resulttype:=voiddef; + end; + + + procedure firsterror(var p : ptree); + begin + p^.error:=true; + codegenerror:=true; + p^.resulttype:=generrordef; + end; + + + procedure firststatement(var p : ptree); + begin + { left is the next statement in the list } + p^.resulttype:=voiddef; + { no temps over several statements } +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + { right is the statement itself calln assignn or a complex one } + {must_be_valid:=true; obsolete PM } + firstpass(p^.right); + if (not (cs_extsyntax in aktmoduleswitches)) and + assigned(p^.right^.resulttype) and + (p^.right^.resulttype<>pdef(voiddef)) then + CGMessage(cg_e_illegal_expression); + if codegenerror then + exit; + p^.registers32:=p^.right^.registers32; + p^.registersfpu:=p^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.right^.registersmmx; +{$endif SUPPORT_MMX} + { left is the next in the list } + firstpass(p^.left); + if codegenerror then + exit; + if p^.right^.registers32>p^.registers32 then + p^.registers32:=p^.right^.registers32; + if p^.right^.registersfpu>p^.registersfpu then + p^.registersfpu:=p^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + if p^.right^.registersmmx>p^.registersmmx then + p^.registersmmx:=p^.right^.registersmmx; +{$endif} + end; + + + procedure firstblock(var p : ptree); + var + hp : ptree; + count : longint; + begin + count:=0; + hp:=p^.left; + while assigned(hp) do + begin + if cs_regalloc in aktglobalswitches then + begin + { Codeumstellungen } + + { Funktionsresultate an exit anhngen } + { this is wrong for string or other complex + result types !!! } + if ret_in_acc(procinfo^.returntype.def) and + assigned(hp^.left) and + assigned(hp^.left^.right) and + (hp^.left^.right^.treetype=exitn) and + (hp^.right^.treetype=assignn) and + (hp^.right^.left^.treetype=funcretn) then + begin + if assigned(hp^.left^.right^.left) then + CGMessage(cg_n_inefficient_code) + else + begin + hp^.left^.right^.left:=hp^.right^.right; + hp^.right^.right:=nil; + disposetree(hp^.right); + hp^.right:=nil; + end; + end + { warning if unreachable code occurs and elimate this } + else if (hp^.right^.treetype in + [exitn,breakn,continuen,goton]) and + { statement node (JM) } + assigned(hp^.left) and + { kind of statement! (JM) } + assigned(hp^.left^.right) and + (hp^.left^.right^.treetype<>labeln) then + begin + { use correct line number } + aktfilepos:=hp^.left^.fileinfo; + disposetree(hp^.left); + hp^.left:=nil; + CGMessage(cg_w_unreachable_code); + { old lines } + aktfilepos:=hp^.right^.fileinfo; + end; + end; + if assigned(hp^.right) then + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + codegenerror:=false; + firstpass(hp^.right); + if (not (cs_extsyntax in aktmoduleswitches)) and + assigned(hp^.right^.resulttype) and + (hp^.right^.resulttype<>pdef(voiddef)) then + CGMessage(cg_e_illegal_expression); + {if codegenerror then + exit;} + hp^.registers32:=hp^.right^.registers32; + hp^.registersfpu:=hp^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + hp^.registersmmx:=hp^.right^.registersmmx; +{$endif SUPPORT_MMX} + end + else + hp^.registers32:=0; + + if hp^.registers32>p^.registers32 then + p^.registers32:=hp^.registers32; + if hp^.registersfpu>p^.registersfpu then + p^.registersfpu:=hp^.registersfpu; +{$ifdef SUPPORT_MMX} + if hp^.registersmmx>p^.registersmmx then + p^.registersmmx:=hp^.registersmmx; +{$endif} + inc(count); + hp:=hp^.left; + end; + end; + + + + procedure firstasm(var p : ptree); + begin + procinfo^.flags:=procinfo^.flags or pi_uses_asm; + end; + + + + procedure firstpass(var p : ptree); + const + procedures : array[ttreetyp] of firstpassproc = + (firstadd, {addn} + firstadd, {muln} + firstadd, {subn} + firstmoddiv, {divn} + firstadd, {symdifn} + firstmoddiv, {modn} + firstassignment, {assignn} + firstload, {loadn} + firstrange, {range} + firstadd, {ltn} + firstadd, {lten} + firstadd, {gtn} + firstadd, {gten} + firstadd, {equaln} + firstadd, {unequaln} + firstin, {inn} + firstadd, {orn} + firstadd, {xorn} + firstshlshr, {shrn} + firstshlshr, {shln} + firstadd, {slashn} + firstadd, {andn} + firstsubscript, {subscriptn} + firstderef, {derefn} + firstaddr, {addrn} + firstdoubleaddr, {doubleaddrn} + firstordconst, {ordconstn} + firsttypeconv, {typeconvn} + firstcalln, {calln} + firstnothing, {callparan} + firstrealconst, {realconstn} + firstfixconst, {fixconstn} + firstunaryminus, {unaryminusn} + firstasm, {asmn} + firstvec, {vecn} + firstpointerconst,{pointerconstn} + firststringconst, {stringconstn} + firstfuncret, {funcretn} + firstself, {selfn} + firstnot, {notn} + firstinline, {inlinen} + firstniln, {niln} + firsterror, {errorn} + firsttype, {typen} + firsthnew, {hnewn} + firsthdispose, {hdisposen} + firstnew, {newn} + firstsimplenewdispose, {simpledisposen} + firstsetelement, {setelementn} + firstsetconst, {setconstn} + firstblock, {blockn} + firststatement, {statementn} + firstnothing, {loopn} + firstif, {ifn} + firstnothing, {breakn} + firstnothing, {continuen} + first_while_repeat, {repeatn} + first_while_repeat, {whilen} + firstfor, {forn} + firstexit, {exitn} + firstwith, {withn} + firstcase, {casen} + firstlabel, {labeln} + firstgoto, {goton} + firstsimplenewdispose, {simplenewn} + firsttryexcept, {tryexceptn} + firstraise, {raisen} + firstnothing, {switchesn} + firsttryfinally, {tryfinallyn} + firston, {onn} + firstis, {isn} + firstas, {asn} + firsterror, {caretn} + firstnothing, {failn} + firstadd, {starstarn} + firstprocinline, {procinlinen} + firstarrayconstruct, {arrayconstructn} + firstarrayconstructrange, {arrayconstructrangen} + firstnothing, {nothingn} + firstloadvmt {loadvmtn} + ); + var + oldcodegenerror : boolean; + oldlocalswitches : tlocalswitches; + oldpos : tfileposinfo; +{$ifdef extdebug} + str1,str2 : string; + oldp : ptree; + not_first : boolean; +{$endif extdebug} + begin +{$ifdef extdebug} + inc(total_of_firstpass); + if (p^.firstpasscount>0) and only_one_pass then + exit; +{$endif extdebug} + oldcodegenerror:=codegenerror; + oldpos:=aktfilepos; + oldlocalswitches:=aktlocalswitches; +{$ifdef extdebug} + if p^.firstpasscount>0 then + begin + move(p^,str1[1],sizeof(ttree)); + {$ifndef TP} + {$ifopt H+} + SetLength(str1,sizeof(ttree)); + {$else} + str1[0]:=char(sizeof(ttree)); + {$endif} + {$else} + str1[0]:=char(sizeof(ttree)); + {$endif} + new(oldp); + oldp^:=p^; + not_first:=true; + inc(firstpass_several); + end + else + not_first:=false; +{$endif extdebug} + + if not p^.error then + begin + codegenerror:=false; + aktfilepos:=p^.fileinfo; + aktlocalswitches:=p^.localswitches; + procedures[p^.treetype](p); + aktlocalswitches:=oldlocalswitches; + aktfilepos:=oldpos; + p^.error:=codegenerror; + codegenerror:=codegenerror or oldcodegenerror; + end + else + codegenerror:=true; +{$ifdef extdebug} + if not_first then + begin + { dirty trick to compare two ttree's (PM) } + move(p^,str2[1],sizeof(ttree)); + {$ifndef TP} + {$ifopt H+} + SetLength(str2,sizeof(ttree)); + {$else} + str2[0]:=char(sizeof(ttree)); + {$endif} + {$else} + str2[0]:=char(sizeof(ttree)); + {$endif} + if str1<>str2 then + begin + comment(v_debug,'tree changed after first counting pass ' + +tostr(longint(p^.treetype))); + compare_trees(oldp,p); + end; + dispose(oldp); + end; + if count_ref then + inc(p^.firstpasscount); +{$endif extdebug} + end; + + + function do_firstpass(var p : ptree) : boolean; + begin + aktexceptblock:=nil; + codegenerror:=false; + firstpass(p); + do_firstpass:=codegenerror; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.115 2000/05/25 12:00:14 jonas + * fixed unreachable code detection + + Revision 1.114 2000/02/17 14:53:42 florian + * some updates for the newcg + + Revision 1.113 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.112 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.111 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.110 1999/11/30 10:40:44 peter + + ttype, tsymlist + + Revision 1.109 1999/11/18 15:34:47 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.108 1999/11/17 17:05:01 pierre + * Notes/hints changes + + Revision 1.107 1999/10/26 12:30:43 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.106 1999/09/27 23:44:51 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.105 1999/09/26 21:30:16 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.104 1999/09/11 09:08:31 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.103 1999/08/04 00:23:09 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} diff --git a/befpc/compiler/pass_2.pas b/befpc/compiler/pass_2.pas new file mode 100644 index 0000000..bdd10ba --- /dev/null +++ b/befpc/compiler/pass_2.pas @@ -0,0 +1,952 @@ +{ + $Id: pass_2.pas,v 1.1.1.1 2001-07-23 17:16:44 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit handles the codegeneration pass + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} +{$ifdef TP} + {$E+,F+,N+} +{$endif} +unit pass_2; +interface + +uses + tree; + +{ produces assembler for the expression in variable p } +{ and produces an assembler node at the end } +procedure generatecode(var p : ptree); + +{ produces the actual code } +function do_secondpass(var p : ptree) : boolean; +procedure secondpass(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,comphook,verbose,globals,files, + symconst,symtable,types,aasm,scanner, + pass_1,hcodegen,temp_gen,cpubase,cpuasm +{$ifndef newcg} + ,tcflw +{$endif newcg} +{$ifdef GDB} + ,gdb +{$endif} +{$ifdef i386} + ,tgeni386,cgai386 + ,cg386con,cg386mat,cg386cnv,cg386set,cg386add + ,cg386mem,cg386cal,cg386ld,cg386flw,cg386inl +{$endif} +{$ifdef m68k} + ,tgen68k,cga68k + ,cg68kcon,cg68kmat,cg68kcnv,cg68kset,cg68kadd + ,cg68kmem,cg68kcal,cg68kld,cg68kflw,cg68kinl +{$endif} + ; + +{***************************************************************************** + SecondPass +*****************************************************************************} + + type + secondpassproc = procedure(var p : ptree); + + procedure secondnothing(var p : ptree); + + begin + end; + + procedure seconderror(var p : ptree); + + begin + p^.error:=true; + codegenerror:=true; + end; + + + procedure secondstatement(var p : ptree); + + var + hp : ptree; + begin + hp:=p; + while assigned(hp) do + begin + if assigned(hp^.right) then + begin + cleartempgen; + {!!!!!! + oldrl:=temptoremove; + temptoremove:=new(plinkedlist,init); + } + secondpass(hp^.right); + { !!!!!!! + some temporary data which can't be released elsewhere + removetemps(exprasmlist,temptoremove); + dispose(temptoremove,done); + temptoremove:=oldrl; + } + end; + hp:=hp^.left; + end; + end; + + + procedure secondblockn(var p : ptree); + begin + { do second pass on left node } + if assigned(p^.left) then + secondpass(p^.left); + end; + + + procedure secondasm(var p : ptree); + + procedure ReLabel(var p:pasmsymbol); + begin + if p^.proclocal then + begin + if not assigned(p^.altsymbol) then + p^.GenerateAltSymbol; + p:=p^.altsymbol; + end; + end; + + var + hp,hp2 : pai; + localfixup,parafixup, + i : longint; + r : preference; + skipnode : boolean; + begin + if inlining_procedure then + begin + localfixup:=aktprocsym^.definition^.localst^.address_fixup; + parafixup:=aktprocsym^.definition^.parast^.address_fixup; + ResetAsmSymbolListAltSymbol; + hp:=pai(p^.p_asm^.first); + while assigned(hp) do + begin + hp2:=pai(hp^.getcopy); + skipnode:=false; + case hp2^.typ of + ait_label : + begin + { regenerate the labels by setting altsymbol } + ReLabel(pasmsymbol(pai_label(hp2)^.l)); + end; + ait_const_rva, + ait_const_symbol : + begin + ReLabel(pai_const_symbol(hp2)^.sym); + end; + ait_instruction : + begin +{$ifdef i386} + { fixup the references } + for i:=1 to paicpu(hp2)^.ops do + case paicpu(hp2)^.oper[i-1].typ of + top_ref : + begin + r:=paicpu(hp2)^.oper[i-1].ref; + case r^.options of + ref_parafixup : + r^.offsetfixup:=parafixup; + ref_localfixup : + r^.offsetfixup:=localfixup; + end; + if assigned(r^.symbol) then + ReLabel(r^.symbol); + end; + top_symbol : + begin + ReLabel(paicpu(hp2)^.oper[i-1].sym); + end; + end; +{$endif i386} + end; + ait_marker : + begin + { it's not an assembler block anymore } + if (pai_marker(hp2)^.kind in [AsmBlockStart, AsmBlockEnd]) then + skipnode:=true; + end; + else + end; + if not skipnode then + exprasmlist^.concat(hp2) + else + dispose(hp2,done); + hp:=pai(hp^.next); + end + end + else + begin + { if the routine is an inline routine, then we must hold a copy + becuase it can be necessary for inlining later } + if (pocall_inline in aktprocsym^.definition^.proccalloptions) then + exprasmlist^.concatlistcopy(p^.p_asm) + else + exprasmlist^.concatlist(p^.p_asm); + end; + if not p^.object_preserved then + begin +{$ifdef i386} + maybe_loadesi; +{$endif} +{$ifdef m68k} + maybe_loada5; +{$endif} + end; + end; + +{$ifdef logsecondpass} + procedure logsecond(const s: string; entry: boolean); + var p: pchar; + begin + if entry then + p := strpnew(s+' (entry)') + else p := strpnew(s+' (exit)'); + exprasmlist^.concat(new(pai_asm_comment,init(p))); + end; +{$endif logsecondpass} + + procedure secondpass(var p : ptree); + const + procedures : array[ttreetyp] of secondpassproc = + (secondadd, {addn} + secondadd, {muln} + secondadd, {subn} + secondmoddiv, {divn} + secondadd, {symdifn} + secondmoddiv, {modn} + secondassignment, {assignn} + secondload, {loadn} + secondnothing, {range} + secondadd, {ltn} + secondadd, {lten} + secondadd, {gtn} + secondadd, {gten} + secondadd, {equaln} + secondadd, {unequaln} + secondin, {inn} + secondadd, {orn} + secondadd, {xorn} + secondshlshr, {shrn} + secondshlshr, {shln} + secondadd, {slashn} + secondadd, {andn} + secondsubscriptn, {subscriptn} + secondderef, {derefn} + secondaddr, {addrn} + seconddoubleaddr, {doubleaddrn} + secondordconst, {ordconstn} + secondtypeconv, {typeconvn} + secondcalln, {calln} + secondnothing, {callparan} + secondrealconst, {realconstn} + secondfixconst, {fixconstn} + secondunaryminus, {unaryminusn} + secondasm, {asmn} + secondvecn, {vecn} + secondpointerconst, {pointerconstn} + secondstringconst, {stringconstn} + secondfuncret, {funcretn} + secondselfn, {selfn} + secondnot, {notn} + secondinline, {inlinen} + secondniln, {niln} + seconderror, {errorn} + secondnothing, {typen} + secondhnewn, {hnewn} + secondhdisposen, {hdisposen} + secondnewn, {newn} + secondsimplenewdispose, {simpledisposen} + secondsetelement, {setelementn} + secondsetconst, {setconstn} + secondblockn, {blockn} + secondstatement, {statementn} + secondnothing, {loopn} + secondifn, {ifn} + secondbreakn, {breakn} + secondcontinuen, {continuen} + second_while_repeatn, {repeatn} + second_while_repeatn, {whilen} + secondfor, {forn} + secondexitn, {exitn} + secondwith, {withn} + secondcase, {casen} + secondlabel, {labeln} + secondgoto, {goton} + secondsimplenewdispose, {simplenewn} + secondtryexcept, {tryexceptn} + secondraise, {raisen} + secondnothing, {switchesn} + secondtryfinally, {tryfinallyn} + secondon, {onn} + secondis, {isn} + secondas, {asn} + seconderror, {caretn} + secondfail, {failn} + secondadd, {starstarn} + secondprocinline, {procinlinen} + secondarrayconstruct, {arrayconstructn} + secondnothing, {arrayconstructrangen} + secondnothing, {nothingn} + secondloadvmt {loadvmtn} + ); +{$ifdef logsecondpass} + secondnames: array[ttreetyp] of string[13] = + ('add-addn', {addn} + 'add-muln)', {muln} + 'add-subn', {subn} + 'moddiv-divn', {divn} + 'add-symdifn', {symdifn} + 'moddiv-modn', {modn} + 'assignment', {assignn} + 'load', {loadn} + 'nothing-range', {range} + 'add-ltn', {ltn} + 'add-lten', {lten} + 'add-gtn', {gtn} + 'add-gten', {gten} + 'add-equaln', {equaln} + 'add-unequaln', {unequaln} + 'in', {inn} + 'add-orn', {orn} + 'add-xorn', {xorn} + 'shlshr-shrn', {shrn} + 'shlshr-shln', {shln} + 'add-slashn', {slashn} + 'add-andn', {andn} + 'subscriptn', {subscriptn} + 'dderef', {derefn} + 'addr', {addrn} + 'doubleaddr', {doubleaddrn} + 'ordconst', {ordconstn} + 'typeconv', {typeconvn} + 'calln', {calln} + 'nothing-callp', {callparan} + 'realconst', {realconstn} + 'fixconst', {fixconstn} + 'unaryminus', {unaryminusn} + 'asm', {asmn} + 'vecn', {vecn} + 'pointerconst', {pointerconstn} + 'stringconst', {stringconstn} + 'funcret', {funcretn} + 'selfn', {selfn} + 'not', {notn} + 'inline', {inlinen} + 'niln', {niln} + 'error', {errorn} + 'nothing-typen', {typen} + 'hnewn', {hnewn} + 'hdisposen', {hdisposen} + 'newn', {newn} + 'simplenewDISP', {simpledisposen} + 'setelement', {setelementn} + 'setconst', {setconstn} + 'blockn', {blockn} + 'statement', {statementn} + 'nothing-loopn', {loopn} + 'ifn', {ifn} + 'breakn', {breakn} + 'continuen', {continuen} + '_while_REPEAT', {repeatn} + '_WHILE_repeat', {whilen} + 'for', {forn} + 'exitn', {exitn} + 'with', {withn} + 'case', {casen} + 'label', {labeln} + 'goto', {goton} + 'simpleNEWdisp', {simplenewn} + 'tryexcept', {tryexceptn} + 'raise', {raisen} + 'nothing-swtch', {switchesn} + 'tryfinally', {tryfinallyn} + 'on', {onn} + 'is', {isn} + 'as', {asn} + 'error-caret', {caretn} + 'fail', {failn} + 'add-startstar', {starstarn} + 'procinline', {procinlinen} + 'arrayconstruc', {arrayconstructn} + 'noth-arrcnstr', {arrayconstructrangen} + 'nothing-nothg', {nothingn} + 'loadvmt' {loadvmtn} + ); + +{$endif logsecondpass} + var + oldcodegenerror : boolean; + oldlocalswitches : tlocalswitches; + oldpos : tfileposinfo; +{$ifdef TEMPREGDEBUG} + prevp : pptree; +{$endif TEMPREGDEBUG} + begin + if not(p^.error) then + begin + oldcodegenerror:=codegenerror; + oldlocalswitches:=aktlocalswitches; + oldpos:=aktfilepos; +{$ifdef TEMPREGDEBUG} + testregisters32; + prevp:=curptree; + curptree:=@p; + p^.usableregs:=usablereg32; +{$endif TEMPREGDEBUG} + aktfilepos:=p^.fileinfo; + aktlocalswitches:=p^.localswitches; + codegenerror:=false; +{$ifdef logsecondpass} + logsecond('second'+secondnames[p^.treetype],true); +{$endif logsecondpass} + procedures[p^.treetype](p); +{$ifdef logsecondpass} + logsecond('second'+secondnames[p^.treetype],false); +{$endif logsecondpass} + p^.error:=codegenerror; + + codegenerror:=codegenerror or oldcodegenerror; + aktlocalswitches:=oldlocalswitches; + aktfilepos:=oldpos; +{$ifdef TEMPREGDEBUG} + curptree:=prevp; +{$endif TEMPREGDEBUG} +{$ifdef EXTTEMPREGDEBUG} + if p^.usableregs-usablereg32>p^.reallyusedregs then + p^.reallyusedregs:=p^.usableregs-usablereg32; + if p^.reallyusedregs'+tostr(p^.reallyusedregs)); +{$endif EXTTEMPREGDEBUG} + end + else + codegenerror:=true; + end; + + + function do_secondpass(var p : ptree) : boolean; + begin + codegenerror:=false; + if not(p^.error) then + secondpass(p); + do_secondpass:=codegenerror; + end; + + var + { the array ranges are overestimated !!! } + { max(maxvarregs,maxfpuvarregs) would be } + { enough } + regvars : array[1..maxvarregs+maxfpuvarregs] of pvarsym; + regvars_para : array[1..maxvarregs+maxfpuvarregs] of boolean; + regvars_refs : array[1..maxvarregs+maxfpuvarregs] of longint; + parasym : boolean; + + procedure searchregvars(p : pnamedindexobject); + var + i,j,k : longint; + begin + if (psym(p)^.typ=varsym) and (vo_regable in pvarsym(p)^.varoptions) then + begin + j:=pvarsym(p)^.refs; + { parameter get a less value } + if parasym then + begin + if cs_littlesize in aktglobalswitches then + dec(j,1) + else + dec(j,100); + end; + { walk through all momentary register variables } + for i:=1 to maxvarregs do + begin + if ((regvars[i]=nil) or (j>regvars_refs[i])) and (j>0) then + begin + for k:=maxvarregs-1 downto i do + begin + regvars[k+1]:=regvars[k]; + regvars_para[k+1]:=regvars_para[k]; + regvars_refs[k+1]:=regvars_refs[k]; + end; + { calc the new refs + pvarsym(p)^.refs:=j; } + regvars[i]:=pvarsym(p); + regvars_para[i]:=parasym; + regvars_refs[i]:=j; + break; + end; + end; + end; + end; + + + procedure searchfpuregvars(p : pnamedindexobject); + var + i,j,k : longint; + begin + if (psym(p)^.typ=varsym) and (vo_fpuregable in pvarsym(p)^.varoptions) then + begin + j:=pvarsym(p)^.refs; + { parameter get a less value } + if parasym then + begin + if cs_littlesize in aktglobalswitches then + dec(j,1) + else + dec(j,100); + end; + { walk through all momentary register variables } + for i:=1 to maxfpuvarregs do + begin + if ((regvars[i]=nil) or (j>regvars_refs[i])) and (j>0) then + begin + for k:=maxfpuvarregs-1 downto i do + begin + regvars[k+1]:=regvars[k]; + regvars_para[k+1]:=regvars_para[k]; + regvars_refs[k+1]:=regvars_refs[k]; + end; + { calc the new refs + pvarsym(p)^.refs:=j; } + regvars[i]:=pvarsym(p); + regvars_para[i]:=parasym; + regvars_refs[i]:=j; + break; + end; + end; + end; + end; + + procedure clearrefs(p : pnamedindexobject); + + begin + if (psym(p)^.typ=varsym) then + if pvarsym(p)^.refs>1 then + pvarsym(p)^.refs:=1; + end; + + procedure generatecode(var p : ptree); + var + i : longint; + regsize : topsize; + hr : preference; + label + nextreg; + begin + cleartempgen; + flowcontrol:=[]; + { when size optimization only count occurrence } + if cs_littlesize in aktglobalswitches then + t_times:=1 + else + { reference for repetition is 100 } + t_times:=100; + { clear register count } + clearregistercount; + use_esp_stackframe:=false; + aktexceptblock:=nil; + symtablestack^.foreach(@clearrefs); + symtablestack^.next^.foreach(@clearrefs); + if not(do_firstpass(p)) then + begin + { max. optimizations } + { only if no asm is used } + { and no try statement } + if (cs_regalloc in aktglobalswitches) and + ((procinfo^.flags and (pi_uses_asm or pi_uses_exceptions))=0) then + begin + { can we omit the stack frame ? } + { conditions: + 1. procedure (not main block) + 2. no constructor or destructor + 3. no call to other procedures + 4. no interrupt handler + } + {!!!!!! this doesn work yet, because of problems with + with linux and windows + } + (* + if assigned(aktprocsym) then + begin + if not(assigned(procinfo^._class)) and + not(aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor]) and + not(po_interrupt in aktprocsym^.definition^.procoptions) and + ((procinfo^.flags and pi_do_call)=0) and + (lexlevel>=normal_function_level) then + begin + { use ESP as frame pointer } + procinfo^.framepointer:=stack_pointer; + use_esp_stackframe:=true; + + { calc parameter distance new } + dec(procinfo^.framepointer_offset,4); + dec(procinfo^.selfpointer_offset,4); + + { is this correct ???} + { retoffset can be negativ for results in eax !! } + { the value should be decreased only if positive } + if procinfo^.retoffset>=0 then + dec(procinfo^.retoffset,4); + + dec(procinfo^.para_offset,4); + aktprocsym^.definition^.parast^.address_fixup:=procinfo^.para_offset; + end; + end; + *) + if (p^.registers32<4) then + begin + for i:=1 to maxvarregs do + regvars[i]:=nil; + parasym:=false; + symtablestack^.foreach({$ifndef TP}@{$endif}searchregvars); + { copy parameter into a register ? } + parasym:=true; + symtablestack^.next^.foreach({$ifndef TP}@{$endif}searchregvars); + { hold needed registers free } + for i:=maxvarregs downto maxvarregs-p^.registers32+1 do + regvars[i]:=nil; + { now assign register } + for i:=1 to maxvarregs-p^.registers32 do + begin + if assigned(regvars[i]) then + begin + { it is nonsens, to copy the variable to } + { a register because we need then much } + { too pushes ? } + if reg_pushes[varregs[i]]>=regvars[i]^.refs then + begin + regvars[i]:=nil; + goto nextreg; + end; + + { register is no longer available for } + { expressions } + { search the register which is the most } + { unused } + usableregs:=usableregs-[varregs[i]]; +{$ifdef i386} + procinfo^.aktentrycode^.concat(new(pairegalloc,alloc(varregs[i]))); +{$endif i386} + is_reg_var[varregs[i]]:=true; + dec(c_usableregs); + + { possibly no 32 bit register are needed } + { call by reference/const ? } + if (regvars[i]^.varspez=vs_var) or + ((regvars[i]^.varspez=vs_const) and + push_addr_param(regvars[i]^.vartype.def)) then + begin + regvars[i]^.reg:=varregs[i]; + regsize:=S_L; + end + else + if (regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and + (porddef(regvars[i]^.vartype.def)^.size=1) then + begin +{$ifdef i386} + regvars[i]^.reg:=reg32toreg8(varregs[i]); +{$endif} + regsize:=S_B; + end + else + if (regvars[i]^.vartype.def^.deftype in [orddef,enumdef]) and + (porddef(regvars[i]^.vartype.def)^.size=2) then + begin +{$ifdef i386} + regvars[i]^.reg:=reg32toreg16(varregs[i]); +{$endif} + regsize:=S_W; + end + else + begin + regvars[i]^.reg:=varregs[i]; + regsize:=S_L; + end; + { parameter must be load } + if regvars_para[i] then + begin + { procinfo is there actual, } + { because we can't never be in a } + { nested procedure } + { when loading parameter to reg } + new(hr); + reset_reference(hr^); + hr^.offset:=pvarsym(regvars[i])^.address+procinfo^.para_offset; + hr^.base:=procinfo^.framepointer; +{$ifdef i386} + procinfo^.aktentrycode^.concat(new(paicpu,op_ref_reg(A_MOV,regsize, + hr,regvars[i]^.reg))); +{$endif i386} +{$ifdef m68k} + procinfo^.aktentrycode^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize, + hr,regvars[i]^.reg))); +{$endif m68k} + unused:=unused - [regvars[i]^.reg]; + end; + { procedure uses this register } +{$ifdef i386} + usedinproc:=usedinproc or ($80 shr byte(varregs[i])); +{$endif i386} +{$ifdef m68k} + usedinproc:=usedinproc or ($800 shr word(varregs[i])); +{$endif m68k} + end; + nextreg: + { dummy } + regsize:=S_W; + end; + for i:=1 to maxvarregs do + begin + if assigned(regvars[i]) then + begin + if cs_asm_source in aktglobalswitches then + procinfo^.aktentrycode^.insert(new(pai_asm_comment,init(strpnew(regvars[i]^.name+ + ' with weight '+tostr(regvars[i]^.refs)+' assigned to register '+ + reg2str(regvars[i]^.reg))))); + if (status.verbosity and v_debug)=v_debug then + Message3(cg_d_register_weight,reg2str(regvars[i]^.reg), + tostr(regvars[i]^.refs),regvars[i]^.name); + end; + end; + end; + if ((p^.registersfpu+1)0 then + begin + for i:=maxfpuvarregs downto 2 do + regvars[i]:=nil; + end + else + begin + for i:=maxfpuvarregs downto maxfpuvarregs-p^.registersfpu do + regvars[i]:=nil; + end; + end + else + begin + for i:=aktmaxfpuregisters+1 to maxfpuvarregs do + regvars[i]:=nil; + end; + { now assign register } + for i:=1 to maxfpuvarregs do + begin + if assigned(regvars[i]) then + begin +{$ifdef i386} + { reserve place on the FPU stack } + regvars[i]^.reg:=correct_fpuregister(R_ST0,i-1); + procinfo^.aktentrycode^.concat(new(paicpu,op_none(A_FLDZ,S_NO))); + { ... and clean it up } + procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_FSTP,S_NO,R_ST0))); +{$endif i386} +{$ifdef m68k} + regvars[i]^.reg:=fpuvarregs[i]; +{$endif m68k} +{$ifdef dummy} + { parameter must be load } + if regvars_para[i] then + begin + { procinfo is there actual, } + { because we can't never be in a } + { nested procedure } + { when loading parameter to reg } + new(hr); + reset_reference(hr^); + hr^.offset:=pvarsym(regvars[i])^.address+procinfo^.para_offset; + hr^.base:=procinfo^.framepointer; +{$ifdef i386} + procinfo^.aktentrycode^.concat(new(paicpu,op_ref_reg(A_MOV,regsize, + hr,regvars[i]^.reg))); +{$endif i386} +{$ifdef m68k} + procinfo^.aktentrycode^.concat(new(paicpu,op_ref_reg(A_MOVE,regsize, + hr,regvars[i]^.reg))); +{$endif m68k} + end; +{$endif dummy} + end; + end; + if cs_asm_source in aktglobalswitches then + procinfo^.aktentrycode^.insert(new(pai_asm_comment,init(strpnew(tostr(p^.registersfpu)+ + ' registers on FPU stack used by temp. expressions')))); + for i:=1 to maxfpuvarregs do + begin + if assigned(regvars[i]) then + begin + if cs_asm_source in aktglobalswitches then + procinfo^.aktentrycode^.insert(new(pai_asm_comment,init(strpnew(regvars[i]^.name+ + ' with weight '+tostr(regvars[i]^.refs)+' assigned to register '+ + reg2str(regvars[i]^.reg))))); + if (status.verbosity and v_debug)=v_debug then + Message3(cg_d_register_weight,reg2str(regvars[i]^.reg), + tostr(regvars[i]^.refs),regvars[i]^.name); + end; + end; + if cs_asm_source in aktglobalswitches then + procinfo^.aktentrycode^.insert(new(pai_asm_comment,init(strpnew('Register variable assignment:')))); + end; + end; + if assigned(aktprocsym) and + (pocall_inline in aktprocsym^.definition^.proccalloptions) then + make_const_global:=true; + do_secondpass(p); + + if assigned(procinfo^.def) then + procinfo^.def^.fpu_used:=p^.registersfpu; + + end; + procinfo^.aktproccode^.concatlist(exprasmlist); + make_const_global:=false; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.63 2000/04/06 11:28:17 pierre + * avoid bug 911, worng unused parameter hints + + Revision 1.62 2000/04/02 12:11:38 florian + * enumerations with size 1 or 2 weren't handled corretly if they were register + variables: in fact they got 32 bit register assigned; fixed + + Revision 1.61 2000/03/26 10:50:04 florian + * improved allocation rules for integer register variables + + Revision 1.60 2000/03/19 08:17:36 peter + * tp7 fix + + Revision 1.59 2000/03/01 00:01:14 pierre + Use $GOTO ON + + Revision 1.58 2000/02/20 20:49:45 florian + * newcg is compiling + * fixed the dup id problem reported by Paul Y. + + Revision 1.57 2000/02/10 23:44:43 florian + * big update for exception handling code generation: possible mem holes + fixed, break/continue/exit should work always now as expected + + Revision 1.56 2000/02/09 13:22:55 peter + * log truncated + + Revision 1.55 2000/02/05 15:57:58 florian + * for some strange reasons my fix regarding register variable + allocation was lost + + Revision 1.54 2000/02/04 14:54:17 jonas + * moved call to resetusableregs to compile_proc_body (put it right before the + reset of the temp generator) so the optimizer can know which registers are + regvars + + Revision 1.52 2000/01/22 15:58:12 jonas + * forgot to commit a procedure for -dlogsecondpass the last time + + Revision 1.51 2000/01/21 12:16:53 jonas + + add info on entry/exit of secondpass procedure in assembler files, between + -dlogsecondpass + + Revision 1.50 2000/01/16 22:17:11 peter + * renamed call_offset to para_offset + + Revision 1.49 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.48 2000/01/04 15:15:52 florian + + added compiler switch $maxfpuregisters + + fixed a small problem in secondvecn + + Revision 1.47 1999/12/22 01:01:52 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.46 1999/12/19 23:37:18 pierre + * fix for web bug735 + + Revision 1.45 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.44 1999/11/30 10:40:44 peter + + ttype, tsymlist + + Revision 1.43 1999/11/18 15:34:47 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.42 1999/11/09 23:06:45 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.41 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.40 1999/09/27 23:44:52 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.39 1999/09/26 21:30:17 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.38 1999/09/16 23:05:54 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.37 1999/09/15 20:35:41 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.36 1999/09/07 14:12:35 jonas + * framepointer cannot be changed to esp for methods + + Revision 1.35 1999/08/27 10:46:26 pierre + + some EXTTEMPREGDEBUG code added + +} \ No newline at end of file diff --git a/befpc/compiler/pbase.pas b/befpc/compiler/pbase.pas new file mode 100644 index 0000000..add888b --- /dev/null +++ b/befpc/compiler/pbase.pas @@ -0,0 +1,236 @@ +{ + $Id: pbase.pas,v 1.1.1.1 2001-07-23 17:16:46 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Contains some helper routines for the parser + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pbase; + + interface + + uses + cobjects,tokens,globals,symtable +{$ifdef fixLeaksOnError} + ,comphook +{$endif fixLeaksOnError} +{$IFDEF NEWST} + ,symbols,defs +{$ENDIF NEWST} + ; + + const + { true, if we are after an assignement } + afterassignment : boolean = false; + + { sspecial for handling procedure vars } + getprocvar : boolean = false; + getprocvardef : pprocvardef = nil; + + + var + { size of data segment, set by proc_unit or proc_program } + datasize : longint; + + { for operators } + optoken : ttoken; + opsym : pvarsym; + + { symtable were unit references are stored } + refsymtable : psymtable; + + { true, if only routine headers should be parsed } + parse_only : boolean; + + { true, if we should ignore an equal in const x : 1..2=2 } + ignore_equal : boolean; + +{$ifdef fixLeaksOnError} + { not worth it to make a pstack, there's only one data field (a pointer). } + { in the interface, because pmodules and psub also use it for their names } + var strContStack: TStack; + pbase_old_do_stop: tstopprocedure; +{$endif fixLeaksOnError} + + function tokenstring(i : ttoken):string; + + { consumes token i, if the current token is unequal i } + { a syntax error is written } + procedure consume(i : ttoken); + + {Tries to consume the token i, and returns true if it was consumed: + if token=i.} + function try_to_consume(i:Ttoken):boolean; + + { consumes all tokens til atoken (for error recovering } + procedure consume_all_until(atoken : ttoken); + + { consumes tokens while they are semicolons } + procedure emptystats; + + { reads a list of identifiers into a string container } + function idlist : pstringcontainer; + + { just for an accurate position of the end of a procedure (PM) } + var + last_endtoken_filepos: tfileposinfo; + + + implementation + + uses + files,scanner,systems,verbose; + + function tokenstring(i : ttoken):string; + begin + tokenstring:=tokeninfo^[i].str; + end; + + { consumes token i, write error if token is different } + procedure consume(i : ttoken); + begin + if (token<>i) and (idtoken<>i) then + if token=_id then + Message2(scan_f_syn_expected,tokeninfo^[i].str,'identifier '+pattern) + else + Message2(scan_f_syn_expected,tokeninfo^[i].str,tokeninfo^[token].str) + else + begin + if token=_END then + last_endtoken_filepos:=tokenpos; + current_scanner^.readtoken; + end; + end; + + function try_to_consume(i:Ttoken):boolean; + + + begin + try_to_consume:=false; + if (token=i) or (idtoken=i) then + begin + try_to_consume:=true; + if token=_END then + last_endtoken_filepos:=tokenpos; + current_scanner^.readtoken; + end; + end; + + procedure consume_all_until(atoken : ttoken); + begin + while (token<>atoken) and (idtoken<>atoken) do + begin + Consume(token); + if token=_EOF then + begin + Consume(atoken); + Message(scan_f_end_of_file); + exit; + end; + end; + end; + + + procedure emptystats; + begin + repeat + until not try_to_consume(_SEMICOLON); + end; + + + { reads a list of identifiers into a string container } + function idlist : pstringcontainer; + var + sc : pstringcontainer; + begin + sc:=new(pstringcontainer,init); + repeat + sc^.insert_with_tokeninfo(pattern, + tokenpos); + consume(_id); + if token=_COMMA then consume(_COMMA) + else break + until false; + idlist:=sc; + end; + +{$ifdef fixLeaksOnError} +procedure pbase_do_stop; {$ifdef tp} far; {$endif tp} +var names: PStringContainer; +begin + names := PStringContainer(strContStack.pop); + while names <> nil do + begin + dispose(names,done); + names := PStringContainer(strContStack.pop); + end; + strContStack.done; + do_stop := pbase_old_do_stop; +{$ifdef tp} + do_stop; +{$else tp} + do_stop(); +{$endif tp} +end; + +begin + strContStack.init; + pbase_old_do_stop := do_stop; + do_stop := {$ifndef tp}@{$endif}pbase_do_stop; +{$endif fixLeaksOnError} +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.31 2000/03/11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.30 2000/02/09 13:22:56 peter + * log truncated + + Revision 1.29 2000/01/11 17:16:04 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.28 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.27 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.26 1999/10/01 08:02:46 peter + * forward type declaration rewritten + + Revision 1.25 1999/09/02 18:47:44 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.24 1999/08/04 13:02:50 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.23 1999/07/27 23:42:10 peter + * indirect type referencing is now allowed + + Revision 1.22 1999/07/26 09:42:10 florian + * bugs 494-496 fixed + +} diff --git a/befpc/compiler/pdecl.pas b/befpc/compiler/pdecl.pas new file mode 100644 index 0000000..994e61f --- /dev/null +++ b/befpc/compiler/pdecl.pas @@ -0,0 +1,1369 @@ +{ + $Id: pdecl.pas,v 1.1.1.1 2001-07-23 17:16:46 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Does declaration (but not type) parsing for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pdecl; + +{$define UseUnionSymtable} + + interface + + uses + globtype,tokens,globals,symtable; + + procedure parameter_dec(aktprocdef:pabstractprocdef); + + procedure read_var_decs(is_record,is_object,is_threadvar:boolean); + + { reads the declaration blocks } + procedure read_declarations(islibrary : boolean); + + { reads declarations in the interface part of a unit } + procedure read_interface_declarations; + + implementation + + uses + cobjects,scanner, + symconst,aasm,tree,pass_1,strings, + files,types,verbose,systems,import, + cpubase +{$ifndef newcg} + ,tccnv +{$endif newcg} +{$ifdef GDB} + ,gdb +{$endif GDB} + { parser specific stuff } + ,pbase,ptconst,pexpr,ptype,psub,pexports + { processor specific stuff } + { codegen } +{$ifdef newcg} + ,cgbase +{$else} + ,hcodegen +{$endif} + + ,hcgdata + ; + + + procedure parameter_dec(aktprocdef:pabstractprocdef); + { + handle_procvar needs the same changes + } + var + is_procvar : boolean; + sc : Pstringcontainer; + s : string; + storetokenpos : tfileposinfo; + tt : ttype; + hvs, + vs : Pvarsym; + hs1,hs2 : string; + varspez : Tvarspez; + inserthigh : boolean; + begin + { parsing a proc or procvar ? } + is_procvar:=(aktprocdef^.deftype=procvardef); + consume(_LKLAMMER); + inc(testcurobject); + repeat + if try_to_consume(_VAR) then + varspez:=vs_var + else + if try_to_consume(_CONST) then + varspez:=vs_const + else + varspez:=vs_value; + inserthigh:=false; + tt.reset; + if idtoken=_SELF then + begin + { only allowed in procvars and class methods } + if is_procvar or + (assigned(procinfo^._class) and procinfo^._class^.is_class) then + begin + if not is_procvar then + begin +{$ifndef UseNiceNames} + hs2:=hs2+'$'+'self'; +{$else UseNiceNames} + hs2:=hs2+tostr(length('self'))+'self'; +{$endif UseNiceNames} + vs:=new(Pvarsym,initdef('@',procinfo^._class)); + vs^.varspez:=vs_var; + { insert the sym in the parasymtable } + pprocdef(aktprocdef)^.parast^.insert(vs); +{$ifdef INCLUDEOK} + include(aktprocdef^.procoptions,po_containsself); +{$else} + aktprocdef^.procoptions:=aktprocdef^.procoptions+[po_containsself]; +{$endif} + inc(procinfo^.selfpointer_offset,vs^.address); + end; + consume(idtoken); + consume(_COLON); + single_type(tt,hs1,false); + aktprocdef^.concatpara(tt,vs_value); + { check the types for procedures only } + if not is_procvar then + CheckTypes(tt.def,procinfo^._class); + end + else + consume(_ID); + end + else + begin + { read identifiers } + sc:=idlist; +{$ifdef fixLeaksOnError} + strContStack.push(sc); +{$endif fixLeaksOnError} + { read type declaration, force reading for value and const paras } + if (token=_COLON) or (varspez=vs_value) then + begin + consume(_COLON); + { check for an open array } + if token=_ARRAY then + begin + consume(_ARRAY); + consume(_OF); + { define range and type of range } + tt.setdef(new(Parraydef,init(0,-1,s32bitdef))); + { array of const ? } + if (token=_CONST) and (m_objpas in aktmodeswitches) then + begin + consume(_CONST); + srsym:=nil; + getsymonlyin(systemunit,'TVARREC'); + if not assigned(srsym) then + InternalError(1234124); + Parraydef(tt.def)^.elementtype:=ptypesym(srsym)^.restype; + Parraydef(tt.def)^.IsArrayOfConst:=true; + hs1:='array_of_const'; + end + else + begin + { define field type } + single_type(parraydef(tt.def)^.elementtype,hs1,false); + hs1:='array_of_'+hs1; + end; + inserthigh:=true; + end + { open string ? } + else if (varspez=vs_var) and + ( + ( + ((token=_STRING) or (idtoken=_SHORTSTRING)) and + (cs_openstring in aktmoduleswitches) and + not(cs_ansistrings in aktlocalswitches) + ) or + (idtoken=_OPENSTRING)) then + begin + consume(token); + tt.setdef(openshortstringdef); + hs1:='openstring'; + inserthigh:=true; + end + { everything else } + else + single_type(tt,hs1,false); + end + else + begin +{$ifndef UseNiceNames} + hs1:='$$$'; +{$else UseNiceNames} + hs1:='var'; +{$endif UseNiceNames} + tt.setdef(cformaldef); + end; + if not is_procvar then + hs2:=pprocdef(aktprocdef)^.mangledname; + storetokenpos:=tokenpos; + while not sc^.empty do + begin + s:=sc^.get_with_tokeninfo(tokenpos); + aktprocdef^.concatpara(tt,varspez); + { For proc vars we only need the definitions } + if not is_procvar then + begin +{$ifndef UseNiceNames} + hs2:=hs2+'$'+hs1; +{$else UseNiceNames} + hs2:=hs2+tostr(length(hs1))+hs1; +{$endif UseNiceNames} + vs:=new(pvarsym,init(s,tt)); + vs^.varspez:=varspez; + { we have to add this to avoid var param to be in registers !!!} + if (varspez in [vs_var,vs_const]) and push_addr_param(tt.def) then + include(vs^.varoptions,vo_regable); + + { insert the sym in the parasymtable } + pprocdef(aktprocdef)^.parast^.insert(vs); + + { do we need a local copy? Then rename the varsym, do this after the + insert so the dup id checking is done correctly } + if (varspez=vs_value) and + push_addr_param(tt.def) and + not(is_open_array(tt.def) or is_array_of_const(tt.def)) then + pprocdef(aktprocdef)^.parast^.rename(vs^.name,'val'+vs^.name); + + { also need to push a high value? } + if inserthigh then + begin + hvs:=new(Pvarsym,initdef('high'+s,s32bitdef)); + hvs^.varspez:=vs_const; + pprocdef(aktprocdef)^.parast^.insert(hvs); + end; + + end; + end; +{$ifdef fixLeaksOnError} + if PStringContainer(strContStack.pop) <> sc then + writeln('problem with strContStack in pdecl (1)'); +{$endif fixLeaksOnError} + dispose(sc,done); + tokenpos:=storetokenpos; + end; + { set the new mangled name } + if not is_procvar then + pprocdef(aktprocdef)^.setmangledname(hs2); + until not try_to_consume(_SEMICOLON); + dec(testcurobject); + consume(_RKLAMMER); + end; + + + + + + + const + variantrecordlevel : longint = 0; + + procedure read_var_decs(is_record,is_object,is_threadvar:boolean); + { reads the filed of a record into a } + { symtablestack, if record=false } + { variants are forbidden, so this procedure } + { can be used to read object fields } + { if absolute is true, ABSOLUTE and file } + { types are allowed } + { => the procedure is also used to read } + { a sequence of variable declaration } + + procedure insert_syms(st : psymtable;sc : pstringcontainer;tt : ttype;is_threadvar : boolean); + { inserts the symbols of sc in st with def as definition or sym as ptypesym, sc is disposed } + var + s : string; + filepos : tfileposinfo; + ss : pvarsym; + begin + filepos:=tokenpos; + while not sc^.empty do + begin + s:=sc^.get_with_tokeninfo(tokenpos); + ss:=new(pvarsym,init(s,tt)); + if is_threadvar then +{$ifdef INCLUDEOK} + include(ss^.varoptions,vo_is_thread_var); +{$else} + ss^.varoptions:=ss^.varoptions+[vo_is_thread_var]; +{$endif} + st^.insert(ss); + { static data fields are inserted in the globalsymtable } + if (st^.symtabletype=objectsymtable) and + (sp_static in current_object_option) then + begin + s:=lower(st^.name^)+'_'+s; + st^.defowner^.owner^.insert(new(pvarsym,init(s,tt))); + end; + end; +{$ifdef fixLeaksOnError} + if strContStack.pop <> sc then + writeln('problem with strContStack in pdecl (2)'); +{$endif fixLeaksOnError} + dispose(sc,done); + tokenpos:=filepos; + end; + + var + sc : pstringcontainer; + s : stringid; + old_block_type : tblock_type; + declarepos,storetokenpos : tfileposinfo; + symdone : boolean; + { to handle absolute } + abssym : pabsolutesym; + l : longint; + code : integer; + { c var } + newtype : ptypesym; + is_dll, + is_gpc_name,is_cdecl,extern_aktvarsym,export_aktvarsym : boolean; + old_current_object_option : tsymoptions; + dll_name, + C_name : string; + tt,casetype : ttype; + { Delphi initialized vars } + pconstsym : ptypedconstsym; + { maxsize contains the max. size of a variant } + { startvarrec contains the start of the variant part of a record } + maxsize,maxalignment,startvarrecalign,startvarrecsize : longint; + pt : ptree; +{$ifdef UseUnionSymtable} + unionsymtable : psymtable; + offset : longint; + uniondef : precorddef; + unionsym : pvarsym; + uniontype : ttype; +{$endif UseUnionSymtable} + begin + old_current_object_option:=current_object_option; + { all variables are public if not in a object declaration } + if not is_object then + current_object_option:=[sp_public]; + old_block_type:=block_type; + block_type:=bt_type; + is_gpc_name:=false; + { Force an expected ID error message } + if not (token in [_ID,_CASE,_END]) then + consume(_ID); + { read vars } + while (token=_ID) and + not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do + begin + C_name:=orgpattern; + sc:=idlist; +{$ifdef fixLeaksOnError} + strContStack.push(sc); +{$endif fixLeaksOnError} + consume(_COLON); + if (m_gpc in aktmodeswitches) and + not(is_record or is_object or is_threadvar) and + (token=_ID) and (orgpattern='__asmname__') then + begin + consume(_ID); + C_name:=pattern; + if token=_CCHAR then + consume(_CCHAR) + else + consume(_CSTRING); + Is_gpc_name:=true; + end; + { this is needed for Delphi mode at least + but should be OK for all modes !! (PM) } + ignore_equal:=true; + read_type(tt,''); + if (variantrecordlevel>0) and tt.def^.needs_inittable then + Message(parser_e_cant_use_inittable_here); + ignore_equal:=false; + symdone:=false; + if is_gpc_name then + begin + storetokenpos:=tokenpos; + s:=sc^.get_with_tokeninfo(tokenpos); + if not sc^.empty then + Message(parser_e_absolute_only_one_var); +{$ifdef fixLeaksOnError} + if strContStack.pop <> sc then + writeln('problem with strContStack in pdecl (3)'); +{$endif fixLeaksOnError} + dispose(sc,done); + aktvarsym:=new(pvarsym,init_C(s,target_os.Cprefix+C_name,tt)); +{$ifdef INCLUDEOK} + include(aktvarsym^.varoptions,vo_is_external); +{$else} + aktvarsym^.varoptions:=aktvarsym^.varoptions+[vo_is_external]; +{$endif} + symtablestack^.insert(aktvarsym); + tokenpos:=storetokenpos; + symdone:=true; + end; + { check for absolute } + if not symdone and + (idtoken=_ABSOLUTE) and not(is_record or is_object or is_threadvar) then + begin + consume(_ABSOLUTE); + { only allowed for one var } + s:=sc^.get_with_tokeninfo(declarepos); + if not sc^.empty then + Message(parser_e_absolute_only_one_var); +{$ifdef fixLeaksOnError} + if strContStack.pop <> sc then + writeln('problem with strContStack in pdecl (4)'); +{$endif fixLeaksOnError} + dispose(sc,done); + { parse the rest } + if token=_ID then + begin + getsym(pattern,true); + consume(_ID); + { support unit.variable } + if srsym^.typ=unitsym then + begin + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + consume(_ID); + end; + { we should check the result type of srsym } + if not (srsym^.typ in [varsym,typedconstsym]) then + Message(parser_e_absolute_only_to_var_or_const); + storetokenpos:=tokenpos; + tokenpos:=declarepos; + abssym:=new(pabsolutesym,init(s,tt)); + abssym^.abstyp:=tovar; + abssym^.ref:=srsym; + symtablestack^.insert(abssym); + tokenpos:=storetokenpos; + end + else + if (token=_CSTRING) or (token=_CCHAR) then + begin + storetokenpos:=tokenpos; + tokenpos:=declarepos; + abssym:=new(pabsolutesym,init(s,tt)); + s:=pattern; + consume(token); + abssym^.abstyp:=toasm; + abssym^.asmname:=stringdup(s); + symtablestack^.insert(abssym); + tokenpos:=storetokenpos; + end + else + { absolute address ?!? } + if token=_INTCONST then + begin + if (target_info.target=target_i386_go32v2) then + begin + storetokenpos:=tokenpos; + tokenpos:=declarepos; + abssym:=new(pabsolutesym,init(s,tt)); + abssym^.abstyp:=toaddr; + abssym^.absseg:=false; + s:=pattern; + consume(_INTCONST); + val(s,abssym^.address,code); + if token=_COLON then + begin + consume(token); + s:=pattern; + consume(_INTCONST); + val(s,l,code); + abssym^.address:=abssym^.address shl 4+l; + abssym^.absseg:=true; + end; + symtablestack^.insert(abssym); + tokenpos:=storetokenpos; + end + else + Message(parser_e_absolute_only_to_var_or_const); + end + else + Message(parser_e_absolute_only_to_var_or_const); + symdone:=true; + end; + { Handling of Delphi typed const = initialized vars ! } + { When should this be rejected ? + - in parasymtable + - in record or object + - ... (PM) } + if (m_delphi in aktmodeswitches) and (token=_EQUAL) and + not (symtablestack^.symtabletype in [parasymtable]) and + not is_record and not is_object then + begin + storetokenpos:=tokenpos; + s:=sc^.get_with_tokeninfo(tokenpos); + if not sc^.empty then + Message(parser_e_initialized_only_one_var); + pconstsym:=new(ptypedconstsym,inittype(s,tt,false)); + symtablestack^.insert(pconstsym); + tokenpos:=storetokenpos; + consume(_EQUAL); + readtypedconst(tt.def,pconstsym,false); + symdone:=true; + end; + { for a record there doesn't need to be a ; before the END or ) } + if not((is_record or is_object) and (token in [_END,_RKLAMMER])) then + consume(_SEMICOLON); + { procvar handling } + if (tt.def^.deftype=procvardef) and (tt.def^.typesym=nil) then + begin + newtype:=new(ptypesym,init('unnamed',tt)); + parse_var_proc_directives(psym(newtype)); + newtype^.restype.def:=nil; + tt.def^.typesym:=nil; + dispose(newtype,done); + end; + { Check for variable directives } + if not symdone and (token=_ID) then + begin + { Check for C Variable declarations } + if (m_cvar_support in aktmodeswitches) and + not(is_record or is_object or is_threadvar) and + (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then + begin + { only allowed for one var } + s:=sc^.get_with_tokeninfo(declarepos); + if not sc^.empty then + Message(parser_e_absolute_only_one_var); +{$ifdef fixLeaksOnError} + if strContStack.pop <> sc then + writeln('problem with strContStack in pdecl (5)'); +{$endif fixLeaksOnError} + dispose(sc,done); + { defaults } + is_dll:=false; + is_cdecl:=false; + extern_aktvarsym:=false; + export_aktvarsym:=false; + { cdecl } + if idtoken=_CVAR then + begin + consume(_CVAR); + consume(_SEMICOLON); + is_cdecl:=true; + C_name:=target_os.Cprefix+C_name; + end; + { external } + if idtoken=_EXTERNAL then + begin + consume(_EXTERNAL); + extern_aktvarsym:=true; + end; + { export } + if idtoken in [_EXPORT,_PUBLIC] then + begin + consume(_ID); + if extern_aktvarsym or + (symtablestack^.symtabletype in [parasymtable,localsymtable]) then + Message(parser_e_not_external_and_export) + else + export_aktvarsym:=true; + end; + { external and export need a name after when no cdecl is used } + if not is_cdecl then + begin + { dll name ? } + if (extern_aktvarsym) and (idtoken<>_NAME) then + begin + is_dll:=true; + dll_name:=get_stringconst; + end; + consume(_NAME); + C_name:=get_stringconst; + end; + { consume the ; when export or external is used } + if extern_aktvarsym or export_aktvarsym then + consume(_SEMICOLON); + { insert in the symtable } + storetokenpos:=tokenpos; + tokenpos:=declarepos; + if is_dll then + aktvarsym:=new(pvarsym,init_dll(s,tt)) + else + aktvarsym:=new(pvarsym,init_C(s,C_name,tt)); + { set some vars options } + if export_aktvarsym then + begin + inc(aktvarsym^.refs); +{$ifdef INCLUDEOK} + include(aktvarsym^.varoptions,vo_is_exported); +{$else} + aktvarsym^.varoptions:=aktvarsym^.varoptions+[vo_is_exported]; +{$endif} + end; + if extern_aktvarsym then +{$ifdef INCLUDEOK} + include(aktvarsym^.varoptions,vo_is_external); +{$else} + aktvarsym^.varoptions:=aktvarsym^.varoptions+[vo_is_external]; +{$endif} + { insert in the stack/datasegment } + symtablestack^.insert(aktvarsym); + tokenpos:=storetokenpos; + { now we can insert it in the import lib if its a dll, or + add it to the externals } + if extern_aktvarsym then + begin + if is_dll then + begin + if not(current_module^.uses_imports) then + begin + current_module^.uses_imports:=true; + importlib^.preparelib(current_module^.modulename^); + end; + importlib^.importvariable(aktvarsym^.mangledname,dll_name,C_name) + end + end; + symdone:=true; + end + else + if (is_object) and (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then + begin +{$ifdef INCLUDEOK} + include(current_object_option,sp_static); +{$else} + current_object_option:=current_object_option+[sp_static]; +{$endif} + insert_syms(symtablestack,sc,tt,false); +{$ifdef INCLUDEOK} + exclude(current_object_option,sp_static); +{$else} + current_object_option:=current_object_option-[sp_static]; +{$endif} + consume(_STATIC); + consume(_SEMICOLON); + symdone:=true; + end; + end; + { insert it in the symtable, if not done yet } + if not symdone then + begin + { save object option, because we can turn of the sp_published } + if (sp_published in current_object_option) and + (not((tt.def^.deftype=objectdef) and (pobjectdef(tt.def)^.is_class))) then + begin + Message(parser_e_cant_publish_that); + exclude(current_object_option,sp_published); + end + else + if (sp_published in current_object_option) and + not(oo_can_have_published in pobjectdef(tt.def)^.objectoptions) then + begin + Message(parser_e_only_publishable_classes_can__be_published); + exclude(current_object_option,sp_published); + end; + insert_syms(symtablestack,sc,tt,is_threadvar); + current_object_option:=old_current_object_option; + end; + end; + { Check for Case } + if is_record and (token=_CASE) then + begin + maxsize:=0; + maxalignment:=0; + consume(_CASE); + s:=pattern; + getsym(s,false); + { may be only a type: } + if assigned(srsym) and (srsym^.typ in [typesym,unitsym]) then + read_type(casetype,'') + else + begin + consume(_ID); + consume(_COLON); + read_type(casetype,''); + symtablestack^.insert(new(pvarsym,init(s,casetype))); + end; + if not(is_ordinal(casetype.def)) or is_64bitint(casetype.def) then + Message(type_e_ordinal_expr_expected); + consume(_OF); +{$ifdef UseUnionSymtable} + UnionSymtable:=new(psymtable,init(recordsymtable)); + UnionSymtable^.next:=symtablestack; + registerdef:=false; + UnionDef:=new(precorddef,init(unionsymtable)); + registerdef:=true; + symtablestack:=UnionSymtable; +{$endif UseUnionSymtable} + startvarrecsize:=symtablestack^.datasize; + startvarrecalign:=symtablestack^.dataalignment; + repeat + repeat + pt:=comp_expr(true); + do_firstpass(pt); + if not(pt^.treetype=ordconstn) then + Message(cg_e_illegal_expression); + disposetree(pt); + if token=_COMMA then + consume(_COMMA) + else + break; + until false; + consume(_COLON); + { read the vars } + consume(_LKLAMMER); + inc(variantrecordlevel); + if token<>_RKLAMMER then + read_var_decs(true,false,false); + dec(variantrecordlevel); + consume(_RKLAMMER); + { calculates maximal variant size } + maxsize:=max(maxsize,symtablestack^.datasize); + maxalignment:=max(maxalignment,symtablestack^.dataalignment); + { the items of the next variant are overlayed } + symtablestack^.datasize:=startvarrecsize; + symtablestack^.dataalignment:=startvarrecalign; + if (token<>_END) and (token<>_RKLAMMER) then + consume(_SEMICOLON) + else + break; + until (token=_END) or (token=_RKLAMMER); + { at last set the record size to that of the biggest variant } + symtablestack^.datasize:=maxsize; + symtablestack^.dataalignment:=maxalignment; +{$ifdef UseUnionSymtable} + uniontype.def:=uniondef; + uniontype.sym:=nil; + UnionSym:=new(pvarsym,init('case',uniontype)); + symtablestack:=symtablestack^.next; + { we do NOT call symtablestack^.insert + on purpose PM } + offset:=align_from_size(symtablestack^.datasize,maxalignment); + symtablestack^.datasize:=offset+unionsymtable^.datasize; + if maxalignment>symtablestack^.dataalignment then + symtablestack^.dataalignment:=maxalignment; + UnionSymtable^.Insert_in(symtablestack,offset); + UnionSym^.owner:=nil; + dispose(unionsym,done); + dispose(uniondef,done); +{$endif UseUnionSymtable} + end; + block_type:=old_block_type; + current_object_option:=old_current_object_option; + end; + + + procedure const_dec; + var + name : stringid; + p : ptree; + tt : ttype; + sym : psym; + storetokenpos,filepos : tfileposinfo; + old_block_type : tblock_type; + ps : pconstset; + pd : pbestreal; + sp : pchar; + skipequal : boolean; + begin + consume(_CONST); + old_block_type:=block_type; + block_type:=bt_const; + repeat + name:=pattern; + filepos:=tokenpos; + consume(_ID); + case token of + + _EQUAL: + begin + consume(_EQUAL); + p:=comp_expr(true); + do_firstpass(p); + storetokenpos:=tokenpos; + tokenpos:=filepos; + case p^.treetype of + ordconstn: + begin + if is_constintnode(p) then + symtablestack^.insert(new(pconstsym,init_def(name,constint,p^.value,nil))) + else if is_constcharnode(p) then + symtablestack^.insert(new(pconstsym,init_def(name,constchar,p^.value,nil))) + else if is_constboolnode(p) then + symtablestack^.insert(new(pconstsym,init_def(name,constbool,p^.value,nil))) + else if p^.resulttype^.deftype=enumdef then + symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype))) + else if p^.resulttype^.deftype=pointerdef then + symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype))) + else internalerror(111); + end; + stringconstn: + begin + getmem(sp,p^.length+1); + move(p^.value_str^,sp^,p^.length+1); + symtablestack^.insert(new(pconstsym,init_string(name,conststring,sp,p^.length))); + end; + realconstn : + begin + new(pd); + pd^:=p^.value_real; + symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd)))); + end; + setconstn : + begin + new(ps); + ps^:=p^.value_set^; + symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype))); + end; + pointerconstn : + begin + symtablestack^.insert(new(pconstsym,init_def(name,constpointer,p^.value,p^.resulttype))) + end; + niln : + begin + symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype))); + end; + else + Message(cg_e_illegal_expression); + end; + tokenpos:=storetokenpos; + consume(_SEMICOLON); + disposetree(p); + end; + + _COLON: + begin + { set the blocktype first so a consume also supports a + caret, to support const s : ^string = nil } + block_type:=bt_type; + consume(_COLON); + ignore_equal:=true; + read_type(tt,''); + ignore_equal:=false; + block_type:=bt_const; + skipequal:=false; + { create symbol } + storetokenpos:=tokenpos; + tokenpos:=filepos; +{$ifdef DELPHI_CONST_IN_RODATA} + if m_delphi in aktmodeswitches then + begin + if assigned(readtypesym) then + sym:=new(ptypedconstsym,initsym(name,readtypesym,true)) + else + sym:=new(ptypedconstsym,init(name,def,true)) + end + else +{$endif DELPHI_CONST_IN_RODATA} + begin + sym:=new(ptypedconstsym,inittype(name,tt,false)) + end; + tokenpos:=storetokenpos; + symtablestack^.insert(sym); + { procvar can have proc directives } + if (tt.def^.deftype=procvardef) then + begin + { support p : procedure;stdcall=nil; } + if (token=_SEMICOLON) then + begin + consume(_SEMICOLON); + if is_proc_directive(token) then + parse_var_proc_directives(sym) + else + begin + Message(parser_e_proc_directive_expected); + skipequal:=true; + end; + end + else + { support p : procedure stdcall=nil; } + begin + if is_proc_directive(token) then + parse_var_proc_directives(sym); + end; + end; + if not skipequal then + begin + { get init value } + consume(_EQUAL); +{$ifdef DELPHI_CONST_IN_RODATA} + if m_delphi in aktmodeswitches then + readtypedconst(tt.def,ptypedconstsym(sym),true) + else +{$endif DELPHI_CONST_IN_RODATA} + readtypedconst(tt.def,ptypedconstsym(sym),false); + consume(_SEMICOLON); + end; + end; + + else + { generate an error } + consume(_EQUAL); + end; + until token<>_ID; + block_type:=old_block_type; + end; + + procedure label_dec; + + var + hl : pasmlabel; + + begin + consume(_LABEL); + if not(cs_support_goto in aktmoduleswitches) then + Message(sym_e_goto_and_label_not_supported); + repeat + if not(token in [_ID,_INTCONST]) then + consume(_ID) + else + begin + if (cs_create_smart in aktmoduleswitches) then + begin + getdatalabel(hl); + { we still want a warning if unused } + hl^.refs:=0; + end + else + getlabel(hl); + symtablestack^.insert(new(plabelsym,init(pattern,hl))); + consume(token); + end; + if token<>_SEMICOLON then consume(_COMMA); + until not(token in [_ID,_INTCONST]); + consume(_SEMICOLON); + end; + + + { search in symtablestack used, but not defined type } + procedure resolve_type_forward(p : pnamedindexobject);{$ifndef FPC}far;{$endif} + var + hpd,pd : pdef; + stpos : tfileposinfo; + again : boolean; + begin + { Check only typesyms or record/object fields } + case psym(p)^.typ of + typesym : + pd:=ptypesym(p)^.restype.def; + varsym : + if (psym(p)^.owner^.symtabletype in [objectsymtable,recordsymtable]) then + pd:=pvarsym(p)^.vartype.def + else + exit; + else + exit; + end; + repeat + again:=false; + case pd^.deftype of + arraydef : + begin + { elementtype could also be defined using a forwarddef } + pd:=parraydef(pd)^.elementtype.def; + again:=true; + end; + pointerdef, + classrefdef : + begin + { classrefdef inherits from pointerdef } + hpd:=ppointerdef(pd)^.pointertype.def; + { still a forward def ? } + if hpd^.deftype=forwarddef then + begin + { try to resolve the forward } + { get the correct position for it } + stpos:=tokenpos; + tokenpos:=pforwarddef(hpd)^.forwardpos; + resolving_forward:=true; + make_ref:=false; + getsym(pforwarddef(hpd)^.tosymname,false); + make_ref:=true; + resolving_forward:=false; + tokenpos:=stpos; + { we don't need the forwarddef anymore, dispose it } + dispose(hpd,done); + { was a type sym found ? } + if assigned(srsym) and + (srsym^.typ=typesym) then + begin + ppointerdef(pd)^.pointertype.setsym(srsym); + { avoid wrong unused warnings web bug 801 PM } + inc(srsym^.refs); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and assigned(debuglist) and + (psym(p)^.owner^.symtabletype in [globalsymtable,staticsymtable]) then + begin + ptypesym(p)^.isusedinstab := true; + psym(p)^.concatstabto(debuglist); + end; +{$endif GDB} + { we need a class type for classrefdef } + if (pd^.deftype=classrefdef) and + not((ptypesym(srsym)^.restype.def^.deftype=objectdef) and + pobjectdef(ptypesym(srsym)^.restype.def)^.is_class) then + Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename); + end + else + begin + MessagePos1(psym(p)^.fileinfo,sym_e_forward_type_not_resolved,p^.name); + { try to recover } + ppointerdef(pd)^.pointertype.def:=generrordef; + end; + end; + end; + recorddef : + precorddef(pd)^.symtable^.foreach({$ifndef TP}@{$endif}resolve_type_forward); + objectdef : + { Don't check objectdefs in objects/records, because these can't + exist (anonymous objects aren't allowed) } + if not(psym(p)^.owner^.symtabletype in [objectsymtable,recordsymtable]) then + pobjectdef(pd)^.symtable^.foreach({$ifndef TP}@{$endif}resolve_type_forward); + end; + until not again; + end; + + { reads a type declaration to the symbol table } + procedure type_dec; + + var + typename : stringid; + newtype : ptypesym; + sym : psym; + tt : ttype; + defpos,storetokenpos : tfileposinfo; + old_block_type : tblock_type; + begin + old_block_type:=block_type; + block_type:=bt_type; + consume(_TYPE); + typecanbeforward:=true; + repeat + typename:=pattern; + defpos:=tokenpos; + consume(_ID); + consume(_EQUAL); + { support 'ttype=type word' syntax } + if token=_TYPE then + Consume(_TYPE); + { is the type already defined? } + getsym(typename,false); + sym:=srsym; + newtype:=nil; + { found a symbol with this name? } + if assigned(sym) then + begin + if (sym^.typ=typesym) then + begin + if (token=_CLASS) and + (assigned(ptypesym(sym)^.restype.def)) and + (ptypesym(sym)^.restype.def^.deftype=objectdef) and + pobjectdef(ptypesym(sym)^.restype.def)^.is_class and + (oo_is_forward in pobjectdef(ptypesym(sym)^.restype.def)^.objectoptions) then + begin + { we can ignore the result } + { the definition is modified } + object_dec(typename,pobjectdef(ptypesym(sym)^.restype.def)); + newtype:=ptypesym(sym); + end; + end; + end; + { no old type reused ? Then insert this new type } + if not assigned(newtype) then + begin + read_type(tt,typename); + storetokenpos:=tokenpos; + tokenpos:=defpos; + newtype:=new(ptypesym,init(typename,tt)); + symtablestack^.insert(newtype); + tokenpos:=storetokenpos; + end; + if assigned(newtype^.restype.def) and + (newtype^.restype.def^.deftype=procvardef) then + begin + if not is_proc_directive(token) then + consume(_SEMICOLON); + parse_var_proc_directives(psym(newtype)); + end + else + consume(_SEMICOLON); + until token<>_ID; + typecanbeforward:=false; + symtablestack^.foreach({$ifndef TP}@{$endif}resolve_type_forward); + block_type:=old_block_type; + end; + + + procedure var_dec; + { parses variable declarations and inserts them in } + { the top symbol table of symtablestack } + begin + consume(_VAR); + read_var_decs(false,false,false); + end; + + procedure threadvar_dec; + { parses thread variable declarations and inserts them in } + { the top symbol table of symtablestack } + begin + consume(_THREADVAR); + if not(symtablestack^.symtabletype in [staticsymtable,globalsymtable]) then + message(parser_e_threadvars_only_sg); + read_var_decs(false,false,true); + end; + + procedure resourcestring_dec; + + var + name : stringid; + p : ptree; + storetokenpos,filepos : tfileposinfo; + old_block_type : tblock_type; + sp : pchar; + + begin + consume(_RESOURCESTRING); + if not(symtablestack^.symtabletype in [staticsymtable,globalsymtable]) then + message(parser_e_resourcestring_only_sg); + old_block_type:=block_type; + block_type:=bt_const; + repeat + name:=pattern; + filepos:=tokenpos; + consume(_ID); + case token of + _EQUAL: + begin + consume(_EQUAL); + p:=comp_expr(true); + do_firstpass(p); + storetokenpos:=tokenpos; + tokenpos:=filepos; + case p^.treetype of + ordconstn: + begin + if is_constcharnode(p) then + begin + getmem(sp,2); + sp[0]:=chr(p^.value); + sp[1]:=#0; + symtablestack^.insert(new(pconstsym,init_string(name,constresourcestring,sp,1))); + end + else + Message(cg_e_illegal_expression); + end; + stringconstn: + begin + getmem(sp,p^.length+1); + move(p^.value_str^,sp^,p^.length+1); + symtablestack^.insert(new(pconstsym,init_string(name,constresourcestring,sp,p^.length))); + end; + else + Message(cg_e_illegal_expression); + end; + tokenpos:=storetokenpos; + consume(_SEMICOLON); + disposetree(p); + end; + else consume(_EQUAL); + end; + until token<>_ID; + block_type:=old_block_type; + + end; + + procedure Not_supported_for_inline(t : ttoken); + + begin + if assigned(aktprocsym) and + (pocall_inline in aktprocsym^.definition^.proccalloptions) then + Begin + Message1(parser_w_not_supported_for_inline,tokenstring(t)); + Message(parser_w_inlining_disabled); +{$ifdef INCLUDEOK} + exclude(aktprocsym^.definition^.proccalloptions,pocall_inline); +{$else} + aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions-[pocall_inline]; +{$endif} + End; + end; + + + procedure read_declarations(islibrary : boolean); + + begin + repeat + case token of + _LABEL: + begin + Not_supported_for_inline(token); + label_dec; + end; + _CONST: + begin + Not_supported_for_inline(token); + const_dec; + end; + _TYPE: + begin + Not_supported_for_inline(token); + type_dec; + end; + _VAR: + var_dec; + _THREADVAR: + threadvar_dec; + _CONSTRUCTOR,_DESTRUCTOR, + _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS: + begin + Not_supported_for_inline(token); + read_proc; + end; + _RESOURCESTRING: + resourcestring_dec; + _EXPORTS: + begin + Not_supported_for_inline(token); + { here we should be at lexlevel 1, no ? PM } + if (lexlevel<>main_program_level) or + (current_module^.is_unit) then + begin + Message(parser_e_syntax_error); + consume_all_until(_SEMICOLON); + end + else if islibrary or (target_info.target=target_i386_WIN32) then + read_exports; + end + else break; + end; + until false; + end; + + + procedure read_interface_declarations; + begin + {Since the body is now parsed at lexlevel 1, and the declarations + must be parsed at the same lexlevel we increase the lexlevel.} + inc(lexlevel); + repeat + case token of + _CONST : const_dec; + _TYPE : type_dec; + _VAR : var_dec; + _THREADVAR : threadvar_dec; + _RESOURCESTRING: + resourcestring_dec; + _FUNCTION, + _PROCEDURE, + _OPERATOR : read_proc; + else + break; + end; + until false; + dec(lexlevel); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.189 2000/07/03 13:26:48 pierre + * fix for bug 1023 + + Revision 1.188 2000/06/23 21:34:09 pierre + * align all variants to same start address + + Revision 1.187 2000/06/23 20:14:39 peter + * reset current_object_option when reading other symtables than + object declarations + + Revision 1.186 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.185 2000/06/11 06:59:36 peter + * support procvar directive without ; before the directives + + Revision 1.184 2000/06/09 21:34:40 peter + * checking for dup id with para of methods fixed for delphi mode + + Revision 1.183 2000/06/02 21:18:13 pierre + + set vo_is_exported for vars + + Revision 1.182 2000/06/01 19:14:09 peter + * symtable.insert changed to procedure + + Revision 1.181 2000/04/17 18:44:22 peter + * fixed forward resolving with redefined types + + Revision 1.180 2000/02/09 13:22:56 peter + * log truncated + + Revision 1.179 2000/01/20 12:29:02 pierre + * bug 801 fixed + + Revision 1.178 2000/01/11 17:16:05 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.177 2000/01/10 11:14:19 peter + * fixed memory leak with options, you must use StopOptions instead of + Stop + * fixed memory leak with forward resolving, make_ref is now false + + Revision 1.176 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.175 1999/12/10 10:04:21 peter + * also check elementtype of arraydef for forwarddef + + Revision 1.174 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.173 1999/11/30 10:40:44 peter + + ttype, tsymlist + + Revision 1.172 1999/11/29 15:18:27 pierre + + allow exports in win32 executables + + Revision 1.171 1999/11/09 23:43:08 pierre + * better browser info + + Revision 1.170 1999/11/09 23:06:45 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.169 1999/11/09 12:58:29 peter + * support absolute unit.variable + + Revision 1.168 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.167 1999/10/26 12:30:44 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.166 1999/10/22 10:39:34 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.165 1999/10/21 16:41:41 florian + * problems with readln fixed: esi wasn't restored correctly when + reading ordinal fields of objects futher the register allocation + didn't take care of the extra register when reading ordinal values + * enumerations can now be used in constant indexes of properties + + Revision 1.164 1999/10/14 14:57:52 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.163 1999/10/06 17:39:14 peter + * fixed stabs writting for forward types + + Revision 1.162 1999/10/03 19:44:42 peter + * removed objpasunit reference, tvarrec is now searched in systemunit + where it already was located + + Revision 1.161 1999/10/01 11:18:02 peter + * class/record type forward checking fixed + + Revision 1.159 1999/10/01 10:05:42 peter + + procedure directive support in const declarations, fixes bug 232 + +} \ No newline at end of file diff --git a/befpc/compiler/pexports.pas b/befpc/compiler/pexports.pas new file mode 100644 index 0000000..b2739f3 --- /dev/null +++ b/befpc/compiler/pexports.pas @@ -0,0 +1,213 @@ +{ + $Id: pexports.pas,v 1.1.1.1 2001-07-23 17:16:46 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit handles the exports parsing + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pexports; + + interface + + { reads an exports statement in a library } + procedure read_exports; + + implementation + + uses + globtype,systems,tokens, + strings,cobjects,globals,verbose, + scanner,symconst,symtable,pbase, + export,GenDef,tree,pass_1,pexpr; + + procedure read_exports; + + var + hp : pexported_item; + DefString:string; + ProcName:string; + InternalProcName:string; + pt : ptree; + + begin + DefString:=''; + InternalProcName:=''; + consume(_EXPORTS); + while true do + begin + hp:=new(pexported_item,init); + if token=_ID then + begin + getsym(pattern,true); + if srsym^.typ=unitsym then + begin + consume(_ID); + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + end; + consume(_ID); + if assigned(srsym) then + begin + hp^.sym:=srsym; + if ((hp^.sym^.typ<>procsym) or + ((tf_need_export in target_info.flags) and + not(po_exports in pprocdef(pprocsym(srsym)^.definition)^.procoptions) + ) + ) and + (srsym^.typ<>varsym) and (srsym^.typ<>typedconstsym) then + Message(parser_e_illegal_symbol_exported) + else + begin + ProcName:=hp^.sym^.name; + InternalProcName:=hp^.sym^.mangledname; + { This is wrong if the first is not + an underline } + if InternalProcName[1]='_' then + delete(InternalProcName,1,1) + else if (target_os.id=os_i386_win32) and UseDeffileForExport then + begin + Message(parser_e_dlltool_unit_var_problem); + Message(parser_e_dlltool_unit_var_problem2); + end; + if length(InternalProcName)<2 then + Message(parser_e_procname_to_short_for_export); + DefString:=ProcName+'='+InternalProcName; + end; + if (idtoken=_INDEX) then + begin + consume(_INDEX); + pt:=comp_expr(true); + do_firstpass(pt); + if pt^.treetype=ordconstn then + hp^.index:=pt^.value + else + begin + hp^.index:=0; + consume(_INTCONST); + end; + hp^.options:=hp^.options or eo_index; + disposetree(pt); + if target_os.id=os_i386_win32 then + DefString:=ProcName+'='+InternalProcName+' @ '+tostr(hp^.index) + else + DefString:=ProcName+'='+InternalProcName; {Index ignored!} + end; + if (idtoken=_NAME) then + begin + consume(_NAME); + pt:=comp_expr(true); + do_firstpass(pt); + if pt^.treetype=stringconstn then + hp^.name:=stringdup(strpas(pt^.value_str)) + else + begin + hp^.name:=stringdup(''); + consume(_CSTRING); + end; + hp^.options:=hp^.options or eo_name; + disposetree(pt); + DefString:=hp^.name^+'='+InternalProcName; + end; + if (idtoken=_RESIDENT) then + begin + consume(_RESIDENT); + hp^.options:=hp^.options or eo_resident; + DefString:=ProcName+'='+InternalProcName;{Resident ignored!} + end; + if (DefString<>'') and UseDeffileForExport then + DefFile.AddExport(DefString); + if hp^.sym^.typ=procsym then + exportlib^.exportprocedure(hp) + else + exportlib^.exportvar(hp); + end; + end + else + consume(_ID); + if token=_COMMA then + consume(_COMMA) + else + break; + end; + consume(_SEMICOLON); + if not DefFile.empty then + DefFile.writefile; + end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.22 2000/04/24 12:47:27 peter + * fixed check for exporting var or proc + + Revision 1.21 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.20 2000/02/23 23:06:39 florian + + the expr for names and indizies of exports sections support now + every type of expressions which evalute to a constant + + Revision 1.19 2000/02/09 13:22:56 peter + * log truncated + + Revision 1.18 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.17 1999/12/20 23:23:30 pierre + + $description $version + + Revision 1.16 1999/12/08 10:40:01 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.15 1999/11/22 22:20:43 pierre + * Def file syntax for win32 with index corrected + * direct output of .edata leads to same indexes + (index 5 leads to next export being 6 unless otherwise + specified like for enums) + + Revision 1.14 1999/11/20 01:19:10 pierre + * DLL index used for win32 target with DEF file + + DLL initialization/finalization support + + Revision 1.13 1999/10/26 12:30:44 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.12 1999/08/10 12:51:19 pierre + * bind_win32_dll removed (Relocsection used instead) + * now relocsection is true by default ! (needs dlltool + for DLL generation) + + Revision 1.11 1999/08/04 13:02:54 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.10 1999/08/03 22:02:58 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/pexpr.pas b/befpc/compiler/pexpr.pas new file mode 100644 index 0000000..442548a --- /dev/null +++ b/befpc/compiler/pexpr.pas @@ -0,0 +1,2278 @@ +{ + $Id: pexpr.pas,v 1.1.1.1 2001-07-23 17:16:47 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Does parsing of expression for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pexpr; + + interface + + uses symtable,tree; + + { reads a whole expression } + function expr : ptree; + + { reads an expression without assignements and .. } + function comp_expr(accept_equal : boolean):Ptree; + + { reads a single factor } + function factor(getaddr : boolean) : ptree; + + { the ID token has to be consumed before calling this function } + procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : ptree; + var pd : pdef;var again : boolean); + + function get_intconst:longint; + + function get_stringconst:string; + + implementation + + uses + globtype,systems,tokens, + cobjects,globals,scanner, + symconst,aasm,htypechk, +{$ifdef newcg} + cgbase, +{$else} + hcodegen, +{$endif} + types,verbose,strings, +{$ifndef newcg} + tccal, +{$endif newcg} + pass_1, + { parser specific stuff } + pbase,ptype, + { processor specific stuff } + cpubase,cpuinfo; + + { sub_expr(opmultiply) is need to get -1 ** 4 to be + read as - (1**4) and not (-1)**4 PM } + + type + Toperator_precedence=(opcompare,opaddition,opmultiply,oppower); + + const + highest_precedence = oppower; + + function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;forward; + + const + allow_type : boolean = true; + got_addrn : boolean = false; + auto_inherited : boolean = false; + + function parse_paras(__colon,in_prop_paras : boolean) : ptree; + + var + p1,p2 : ptree; + end_of_paras : ttoken; + + begin + if in_prop_paras then + end_of_paras:=_RECKKLAMMER + else + end_of_paras:=_RKLAMMER; + if token=end_of_paras then + begin + parse_paras:=nil; + exit; + end; + p2:=nil; + inc(parsing_para_level); + while true do + begin + p1:=comp_expr(true); + p2:=gencallparanode(p1,p2); + { it's for the str(l:5,s); } + if __colon and (token=_COLON) then + begin + consume(_COLON); + p1:=comp_expr(true); + p2:=gencallparanode(p1,p2); + p2^.is_colon_para:=true; + if token=_COLON then + begin + consume(_COLON); + p1:=comp_expr(true); + p2:=gencallparanode(p1,p2); + p2^.is_colon_para:=true; + end + end; + if token=_COMMA then + consume(_COMMA) + else + break; + end; + dec(parsing_para_level); + parse_paras:=p2; + end; + + + procedure check_tp_procvar(var p : ptree); + var + p1 : ptree; + + begin + if (m_tp_procvar in aktmodeswitches) and + (not got_addrn) and + (not in_args) and + (p^.treetype=loadn) then + begin + { support if procvar then for tp7 and many other expression like this } + do_firstpass(p); + set_varstate(p,false); + { reset varstateset to maybe set used state later web bug769 PM } + p^.varstateset:=false; + if not(getprocvar) and (p^.resulttype^.deftype=procvardef) then + begin + p1:=gencallnode(nil,nil); + p1^.right:=p; + p1^.resulttype:=pprocvardef(p^.resulttype)^.rettype.def; + firstpass(p1); + p:=p1; + end; + end; + end; + + + function statement_syssym(l : longint;var pd : pdef) : ptree; + var + p1,p2,paras : ptree; + prev_in_args : boolean; + begin + prev_in_args:=in_args; + case l of + in_ord_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + consume(_RKLAMMER); + do_firstpass(p1); + p1:=geninlinenode(in_ord_x,false,p1); + do_firstpass(p1); + statement_syssym := p1; + pd:=p1^.resulttype; + end; + + in_break : + begin + statement_syssym:=genzeronode(breakn); + pd:=voiddef; + end; + + in_continue : + begin + statement_syssym:=genzeronode(continuen); + pd:=voiddef; + end; + + in_typeof_x : + begin + consume(_LKLAMMER); + in_args:=true; + {allow_type:=true;} + p1:=comp_expr(true); + {allow_type:=false;} + consume(_RKLAMMER); + pd:=voidpointerdef; + if p1^.treetype=typen then + begin + if (p1^.typenodetype=nil) then + begin + Message(type_e_mismatch); + statement_syssym:=genzeronode(errorn); + end + else + if p1^.typenodetype^.deftype=objectdef then + begin + { we can use resulttype in pass_2 (PM) } + p1^.resulttype:=p1^.typenodetype; + statement_syssym:=geninlinenode(in_typeof_x,false,p1); + end + else + begin + Message(type_e_mismatch); + disposetree(p1); + statement_syssym:=genzeronode(errorn); + end; + end + else { not a type node } + begin + do_firstpass(p1); + set_varstate(p1,false); + if (p1^.resulttype=nil) then + begin + Message(type_e_mismatch); + disposetree(p1); + statement_syssym:=genzeronode(errorn) + end + else + if p1^.resulttype^.deftype=objectdef then + statement_syssym:=geninlinenode(in_typeof_x,false,p1) + else + begin + Message(type_e_mismatch); + statement_syssym:=genzeronode(errorn); + disposetree(p1); + end; + end; + end; + + in_sizeof_x : + begin + consume(_LKLAMMER); + in_args:=true; + {allow_type:=true;} + p1:=comp_expr(true); + {allow_type:=false; } + consume(_RKLAMMER); + pd:=s32bitdef; + if p1^.treetype=typen then + begin + statement_syssym:=genordinalconstnode(p1^.typenodetype^.size,pd); + { p1 not needed !} + disposetree(p1); + end + else + begin + do_firstpass(p1); + if ((p1^.resulttype^.deftype=objectdef) and + (oo_has_constructor in pobjectdef(p1^.resulttype)^.objectoptions)) or + is_open_array(p1^.resulttype) or + is_open_string(p1^.resulttype) then + statement_syssym:=geninlinenode(in_sizeof_x,false,p1) + else + begin + statement_syssym:=genordinalconstnode(p1^.resulttype^.size,pd); + { p1 not needed !} + disposetree(p1); + end; + end; + end; + + in_assigned_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + do_firstpass(p1); + if not codegenerror then + begin + case p1^.resulttype^.deftype of + pointerdef, + procvardef, + classrefdef : ; + objectdef : + if not(pobjectdef(p1^.resulttype)^.is_class) then + Message(parser_e_illegal_parameter_list); + else + Message(parser_e_illegal_parameter_list); + end; + end; + p2:=gencallparanode(p1,nil); + p2:=geninlinenode(in_assigned_x,false,p2); + consume(_RKLAMMER); + pd:=booldef; + statement_syssym:=p2; + end; + + in_ofs_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + p1:=gensinglenode(addrn,p1); + do_firstpass(p1); + + { Ofs() returns a longint, not a pointer } + p1^.resulttype:=u32bitdef; + pd:=p1^.resulttype; + consume(_RKLAMMER); + statement_syssym:=p1; + end; + + in_addr_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + p1:=gensinglenode(addrn,p1); + do_firstpass(p1); + pd:=p1^.resulttype; + consume(_RKLAMMER); + statement_syssym:=p1; + end; + + in_seg_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + do_firstpass(p1); + set_varstate(p1,false); + if p1^.location.loc<>LOC_REFERENCE then + Message(cg_e_illegal_expression); + p1:=genordinalconstnode(0,s32bitdef); + pd:=s32bitdef; + consume(_RKLAMMER); + statement_syssym:=p1; + end; + + in_high_x, + in_low_x : + begin + consume(_LKLAMMER); + in_args:=true; + {allow_type:=true;} + p1:=comp_expr(true); + {allow_type:=false;} + do_firstpass(p1); + if p1^.treetype=typen then + p1^.resulttype:=p1^.typenodetype; + p2:=geninlinenode(l,false,p1); + consume(_RKLAMMER); + pd:=s32bitdef; + statement_syssym:=p2; + end; + + in_succ_x, + in_pred_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + do_firstpass(p1); + p2:=geninlinenode(l,false,p1); + consume(_RKLAMMER); + pd:=p1^.resulttype; + statement_syssym:=p2; + end; + + in_inc_x, + in_dec_x : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + if token=_COMMA then + begin + consume(_COMMA); + p2:=gencallparanode(comp_expr(true),nil); + end + else + p2:=nil; + p2:=gencallparanode(p1,p2); + statement_syssym:=geninlinenode(l,false,p2); + consume(_RKLAMMER); + pd:=voiddef; + end; + + in_concat_x : + begin + consume(_LKLAMMER); + in_args:=true; + p2:=nil; + while true do + begin + p1:=comp_expr(true); + do_firstpass(p1); + set_varstate(p1,true); + if not((p1^.resulttype^.deftype=stringdef) or + ((p1^.resulttype^.deftype=orddef) and + (porddef(p1^.resulttype)^.typ=uchar))) then + Message(parser_e_illegal_parameter_list); + if p2<>nil then + p2:=gennode(addn,p2,p1) + else + p2:=p1; + if token=_COMMA then + consume(_COMMA) + else + break; + end; + consume(_RKLAMMER); + pd:=cshortstringdef; + statement_syssym:=p2; + end; + + in_read_x, + in_readln_x : + begin + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + in_args:=true; + paras:=parse_paras(false,false); + consume(_RKLAMMER); + end + else + paras:=nil; + pd:=voiddef; + p1:=geninlinenode(l,false,paras); + do_firstpass(p1); + statement_syssym := p1; + end; + + in_write_x, + in_writeln_x : + begin + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + in_args:=true; + paras:=parse_paras(true,false); + consume(_RKLAMMER); + end + else + paras:=nil; + pd:=voiddef; + p1 := geninlinenode(l,false,paras); + do_firstpass(p1); + statement_syssym := p1; + end; + + in_str_x_string : + begin + consume(_LKLAMMER); + in_args:=true; + paras:=parse_paras(true,false); + consume(_RKLAMMER); + p1 := geninlinenode(l,false,paras); + do_firstpass(p1); + statement_syssym := p1; + pd:=voiddef; + end; + + in_val_x: + Begin + consume(_LKLAMMER); + in_args := true; + p1:= gencallparanode(comp_expr(true), nil); + consume(_COMMA); + p2 := gencallparanode(comp_expr(true),p1); + if (token = _COMMA) then + Begin + consume(_COMMA); + p2 := gencallparanode(comp_expr(true),p2) + End; + consume(_RKLAMMER); + p2 := geninlinenode(l,false,p2); + do_firstpass(p2); + statement_syssym := p2; + pd := voiddef; + End; + + in_include_x_y, + in_exclude_x_y : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + consume(_COMMA); + p2:=comp_expr(true); + statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil))); + consume(_RKLAMMER); + pd:=voiddef; + end; + + in_assert_x_y : + begin + consume(_LKLAMMER); + in_args:=true; + p1:=comp_expr(true); + if token=_COMMA then + begin + consume(_COMMA); + p2:=comp_expr(true); + end + else + begin + { then insert an empty string } + p2:=genstringconstnode('',st_default); + end; + statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil))); + consume(_RKLAMMER); + pd:=voiddef; + end; + + else + internalerror(15); + + end; + in_args:=prev_in_args; + end; + + + { reads the parameter for a subroutine call } + procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef); + var + prev_in_args : boolean; + prevafterassn : boolean; + hs,hs1 : pvarsym; + st : psymtable; + p2 : ptree; + begin + prev_in_args:=in_args; + prevafterassn:=afterassignment; + afterassignment:=false; + { want we only determine the address of } + { a subroutine ? } + if not(getaddr) then + begin + if auto_inherited then + begin + st:=symtablestack; + while assigned(st) and (st^.symtabletype<>parasymtable) do + st:=st^.next; + p2:=nil; + if assigned(st) then + begin + hs:=pvarsym(st^.symindex^.first); + while assigned(hs) do + begin + if hs^.typ<>varsym then + internalerror(54382953); + { if there is a localcopy then use that } + if assigned(hs^.localvarsym) then + hs1:=hs^.localvarsym + else + hs1:=hs; + p2:=gencallparanode(genloadnode(hs1,hs1^.owner),p2); + hs:=pvarsym(hs^.next); + end; + end + else + internalerror(54382954); + p1^.left:=p2; + end + else + begin + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + in_args:=true; + p1^.left:=parse_paras(false,false); + consume(_RKLAMMER); + end + else + p1^.left:=nil; + end; + { do firstpass because we need the } + { result type } + do_firstpass(p1); + {set_var_state is handled inside firstcalln } + end + else + begin + { address operator @: } + p1^.left:=nil; + { forget pd } + pd:=nil; + if (p1^.symtableproc^.symtabletype=withsymtable) and + (p1^.symtableproc^.defowner^.deftype=objectdef) then + begin + p1^.methodpointer:=getcopy(pwithsymtable(p1^.symtableproc)^.withrefnode); + end + else if not(assigned(p1^.methodpointer)) then + begin + { we must provide a method pointer, if it isn't given, } + { it is self } + if assigned(procinfo) then + begin + p1^.methodpointer:=genselfnode(procinfo^._class); + p1^.methodpointer^.resulttype:=procinfo^._class; + end + else + begin + p1^.methodpointer:=genselfnode(nil); + p1^.methodpointer^.resulttype:=nil; + end; + end; + { no postfix operators } + again:=false; + end; + pd:=p1^.resulttype; + in_args:=prev_in_args; + afterassignment:=prevafterassn; + end; + + procedure handle_procvar(pv : pprocvardef;var p2 : ptree); + + procedure doconv(procvar : pprocvardef;var t : ptree); + var + hp : ptree; + begin + hp:=nil; + if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then + begin + if (po_methodpointer in procvar^.procoptions) then + hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable); + end; + if assigned(hp) then + begin + disposetree(t); + t:=hp; + end; + end; + + begin + if (p2^.treetype=calln) then + doconv(pv,p2) + else + if (p2^.treetype=typeconvn) and + (p2^.left^.treetype=calln) then + doconv(pv,p2^.left); + end; + + + { the following procedure handles the access to a property symbol } + procedure handle_propertysym(sym : psym;st : psymtable;var p1 : ptree; + var pd : pdef); + + var + paras : ptree; + p2 : ptree; + plist : psymlistitem; + + begin + paras:=nil; + { property parameters? read them only if the property really } + { has parameters } + if ppo_hasparameters in ppropertysym(sym)^.propoptions then + begin + if token=_LECKKLAMMER then + begin + consume(_LECKKLAMMER); + paras:=parse_paras(false,true); + consume(_RECKKLAMMER); + end; + { indexed property } + if (ppo_indexed in ppropertysym(sym)^.propoptions) then + begin + p2:=genordinalconstnode(ppropertysym(sym)^.index,ppropertysym(sym)^.indextype.def); + paras:=gencallparanode(p2,paras); + end; + end; + { we need only a write property if a := follows } + { if not(afterassignment) and not(in_args) then } + if token=_ASSIGNMENT then + begin + { write property: } + { no result } + pd:=voiddef; + if not ppropertysym(sym)^.writeaccess^.empty then + begin + case ppropertysym(sym)^.writeaccess^.firstsym^.sym^.typ of + procsym : + begin + { generate the method call } + p1:=genmethodcallnode(pprocsym(ppropertysym(sym)^.writeaccess^.firstsym^.sym),st,p1); + { we know the procedure to call, so + force the usage of that procedure } + p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccess^.def); + p1^.left:=paras; + consume(_ASSIGNMENT); + { read the expression } + getprocvar:=ppropertysym(sym)^.proptype.def^.deftype=procvardef; + p2:=comp_expr(true); + if getprocvar then + handle_procvar(pprocvardef(ppropertysym(sym)^.proptype.def),p2); + p1^.left:=gencallparanode(p2,p1^.left); + p1^.isproperty:=true; + getprocvar:=false; + end; + varsym : + begin + if assigned(paras) then + message(parser_e_no_paras_allowed); + { subscribed access? } + plist:=ppropertysym(sym)^.writeaccess^.firstsym; + while assigned(plist) do + begin + if p1=nil then + p1:=genloadnode(pvarsym(plist^.sym),st) + else + p1:=gensubscriptnode(pvarsym(plist^.sym),p1); + plist:=plist^.next; + end; + p1^.isproperty:=true; + consume(_ASSIGNMENT); + { read the expression } + p2:=comp_expr(true); + p1:=gennode(assignn,p1,p2); + end + else + begin + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end; + end + else + begin + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end + else + begin + { read property: } + pd:=ppropertysym(sym)^.proptype.def; + if not ppropertysym(sym)^.readaccess^.empty then + begin + case ppropertysym(sym)^.readaccess^.firstsym^.sym^.typ of + varsym : + begin + if assigned(paras) then + message(parser_e_no_paras_allowed); + { subscribed access? } + plist:=ppropertysym(sym)^.readaccess^.firstsym; + while assigned(plist) do + begin + if p1=nil then + p1:=genloadnode(pvarsym(plist^.sym),st) + else + p1:=gensubscriptnode(pvarsym(plist^.sym),p1); + plist:=plist^.next; + end; + p1^.isproperty:=true; + end; + procsym : + begin + { generate the method call } + p1:=genmethodcallnode(pprocsym(ppropertysym(sym)^.readaccess^.firstsym^.sym),st,p1); + { we know the procedure to call, so + force the usage of that procedure } + p1^.procdefinition:=pprocdef(ppropertysym(sym)^.readaccess^.def); + { insert paras } + p1^.left:=paras; + p1^.isproperty:=true; + end + else + begin + p1:=genzeronode(errorn); + Message(type_e_mismatch); + end; + end; + end + else + begin + { error, no function to read property } + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end; + end; + + + { the ID token has to be consumed before calling this function } + procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : ptree; + var pd : pdef;var again : boolean); + + var + static_name : string; + isclassref : boolean; + objdef : pobjectdef; + + begin + if sym=nil then + begin + { pattern is still valid unless + there is another ID just after the ID of sym } + Message1(sym_e_id_no_member,pattern); + disposetree(p1); + p1:=genzeronode(errorn); + { try to clean up } + pd:=generrordef; + again:=false; + end + else + begin + objdef:=pobjectdef(sym^.owner^.defowner); + isclassref:=(pd^.deftype=classrefdef); + + { check protected and private members } + { please leave this code as it is, } + { it has now the same behaviaor as TP/Delphi } + if (sp_private in sym^.symoptions) and + (objdef^.owner^.symtabletype=unitsymtable) then + Message(parser_e_cant_access_private_member); + + if (sp_protected in sym^.symoptions) and + (objdef^.owner^.symtabletype=unitsymtable) then + begin + if assigned(aktprocsym^.definition^._class) then + begin + if not aktprocsym^.definition^._class^.is_related(objdef) then + Message(parser_e_cant_access_protected_member); + end + else + Message(parser_e_cant_access_protected_member); + end; + + { we assume, that only procsyms and varsyms are in an object } + { symbol table, for classes, properties are allowed } + case sym^.typ of + procsym: + begin + p1:=genmethodcallnode(pprocsym(sym),sym^.owner,p1); + do_proc_call(getaddr or + (getprocvar and + ((block_type=bt_const) or + ((m_tp_procvar in aktmodeswitches) and + proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef) + ) + ) + ),again,p1,pd); + if (block_type=bt_const) and + getprocvar then + handle_procvar(getprocvardef,p1); + { now we know the real method e.g. we can check for a class method } + if isclassref and + assigned(p1^.procdefinition) and + not(po_classmethod in p1^.procdefinition^.procoptions) and + not(p1^.procdefinition^.proctypeoption=potype_constructor) then + Message(parser_e_only_class_methods_via_class_ref); + end; + varsym: + begin + if isclassref then + Message(parser_e_only_class_methods_via_class_ref); + if (sp_static in sym^.symoptions) then + begin + { static_name:=lower(srsymtable^.name^)+'_'+sym^.name; + this is wrong for static field in with symtable (PM) } + static_name:=lower(srsym^.owner^.name^)+'_'+sym^.name; + getsym(static_name,true); + disposetree(p1); + p1:=genloadnode(pvarsym(srsym),srsymtable); + end + else + p1:=gensubscriptnode(pvarsym(sym),p1); + pd:=pvarsym(sym)^.vartype.def; + end; + propertysym: + begin + if isclassref then + Message(parser_e_only_class_methods_via_class_ref); + handle_propertysym(sym,srsymtable,p1,pd); + end; + else internalerror(16); + end; + end; + end; + + +{**************************************************************************** + Factor +****************************************************************************} +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + function factor(getaddr : boolean) : ptree; + var + l : longint; + oldp1, + p1,p2,p3 : ptree; + code : integer; + pd,pd2 : pdef; + possible_error, + unit_specific, + again : boolean; + sym : psym; + classh : pobjectdef; + d : bestreal; + hs, + static_name : string; + propsym : ppropertysym; + filepos : tfileposinfo; + + {--------------------------------------------- + Is_func_ret + ---------------------------------------------} + + function is_func_ret(sym : psym) : boolean; + var + p : pprocinfo; + storesymtablestack : psymtable; + + begin + is_func_ret:=false; + if not assigned(procinfo) or + ((sym^.typ<>funcretsym) and ((procinfo^.flags and pi_operator)=0)) then + exit; + p:=procinfo; + while assigned(p) do + begin + { is this an access to a function result? Accessing _RESULT is + always allowed and funcretn is generated } + if assigned(p^.funcretsym) and + ((pfuncretsym(sym)=p^.resultfuncretsym) or + ((pfuncretsym(sym)=p^.funcretsym) or + ((pvarsym(sym)=opsym) and ((p^.flags and pi_operator)<>0))) and + (p^.returntype.def<>pdef(voiddef)) and + (token<>_LKLAMMER) and + (not ((m_tp in aktmodeswitches) and (afterassignment or in_args))) + ) then + begin + if ((pvarsym(sym)=opsym) and + ((p^.flags and pi_operator)<>0)) then + inc(opsym^.refs); + p1:=genzeronode(funcretn); + pd:=p^.returntype.def; + p1^.funcretprocinfo:=p; + p1^.rettype.def:=pd; + is_func_ret:=true; + if p^.funcret_state=vs_declared then + begin + p^.funcret_state:=vs_declared_and_first_found; + p1^.is_first_funcret:=true; + end; + exit; + end; + p:=p^.parent; + end; + { we must use the function call } + if (sym^.typ=funcretsym) then + begin + storesymtablestack:=symtablestack; + symtablestack:=srsymtable^.next; + getsym(sym^.name,true); + if srsym^.typ<>procsym then + Message(cg_e_illegal_expression); + symtablestack:=storesymtablestack; + end; + end; + + {--------------------------------------------- + Factor_read_id + ---------------------------------------------} + + procedure factor_read_id; + var + pc : pchar; + len : longint; + begin + { allow post fix operators } + again:=true; + begin + if lastsymknown then + begin + srsym:=lastsrsym; + srsymtable:=lastsrsymtable; + lastsymknown:=false; + end + else + getsym(pattern,true); + consume(_ID); + if not is_func_ret(srsym) then + { else it's a normal symbol } + begin + { is it defined like UNIT.SYMBOL ? } + if srsym^.typ=unitsym then + begin + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + unit_specific:=true; + consume(_ID); + end + else + unit_specific:=false; + if not assigned(srsym) then + Begin + p1:=genzeronode(errorn); + { try to clean up } + pd:=generrordef; + end + else + Begin + { check semantics of private } + if (srsym^.typ in [propertysym,procsym,varsym]) and + (srsymtable^.symtabletype=objectsymtable) then + begin + if (sp_private in srsym^.symoptions) and + (pobjectdef(srsym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then + Message(parser_e_cant_access_private_member); + end; + case srsym^.typ of + absolutesym : begin + p1:=genloadnode(pvarsym(srsym),srsymtable); + pd:=pabsolutesym(srsym)^.vartype.def; + end; + varsym : begin + { are we in a class method ? } + if (srsymtable^.symtabletype=objectsymtable) and + assigned(aktprocsym) and + (po_classmethod in aktprocsym^.definition^.procoptions) then + Message(parser_e_only_class_methods); + if (sp_static in srsym^.symoptions) then + begin + static_name:=lower(srsym^.owner^.name^)+'_'+srsym^.name; + getsym(static_name,true); + end; + p1:=genloadnode(pvarsym(srsym),srsymtable); + if pvarsym(srsym)^.varstate=vs_declared then + begin + p1^.is_first := true; + { set special between first loaded until checked in firstpass } + pvarsym(srsym)^.varstate:=vs_declared_and_first_found; + end; + pd:=pvarsym(srsym)^.vartype.def; + end; + typedconstsym : begin + p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable); + pd:=ptypedconstsym(srsym)^.typedconsttype.def; + end; + syssym : p1:=statement_syssym(psyssym(srsym)^.number,pd); + typesym : begin + pd:=ptypesym(srsym)^.restype.def; + if not assigned(pd) then + begin + pd:=generrordef; + again:=false; + end + else + begin + { if we read a type declaration } + { we have to return the type and } + { nothing else } + if block_type=bt_type then + begin + { we don't need sym reference when it's in the + current unit or system unit, because those + units are always loaded (PFV) } + if not(assigned(pd^.owner)) or + (pd^.owner^.unitid=0) or + (pd^.owner^.unitid=1) then + p1:=gentypenode(pd,nil) + else + p1:=gentypenode(pd,ptypesym(srsym)); + { here we can also set resulttype !! } + p1^.resulttype:=pd; + pd:=voiddef; + end + else { not type block } + begin + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + p1:=comp_expr(true); + consume(_RKLAMMER); + p1:=gentypeconvnode(p1,pd); + p1^.explizit:=true; + end + else { not LKLAMMER} + if (token=_POINT) and + (pd^.deftype=objectdef) and + not(pobjectdef(pd)^.is_class) then + begin + consume(_POINT); + if assigned(procinfo) and + assigned(procinfo^._class) and + not(getaddr) then + begin + if procinfo^._class^.is_related(pobjectdef(pd)) then + begin + p1:=gentypenode(pd,ptypesym(srsym)); + p1^.resulttype:=pd; + { search also in inherited methods } + repeat + srsymtable:=pobjectdef(pd)^.symtable; + sym:=pvarsym(srsymtable^.search(pattern)); + if assigned(sym) then + break; + pd:=pobjectdef(pd)^.childof; + until not assigned(pd); + consume(_ID); + do_member_read(false,sym,p1,pd,again); + end + else + begin + Message(parser_e_no_super_class); + pd:=generrordef; + again:=false; + end; + end + else + begin + { allows @TObject.Load } + { also allows static methods and variables } + p1:=genzeronode(typen); + p1^.resulttype:=pd; + { TP allows also @TMenu.Load if Load is only } + { defined in an anchestor class } + sym:=pvarsym(search_class_member(pobjectdef(pd),pattern)); + if not assigned(sym) then + Message1(sym_e_id_no_member,pattern) + else if not(getaddr) and not(sp_static in sym^.symoptions) then + Message(sym_e_only_static_in_static) + else + begin + consume(_ID); + do_member_read(getaddr,sym,p1,pd,again); + end; + end; + end + else + begin + { class reference ? } + if (pd^.deftype=objectdef) + and pobjectdef(pd)^.is_class then + begin + p1:=gentypenode(pd,nil); + p1^.resulttype:=pd; + pd:=new(pclassrefdef,init(pd)); + p1:=gensinglenode(loadvmtn,p1); + p1^.resulttype:=pd; + end + else + begin + { generate a type node } + { (for typeof etc) } + if allow_type then + begin + p1:=gentypenode(pd,nil); + { here we must use typenodetype explicitly !! PM + p1^.resulttype:=pd; } + pd:=voiddef; + end + else + Message(parser_e_no_type_not_allowed_here); + end; + end; + end; + end; + end; + enumsym : begin + p1:=genenumnode(penumsym(srsym)); + pd:=p1^.resulttype; + end; + constsym : begin + case pconstsym(srsym)^.consttyp of + constint : + p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef); + conststring : + begin + len:=pconstsym(srsym)^.len; + if not(cs_ansistrings in aktlocalswitches) and (len>255) then + len:=255; + getmem(pc,len+1); + move(pchar(pconstsym(srsym)^.value)^,pc^,len); + pc[len]:=#0; + p1:=genpcharconstnode(pc,len); + end; + constchar : + p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef); + constreal : + p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^,bestrealdef^); + constbool : + p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef); + constset : + p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value), + psetdef(pconstsym(srsym)^.consttype.def)); + constord : + p1:=genordinalconstnode(pconstsym(srsym)^.value, + pconstsym(srsym)^.consttype.def); + constpointer : + p1:=genpointerconstnode(pconstsym(srsym)^.value, + pconstsym(srsym)^.consttype.def); + constnil : + p1:=genzeronode(niln); + constresourcestring: + begin + p1:=genloadnode(pvarsym(srsym),srsymtable); + p1^.resulttype:=cansistringdef; + end; + end; + pd:=p1^.resulttype; + end; + procsym : begin + { are we in a class method ? } + possible_error:=(srsymtable^.symtabletype=objectsymtable) and + assigned(aktprocsym) and + (po_classmethod in aktprocsym^.definition^.procoptions); + p1:=gencallnode(pprocsym(srsym),srsymtable); + p1^.unit_specific:=unit_specific; + do_proc_call(getaddr or + (getprocvar and + ((block_type=bt_const) or + ((m_tp_procvar in aktmodeswitches) and + proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef) + ) + ) + ),again,p1,pd); + if (block_type=bt_const) and + getprocvar then + handle_procvar(getprocvardef,p1); + if possible_error and + not(po_classmethod in p1^.procdefinition^.procoptions) then + Message(parser_e_only_class_methods); + end; + propertysym : begin + { access to property in a method } + { are we in a class method ? } + if (srsymtable^.symtabletype=objectsymtable) and + assigned(aktprocsym) and + (po_classmethod in aktprocsym^.definition^.procoptions) then + Message(parser_e_only_class_methods); + { no method pointer } + p1:=nil; + handle_propertysym(srsym,srsymtable,p1,pd); + end; + errorsym : begin + p1:=genzeronode(errorn); + p1^.resulttype:=generrordef; + pd:=generrordef; + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + parse_paras(false,false); + consume(_RKLAMMER); + end; + end; + else + begin + p1:=genzeronode(errorn); + pd:=generrordef; + Message(cg_e_illegal_expression); + end; + end; { end case } + end; + end; + end; + end; + + {--------------------------------------------- + Factor_Read_Set + ---------------------------------------------} + + { Read a set between [] } + function factor_read_set:ptree; + var + p1, + lastp, + buildp : ptree; + begin + buildp:=nil; + { be sure that a least one arrayconstructn is used, also for an + empty [] } + if token=_RECKKLAMMER then + buildp:=gennode(arrayconstructn,nil,buildp) + else + begin + while true do + begin + p1:=comp_expr(true); + if token=_POINTPOINT then + begin + consume(_POINTPOINT); + p2:=comp_expr(true); + p1:=gennode(arrayconstructrangen,p1,p2); + end; + { insert at the end of the tree, to get the correct order } + if not assigned(buildp) then + begin + buildp:=gennode(arrayconstructn,p1,nil); + lastp:=buildp; + end + else + begin + lastp^.right:=gennode(arrayconstructn,p1,nil); + lastp:=lastp^.right; + end; + { there could be more elements } + if token=_COMMA then + consume(_COMMA) + else + break; + end; + end; + factor_read_set:=buildp; + end; + + {--------------------------------------------- + Helpers + ---------------------------------------------} + + procedure check_tokenpos; + begin + if (p1<>oldp1) then + begin + if assigned(p1) then + set_tree_filepos(p1,filepos); + oldp1:=p1; + filepos:=tokenpos; + end; + end; + + + + {--------------------------------------------- + PostFixOperators + ---------------------------------------------} + + procedure postfixoperators; + var + store_static : boolean; + + { p1 and p2 must contain valid value_str } + begin + check_tokenpos; + while again do + begin + { prevent crashes with unknown types } + if not assigned(pd) then + begin + { try to recover } + repeat + case token of + _CARET: + consume(_CARET); + + _POINT: + begin + consume(_POINT); + consume(_ID); + end; + + _LECKKLAMMER: + begin + repeat + consume(token); + until token in [_RECKKLAMMER,_SEMICOLON]; + end; + else + break; + end; + until false; + exit; + end; + { handle token } + case token of + _CARET: + begin + consume(_CARET); + if (pd^.deftype<>pointerdef) then + begin + { ^ as binary operator is a problem!!!! (FK) } + again:=false; + Message(cg_e_invalid_qualifier); + disposetree(p1); + p1:=genzeronode(errorn); + end + else + begin + p1:=gensinglenode(derefn,p1); + pd:=ppointerdef(pd)^.pointertype.def; + end; + end; + + _LECKKLAMMER: + begin + if (pd^.deftype=objectdef) and pobjectdef(pd)^.is_class then + begin + { default property } + propsym:=search_default_property(pobjectdef(pd)); + if not(assigned(propsym)) then + begin + disposetree(p1); + p1:=genzeronode(errorn); + again:=false; + message(parser_e_no_default_property_available); + end + else + handle_propertysym(propsym,propsym^.owner,p1,pd); + end + else + begin + consume(_LECKKLAMMER); + repeat + case pd^.deftype of + pointerdef: + begin + p2:=comp_expr(true); + p1:=gennode(vecn,p1,p2); + pd:=ppointerdef(pd)^.pointertype.def; + end; + + stringdef : begin + p2:=comp_expr(true); + p1:=gennode(vecn,p1,p2); + pd:=cchardef + end; + arraydef : begin + p2:=comp_expr(true); + { support SEG:OFS for go32v2 Mem[] } + if (target_info.target=target_i386_go32v2) and + (p1^.treetype=loadn) and + assigned(p1^.symtableentry) and + assigned(p1^.symtableentry^.owner^.name) and + (p1^.symtableentry^.owner^.name^='SYSTEM') and + ((p1^.symtableentry^.name='MEM') or + (p1^.symtableentry^.name='MEMW') or + (p1^.symtableentry^.name='MEML')) then + begin + if (token=_COLON) then + begin + consume(_COLON); + p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2); + p2:=comp_expr(true); + p2:=gennode(addn,p2,p3); + p1:=gennode(vecn,p1,p2); + p1^.memseg:=true; + p1^.memindex:=true; + end + else + begin + p1:=gennode(vecn,p1,p2); + p1^.memindex:=true; + end; + end + else + p1:=gennode(vecn,p1,p2); + pd:=parraydef(pd)^.elementtype.def; + end; + else + begin + Message(cg_e_invalid_qualifier); + disposetree(p1); + p1:=genzeronode(errorn); + again:=false; + end; + end; + if token=_COMMA then + consume(_COMMA) + else + break; + until false; + consume(_RECKKLAMMER); + end; + end; + _POINT : begin + consume(_POINT); + if (pd^.deftype=pointerdef) and + (m_autoderef in aktmodeswitches) then + begin + p1:=gensinglenode(derefn,p1); + pd:=ppointerdef(pd)^.pointertype.def; + end; + case pd^.deftype of + recorddef: + begin + sym:=precorddef(pd)^.symtable^.search(pattern); + if assigned(sym) and + (sym^.typ=varsym) then + begin + p1:=gensubscriptnode(pvarsym(sym),p1); + pd:=pvarsym(sym)^.vartype.def; + end + else + begin + Message1(sym_e_illegal_field,pattern); + disposetree(p1); + p1:=genzeronode(errorn); + end; + consume(_ID); + end; + + classrefdef: + begin + classh:=pobjectdef(pclassrefdef(pd)^.pointertype.def); + sym:=nil; + while assigned(classh) do + begin + sym:=classh^.symtable^.search(pattern); + srsymtable:=classh^.symtable; + if assigned(sym) then + break; + classh:=classh^.childof; + end; + if sym=nil then + begin + Message1(sym_e_id_no_member,pattern); + disposetree(p1); + p1:=genzeronode(errorn); + { try to clean up } + pd:=generrordef; + consume(_ID); + end + else + begin + consume(_ID); + do_member_read(getaddr,sym,p1,pd,again); + end; + end; + + objectdef: + begin + classh:=pobjectdef(pd); + sym:=nil; + store_static:=allow_only_static; + allow_only_static:=false; + while assigned(classh) do + begin + sym:=classh^.symtable^.search(pattern); + srsymtable:=classh^.symtable; + if assigned(sym) then + break; + classh:=classh^.childof; + end; + allow_only_static:=store_static; + if sym=nil then + begin + Message1(sym_e_id_no_member,pattern); + disposetree(p1); + p1:=genzeronode(errorn); + { try to clean up } + pd:=generrordef; + consume(_ID); + end + else + begin + consume(_ID); + do_member_read(getaddr,sym,p1,pd,again); + end; + end; + + pointerdef: + begin + Message(cg_e_invalid_qualifier); + if ppointerdef(pd)^.pointertype.def^.deftype in [recorddef,objectdef,classrefdef] then + Message(parser_h_maybe_deref_caret_missing); + end; + else + begin + Message(cg_e_invalid_qualifier); + disposetree(p1); + p1:=genzeronode(errorn); + end; + end; + end; + else + begin + { is this a procedure variable ? } + if assigned(pd) then + begin + if (pd^.deftype=procvardef) then + begin + if getprocvar and is_equal(pd,getprocvardef) then + again:=false + else + if (token=_LKLAMMER) or + ((pprocvardef(pd)^.para^.empty) and + (not((token in [_ASSIGNMENT,_UNEQUAL,_EQUAL]))) and + (not afterassignment) and + (not in_args)) then + begin + { do this in a strange way } + { it's not a clean solution } + p2:=p1; + p1:=gencallnode(nil,nil); + p1^.right:=p2; + p1^.unit_specific:=unit_specific; + p1^.symtableprocentry:=pprocsym(sym); + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + p1^.left:=parse_paras(false,false); + consume(_RKLAMMER); + end; + pd:=pprocvardef(pd)^.rettype.def; + { proc():= is never possible } + if token=_ASSIGNMENT then + begin + Message(cg_e_illegal_expression); + p1:=genzeronode(errorn); + again:=false; + end; + p1^.resulttype:=pd; + end + else + again:=false; + p1^.resulttype:=pd; + end + else + again:=false; + end + else + again:=false; + end; + end; + check_tokenpos; + end; { while again } + end; + + + {--------------------------------------------- + Factor (Main) + ---------------------------------------------} + + begin + oldp1:=nil; + p1:=nil; + filepos:=tokenpos; + if token=_ID then + begin + factor_read_id; + { handle post fix operators } + postfixoperators; + end + else + case token of + _NEW : begin + consume(_NEW); + consume(_LKLAMMER); + {allow_type:=true;} + p1:=factor(false); + {allow_type:=false;} + if p1^.treetype<>typen then + begin + Message(type_e_type_id_expected); + disposetree(p1); + pd:=generrordef; + end + else + pd:=p1^.typenodetype; + pd2:=pd; + + if (pd^.deftype<>pointerdef) then + Message1(type_e_pointer_type_expected,pd^.typename) + else + if token=_RKLAMMER then + begin + if (ppointerdef(pd)^.pointertype.def^.deftype=objectdef) and + (oo_has_vmt in pobjectdef(ppointerdef(pd)^.pointertype.def)^.objectoptions) then + Message(parser_w_use_extended_syntax_for_objects); + p1:=gensinglenode(newn,nil); + p1^.resulttype:=pd2; + consume(_RKLAMMER); + end + else + begin + disposetree(p1); + p1:=genzeronode(hnewn); + p1^.resulttype:=ppointerdef(pd)^.pointertype.def; + consume(_COMMA); + afterassignment:=false; + { determines the current object defintion } + classh:=pobjectdef(ppointerdef(pd)^.pointertype.def); + if classh^.deftype<>objectdef then + Message(parser_e_pointer_to_class_expected) + else + begin + { check for an abstract class } + if (oo_has_abstract in classh^.objectoptions) then + Message(sym_e_no_instance_of_abstract_object); + { search the constructor also in the symbol tables of + the parents } + sym:=nil; + while assigned(classh) do + begin + sym:=classh^.symtable^.search(pattern); + srsymtable:=classh^.symtable; + if assigned(sym) then + break; + classh:=classh^.childof; + end; + consume(_ID); + do_member_read(false,sym,p1,pd,again); + if (p1^.treetype<>calln) or + (assigned(p1^.procdefinition) and + (p1^.procdefinition^.proctypeoption<>potype_constructor)) then + Message(parser_e_expr_have_to_be_constructor_call); + end; + p1:=gensinglenode(newn,p1); + { set the resulttype } + p1^.resulttype:=pd2; + consume(_RKLAMMER); + end; + postfixoperators; + end; + _SELF : begin + again:=true; + consume(_SELF); + if not assigned(procinfo^._class) then + begin + p1:=genzeronode(errorn); + pd:=generrordef; + again:=false; + Message(parser_e_self_not_in_method); + end + else + begin + if (po_classmethod in aktprocsym^.definition^.procoptions) then + begin + { self in class methods is a class reference type } + pd:=new(pclassrefdef,init(procinfo^._class)); + p1:=genselfnode(pd); + p1^.resulttype:=pd; + end + else + begin + p1:=genselfnode(procinfo^._class); + p1^.resulttype:=procinfo^._class; + end; + pd:=p1^.resulttype; + postfixoperators; + end; + end; + _INHERITED : begin + again:=true; + consume(_INHERITED); + if assigned(procinfo^._class) then + begin + { if inherited; only then we need the method with + the same name } + if token=_SEMICOLON then + begin + hs:=aktprocsym^.name; + auto_inherited:=true + end + else + begin + hs:=pattern; + consume(_ID); + auto_inherited:=false; + end; + classh:=procinfo^._class^.childof; + while assigned(classh) do + begin + srsymtable:=pobjectdef(classh)^.symtable; + sym:=srsymtable^.search(hs); + if assigned(sym) then + begin + { only for procsyms we need to set the type (PFV) } + case sym^.typ of + procsym : + begin + p1:=genzeronode(typen); + p1^.resulttype:=classh; + pd:=p1^.resulttype; + end; + varsym : + begin + p1:=nil; + pd:=pvarsym(sym)^.vartype.def; + end; + propertysym : + begin + p1:=nil; + pd:=ppropertysym(sym)^.proptype.def; + end; + else + internalerror(83251763); + end; + do_member_read(false,sym,p1,pd,again); + break; + end; + classh:=classh^.childof; + end; + if classh=nil then + begin + Message1(sym_e_id_no_member,hs); + again:=false; + pd:=generrordef; + p1:=genzeronode(errorn); + end; + { turn auto inheriting off } + auto_inherited:=false; + end + else + begin + Message(parser_e_generic_methods_only_in_methods); + again:=false; + pd:=generrordef; + p1:=genzeronode(errorn); + end; + postfixoperators; + end; + _INTCONST : begin + valint(pattern,l,code); + if code<>0 then + begin + val(pattern,d,code); + if code<>0 then + begin + Message(cg_e_invalid_integer); + consume(_INTCONST); + l:=1; + p1:=genordinalconstnode(l,s32bitdef); + end + else + begin + consume(_INTCONST); + p1:=genrealconstnode(d,bestrealdef^); + end; + end + else + begin + consume(_INTCONST); + p1:=genordinalconstnode(l,s32bitdef); + end; + end; + _REALNUMBER : begin + val(pattern,d,code); + if code<>0 then + begin + Message(parser_e_error_in_real); + d:=1.0; + end; + consume(_REALNUMBER); + p1:=genrealconstnode(d,bestrealdef^); + end; + _STRING : begin + pd:=string_dec; + { STRING can be also a type cast } + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + p1:=comp_expr(true); + consume(_RKLAMMER); + p1:=gentypeconvnode(p1,pd); + p1^.explizit:=true; + { handle postfix operators here e.g. string(a)[10] } + again:=true; + postfixoperators; + end + else + p1:=gentypenode(pd,nil); + end; + _FILE : begin + pd:=cfiledef; + consume(_FILE); + { FILE can be also a type cast } + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + p1:=comp_expr(true); + consume(_RKLAMMER); + p1:=gentypeconvnode(p1,pd); + p1^.explizit:=true; + { handle postfix operators here e.g. string(a)[10] } + again:=true; + postfixoperators; + end + else + p1:=gentypenode(pd,nil); + end; + _CSTRING : begin + p1:=genstringconstnode(pattern,st_default); + consume(_CSTRING); + end; + _CCHAR : begin + p1:=genordinalconstnode(ord(pattern[1]),cchardef); + consume(_CCHAR); + end; +_KLAMMERAFFE : begin + consume(_KLAMMERAFFE); + got_addrn:=true; + { support both @ and @() } + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + p1:=factor(true); + consume(_RKLAMMER); + if token in [_CARET,_POINT,_LECKKLAMMER] then + begin + { we need the resulttype } + { of the expression in pd } + do_firstpass(p1); + pd:=p1^.resulttype; + again:=true; + postfixoperators; + end; + end + else + p1:=factor(true); + got_addrn:=false; + p1:=gensinglenode(addrn,p1); + end; + _LKLAMMER : begin + consume(_LKLAMMER); + p1:=comp_expr(true); + consume(_RKLAMMER); + { it's not a good solution } + { but (a+b)^ makes some problems } + if token in [_CARET,_POINT,_LECKKLAMMER] then + begin + { we need the resulttype } + { of the expression in pd } + do_firstpass(p1); + pd:=p1^.resulttype; + again:=true; + postfixoperators; + end; + end; +_LECKKLAMMER : begin + consume(_LECKKLAMMER); + p1:=factor_read_set; + consume(_RECKKLAMMER); + end; + _PLUS : begin + consume(_PLUS); + p1:=factor(false); + end; + _MINUS : begin + consume(_MINUS); + p1:=sub_expr(oppower,false); + p1:=gensinglenode(unaryminusn,p1); + end; + _OP_NOT : begin + consume(_OP_NOT); + p1:=factor(false); + p1:=gensinglenode(notn,p1); + end; + _TRUE : begin + consume(_TRUE); + p1:=genordinalconstnode(1,booldef); + end; + _FALSE : begin + consume(_FALSE); + p1:=genordinalconstnode(0,booldef); + end; + _NIL : begin + consume(_NIL); + p1:=genzeronode(niln); + end; + else + begin + p1:=genzeronode(errorn); + consume(token); + Message(cg_e_illegal_expression); + end; + end; + { generate error node if no node is created } + if not assigned(p1) then + p1:=genzeronode(errorn); + { tp7 procvar handling, but not if the next token + will be a := } + if (m_tp_procvar in aktmodeswitches) and + (token<>_ASSIGNMENT) then + check_tp_procvar(p1); + factor:=p1; + check_tokenpos; + end; +{$ifdef fpc} +{$maxfpuregisters default} +{$endif fpc} + +{**************************************************************************** + Sub_Expr +****************************************************************************} + const + { Warning these stay be ordered !! } + operator_levels:array[Toperator_precedence] of set of Ttoken= + ([_LT,_LTE,_GT,_GTE,_EQUAL,_UNEQUAL,_OP_IN,_OP_IS], + [_PLUS,_MINUS,_OP_OR,_OP_XOR], + [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH, + _OP_AS,_OP_AND,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR], + [_STARSTAR] ); + + function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree; + {Reads a subexpression while the operators are of the current precedence + level, or any higher level. Replaces the old term, simpl_expr and + simpl2_expr.} + var + low,high,mid : longint; + p1,p2 : Ptree; + oldt : Ttoken; + filepos : tfileposinfo; + begin + if pred_level=highest_precedence then + p1:=factor(false) + else + p1:=sub_expr(succ(pred_level),true); + repeat + if (token in operator_levels[pred_level]) and + ((token<>_EQUAL) or accept_equal) then + begin + oldt:=token; + filepos:=tokenpos; + consume(token); + if pred_level=highest_precedence then + p2:=factor(false) + else + p2:=sub_expr(succ(pred_level),true); + low:=1; + high:=tok2nodes; + while (low_ASSIGNMENT) then + check_tp_procvar(p1); + if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then + afterassignment:=true; + oldp1:=p1; + case token of + _POINTPOINT : begin + consume(_POINTPOINT); + p2:=sub_expr(opcompare,true); + p1:=gennode(rangen,p1,p2); + end; + _ASSIGNMENT : begin + consume(_ASSIGNMENT); + { avoid a firstpass of a procedure if + it must be assigned to a procvar } + { should be recursive for a:=b:=c !!! } + if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then + begin + getprocvar:=true; + getprocvardef:=pprocvardef(p1^.resulttype); + end; + p2:=sub_expr(opcompare,true); + if getprocvar then + handle_procvar(getprocvardef,p2); + getprocvar:=false; + p1:=gennode(assignn,p1,p2); + end; + { this is the code for C like assignements } + { from an improvement of Peter Schaefer } + _PLUSASN : begin + consume(_PLUSASN ); + p2:=sub_expr(opcompare,true); + p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2)); + { was first + p1:=gennode(assignn,p1,gennode(addn,p1,p2)); + but disposetree assumes that we have a real + *** tree *** } + end; + + _MINUSASN : begin + consume(_MINUSASN ); + p2:=sub_expr(opcompare,true); + p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2)); + end; + _STARASN : begin + consume(_STARASN ); + p2:=sub_expr(opcompare,true); + p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2)); + end; + _SLASHASN : begin + consume(_SLASHASN ); + p2:=sub_expr(opcompare,true); + p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2)); + end; + end; + afterassignment:=oldafterassignment; + if p1<>oldp1 then + set_tree_filepos(p1,filepos); + expr:=p1; + end; + + + function get_intconst:longint; + {Reads an expression, tries to evalute it and check if it is an integer + constant. Then the constant is returned.} + var + p:Ptree; + begin + p:=comp_expr(true); + do_firstpass(p); + if not codegenerror then + begin + if (p^.treetype<>ordconstn) and + (p^.resulttype^.deftype=orddef) and + not(Porddef(p^.resulttype)^.typ in [uvoid,uchar,bool8bit,bool16bit,bool32bit]) then + Message(cg_e_illegal_expression) + else + get_intconst:=p^.value; + end; + disposetree(p); + end; + + + function get_stringconst:string; + {Reads an expression, tries to evaluate it and checks if it is a string + constant. Then the constant is returned.} + var + p:Ptree; + begin + get_stringconst:=''; + p:=comp_expr(true); + do_firstpass(p); + if p^.treetype<>stringconstn then + begin + if (p^.treetype=ordconstn) and is_char(p^.resulttype) then + get_stringconst:=char(p^.value) + else + Message(cg_e_illegal_expression); + end + else + get_stringconst:=strpas(p^.value_str); + disposetree(p); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.176 2000/06/14 16:52:42 peter + * support for inherited; only + + Revision 1.175 2000/06/05 20:41:17 pierre + + support for NOT overloading + + unsupported overloaded operators generate errors + + Revision 1.174 2000/06/02 21:22:56 pierre + tok2node moved to htypechk unit + + Revision 1.173 2000/03/23 15:56:59 peter + * fixed crash with inherited with varsym/propsym + + Revision 1.172 2000/03/19 11:22:21 peter + * protected member check for classes works + + Revision 1.171 2000/03/16 15:13:03 pierre + + oppower + + Revision 1.170 2000/03/14 15:50:19 pierre + * - 1**4 = -1 fix + + Revision 1.169 2000/02/13 14:21:50 jonas + * modifications to make the compiler functional when compiled with + -Or + + Revision 1.168 2000/02/09 13:22:56 peter + * log truncated + + Revision 1.167 2000/01/19 22:41:58 florian + * corrected wrong error message of a member of a class/object/classref wasn't found + + Revision 1.166 2000/01/09 23:16:05 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.165 2000/01/07 01:14:28 peter + * updated copyright to 2000 + + Revision 1.164 1999/12/20 21:24:29 pierre + * web bug769 fix + + Revision 1.163 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.162 1999/11/30 10:40:44 peter + + ttype, tsymlist + + Revision 1.161 1999/11/18 15:34:47 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.160 1999/11/17 17:05:01 pierre + * Notes/hints changes + + Revision 1.159 1999/11/15 17:52:59 pierre + + one field added for ttoken record for operator + linking the id to the corresponding operator token that + can now now all be overloaded + * overloaded operators are resetted to nil in InitSymtable + (bug when trying to compile a uint that overloads operators twice) + + Revision 1.158 1999/11/14 15:57:35 peter + * fixed crash with an errordef + + Revision 1.157 1999/11/08 14:02:16 florian + * problem with "index X"-properties solved + * typed constants of class references are now allowed + + Revision 1.156 1999/11/07 23:21:30 florian + * previous fix for 517 was imcomplete: there was a problem if the property + had only an index + + Revision 1.155 1999/11/07 23:16:49 florian + * finally bug 517 solved ... + + Revision 1.154 1999/11/06 14:34:21 peter + * truncated log to 20 revs + + Revision 1.153 1999/11/05 00:10:30 peter + * fixed inherited with properties + + Revision 1.152 1999/10/27 16:06:19 peter + * check for object in extended new + + Revision 1.151 1999/10/26 12:30:44 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.150 1999/10/22 14:37:30 peter + * error when properties are passed to var parameters + + Revision 1.149 1999/10/22 10:39:34 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.148 1999/10/14 14:57:52 florian + - removed the hcodegen use in the new cg, use cgbase instead + +} \ No newline at end of file diff --git a/befpc/compiler/pmodules.pas b/befpc/compiler/pmodules.pas new file mode 100644 index 0000000..65e234d --- /dev/null +++ b/befpc/compiler/pmodules.pas @@ -0,0 +1,1831 @@ +{ + $Id: pmodules.pas,v 1.1.1.1 2001-07-23 17:16:48 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Handles the parsing and loading of the modules (ppufiles) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pmodules; + { close old_current_ppu on system that are + short on file handles like DOS system PM } +{$ifdef GO32V1} +{$define SHORT_ON_FILE_HANDLES} +{$endif GO32V1} +{$ifdef GO32V2} +{$define SHORT_ON_FILE_HANDLES} +{$endif GO32V2} + +{$define New_GDB} + + interface + + procedure proc_unit; + procedure proc_program(islibrary : boolean); + + + implementation + + uses + globtype,version,systems,tokens, + cobjects,comphook,compiler, + globals,verbose,files, + symconst,symtable,aasm,types, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen, +{$ifdef i386} + cgai386, +{$endif i386} +{$endif newcg} + link,assemble,import,export,gendef,ppu,comprsrc, + cresstr,cpubase,cpuasm, +{$ifdef GDB} + gdb, +{$endif GDB} + scanner,pbase,psystem,pdecl,psub,parser; + + procedure create_objectfile; + begin + { create the .s file and assemble it } + GenerateAsm(false); + + { Also create a smartlinked version ? } + if (cs_create_smart in aktmoduleswitches) then + begin + { regenerate the importssection for win32 } + if assigned(importssection) and + (target_info.target=target_i386_win32) then + begin + importssection^.clear; + importlib^.generatesmartlib; + end; + + GenerateAsm(true); + if target_asm.needar then + Linker^.MakeStaticLibrary; + end; + + { resource files } + CompileResourceFiles; + end; + + + procedure insertobjectfile; + { Insert the used object file for this unit in the used list for this unit } + begin + current_module^.linkunitofiles.insert(current_module^.objfilename^,link_static); + current_module^.flags:=current_module^.flags or uf_static_linked; + + if (cs_create_smart in aktmoduleswitches) then + begin + current_module^.linkunitstaticlibs.insert(current_module^.staticlibfilename^,link_smart); + current_module^.flags:=current_module^.flags or uf_smart_linked; + end; + end; + + + procedure insertsegment; + + procedure fixseg(p:paasmoutput;sec:tsection); + begin + p^.insert(new(pai_section,init(sec))); + if (cs_create_smart in aktmoduleswitches) then + p^.insert(new(pai_cut,init)); + p^.concat(new(pai_section,init(sec_none))); + end; + + begin + { Insert Ident of the compiler } + if (not (cs_create_smart in aktmoduleswitches)) +{$ifndef EXTDEBUG} + and (not current_module^.is_unit) +{$endif} + then + begin + datasegment^.insert(new(pai_align,init(4))); + datasegment^.insert(new(pai_string,init('FPC '+full_version_string+ + ' ['+date_string+'] for '+target_cpu_string+' - '+target_info.short_name))); + end; + { finish codesegment } + codesegment^.concat(new(pai_align,init(16))); + { Insert start and end of sections } + fixseg(codesegment,sec_code); + fixseg(datasegment,sec_data); + fixseg(bsssegment,sec_bss); + { we should use .rdata section for these two no ? } + { .rdata is a read only data section (PM) } + fixseg(rttilist,sec_data); + fixseg(consts,sec_data); + if assigned(resourcestringlist) then + fixseg(resourcestringlist,sec_data); +{$ifdef GDB} + if assigned(debuglist) then + begin + debuglist^.insert(new(pai_symbol,initname('gcc2_compiled',0))); + fixseg(debuglist,sec_code); + end; +{$endif GDB} + end; + + + Procedure InsertResourceTablesTable; + var + hp : pused_unit; + ResourceStringTables : taasmoutput; + count : longint; + begin + ResourceStringTables.init; + count:=0; + hp:=pused_unit(usedunits.first); + while assigned(hp) do + begin + If (hp^.u^.flags and uf_has_resources)=uf_has_resources then + begin + ResourceStringTables.concat(new(pai_const_symbol,initname(hp^.u^.modulename^+'_RESOURCESTRINGLIST'))); + inc(count); + end; + hp:=Pused_unit(hp^.next); + end; + { Add program resources, if any } + If ResourceStringList<>Nil then + begin + ResourceStringTables.concat(new(pai_const_symbol,initname(Current_Module^.modulename^+'_RESOURCESTRINGLIST'))); + Inc(Count); + end; + { TableCount } +{ doesn't work because of bug in the compiler !! (JM) + With ResourceStringTables do} + begin + ResourceStringTables.insert(new(pai_const,init_32bit(count))); + ResourceStringTables.insert(new(pai_symbol,initname_global('FPC_RESOURCESTRINGTABLES',0))); + ResourceStringTables.concat(new(pai_symbol_end,initname('FPC_RESOURCESTRINGTABLES'))); + end; + { insert in data segment } + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_cut,init)); + datasegment^.concatlist(@ResourceStringTables); + ResourceStringTables.done; + end; + + + procedure InsertInitFinalTable; + var + hp : pused_unit; + unitinits : taasmoutput; + count : longint; + begin + unitinits.init; + count:=0; + hp:=pused_unit(usedunits.first); + while assigned(hp) do + begin + { call the unit init code and make it external } + if (hp^.u^.flags and (uf_init or uf_finalize))<>0 then + begin + if (hp^.u^.flags and uf_init)<>0 then + begin + unitinits.concat(new(pai_const_symbol,initname('INIT$$'+hp^.u^.modulename^))); + end + else + unitinits.concat(new(pai_const,init_32bit(0))); + if (hp^.u^.flags and uf_finalize)<>0 then + begin + unitinits.concat(new(pai_const_symbol,initname('FINALIZE$$'+hp^.u^.modulename^))); + end + else + unitinits.concat(new(pai_const,init_32bit(0))); + inc(count); + end; + hp:=Pused_unit(hp^.next); + end; + if current_module^.islibrary then + if (current_module^.flags and uf_finalize)<>0 then + begin + { INIT code is done by PASCALMAIN calling } + unitinits.concat(new(pai_const,init_32bit(0))); + unitinits.concat(new(pai_const_symbol,initname('FINALIZE$$'+current_module^.modulename^))); + inc(count); + end; + { TableCount,InitCount } + unitinits.insert(new(pai_const,init_32bit(0))); + unitinits.insert(new(pai_const,init_32bit(count))); + unitinits.insert(new(pai_symbol,initname_global('INITFINAL',0))); + unitinits.concat(new(pai_symbol_end,initname('INITFINAL'))); + { insert in data segment } + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_cut,init)); + datasegment^.concatlist(@unitinits); + unitinits.done; + end; + + + procedure insertheap; + begin + if (cs_create_smart in aktmoduleswitches) then + begin + bsssegment^.concat(new(pai_cut,init)); + datasegment^.concat(new(pai_cut,init)); + end; + { On the Macintosh Classic M68k Architecture + The Heap variable is simply a POINTER to the + real HEAP. The HEAP must be set up by the RTL + and must store the pointer in this value. + On OS/2 the heap is also intialized by the RTL. We do + not output a pointer } + case target_info.target of +{$ifdef i386} + target_i386_OS2: + ; +{$endif i386} +{$ifdef alpha} + target_alpha_linux: + ; +{$endif alpha} +{$ifdef powerpc} + target_powerpc_linux: + ; +{$endif powerpc} +{$ifdef m68k} + target_m68k_Mac: + bsssegment^.concat(new(pai_datablock,init_global('HEAP',4))); + target_m68k_PalmOS: + ; +{$endif m68k} + else + bsssegment^.concat(new(pai_datablock,init_global('HEAP',heapsize))); + end; +{$ifdef m68k} + if target_info.target<>target_m68k_PalmOS then + begin + datasegment^.concat(new(pai_symbol,initname_global('HEAP_SIZE',0))); + datasegment^.concat(new(pai_const,init_32bit(heapsize))); + end; +{$else m68k} + datasegment^.concat(new(pai_symbol,initname_global('HEAPSIZE',4))); + datasegment^.concat(new(pai_const,init_32bit(heapsize))); +{$endif m68k} + end; + + + procedure inserttargetspecific; + begin + case target_info.target of +{$ifdef alpha} + target_alpha_linux: + ; +{$endif alpha} +{$ifdef powerpc} + target_powerpc_linux: + ; +{$endif powerpc} +{$ifdef i386} + target_i386_GO32V2 : + begin + { stacksize can be specified } + datasegment^.concat(new(pai_symbol,initname_global('__stklen',4))); + datasegment^.concat(new(pai_const,init_32bit(stacksize))); + end; +{$endif i386} +{$ifdef m68k} + target_m68k_Atari : + begin + { stacksize can be specified } + datasegment^.concat(new(pai_symbol,initname_global('__stklen',4))); + datasegment^.concat(new(pai_const,init_32bit(stacksize))); + end; +{$endif m68k} + end; + end; + + + function loadunit(const s : string;compile_system:boolean) : pmodule;forward; + + + procedure load_usedunits(compile_system:boolean); + var + pu : pused_unit; + loaded_unit : pmodule; + load_refs : boolean; + nextmapentry : longint; + begin + load_refs:=true; + { init the map } + new(current_module^.map); + fillchar(current_module^.map^,sizeof(tunitmap),#0); +{$ifdef NEWMAP} + current_module^.map^[0]:=current_module; +{$endif NEWMAP} + nextmapentry:=1; + { load the used units from interface } + current_module^.in_implementation:=false; + pu:=pused_unit(current_module^.used_units.first); + while assigned(pu) do + begin + if (not pu^.loaded) and (pu^.in_interface) then + begin + loaded_unit:=loadunit(pu^.name^,false); + if current_module^.compiled then + exit; + { register unit in used units } + pu^.u:=loaded_unit; + pu^.loaded:=true; + { doubles are not important for that list PM } + pu^.u^.dependent_units.concat(new(pdependent_unit,init(current_module))); + { need to recompile the current unit ? } + if loaded_unit^.crc<>pu^.checksum then + begin + Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^); + current_module^.recompile_reason:=rr_crcchanged; + current_module^.do_compile:=true; + dispose(current_module^.map); + current_module^.map:=nil; + exit; + end; + { setup the map entry for deref } +{$ifndef NEWMAP} + current_module^.map^[nextmapentry]:=loaded_unit^.globalsymtable; +{$else NEWMAP} + current_module^.map^[nextmapentry]:=loaded_unit; +{$endif NEWMAP} + inc(nextmapentry); + if nextmapentry>maxunits then + Message(unit_f_too_much_units); + end; + pu:=pused_unit(pu^.next); + end; + { ok, now load the unit } + current_module^.globalsymtable:=new(punitsymtable,loadasunit); + { now only read the implementation part } + current_module^.in_implementation:=true; + { load the used units from implementation } + pu:=pused_unit(current_module^.used_units.first); + while assigned(pu) do + begin + if (not pu^.loaded) and (not pu^.in_interface) then + begin + loaded_unit:=loadunit(pu^.name^,false); + if current_module^.compiled then + exit; + { register unit in used units } + pu^.u:=loaded_unit; + pu^.loaded:=true; + { need to recompile the current unit ? } + if (loaded_unit^.interface_crc<>pu^.interface_checksum) {and + not(current_module^.in_second_compile) } then + begin + Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^+' {impl}'); + current_module^.recompile_reason:=rr_crcchanged; + current_module^.do_compile:=true; + dispose(current_module^.map); + current_module^.map:=nil; + exit; + end; + { setup the map entry for deref } +{$ifndef NEWMAP} + current_module^.map^[nextmapentry]:=loaded_unit^.globalsymtable; +{$else NEWMAP} + current_module^.map^[nextmapentry]:=loaded_unit; +{$endif NEWMAP} + inc(nextmapentry); + if nextmapentry>maxunits then + Message(unit_f_too_much_units); + end; + pu:=pused_unit(pu^.next); + end; + { load browser info if stored } + if ((current_module^.flags and uf_has_browser)<>0) and load_refs then + punitsymtable(current_module^.globalsymtable)^.load_symtable_refs; + { remove the map, it's not needed anymore } + dispose(current_module^.map); + current_module^.map:=nil; + end; + + + function loadunit(const s : string;compile_system:boolean) : pmodule; + const + ImplIntf : array[boolean] of string[15]=('interface','implementation'); + var + st : punitsymtable; + second_time : boolean; + old_current_ppu : pppufile; + old_current_module,hp,hp2 : pmodule; + name : string;{ necessary because current_module^.mainsource^ is reset in compile !! } + scanner : pscannerfile; + + procedure loadppufile; + begin + { load interface section } + if not current_module^.do_compile then + load_interface; + { only load units when we don't recompile } + if not current_module^.do_compile then + load_usedunits(compile_system); + { recompile if set } + if current_module^.do_compile then + begin + { we don't need the ppufile anymore } + if assigned(current_module^.ppufile) then + begin + dispose(current_module^.ppufile,done); + current_module^.ppufile:=nil; + current_ppu:=nil; + end; + { recompile the unit or give a fatal error if sources not available } + if not(current_module^.sources_avail) and + not(current_module^.sources_checked) then + if (not current_module^.search_unit(current_module^.modulename^,true)) + and (length(current_module^.modulename^)>8) then + current_module^.search_unit(copy(current_module^.modulename^,1,8),true); + if not(current_module^.sources_avail) then + begin + if current_module^.recompile_reason=rr_noppu then + Message1(unit_f_cant_find_ppu,current_module^.modulename^) + else + Message1(unit_f_cant_compile_unit,current_module^.modulename^); + end + else + begin + if current_module^.in_compile then + begin + current_module^.in_second_compile:=true; + Message1(parser_d_compiling_second_time,current_module^.modulename^); + end; + current_scanner^.tempcloseinputfile; + name:=current_module^.mainsource^; + if assigned(scanner) then + scanner^.invalid:=true; + compile(name,compile_system); + current_module^.in_second_compile:=false; + if (not current_scanner^.invalid) then + current_scanner^.tempopeninputfile; + end; + end + else + begin + { only reassemble ? } + if (current_module^.do_assemble) then + OnlyAsm; + end; + if assigned(current_module^.ppufile) then + begin + dispose(current_module^.ppufile,done); + current_module^.ppufile:=nil; + current_ppu:=nil; + end; + end; + + var + dummy : pmodule; + + begin + old_current_module:=current_module; + old_current_ppu:=current_ppu; + { Info } + Message3(unit_u_load_unit,current_module^.modulename^,ImplIntf[current_module^.in_implementation],s); + { unit not found } + st:=nil; + dummy:=nil; + { search all loaded units } + hp:=pmodule(loaded_units.first); + while assigned(hp) do + begin + if hp^.modulename^=s then + begin + { forced to reload ? } + if hp^.do_reload then + begin + hp^.do_reload:=false; + break; + end; + { the unit is already registered } + { and this means that the unit } + { is already compiled } + { else there is a cyclic unit use } + if assigned(hp^.globalsymtable) then + st:=punitsymtable(hp^.globalsymtable) + else + begin + { both units in interface ? } + if (not current_module^.in_implementation) and (not hp^.in_implementation) then + begin + { check for a cycle } + hp2:=current_module^.loaded_from; + while assigned(hp2) and (hp2<>hp) do + begin + if hp2^.in_implementation then + hp2:=nil + else + hp2:=hp2^.loaded_from; + end; + if assigned(hp2) then + Message2(unit_f_circular_unit_reference,current_module^.modulename^,hp^.modulename^); + end; + end; + break; + end + else if copy(hp^.modulename^,1,8)=s then + dummy:=hp; + { the next unit } + hp:=pmodule(hp^.next); + end; + if assigned(dummy) and not assigned(hp) then + Message2(unit_w_unit_name_error,s,dummy^.modulename^); + { the unit is not in the symtable stack } + if (not assigned(st)) then + begin + if assigned(hp) then + begin + { remove the old unit } + loaded_units.remove(hp); + scanner:=hp^.scanner; + hp^.reset; + hp^.scanner:=scanner; + { try to reopen ppu } + hp^.search_unit(s,false); + { try to load the unit a second time first } + current_module:=hp; + current_module^.in_second_load:=true; + Message1(unit_u_second_load_unit,current_module^.modulename^); + second_time:=true; + end + else + { generates a new unit info record } + begin + current_module:=new(pmodule,init(s,true)); + scanner:=nil; + second_time:=false; + end; + current_ppu:=current_module^.ppufile; + { close old_current_ppu on system that are + short on file handles like DOS PM } +{$ifdef SHORT_ON_FILE_HANDLES} + if assigned(old_current_ppu) then + old_current_ppu^.tempclose; +{$endif SHORT_ON_FILE_HANDLES} + { now we can register the unit } + current_module^.loaded_from:=old_current_module; + loaded_units.insert(current_module); + { now realy load the ppu } + loadppufile; + { set compiled flag } + current_module^.compiled:=true; + { load return pointer } + hp:=current_module; + { for a second_time recompile reload all dependent units, + for a first time compile register the unit _once_ } + if second_time then + begin + { now reload all dependent units } + hp2:=pmodule(loaded_units.first); + while assigned(hp2) do + begin + if hp2^.do_reload then + dummy:=loadunit(hp2^.modulename^,false); + hp2:=pmodule(hp2^.next); + end; + end + else + usedunits.concat(new(pused_unit,init(current_module,true))); + end; + { set the old module } +{$ifdef SHORT_ON_FILE_HANDLES} + if assigned(old_current_ppu) then + old_current_ppu^.tempopen; +{$endif SHORT_ON_FILE_HANDLES} + current_ppu:=old_current_ppu; + current_module:=old_current_module; + loadunit:=hp; + end; + + + procedure loaddefaultunits; + var + hp : pmodule; + unitsym : punitsym; + begin + { are we compiling the system unit? } + if (cs_compilesystem in aktmoduleswitches) then + begin + { create system defines } + createconstdefs; + { we don't need to reset anything, it's already done in parser.pas } + exit; + end; + { insert the system unit, it is allways the first } + hp:=loadunit(upper(target_info.system_unit),true); + systemunit:=hp^.globalsymtable; + { it's always the first unit } + systemunit^.next:=nil; + symtablestack:=systemunit; + { add to the used units } + current_module^.used_units.concat(new(pused_unit,init(hp,true))); + unitsym:=new(punitsym,init('SYSTEM',systemunit)); + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + { read default constant definitions } + make_ref:=false; + readconstdefs; + { if POWER is defined in the RTL then use it for starstar overloading } +{$ifdef DONOTCHAINOPERATORS} + getsym('POWER',false); +{$endif DONOTCHAINOPERATORS} + make_ref:=true; +{$ifdef DONOTCHAINOPERATORS} + { Code now in chainoperators PM } + if assigned(srsym) and (srsym^.typ=procsym) and (overloaded_operators[_STARSTAR]=nil) then + overloaded_operators[_STARSTAR]:=pprocsym(srsym); +{$endif DONOTCHAINOPERATORS} + { Objpas unit? } + if m_objpas in aktmodeswitches then + begin + hp:=loadunit('OBJPAS',false); + psymtable(hp^.globalsymtable)^.next:=symtablestack; + symtablestack:=hp^.globalsymtable; + { add to the used units } + current_module^.used_units.concat(new(pused_unit,init(hp,true))); + unitsym:=new(punitsym,init('OBJPAS',hp^.globalsymtable)); + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + end; + { Profile unit? Needed for go32v2 only } + if (cs_profile in aktmoduleswitches) and (target_info.target=target_i386_go32v2) then + begin + hp:=loadunit('PROFILE',false); + psymtable(hp^.globalsymtable)^.next:=symtablestack; + symtablestack:=hp^.globalsymtable; + { add to the used units } + current_module^.used_units.concat(new(pused_unit,init(hp,true))); + unitsym:=new(punitsym,init('PROFILE',hp^.globalsymtable)); + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + end; + { Units only required for main module } + if not(current_module^.is_unit) then + begin + { Heaptrc unit } + if (cs_gdb_heaptrc in aktglobalswitches) then + begin + hp:=loadunit('HEAPTRC',false); + psymtable(hp^.globalsymtable)^.next:=symtablestack; + symtablestack:=hp^.globalsymtable; + { add to the used units } + current_module^.used_units.concat(new(pused_unit,init(hp,true))); + unitsym:=new(punitsym,init('HEAPTRC',hp^.globalsymtable)); + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + end; + { Lineinfo unit } + if (cs_gdb_lineinfo in aktglobalswitches) then + begin + hp:=loadunit('LINEINFO',false); + psymtable(hp^.globalsymtable)^.next:=symtablestack; + symtablestack:=hp^.globalsymtable; + { add to the used units } + current_module^.used_units.concat(new(pused_unit,init(hp,true))); + unitsym:=new(punitsym,init('LINEINFO',hp^.globalsymtable)); + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + end; + end; + { save default symtablestack } + defaultsymtablestack:=symtablestack; + end; + + + procedure loadunits; + var + s : stringid; + pu, + hp : pused_unit; + hp2 : pmodule; + hp3 : psymtable; + oldprocsym:Pprocsym; + unitsym : punitsym; + begin + oldprocsym:=aktprocsym; + consume(_USES); +{$ifdef DEBUG} + test_symtablestack; +{$endif DEBUG} + repeat + s:=pattern; + consume(_ID); + { Give a warning if objpas is loaded } + if s='OBJPAS' then + Message(parser_w_no_objpas_use_mode); + { check if the unit is already used } + pu:=pused_unit(current_module^.used_units.first); + while assigned(pu) do + begin + if (pu^.name^=s) then + break; + pu:=pused_unit(pu^.next); + end; + { avoid uses of itself } + if not assigned(pu) and (s<>current_module^.modulename^) then + begin + { load the unit } + hp2:=loadunit(s,false); + { the current module uses the unit hp2 } + current_module^.used_units.concat(new(pused_unit,init(hp2,not current_module^.in_implementation))); + pused_unit(current_module^.used_units.last)^.in_uses:=true; + if current_module^.compiled then + exit; + unitsym:=new(punitsym,init(s,hp2^.globalsymtable)); + { never claim about unused unit if + there is init or finalize code PM } + if (hp2^.flags and (uf_init or uf_finalize))<>0 then + inc(unitsym^.refs); + refsymtable^.insert(unitsym); + end + else + Message1(sym_e_duplicate_id,s); + if token=_COMMA then + begin + pattern:=''; + consume(_COMMA); + end + else + break; + until false; + consume(_SEMICOLON); + + { set the symtable to systemunit so it gets reorderd correctly } + symtablestack:=defaultsymtablestack; + + { now insert the units in the symtablestack } + hp:=pused_unit(current_module^.used_units.first); + while assigned(hp) do + begin +{$IfDef GDB} + if (cs_debuginfo in aktmoduleswitches) and + (cs_gdb_dbx in aktglobalswitches) and + not hp^.is_stab_written then + begin + punitsymtable(hp^.u^.globalsymtable)^.concattypestabto(debuglist); + hp^.is_stab_written:=true; + hp^.unitid:=psymtable(hp^.u^.globalsymtable)^.unitid; + end; +{$EndIf GDB} + if hp^.in_uses then + begin + hp3:=symtablestack; + while assigned(hp3) do + begin + { insert units only once ! } + if hp^.u^.globalsymtable=hp3 then + break; + hp3:=hp3^.next; + { unit isn't inserted } + if hp3=nil then + begin + psymtable(hp^.u^.globalsymtable)^.next:=symtablestack; + symtablestack:=psymtable(hp^.u^.globalsymtable); +{$ifdef CHAINPROCSYMS} + symtablestack^.chainprocsyms; +{$endif CHAINPROCSYMS} +{$ifdef DEBUG} + test_symtablestack; +{$endif DEBUG} + end; + end; + end; + hp:=pused_unit(hp^.next); + end; + aktprocsym:=oldprocsym; + end; + + + procedure write_gdb_info; +{$IfDef GDB} + var + hp : pused_unit; + begin + if not (cs_debuginfo in aktmoduleswitches) then + exit; + if (cs_gdb_dbx in aktglobalswitches) then + begin + debuglist^.concat(new(pai_asm_comment,init(strpnew('EINCL of global '+ + punitsymtable(current_module^.globalsymtable)^.name^+' has index '+ + tostr(punitsymtable(current_module^.globalsymtable)^.unitid))))); + debuglist^.concat(new(pai_stabs,init(strpnew('"'+ + punitsymtable(current_module^.globalsymtable)^.name^+'",'+ + tostr(N_EINCL)+',0,0,0')))); + punitsymtable(current_module^.globalsymtable)^.dbx_count_ok:={true}false; + dbx_counter:=punitsymtable(current_module^.globalsymtable)^.prev_dbx_counter; + do_count_dbx:=false; + end; + + { now insert the units in the symtablestack } + hp:=pused_unit(current_module^.used_units.first); + while assigned(hp) do + begin + if (cs_debuginfo in aktmoduleswitches) and + not hp^.is_stab_written then + begin + punitsymtable(hp^.u^.globalsymtable)^.concattypestabto(debuglist); + hp^.is_stab_written:=true; + hp^.unitid:=psymtable(hp^.u^.globalsymtable)^.unitid; + end; + hp:=pused_unit(hp^.next); + end; + if current_module^.in_implementation then + begin + if assigned(current_module^.localsymtable) then + begin + { all types } + punitsymtable(current_module^.localsymtable)^.concattypestabto(debuglist); + { and all local symbols} + punitsymtable(current_module^.localsymtable)^.concatstabto(debuglist); + end; + end + else + begin + if assigned(current_module^.globalsymtable) then + begin + { all types } + punitsymtable(current_module^.globalsymtable)^.concattypestabto(debuglist); + { and all local symbols} + punitsymtable(current_module^.globalsymtable)^.concatstabto(debuglist); + end; + end; + end; +{$Else GDB} + begin + end; +{$EndIf GDB} + + + procedure parse_implementation_uses(symt:Psymtable); + begin + if token=_USES then + begin + symt^.symtabletype:=unitsymtable; + loadunits; + symt^.symtabletype:=globalsymtable; +{$ifdef DEBUG} + test_symtablestack; +{$endif DEBUG} + end; + end; + + + procedure setupglobalswitches; + + procedure def_symbol(const s:string); + var + mac : pmacrosym; + begin + mac:=new(pmacrosym,init(s)); + mac^.defined:=true; + Message1(parser_m_macro_defined,mac^.name); + macros^.insert(mac); + end; + + begin + { can't have local browser when no global browser } + if (cs_local_browser in aktmoduleswitches) and + not(cs_browser in aktmoduleswitches) then + aktmoduleswitches:=aktmoduleswitches-[cs_local_browser]; + + { define a symbol in delphi,objfpc,tp,gpc mode } + if (m_delphi in aktmodeswitches) then + def_symbol('FPC_DELPHI') + else + if (m_tp in aktmodeswitches) then + def_symbol('FPC_TP') + else + if (m_objfpc in aktmodeswitches) then + def_symbol('FPC_OBJFPC') + else + if (m_gpc in aktmodeswitches) then + def_symbol('FPC_GPC'); + + { turn ansistrings on by default ? } + if (m_default_ansistring in aktmodeswitches) then + aktlocalswitches:=aktlocalswitches+[cs_ansistrings]; + end; + + + procedure gen_main_procsym(const name:string;options:tproctypeoption;st:psymtable); + var + stt : psymtable; + begin + {Generate a procsym for main} + make_ref:=false; + aktprocsym:=new(Pprocsym,init(name)); + { main are allways used } + inc(aktprocsym^.refs); + {Try to insert in in static symtable ! } + stt:=symtablestack; + symtablestack:=st; + aktprocsym^.definition:=new(Pprocdef,init); + symtablestack:=stt; + aktprocsym^.definition^.proctypeoption:=options; + aktprocsym^.definition^.setmangledname(target_os.cprefix+name); + aktprocsym^.definition^.forwarddef:=false; + make_ref:=true; + { The localst is a local symtable. Change it into the static + symtable } + dispose(aktprocsym^.definition^.localst,done); + aktprocsym^.definition^.localst:=st; + { and insert the procsym in symtable } + st^.insert(aktprocsym); + { set some informations about the main program } + with procinfo^ do + begin + returntype.setdef(voiddef); + _class:=nil; + para_offset:=8; + framepointer:=frame_pointer; + flags:=0; + end; + end; + + + procedure proc_unit; + + function is_assembler_generated:boolean; + begin + is_assembler_generated:=(Errorcount=0) and + not( + codesegment^.empty and + datasegment^.empty and + bsssegment^.empty and + ((importssection=nil) or importssection^.empty) and + ((resourcesection=nil) or resourcesection^.empty) and + ((resourcestringlist=nil) or resourcestringlist^.empty) + ); + end; + + var +{$ifdef fixLeaksOnError} + names : Pstringcontainer; +{$else fixLeaksOnError} + names : Tstringcontainer; +{$endif fixLeaksOnError} + st : psymtable; + unitst : punitsymtable; +{$ifdef GDB} + pu : pused_unit; +{$endif GDB} +{$ifndef Dont_use_double_checksum} + store_crc,store_interface_crc : longint; +{$endif} + s1,s2 : ^string; {Saves stack space} + force_init_final : boolean; + + begin + consume(_UNIT); + if Compile_Level=1 then + IsExe:=false; + + if token=_ID then + begin + { create filenames and unit name } + current_module^.SetFileName(current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^,true); + stringdispose(current_module^.modulename); + current_module^.modulename:=stringdup(upper(pattern)); + { check for system unit } + new(s1); + new(s2); + s1^:=upper(target_info.system_unit); + s2^:=upper(SplitName(current_scanner^.inputfile^.name^)); + if (cs_compilesystem in aktmoduleswitches) then + begin + if ((length(current_module^.modulename^)>8) or + (current_module^.modulename^<>s1^) or + (current_module^.modulename^<>s2^)) then + Message1(unit_e_illegal_unit_name,current_module^.modulename^); + end + else + begin + if (cs_check_unit_name in aktglobalswitches) and + not((current_module^.modulename^=s2^) or + ((length(current_module^.modulename^)>8) and + (copy(current_module^.modulename^,1,8)=s2^))) then + Message1(unit_e_illegal_unit_name,current_module^.modulename^); + if (current_module^.modulename^=s1^) then + Message(unit_w_switch_us_missed); + end; + dispose(s2); + dispose(s1); + end; + + consume(_ID); + consume(_SEMICOLON); + consume(_INTERFACE); + { global switches are read, so further changes aren't allowed } + current_module^.in_global:=false; + + { handle the global switches } + setupglobalswitches; + + Message1(unit_u_start_parse_interface,current_module^.modulename^); + + { update status } + status.currentmodule:=current_module^.modulename^; + + { maybe turn off m_objpas if we are compiling objpas } + if (current_module^.modulename^='OBJPAS') then + aktmodeswitches:=aktmodeswitches-[m_objpas]; + + { this should be placed after uses !!} +{$ifndef UseNiceNames} + procprefix:='_'+current_module^.modulename^+'$$'; +{$else UseNiceNames} + procprefix:='_'+tostr(length(current_module^.modulename^))+lowercase(current_module^.modulename^)+'_'; +{$endif UseNiceNames} + + parse_only:=true; + + { generate now the global symboltable } + st:=new(punitsymtable,init(globalsymtable,current_module^.modulename^)); + refsymtable:=st; + unitst:=punitsymtable(st); + { define first as local to overcome dependency conflicts } + current_module^.localsymtable:=st; + + { the unit name must be usable as a unit specifier } + { inside the unit itself (PM) } + { this also forbids to have another symbol } + { with the same name as the unit } + refsymtable^.insert(new(punitsym,init(current_module^.modulename^,unitst))); + + { a unit compiled at command line must be inside the loaded_unit list } + if (compile_level=1) then + loaded_units.insert(current_module); + + { load default units, like the system unit } + loaddefaultunits; + + { reset } + make_ref:=true; + lexlevel:=0; + + { insert qualifier for the system unit (allows system.writeln) } + if not(cs_compilesystem in aktmoduleswitches) then + begin + if token=_USES then + begin + unitst^.symtabletype:=unitsymtable; + loadunits; + { has it been compiled at a higher level ?} + if current_module^.compiled then + begin + { this unit symtable is obsolete } + { dispose(unitst,done); + disposed as localsymtable !! } + RestoreUnitSyms; + exit; + end; + unitst^.symtabletype:=globalsymtable; + end; + { ... but insert the symbol table later } + st^.next:=symtablestack; + symtablestack:=st; + end + else + { while compiling a system unit, some types are directly inserted } + begin + st^.next:=symtablestack; + symtablestack:=st; + insert_intern_types(st); + end; + + { now we know the place to insert the constants } + constsymtable:=symtablestack; + + { move the global symtab from the temporary local to global } + current_module^.globalsymtable:=current_module^.localsymtable; + current_module^.localsymtable:=nil; + + reset_global_defs; + + { number all units, so we know if a unit is used by this unit or + needs to be added implicitly } + numberunits; + + { ... parse the declarations } + Message1(parser_u_parsing_interface,current_module^.modulename^); + read_interface_declarations; + + { leave when we got an error } + if (Errorcount>0) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(Errorcount)); + status.skip_error:=true; + exit; + end; + {else in inteface its somatimes necessary even if unused + st^.allunitsused; } + +{$ifdef New_GDB} + write_gdb_info; +{$endIf Def New_GDB} + + {$ifndef Dont_use_double_checksum} + if not(cs_compilesystem in aktmoduleswitches) then + if (Errorcount=0) then + writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack),true); + {$endif Test_Double_checksum} + + { Parse the implementation section } + consume(_IMPLEMENTATION); + current_module^.in_implementation:=true; + Message1(unit_u_start_parse_implementation,current_module^.modulename^); + + parse_only:=false; + + { generates static symbol table } + st:=new(punitsymtable,init(staticsymtable,current_module^.modulename^)); + current_module^.localsymtable:=st; + + { remove the globalsymtable from the symtable stack } + { to reinsert it after loading the implementation units } + symtablestack:=unitst^.next; + + { we don't want implementation units symbols in unitsymtable !! PM } + refsymtable:=st; + + { Read the implementation units } + parse_implementation_uses(unitst); + + if current_module^.compiled then + begin + RestoreUnitSyms; + exit; + end; + + { reset ranges/stabs in exported definitions } + reset_global_defs; + + { All units are read, now give them a number } + numberunits; + + { now we can change refsymtable } + refsymtable:=st; + + { but reinsert the global symtable as lasts } + unitst^.next:=symtablestack; + symtablestack:=unitst; + +{$ifndef DONOTCHAINOPERATORS} + symtablestack^.chainoperators; +{$endif DONOTCHAINOPERATORS} + +{$ifdef DEBUG} + test_symtablestack; +{$endif DEBUG} + constsymtable:=symtablestack; + +{$ifdef Splitheap} + if testsplit then + begin + Split_Heap; + allow_special:=true; + Switch_to_temp_heap; + end; + { it will report all crossings } + allow_special:=false; +{$endif Splitheap} + + Message1(parser_u_parsing_implementation,current_module^.modulename^); + + { Compile the unit } + codegen_newprocedure; + gen_main_procsym(current_module^.modulename^+'_init',potype_unitinit,st); +{$ifdef fixLeaksOnError} + new(names,init); + strContStack.push(names); + names^.insert('INIT$$'+current_module^.modulename^); + names^.insert(target_os.cprefix+current_module^.modulename^+'_init'); + compile_proc_body(names^,true,false); + if names <> PstringContainer(strContStack.pop) then + writeln('Problem with strContStack in pmodules (1)'); + dispose(names,done); +{$else fixLeaksOnError} + names.init; + names.insert('INIT$$'+current_module^.modulename^); + names.insert(target_os.cprefix+current_module^.modulename^+'_init'); + compile_proc_body(names,true,false); + names.done; +{$endif fixLeaksOnError} + codegen_doneprocedure; + + { avoid self recursive destructor call !! PM } + aktprocsym^.definition^.localst:=nil; + + { if the unit contains ansi/widestrings, initialization and + finalization code must be forced } + force_init_final:=needs_init_final(current_module^.globalsymtable) + or needs_init_final(current_module^.localsymtable); + + { should we force unit initialization? } + { this is a hack, but how can it be done better ? } + if force_init_final and ((current_module^.flags and uf_init)=0) then + begin + current_module^.flags:=current_module^.flags or uf_init; + { now we can insert a cut } + if (cs_create_smart in aktmoduleswitches) then + codesegment^.concat(new(pai_cut,init)); + genimplicitunitinit(codesegment); + end; + { finalize? } + if token=_FINALIZATION then + begin + { set module options } + current_module^.flags:=current_module^.flags or uf_finalize; + + { Compile the finalize } + codegen_newprocedure; + gen_main_procsym(current_module^.modulename^+'_finalize',potype_unitfinalize,st); +{$ifdef fixLeaksOnError} + new(names,init); + strContStack.push(names); + names^.insert('FINALIZE$$'+current_module^.modulename^); + names^.insert(target_os.cprefix+current_module^.modulename^+'_finalize'); + compile_proc_body(names^,true,false); + if names <> PstringContainer(strContStack.pop) then + writeln('Problem with strContStack in pmodules (2)'); + dispose(names,done); +{$else fixLeaksOnError} + names.init; + names.insert('FINALIZE$$'+current_module^.modulename^); + names.insert(target_os.cprefix+current_module^.modulename^+'_finalize'); + compile_proc_body(names,true,false); + names.done; +{$endif fixLeaksOnError} + codegen_doneprocedure; + end + else if force_init_final then + begin + current_module^.flags:=current_module^.flags or uf_finalize; + { now we can insert a cut } + if (cs_create_smart in aktmoduleswitches) then + codesegment^.concat(new(pai_cut,init)); + genimplicitunitfinal(codesegment); + end; + + { the last char should always be a point } + consume(_POINT); + + If ResourceStrings^.ResStrCount>0 then + begin + ResourceStrings^.CreateResourceStringList; + current_module^.flags:=current_module^.flags or uf_has_resources; + { only write if no errors found } + if (Errorcount=0) then + ResourceStrings^.WriteResourceFile(Current_module^.ModuleName^); + end; + + { avoid self recursive destructor call !! PM } + aktprocsym^.definition^.localst:=nil; + { absence does not matter here !! } + aktprocsym^.definition^.forwarddef:=false; + { test static symtable } + if (Errorcount=0) then + begin + st^.allsymbolsused; + st^.allunitsused; + st^.allprivatesused; + end; + + { size of the static data } + datasize:=st^.datasize; + +{$ifdef GDB} + { add all used definitions even for implementation} + if (cs_debuginfo in aktmoduleswitches) then + begin +{$IfnDef New_GDB} + if assigned(current_module^.globalsymtable) then + begin + { all types } + punitsymtable(current_module^.globalsymtable)^.concattypestabto(debuglist); + { and all local symbols} + punitsymtable(current_module^.globalsymtable)^.concatstabto(debuglist); + end; + { all local types } + punitsymtable(st)^.concattypestabto(debuglist); + { and all local symbols} + st^.concatstabto(debuglist); +{$else New_GDB} + write_gdb_info; +{$endIf Def New_GDB} + end; +{$endif GDB} + + reset_global_defs; + + { tests, if all (interface) forwards are resolved } + if (Errorcount=0) then + begin + symtablestack^.check_forwards; + symtablestack^.allprivatesused; + end; + + { now we have a correct unit, change the symtable type } + current_module^.in_implementation:=false; + symtablestack^.symtabletype:=unitsymtable; +{$ifdef GDB} + punitsymtable(symtablestack)^.is_stab_written:=false; +{$endif GDB} + + { leave when we got an error } + if (Errorcount>0) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(Errorcount)); + status.skip_error:=true; + closecurrentppu; + exit; + end; + + { generate imports } + if current_module^.uses_imports then + importlib^.generatelib; + + { insert own objectfile, or say that it's in a library + (no check for an .o when loading) } + if is_assembler_generated then + insertobjectfile + else + current_module^.flags:=current_module^.flags or uf_no_link; + + if cs_local_browser in aktmoduleswitches then + current_module^.localsymtable:=refsymtable; + { Write out the ppufile } + {$ifndef Dont_use_double_checksum} + store_interface_crc:=current_module^.interface_crc; + store_crc:=current_module^.crc; + {$endif Test_Double_checksum} + if (Errorcount=0) then + writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack),false); + + {$ifndef Dont_use_double_checksum} + if not(cs_compilesystem in aktmoduleswitches) then + if store_interface_crc<>current_module^.interface_crc then + Do_comment(V_Warning,current_module^.ppufilename^+' Interface CRC changed '+ + tostr(store_crc)+'<>'+tostr(current_module^.interface_crc)); + {$ifdef EXTDEBUG} + if not(cs_compilesystem in aktmoduleswitches) then + if (store_crc<>current_module^.crc) and simplify_ppu then + Do_comment(V_Warning,current_module^.ppufilename^+' implementation CRC changed '+ + tostr(store_crc)+'<>'+tostr(current_module^.interface_crc)); + {$endif EXTDEBUG} + {$endif ndef Dont_use_Double_checksum} + { must be done only after local symtable ref stores !! } + closecurrentppu; +{$ifdef GDB} + pu:=pused_unit(usedunits.first); + while assigned(pu) do + begin + if assigned(pu^.u^.globalsymtable) then + punitsymtable(pu^.u^.globalsymtable)^.is_stab_written:=false; + pu:=pused_unit(pu^.next); + end; +{$endif GDB} + + { remove static symtable (=refsymtable) here to save some mem } + if not (cs_local_browser in aktmoduleswitches) then + begin + dispose(st,done); + current_module^.localsymtable:=nil; + end; + + + RestoreUnitSyms; + + if is_assembler_generated then + begin + { finish asmlist by adding segment starts } + insertsegment; + { assemble } + create_objectfile; + end; + + { leave when we got an error } + if (Errorcount>0) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(Errorcount)); + status.skip_error:=true; + exit; + end; + end; + + + procedure proc_program(islibrary : boolean); + var + st : psymtable; + hp : pmodule; +{$ifdef fixLeaksOnError} + names : Pstringcontainer; +{$else fixLeaksOnError} + names : Tstringcontainer; +{$endif fixLeaksOnError} + begin + DLLsource:=islibrary; + IsExe:=true; + parse_only:=false; + { relocation works only without stabs under win32 !! PM } + { internal assembler uses rva for stabs info + so it should work with relocated DLLs } + if RelocSection and + (target_info.target=target_i386_win32) and + (target_info.assem<>as_i386_pecoff) then + begin + aktglobalswitches:=aktglobalswitches+[cs_link_strip]; + { Warning stabs info does not work with reloc section !! } + if cs_debuginfo in aktmoduleswitches then + begin + Message1(parser_w_parser_reloc_no_debug,current_module^.mainsource^); + Message(parser_w_parser_win32_debug_needs_WN); + aktmoduleswitches:=aktmoduleswitches-[cs_debuginfo]; + end; + end; + + { get correct output names } + current_module^.SetFileName(current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^,true); + + if islibrary then + begin + consume(_LIBRARY); + stringdispose(current_module^.modulename); + current_module^.modulename:=stringdup(pattern); + current_module^.islibrary:=true; + exportlib^.preparelib(pattern); + consume(_ID); + consume(_SEMICOLON); + end + else + { is there an program head ? } + if token=_PROGRAM then + begin + consume(_PROGRAM); + stringdispose(current_module^.modulename); + current_module^.modulename:=stringdup(pattern); + if (target_info.target=target_i386_WIN32) then + exportlib^.preparelib(pattern); + consume(_ID); + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + idlist; + consume(_RKLAMMER); + end; + consume(_SEMICOLON); + end + else if (target_info.target=target_i386_WIN32) then + exportlib^.preparelib(current_module^.modulename^); + + { global switches are read, so further changes aren't allowed } + current_module^.in_global:=false; + + { setup things using the global switches } + setupglobalswitches; + + { set implementation flag } + current_module^.in_implementation:=true; + + { insert after the unit symbol tables the static symbol table } + { of the program } + st:=new(punitsymtable,init(staticsymtable,current_module^.modulename^)); + current_module^.localsymtable:=st; + symtablestack:=st; + refsymtable:=st; + + { necessary for browser } + loaded_units.insert(current_module); + + { load standard units (system,objpas,profile unit) } + loaddefaultunits; + + { reset } + lexlevel:=0; + + {Load the units used by the program we compile.} + if token=_USES then + loadunits; + +{$ifndef DONOTCHAINOPERATORS} + symtablestack^.chainoperators; +{$endif DONOTCHAINOPERATORS} + + { reset ranges/stabs in exported definitions } + reset_global_defs; + + { All units are read, now give them a number } + numberunits; + + {Insert the name of the main program into the symbol table.} + if current_module^.modulename^<>'' then + {st^.insert(new(pprogramsym,init(current_module^.modulename^)));} + st^.insert(new(punitsym,init(current_module^.modulename^,punitsymtable(st)))); + + { ...is also constsymtable, this is the symtable where } + { the elements of enumeration types are inserted } + constsymtable:=st; + + Message1(parser_u_parsing_implementation,current_module^.mainsource^); + + { reset } + procprefix:=''; + + {The program intialization needs an alias, so it can be called + from the bootstrap code.} + codegen_newprocedure; + gen_main_procsym('main',potype_proginit,st); +{$ifdef fixLeaksOnError} + new(names,init); + strContStack.push(names); + names^.insert('program_init'); + names^.insert('PASCALMAIN'); + names^.insert(target_os.cprefix+'main'); +{$ifdef m68k} + if target_info.target=target_m68k_PalmOS then + names^.insert('PilotMain'); +{$endif m68k} + compile_proc_body(names^,true,false); + if names <> PstringContainer(strContStack.pop) then + writeln('Problem with strContStack in pmodules (1)'); + dispose(names,done); +{$else fixLeaksOnError} + names.init; + names.insert('program_init'); + names.insert('PASCALMAIN'); + names.insert(target_os.cprefix+'main'); +{$ifdef m68k} + if target_info.target=target_m68k_PalmOS then + names.insert('PilotMain'); +{$endif m68k} + compile_proc_body(names,true,false); + names.done; +{$endif fixLeaksOnError} + + { avoid self recursive destructor call !! PM } + aktprocsym^.definition^.localst:=nil; + + { consider these symbols as global ones } + { for browser } + current_module^.globalsymtable:=current_module^.localsymtable; + current_module^.localsymtable:=nil; + + If ResourceStrings^.ResStrCount>0 then + begin + ResourceStrings^.CreateResourceStringList; + { only write if no errors found } + if (Errorcount=0) then + ResourceStrings^.WriteResourceFile(Current_module^.ModuleName^); + end; + + codegen_doneprocedure; + + { finalize? } + if token=_FINALIZATION then + begin + { set module options } + current_module^.flags:=current_module^.flags or uf_finalize; + + { Compile the finalize } + codegen_newprocedure; + gen_main_procsym(current_module^.modulename^+'_finalize',potype_unitfinalize,st); +{$ifdef fixLeaksOnError} + new(names,init); + strContStack.push(names); + names^.insert('FINALIZE$$'+current_module^.modulename^); + names^.insert(target_os.cprefix+current_module^.modulename^+'_finalize'); + compile_proc_body(names^,true,false); + if names <> PstringContainer(strContStack.pop) then + writeln('Problem with strContStack in pmodules (1)'); + dispose(names,done); +{$else fixLeaksOnError} + names.init; + names.insert('FINALIZE$$'+current_module^.modulename^); + names.insert(target_os.cprefix+current_module^.modulename^+'_finalize'); + compile_proc_body(names,true,false); + names.done; +{$endif fixLeaksOnError} + codegen_doneprocedure; + end; + + { consume the last point } + consume(_POINT); + +{$ifdef New_GDB} + write_gdb_info; +{$endIf Def New_GDB} + { leave when we got an error } + if (Errorcount>0) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(Errorcount)); + status.skip_error:=true; + exit; + end; + + { test static symtable } + if (Errorcount=0) then + begin + st^.allsymbolsused; + st^.allunitsused; + st^.allprivatesused; + end; + + { generate imports } + if current_module^.uses_imports then + importlib^.generatelib; + + if islibrary or + (target_info.target=target_i386_WIN32) then + exportlib^.generatelib; + + + { insert heap } + insertResourceTablesTable; + insertinitfinaltable; + insertheap; + inserttargetspecific; + + datasize:=symtablestack^.datasize; + + { finish asmlist by adding segment starts } + insertsegment; + + { insert own objectfile } + insertobjectfile; + + { assemble and link } + create_objectfile; + + { leave when we got an error } + if (Errorcount>0) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(Errorcount)); + status.skip_error:=true; + exit; + end; + + { create the executable when we are at level 1 } + if (compile_level=1) then + begin + { insert all .o files from all loaded units } + hp:=pmodule(loaded_units.first); + while assigned(hp) do + begin + Linker^.AddModuleFiles(hp); + hp:=pmodule(hp^.next); + end; + { write .def file } + if (cs_link_deffile in aktglobalswitches) then + deffile.writefile; + { finally we can create a executable } + if (not current_module^.is_unit) then + begin + if DLLSource then + Linker^.MakeSharedLibrary + else + Linker^.MakeExecutable; + end; + end; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.197 2000/06/15 18:10:11 peter + * first look for ppu in cwd and outputpath and after that for source + in cwd + * fixpath() for not linux makes path now lowercase so comparing paths + with different cases (sometimes a drive letter could be + uppercased) gives the expected results + * sources_checked flag if there was already a full search for sources + which aren't found, so another scan isn't done when checking for the + sources only when recompile is needed + + Revision 1.196 2000/06/01 19:09:57 peter + * made resourcestrings OOP so it's easier to handle it per module + + Revision 1.195 2000/05/11 09:40:11 pierre + * some DBX changes but it still does not work ! + + Revision 1.194 2000/05/08 13:18:09 peter + * fixed setting of output names with includefile + + Revision 1.193 2000/05/04 20:43:33 peter + * don't write rst files if errors found + + Revision 1.192 2000/05/03 14:39:51 pierre + * Use RestoreUnitsSyms to avoid wrong hints about unused units + * Avoid hints about unsused units if thet have a init or finalize code + + Revision 1.191 2000/04/27 11:35:03 pierre + * power to ** operator fixed + + Revision 1.190 2000/04/26 08:54:18 pierre + * More changes for operator bug + Order_overloaded method removed because it conflicted with + new implementation where the defs are ordered + according to the unit loading order ! + + Revision 1.189 2000/04/25 23:55:30 pierre + + Hint about unused unit + * Testop bug fixed !! + Now the operators are only applied if the unit is explicitly loaded + + Revision 1.188 2000/04/14 08:15:05 pierre + * close ppu file if errors + + Revision 1.187 2000/04/02 10:18:18 florian + * bug 701 fixed: ansistrings in interface and implementation part of the units + are now finalized correctly even if there are no explicit initialization/ + finalization statements + + Revision 1.186 2000/03/01 15:36:11 florian + * some new stuff for the new cg + + Revision 1.185 2000/02/09 13:22:57 peter + * log truncated + + Revision 1.184 2000/02/06 17:20:53 peter + * -gl switch for auto lineinfo including + + Revision 1.183 2000/01/16 22:17:12 peter + * renamed call_offset to para_offset + + Revision 1.182 2000/01/16 14:15:33 jonas + * changed "with object_type" construct because of bug in the + compiler + + Revision 1.181 2000/01/12 10:30:15 peter + * align codesegment at the end after main proc + + Revision 1.180 2000/01/11 17:16:05 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.179 2000/01/11 09:52:07 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.178 2000/01/07 01:14:29 peter + * updated copyright to 2000 + + Revision 1.177 1999/12/20 22:29:26 pierre + * relocation with debug info in rva (only with internal compiler) + + Revision 1.176 1999/12/10 10:02:53 peter + * only check relocsection for win32 + + Revision 1.175 1999/11/30 10:40:44 peter + + ttype, tsymlist + + Revision 1.174 1999/11/29 16:24:52 pierre + * bug in previous commit corrected + + Revision 1.173 1999/11/29 15:18:27 pierre + + allow exports in win32 executables + + Revision 1.172 1999/11/24 11:41:05 pierre + * defaultsymtablestack is now restored after parser.compile + + Revision 1.171 1999/11/22 22:21:46 pierre + * Compute correct Exe Filenam + + Revision 1.170 1999/11/22 00:23:09 pierre + * also complain about unused functions in program + + Revision 1.169 1999/11/20 01:19:10 pierre + * DLL index used for win32 target with DEF file + + DLL initialization/finalization support + + Revision 1.168 1999/11/18 23:35:40 pierre + * avoid double warnings + + Revision 1.167 1999/11/18 15:34:47 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.166 1999/11/17 17:05:02 pierre + * Notes/hints changes + + Revision 1.165 1999/11/15 15:03:47 pierre + * Pavel's changes for reloc section in executable + + warning that -g needs -WN under win32 + +} diff --git a/befpc/compiler/popt386.pas b/befpc/compiler/popt386.pas new file mode 100644 index 0000000..7dcecaa --- /dev/null +++ b/befpc/compiler/popt386.pas @@ -0,0 +1,2071 @@ + { + $Id: popt386.pas,v 1.1.1.1 2001-07-23 17:16:49 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl and Jonas Maebe + + This unit contains the peephole optimizer. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit POpt386; + +{$ifdef newOptimizations} +{$define foropt} +{$define replacereg} +{$define arithopt} +{$define foldarithops} +{$endif newOptimizations} + +Interface + +Uses Aasm; + +Procedure PeepHoleOptPass1(AsmL: PAasmOutput; BlockStart, BlockEnd: Pai); +Procedure PeepHoleOptPass2(AsmL: PAasmOutput; BlockStart, BlockEnd: Pai); + +Implementation + +Uses + globtype,systems, + globals,verbose,hcodegen, +{$ifdef finaldestdebug} + cobjects, +{$endif finaldestdebug} + cpubase,cpuasm,DAOpt386,tgeni386; + +Function RegUsedAfterInstruction(Reg: TRegister; p: Pai; Var UsedRegs: TRegSet): Boolean; +Begin + reg := reg32(reg); + UpdateUsedRegs(UsedRegs, Pai(p^.Next)); + RegUsedAfterInstruction := + (Reg in UsedRegs) and + (not(getNextInstruction(p,p)) or + not(regLoadedWithNewValue(reg,false,p))); +End; + +function doFpuLoadStoreOpt(asmL: paasmoutput; var p: pai): boolean; +{ returns true if a "continue" should be done after this optimization } +var hp1, hp2: pai; +begin + doFpuLoadStoreOpt := false; + if (paicpu(p)^.oper[0].typ = top_ref) and + getNextInstruction(p, hp1) and + (hp1^.typ = ait_instruction) and + (((paicpu(hp1)^.opcode = A_FLD) and + (paicpu(p)^.opcode = A_FSTP)) or + ((paicpu(p)^.opcode = A_FISTP) and + (paicpu(hp1)^.opcode = A_FILD))) and + (paicpu(hp1)^.oper[0].typ = top_ref) and + (paicpu(hp1)^.opsize = Paicpu(p)^.opsize) and + refsEqual(paicpu(p)^.oper[0].ref^, paicpu(hp1)^.oper[0].ref^) then + begin + if getNextInstruction(hp1, hp2) and + (hp2^.typ = ait_instruction) and + ((paicpu(hp2)^.opcode = A_LEAVE) or + (paicpu(hp2)^.opcode = A_RET)) and + (paicpu(p)^.oper[0].ref^.Base = procinfo^.FramePointer) and + (paicpu(p)^.oper[0].ref^.Offset >= procinfo^.Return_Offset) and + (paicpu(p)^.oper[0].ref^.Index = R_NO) then + begin + asmL^.remove(p); + asmL^.remove(hp1); + dispose(p, done); + dispose(hp1, done); + p := hp2; + removeLastDeallocForFuncRes(asmL, p); + doFPULoadStoreOpt := true; + end + else + { fst can't store an extended value! } + if (paicpu(p)^.opsize <> S_FX) and + (paicpu(p)^.opsize <> S_IQ) then + begin + if (paicpu(p)^.opcode = A_FSTP) then + paicpu(p)^.opcode := A_FST + else Paicpu(p)^.opcode := A_FIST; + asmL^.remove(hp1); + dispose(hp1, done) + end + end; +end; + + +Procedure PeepHoleOptPass1(Asml: PAasmOutput; BlockStart, BlockEnd: Pai); +{First pass of peepholeoptimizations} + +Var + l : longint; + p,hp1,hp2 : pai; +{$ifdef foropt} + hp3,hp4: pai; +{$endif foropt} + TmpBool1, TmpBool2: Boolean; + + TmpRef: TReference; + + UsedRegs, TmpUsedRegs: TRegSet; + + Function SkipLabels(hp: Pai; var hp2: pai): boolean; + {skips all labels and returns the next "real" instruction} + Begin + While assigned(hp^.next) and + (pai(hp^.next)^.typ In SkipInstr + [ait_label,ait_align]) Do + hp := pai(hp^.next); + If assigned(hp^.next) Then + Begin + SkipLabels := True; + hp2 := pai(hp^.next) + End + Else + Begin + hp2 := hp; + SkipLabels := False + End; + End; + + Procedure GetFinalDestination(AsmL: PAAsmOutput; hp: paicpu); + {traces sucessive jumps to their final destination and sets it, e.g. + je l1 je l3 + + l1: becomes l1: + je l2 je l3 + + l2: l2: + jmp l3 jmp l3} + + Var p1, p2: pai; + l: pasmlabel; + + Function FindAnyLabel(hp: pai; var l: pasmlabel): Boolean; + Begin + FindAnyLabel := false; + While assigned(hp^.next) and + (pai(hp^.next)^.typ In (SkipInstr+[ait_align])) Do + hp := pai(hp^.next); + If assigned(hp^.next) and + (pai(hp^.next)^.typ = ait_label) Then + Begin + FindAnyLabel := true; + l := pai_label(hp^.next)^.l; + End + End; + + Begin + If (pasmlabel(hp^.oper[0].sym)^.labelnr >= LoLab) and + (pasmlabel(hp^.oper[0].sym)^.labelnr <= HiLab) and {range check, a jump can go past an assembler block!} + Assigned(LTable^[pasmlabel(hp^.oper[0].sym)^.labelnr-LoLab].PaiObj) Then + Begin + p1 := LTable^[pasmlabel(hp^.oper[0].sym)^.labelnr-LoLab].PaiObj; {the jump's destination} + SkipLabels(p1,p1); + If (pai(p1)^.typ = ait_instruction) and + (paicpu(p1)^.is_jmp) Then + If { the next instruction after the label where the jump hp arrives} + { is unconditional or of the same type as hp, so continue } + (paicpu(p1)^.condition in [C_None,hp^.condition]) or + { the next instruction after the label where the jump hp arrives} + { is the opposite of hp (so this one is never taken), but after } + { that one there is a branch that will be taken, so perform a } + { little hack: set p1 equal to this instruction (that's what the} + { last SkipLabels is for, only works with short bool evaluation)} + ((paicpu(p1)^.condition = inverse_cond[hp^.condition]) and + SkipLabels(p1,p2) and + (p2^.typ = ait_instruction) and + (paicpu(p2)^.is_jmp) and + (paicpu(p2)^.condition in [C_None,hp^.condition]) and + SkipLabels(p1,p1)) Then + Begin + GetFinalDestination(asml, paicpu(p1)); + Dec(pasmlabel(hp^.oper[0].sym)^.refs); + hp^.oper[0].sym:=paicpu(p1)^.oper[0].sym; + inc(pasmlabel(hp^.oper[0].sym)^.refs); + End + Else + If (paicpu(p1)^.condition = inverse_cond[hp^.condition]) then + if not FindAnyLabel(p1,l) then + begin + {$ifdef finaldestdebug} + insertllitem(asml,p1,p1^.next,new(pai_asm_comment,init( + strpnew('previous label inserted')))); + {$endif finaldestdebug} + getlabel(l); + insertllitem(asml,p1,p1^.next,new(pai_label,init(l))); + dec(pasmlabel(paicpu(hp)^.oper[0].sym)^.refs); + hp^.oper[0].sym := l; + inc(l^.refs); + { this won't work, since the new label isn't in the labeltable } + { so it will fail the rangecheck. Labeltable should become a } + { hashtable to support this: } + { GetFinalDestination(asml, hp); } + end + else + begin + {$ifdef finaldestdebug} + insertllitem(asml,p1,p1^.next,new(pai_asm_comment,init( + strpnew('next label reused')))); + {$endif finaldestdebug} + inc(l^.refs); + hp^.oper[0].sym := l; + GetFinalDestination(asml, hp); + end; + End; + End; + + Function DoSubAddOpt(var p: Pai): Boolean; + Begin + DoSubAddOpt := False; + If GetLastInstruction(p, hp1) And + (hp1^.typ = ait_instruction) And + (Paicpu(hp1)^.opsize = Paicpu(p)^.opsize) then + Case Paicpu(hp1)^.opcode Of + A_DEC: + If (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = Paicpu(p)^.oper[1].reg) Then + Begin + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val+1); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End; + A_SUB: + If (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) Then + Begin + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val+Paicpu(hp1)^.oper[0].val); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End; + A_ADD: + If (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) Then + Begin + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val-Paicpu(hp1)^.oper[0].val); + AsmL^.Remove(hp1); + Dispose(hp1, Done); + If (Paicpu(p)^.oper[0].val = 0) Then + Begin + hp1 := Pai(p^.next); + AsmL^.Remove(p); + Dispose(p, Done); + If Not GetLastInstruction(hp1, p) Then + p := hp1; + DoSubAddOpt := True; + End + End; + End; + End; + +Begin + P := BlockStart; + UsedRegs := []; + While (P <> BlockEnd) Do + Begin + UpDateUsedRegs(UsedRegs, Pai(p^.next)); + Case P^.Typ Of + ait_instruction: + Begin + { Handle Jmp Optimizations } + if Paicpu(p)^.is_jmp then + begin + {the following if-block removes all code between a jmp and the next label, + because it can never be executed} + If (paicpu(p)^.opcode = A_JMP) Then + Begin + While GetNextInstruction(p, hp1) and + ((hp1^.typ <> ait_label) or + { skip unused labels, they're not referenced anywhere } + Not(Pai_Label(hp1)^.l^.is_used)) Do + If not(hp1^.typ in ([ait_label,ait_align]+skipinstr)) Then + Begin + AsmL^.Remove(hp1); + Dispose(hp1, done); + End; + End; + If GetNextInstruction(p, hp1) then + Begin + if FindLabel(pasmlabel(paicpu(p)^.oper[0].sym), hp1) then + Begin + hp2:=pai(hp1^.next); + asml^.remove(p); + dispose(p,done); + p:=hp2; + continue; + end + Else + Begin + if hp1^.typ = ait_label then + SkipLabels(hp1,hp1); + If (pai(hp1)^.typ=ait_instruction) and + (paicpu(hp1)^.opcode=A_JMP) and + GetNextInstruction(hp1, hp2) And + FindLabel(PAsmLabel(paicpu(p)^.oper[0].sym), hp2) + Then + Begin + if paicpu(p)^.opcode=A_Jcc then + paicpu(p)^.condition:=inverse_cond[paicpu(p)^.condition] + else + begin + If (LabDif <> 0) Then + GetFinalDestination(asml, paicpu(p)); + p:=pai(p^.next); + continue; + end; + Dec(pai_label(hp2)^.l^.refs); + paicpu(p)^.oper[0].sym:=paicpu(hp1)^.oper[0].sym; + Inc(paicpu(p)^.oper[0].sym^.refs); + asml^.remove(hp1); + dispose(hp1,done); + If (LabDif <> 0) Then + GetFinalDestination(asml, paicpu(p)); + end + else + If (LabDif <> 0) Then + GetFinalDestination(asml, paicpu(p)); + end; + end; + end + else + { All other optimizes } + begin + For l := 0 to 2 Do + If (Paicpu(p)^.oper[l].typ = top_ref) Then + With Paicpu(p)^.oper[l].ref^ Do + Begin + If (base = R_NO) And + (index <> R_NO) And + (scalefactor in [0,1]) + Then + Begin + base := index; + index := R_NO + End + End; + Case Paicpu(p)^.opcode Of + A_AND: + Begin + If (Paicpu(p)^.oper[0].typ = top_const) And + (Paicpu(p)^.oper[1].typ = top_reg) And + GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(hp1)^.oper[1].reg) + Then +{change "and const1, reg; and const2, reg" to "and (const1 and const2), reg"} + Begin + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val And Paicpu(hp1)^.oper[0].val); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End + Else +{change "and x, reg; jxx" to "test x, reg", if reg is deallocated before the + jump, but only if it's a conditional jump (PFV) } + If (Paicpu(p)^.oper[1].typ = top_reg) And + GetNextInstruction(p, hp1) And + (hp1^.typ = ait_instruction) And + (Paicpu(hp1)^.is_jmp) and + (Paicpu(hp1)^.opcode<>A_JMP) and + Not(Paicpu(p)^.oper[1].reg in UsedRegs) Then + Paicpu(p)^.opcode := A_TEST; + End; + A_CMP: + Begin + If (Paicpu(p)^.oper[0].typ = top_const) And + (Paicpu(p)^.oper[1].typ in [top_reg,top_ref]) And + (Paicpu(p)^.oper[0].val = 0) Then +{$ifdef foropt} + If GetNextInstruction(p, hp1) And + (hp1^.typ = ait_instruction) And + (Paicpu(hp1)^.is_jmp) and + (paicpu(hp1)^.opcode=A_Jcc) and + (paicpu(hp1)^.condition in [C_LE,C_BE]) and + GetNextInstruction(hp1,hp2) and + (hp2^.typ = ait_instruction) and + (Paicpu(hp2)^.opcode = A_DEC) And + OpsEqual(Paicpu(hp2)^.oper[0],Paicpu(p)^.oper[1]) And + GetNextInstruction(hp2, hp3) And + (hp3^.typ = ait_instruction) and + (Paicpu(hp3)^.is_jmp) and + (Paicpu(hp3)^.opcode = A_JMP) And + GetNextInstruction(hp3, hp4) And + FindLabel(PAsmLabel(paicpu(hp1)^.oper[0].sym),hp4) + Then + Begin + Paicpu(hp2)^.Opcode := A_SUB; + Paicpu(hp2)^.Loadoper(1,Paicpu(hp2)^.oper[0]); + Paicpu(hp2)^.LoadConst(0,1); + Paicpu(hp2)^.ops:=2; + Paicpu(hp3)^.Opcode := A_Jcc; + Case paicpu(hp1)^.condition of + C_LE: Paicpu(hp3)^.condition := C_GE; + C_BE: Paicpu(hp3)^.condition := C_AE; + End; + AsmL^.Remove(p); + AsmL^.Remove(hp1); + Dispose(p, Done); + Dispose(hp1, Done); + p := hp2; + continue; + End + Else +{$endif foropt} + {change "cmp $0, %reg" to "test %reg, %reg"} + If (Paicpu(p)^.oper[1].typ = top_reg) Then + Begin + Paicpu(p)^.opcode := A_TEST; + Paicpu(p)^.loadreg(0,Paicpu(p)^.oper[1].reg); + End; + End; + A_FLD: + Begin + If (Paicpu(p)^.oper[0].typ = top_reg) And + GetNextInstruction(p, hp1) And + (hp1^.typ = Ait_Instruction) And + (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = R_ST) And + (Paicpu(hp1)^.oper[1].reg = R_ST1) Then + { change to + fld reg fxxx reg,st + fxxxp st, st1 (hp1) + Remark: non commutative operations must be reversed! + } + begin + Case Paicpu(hp1)^.opcode Of + A_FMULP,A_FADDP, + A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP: + begin + Case Paicpu(hp1)^.opcode Of + A_FADDP: Paicpu(hp1)^.opcode := A_FADD; + A_FMULP: Paicpu(hp1)^.opcode := A_FMUL; + A_FSUBP: Paicpu(hp1)^.opcode := A_FSUBR; + A_FSUBRP: Paicpu(hp1)^.opcode := A_FSUB; + A_FDIVP: Paicpu(hp1)^.opcode := A_FDIVR; + A_FDIVRP: Paicpu(hp1)^.opcode := A_FDIV; + End; + Paicpu(hp1)^.oper[0].reg := Paicpu(p)^.oper[0].reg; + Paicpu(hp1)^.oper[1].reg := R_ST; + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue; + end; + end; + end + else + If (Paicpu(p)^.oper[0].typ = top_ref) And + GetNextInstruction(p, hp2) And + (hp2^.typ = Ait_Instruction) And + (Paicpu(hp2)^.oper[0].typ = top_reg) And + (Paicpu(hp2)^.oper[1].typ = top_reg) And + (Paicpu(p)^.opsize in [S_FS, S_FL]) And + (Paicpu(hp2)^.oper[0].reg = R_ST) And + (Paicpu(hp2)^.oper[1].reg = R_ST1) Then + If GetLastInstruction(p, hp1) And + (hp1^.typ = Ait_Instruction) And + ((Paicpu(hp1)^.opcode = A_FLD) Or + (Paicpu(hp1)^.opcode = A_FST)) And + (Paicpu(hp1)^.opsize = Paicpu(p)^.opsize) And + (Paicpu(hp1)^.oper[0].typ = top_ref) And + RefsEqual(Paicpu(p)^.oper[0].ref^, Paicpu(hp1)^.oper[0].ref^) Then + If ((Paicpu(hp2)^.opcode = A_FMULP) Or + (Paicpu(hp2)^.opcode = A_FADDP)) Then + + { change to + fld/fst mem1 (hp1) fld/fst mem1 + fld mem1 (p) fadd/ + faddp/ fmul st, st + fmulp st, st1 (hp2) } + Begin + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + If (Paicpu(hp2)^.opcode = A_FADDP) Then + Paicpu(hp2)^.opcode := A_FADD + Else + Paicpu(hp2)^.opcode := A_FMUL; + Paicpu(hp2)^.oper[1].reg := R_ST; + End + Else + { change to + fld/fst mem1 (hp1) fld/fst mem1 + fld mem1 (p) fld st} + Begin + Paicpu(p)^.changeopsize(S_FL); + Paicpu(p)^.loadreg(0,R_ST); + End + Else + Begin + Case Paicpu(hp2)^.opcode Of + A_FMULP,A_FADDP,A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP: + { change to + fld/fst mem1 (hp1) fld/fst mem1 + fld mem2 (p) fxxx mem2 + fxxxp st, st1 (hp2) } + + Begin + Case Paicpu(hp2)^.opcode Of + A_FADDP: Paicpu(p)^.opcode := A_FADD; + A_FMULP: Paicpu(p)^.opcode := A_FMUL; + A_FSUBP: Paicpu(p)^.opcode := A_FSUBR; + A_FSUBRP: Paicpu(p)^.opcode := A_FSUB; + A_FDIVP: Paicpu(p)^.opcode := A_FDIVR; + A_FDIVRP: Paicpu(p)^.opcode := A_FDIV; + End; + AsmL^.Remove(hp2); + Dispose(hp2, Done) + End + End + End + End; + A_FSTP,A_FISTP: + if doFpuLoadStoreOpt(asmL,p) then + continue; + A_IMUL: + {changes certain "imul const, %reg"'s to lea sequences} + Begin + If (Paicpu(p)^.oper[0].typ = Top_Const) And + (Paicpu(p)^.oper[1].typ = Top_Reg) And + (Paicpu(p)^.opsize = S_L) Then + If (Paicpu(p)^.oper[0].val = 1) Then + If (Paicpu(p)^.oper[2].typ = Top_None) Then + {remove "imul $1, reg"} + Begin + hp1 := Pai(p^.Next); + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue; + End + Else + {change "imul $1, reg1, reg2" to "mov reg1, reg2"} + Begin + hp1 := New(Paicpu, Op_Reg_Reg(A_MOV, S_L, Paicpu(p)^.oper[1].reg,Paicpu(p)^.oper[2].reg)); + InsertLLItem(AsmL, p^.previous, p^.next, hp1); + Dispose(p, Done); + p := hp1; + End + Else If + ((Paicpu(p)^.oper[2].typ = Top_Reg) or + (Paicpu(p)^.oper[2].typ = Top_None)) And + (aktoptprocessor < ClassP6) And + (Paicpu(p)^.oper[0].val <= 12) And + Not(CS_LittleSize in aktglobalswitches) And + (Not(GetNextInstruction(p, hp1)) Or + {GetNextInstruction(p, hp1) And} + Not((Pai(hp1)^.typ = ait_instruction) And + ((paicpu(hp1)^.opcode=A_Jcc) and + (paicpu(hp1)^.condition in [C_O,C_NO])))) + Then + Begin + Reset_reference(tmpref); + Case Paicpu(p)^.oper[0].val Of + 3: Begin + {imul 3, reg1, reg2 to + lea (reg1,reg1,2), reg2 + imul 3, reg1 to + lea (reg1,reg1,2), reg1} + TmpRef.base := Paicpu(p)^.oper[1].reg; + TmpRef.Index := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 2; + If (Paicpu(p)^.oper[2].typ = Top_None) Then + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)) + Else + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := hp1; + End; + 5: Begin + {imul 5, reg1, reg2 to + lea (reg1,reg1,4), reg2 + imul 5, reg1 to + lea (reg1,reg1,4), reg1} + TmpRef.base := Paicpu(p)^.oper[1].reg; + TmpRef.Index := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 4; + If (Paicpu(p)^.oper[2].typ = Top_None) Then + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)) + Else + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := hp1; + End; + 6: Begin + {imul 6, reg1, reg2 to + lea (,reg1,2), reg2 + lea (reg2,reg1,4), reg2 + imul 6, reg1 to + lea (reg1,reg1,2), reg1 + add reg1, reg1} + If (aktoptprocessor <= Class386) + Then + Begin + TmpRef.Index := Paicpu(p)^.oper[1].reg; + If (Paicpu(p)^.oper[2].typ = Top_Reg) + Then + Begin + TmpRef.base := Paicpu(p)^.oper[2].reg; + TmpRef.ScaleFactor := 4; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + End + Else + Begin + hp1 := New(Paicpu, op_reg_reg(A_ADD, S_L, + Paicpu(p)^.oper[1].reg,Paicpu(p)^.oper[1].reg)); + End; + InsertLLItem(AsmL,p, p^.next, hp1); + Reset_reference(tmpref); + TmpRef.Index := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 2; + If (Paicpu(p)^.oper[2].typ = Top_Reg) + Then + Begin + TmpRef.base := R_NO; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), + Paicpu(p)^.oper[2].reg)); + End + Else + Begin + TmpRef.base := Paicpu(p)^.oper[1].reg; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + End; + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := Pai(hp1^.next); + End + End; + 9: Begin + {imul 9, reg1, reg2 to + lea (reg1,reg1,8), reg2 + imul 9, reg1 to + lea (reg1,reg1,8), reg1} + TmpRef.base := Paicpu(p)^.oper[1].reg; + TmpRef.Index := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 8; + If (Paicpu(p)^.oper[2].typ = Top_None) Then + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)) + Else + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := hp1; + End; + 10: Begin + {imul 10, reg1, reg2 to + lea (reg1,reg1,4), reg2 + add reg2, reg2 + imul 10, reg1 to + lea (reg1,reg1,4), reg1 + add reg1, reg1} + If (aktoptprocessor <= Class386) Then + Begin + If (Paicpu(p)^.oper[2].typ = Top_Reg) Then + hp1 := New(Paicpu, op_reg_reg(A_ADD, S_L, + Paicpu(p)^.oper[2].reg,Paicpu(p)^.oper[2].reg)) + Else + hp1 := New(Paicpu, op_reg_reg(A_ADD, S_L, + Paicpu(p)^.oper[1].reg,Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p, p^.next, hp1); + TmpRef.base := Paicpu(p)^.oper[1].reg; + TmpRef.Index := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 4; + If (Paicpu(p)^.oper[2].typ = Top_Reg) + Then + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)) + Else + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := Pai(hp1^.next); + End + End; + 12: Begin + {imul 12, reg1, reg2 to + lea (,reg1,4), reg2 + lea (,reg1,8) reg2 + imul 12, reg1 to + lea (reg1,reg1,2), reg1 + lea (,reg1,4), reg1} + If (aktoptprocessor <= Class386) + Then + Begin + TmpRef.Index := Paicpu(p)^.oper[1].reg; + If (Paicpu(p)^.oper[2].typ = Top_Reg) Then + Begin + TmpRef.base := Paicpu(p)^.oper[2].reg; + TmpRef.ScaleFactor := 8; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)); + End + Else + Begin + TmpRef.base := R_NO; + TmpRef.ScaleFactor := 4; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + End; + InsertLLItem(AsmL,p, p^.next, hp1); + Reset_reference(tmpref); + TmpRef.Index := Paicpu(p)^.oper[1].reg; + If (Paicpu(p)^.oper[2].typ = Top_Reg) Then + Begin + TmpRef.base := R_NO; + TmpRef.ScaleFactor := 4; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[2].reg)); + End + Else + Begin + TmpRef.base := Paicpu(p)^.oper[1].reg; + TmpRef.ScaleFactor := 2; + hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + End; + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := Pai(hp1^.next); + End + End + End; + End; + End; + A_LEA: + Begin + {removes seg register prefixes from LEA operations, as they + don't do anything} + Paicpu(p)^.oper[0].ref^.Segment := R_NO; + {changes "lea (%reg1), %reg2" into "mov %reg1, %reg2"} + If (Paicpu(p)^.oper[0].ref^.Base In [R_EAX..R_EDI]) And + (Paicpu(p)^.oper[0].ref^.Index = R_NO) And +{$ifndef newOptimizations} + (Paicpu(p)^.oper[0].ref^.Offset = 0) And +{$endif newOptimizations} + (Not(Assigned(Paicpu(p)^.oper[0].ref^.Symbol))) Then + If (Paicpu(p)^.oper[0].ref^.Base <> Paicpu(p)^.oper[1].reg) +{$ifdef newOptimizations} + and (Paicpu(p)^.oper[0].ref^.Offset = 0) +{$endif newOptimizations} + Then + Begin + hp1 := New(Paicpu, op_reg_reg(A_MOV, S_L,Paicpu(p)^.oper[0].ref^.Base, + Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous,p^.next, hp1); + Dispose(p, Done); + p := hp1; + Continue; + End + Else +{$ifdef newOptimizations} + if (Paicpu(p)^.oper[0].ref^.Offset = 0) then +{$endif newOptimizations} + Begin + hp1 := Pai(p^.Next); + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue; + End +{$ifdef newOptimizations} + else + with Paicpu(p)^.oper[0].ref^ do + if (Base = Paicpu(p)^.oper[1].reg) then + begin + l := offset+offsetfixup; + case l of + 1,-1: + begin + if l = 1 then + paicpu(p)^.opcode := A_INC + else paicpu(p)^.opcode := A_DEC; + paicpu(p)^.loadreg(0,Paicpu(p)^.oper[1].reg); + paicpu(p)^.ops := 1; + end; + else + begin + paicpu(p)^.opcode := A_ADD; + paicpu(p)^.loadconst(0,offset+offsetfixup); + end; + end; + end; +{$endif newOptimizations} + + End; + A_MOV: + Begin + TmpUsedRegs := UsedRegs; + If (Paicpu(p)^.oper[1].typ = top_reg) And + (Paicpu(p)^.oper[1].reg In [R_EAX, R_EBX, R_EDX, R_EDI]) And + GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_MOV) And + (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = Paicpu(p)^.oper[1].reg) + Then + {we have "mov x, %treg; mov %treg, y} + If not(RegUsedAfterInstruction(Paicpu(p)^.oper[1].reg, hp1, TmpUsedRegs)) then + {we've got "mov x, %treg; mov %treg, y; with %treg is not used after } + Case Paicpu(p)^.oper[0].typ Of + top_reg: + Begin + { change "mov %reg, %treg; mov %treg, y" + to "mov %reg, y" } + Paicpu(p)^.LoadOper(1,Paicpu(hp1)^.oper[1]); + AsmL^.Remove(hp1); + Dispose(hp1, Done); + continue; + End; + top_ref: + If (Paicpu(hp1)^.oper[1].typ = top_reg) Then + Begin + { change "mov mem, %treg; mov %treg, %reg" + to "mov mem, %reg" } + Paicpu(p)^.Loadoper(1,Paicpu(hp1)^.oper[1]); + AsmL^.Remove(hp1); + Dispose(hp1, Done); + continue; + End; + End + Else + Else + {Change "mov %reg1, %reg2; xxx %reg2, ???" to + "mov %reg1, %reg2; xxx %reg1, ???" to avoid a write/read + penalty} + If (Paicpu(p)^.oper[0].typ = top_reg) And + (Paicpu(p)^.oper[1].typ = top_reg) And + GetNextInstruction(p,hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = Paicpu(p)^.oper[1].reg) + Then + {we have "mov %reg1, %reg2; XXX %reg2, ???"} + Begin + If ((Paicpu(hp1)^.opcode = A_OR) Or + (Paicpu(hp1)^.opcode = A_TEST)) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = Paicpu(hp1)^.oper[1].reg) + Then + {we have "mov %reg1, %reg2; test/or %reg2, %reg2"} + Begin + TmpUsedRegs := UsedRegs; + { reg1 will be used after the first instruction, } + { so update the allocation info } + allocRegBetween(asmL,paicpu(p)^.oper[0].reg,p,hp1); + If GetNextInstruction(hp1, hp2) And + (hp2^.typ = ait_instruction) And + paicpu(hp2)^.is_jmp and + Not(RegUsedAfterInstruction(Paicpu(hp1)^.oper[0].reg, hp1, TmpUsedRegs)) + Then + {change "mov %reg1, %reg2; test/or %reg2, %reg2; jxx" to + "test %reg1, %reg1; jxx"} + Begin + Paicpu(hp1)^.Loadoper(0,Paicpu(p)^.oper[0]); + Paicpu(hp1)^.Loadoper(1,Paicpu(p)^.oper[0]); + AsmL^.Remove(p); + Dispose(p, done); + p := hp1; + continue + End + Else + {change "mov %reg1, %reg2; test/or %reg2, %reg2" to + "mov %reg1, %reg2; test/or %reg1, %reg1"} + Begin + Paicpu(hp1)^.Loadoper(0,Paicpu(p)^.oper[0]); + Paicpu(hp1)^.Loadoper(1,Paicpu(p)^.oper[0]); + End; + End +{ Else + If (Paicpu(p^.next)^.opcode + In [A_PUSH, A_OR, A_XOR, A_AND, A_TEST])} + {change "mov %reg1, %reg2; push/or/xor/... %reg2, ???" to + "mov %reg1, %reg2; push/or/xor/... %reg1, ???"} + End + Else + {leave out the mov from "mov reg, x(%frame_pointer); leave/ret" (with + x >= RetOffset) as it doesn't do anything (it writes either to a + parameter or to the temporary storage room for the function + result)} + If GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) + Then + If ((Paicpu(hp1)^.opcode = A_LEAVE) Or + (Paicpu(hp1)^.opcode = A_RET)) And + (Paicpu(p)^.oper[1].typ = top_ref) And + (Paicpu(p)^.oper[1].ref^.base = procinfo^.FramePointer) And + (Paicpu(p)^.oper[1].ref^.offset >= procinfo^.Return_Offset) And + (Paicpu(p)^.oper[1].ref^.index = R_NO) And + (Paicpu(p)^.oper[0].typ = top_reg) + Then + Begin + AsmL^.Remove(p); + Dispose(p, done); + p := hp1; + RemoveLastDeallocForFuncRes(asmL,p); + End + Else + If (Paicpu(p)^.oper[0].typ = top_reg) And + (Paicpu(p)^.oper[1].typ = top_ref) And + (Paicpu(p)^.opsize = Paicpu(hp1)^.opsize) And + (Paicpu(hp1)^.opcode = A_CMP) And + (Paicpu(hp1)^.oper[1].typ = top_ref) And + RefsEqual(Paicpu(p)^.oper[1].ref^, Paicpu(hp1)^.oper[1].ref^) Then + {change "mov reg1, mem1; cmp x, mem1" to "mov reg, mem1; cmp x, reg1"} + begin + Paicpu(hp1)^.loadreg(1,Paicpu(p)^.oper[0].reg); + allocRegBetween(asmL,paicpu(p)^.oper[0].reg,p,hp1); + end; + { Next instruction is also a MOV ? } + If GetNextInstruction(p, hp1) And + (pai(hp1)^.typ = ait_instruction) and + (Paicpu(hp1)^.opcode = A_MOV) and + (Paicpu(hp1)^.opsize = Paicpu(p)^.opsize) + Then + Begin + If (Paicpu(hp1)^.oper[0].typ = Paicpu(p)^.oper[1].typ) and + (Paicpu(hp1)^.oper[1].typ = Paicpu(p)^.oper[0].typ) + Then + {mov reg1, mem1 or mov mem1, reg1 + mov mem2, reg2 mov reg2, mem2} + Begin + If OpsEqual(Paicpu(hp1)^.oper[1],Paicpu(p)^.oper[0]) Then + {mov reg1, mem1 or mov mem1, reg1 + mov mem2, reg1 mov reg2, mem1} + Begin + If OpsEqual(Paicpu(hp1)^.oper[0],Paicpu(p)^.oper[1]) Then + { Removes the second statement from + mov reg1, mem1/reg2 + mov mem1/reg2, reg1 } + Begin + if (paicpu(p)^.oper[0].typ = top_reg) then + AllocRegBetween(asmL,paicpu(p)^.oper[0].reg,p,hp1); + AsmL^.remove(hp1); + Dispose(hp1,done); + End + Else + Begin + TmpUsedRegs := UsedRegs; + UpdateUsedRegs(TmpUsedRegs, Pai(hp1^.next)); + If (Paicpu(p)^.oper[0].typ = top_reg) And + { mov reg1, mem1 + mov mem2, reg1 } + GetNextInstruction(hp1, hp2) And + (hp2^.typ = ait_instruction) And + (Paicpu(hp2)^.opcode = A_CMP) And + (Paicpu(hp2)^.opsize = Paicpu(p)^.opsize) and + (Paicpu(hp2)^.oper[0].typ = TOp_Ref) And + (Paicpu(hp2)^.oper[1].typ = TOp_Reg) And + RefsEqual(Paicpu(hp2)^.oper[0].ref^, Paicpu(p)^.oper[1].ref^) And + (Paicpu(hp2)^.oper[1].reg = Paicpu(p)^.oper[0].reg) And + Not(RegUsedAfterInstruction(Paicpu(p)^.oper[0].reg, hp2, TmpUsedRegs)) Then + { change to + mov reg1, mem1 mov reg1, mem1 + mov mem2, reg1 cmp reg1, mem2 + cmp mem1, reg1 } + Begin + AsmL^.Remove(hp2); + Dispose(hp2, Done); + Paicpu(hp1)^.opcode := A_CMP; + Paicpu(hp1)^.loadref(1,newreference(Paicpu(hp1)^.oper[0].ref^)); + Paicpu(hp1)^.loadreg(0,Paicpu(p)^.oper[0].reg); + End; + End; + End + Else + Begin + tmpUsedRegs := UsedRegs; + If GetNextInstruction(hp1, hp2) And + (Paicpu(p)^.oper[0].typ = top_ref) And + (Paicpu(p)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg = Paicpu(p)^.oper[1].reg) And + (Paicpu(hp1)^.oper[1].typ = top_ref) And + (Pai(hp2)^.typ = ait_instruction) And + (Paicpu(hp2)^.opcode = A_MOV) And + (Paicpu(hp2)^.opsize = Paicpu(p)^.opsize) and + (Paicpu(hp2)^.oper[1].typ = top_reg) And + (Paicpu(hp2)^.oper[0].typ = top_ref) And + RefsEqual(Paicpu(hp2)^.oper[0].ref^, Paicpu(hp1)^.oper[1].ref^) Then + If not regInRef(Paicpu(hp2)^.oper[1].reg,Paicpu(hp2)^.oper[0].ref^) and + (Paicpu(p)^.oper[1].reg in [R_DI,R_EDI]) and + not(RegUsedAfterInstruction(R_EDI,hp1,tmpUsedRegs)) Then + { mov mem1, %edi + mov %edi, mem2 + mov mem2, reg2 + to: + mov mem1, reg2 + mov reg2, mem2} + Begin + Paicpu(p)^.Loadoper(1,Paicpu(hp2)^.oper[1]); + Paicpu(hp1)^.loadoper(0,Paicpu(hp2)^.oper[1]); + AsmL^.Remove(hp2); + Dispose(hp2,Done); + End + Else + If (Paicpu(p)^.oper[1].reg <> Paicpu(hp2)^.oper[1].reg) And + not(RegInRef(Paicpu(p)^.oper[1].reg,Paicpu(p)^.oper[0].ref^)) And + not(RegInRef(Paicpu(hp2)^.oper[1].reg,Paicpu(hp2)^.oper[0].ref^)) + Then + { mov mem1, reg1 mov mem1, reg1 + mov reg1, mem2 mov reg1, mem2 + mov mem2, reg2 mov mem2, reg1 + to: to: + mov mem1, reg1 mov mem1, reg1 + mov mem1, reg2 mov reg1, mem2 + mov reg1, mem2 + + or (if mem1 depends on reg1 + and/or if mem2 depends on reg2) + to: + mov mem1, reg1 + mov reg1, mem2 + mov reg1, reg2 + } + Begin + Paicpu(hp1)^.LoadRef(0,newreference(Paicpu(p)^.oper[0].ref^)); + Paicpu(hp1)^.LoadReg(1,Paicpu(hp2)^.oper[1].reg); + Paicpu(hp2)^.LoadRef(1,newreference(Paicpu(hp2)^.oper[0].ref^)); + Paicpu(hp2)^.LoadReg(0,Paicpu(p)^.oper[1].reg); + allocRegBetween(asmL,paicpu(p)^.oper[1].reg,p,hp2); + if (paicpu(p)^.oper[0].ref^.base in (usableregs+[R_EDI])) then + allocRegBetween(asmL,paicpu(p)^.oper[0].ref^.base,p,hp2); + if (paicpu(p)^.oper[0].ref^.index in (usableregs+[R_EDI])) then + allocRegBetween(asmL,paicpu(p)^.oper[0].ref^.index,p,hp2); + End + Else + If (Paicpu(hp1)^.Oper[0].reg <> Paicpu(hp2)^.Oper[1].reg) Then + begin + Paicpu(hp2)^.LoadReg(0,Paicpu(hp1)^.Oper[0].reg); + allocRegBetween(asmL,paicpu(p)^.oper[1].reg,p,hp2); + end + else + begin + asmL^.Remove(hp2); + dispose(hp2, done); + end + End; + End + Else +(* {movl [mem1],reg1 + movl [mem1],reg2 + to: + movl [mem1],reg1 + movl reg1,reg2 } + If (Paicpu(p)^.oper[0].typ = top_ref) and + (Paicpu(p)^.oper[1].typ = top_reg) and + (Paicpu(hp1)^.oper[0].typ = top_ref) and + (Paicpu(hp1)^.oper[1].typ = top_reg) and + (Paicpu(p)^.opsize = Paicpu(hp1)^.opsize) and + RefsEqual(TReference(Paicpu(p)^.oper[0]^),Paicpu(hp1)^.oper[0]^.ref^) and + (Paicpu(p)^.oper[1].reg<>Paicpu(hp1)^.oper[0]^.ref^.base) and + (Paicpu(p)^.oper[1].reg<>Paicpu(hp1)^.oper[0]^.ref^.index) then + Paicpu(hp1)^.LoadReg(0,Paicpu(p)^.oper[1].reg) + Else*) + { movl const1,[mem1] + movl [mem1],reg1 + to: + movl const1,reg1 + movl reg1,[mem1] } + If (Paicpu(p)^.oper[0].typ = top_const) and + (Paicpu(p)^.oper[1].typ = top_ref) and + (Paicpu(hp1)^.oper[0].typ = top_ref) and + (Paicpu(hp1)^.oper[1].typ = top_reg) and + (Paicpu(p)^.opsize = Paicpu(hp1)^.opsize) and + RefsEqual(Paicpu(hp1)^.oper[0].ref^,Paicpu(p)^.oper[1].ref^) then + Begin + allocregbetween(asml,Paicpu(hp1)^.oper[1].reg,p,hp1); + { allocregbetween doesn't insert this because at } + { this time, no regalloc info is available in } + { the optinfo field, so do it manually (JM) } + hp2 := new(paiRegalloc,alloc(Paicpu(hp1)^.oper[1].reg)); + insertllitem(asml,p^.previous,p,hp2); + Paicpu(hp1)^.LoadReg(0,Paicpu(hp1)^.oper[1].reg); + Paicpu(hp1)^.LoadRef(1,newreference(Paicpu(p)^.oper[1].ref^)); + Paicpu(p)^.LoadReg(1,Paicpu(hp1)^.oper[0].reg); + End + End; + End; + A_MOVZX: + Begin + {removes superfluous And's after movzx's} + If (Paicpu(p)^.oper[1].typ = top_reg) And + GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) + Then + Case Paicpu(p)^.opsize Of + S_BL, S_BW: + If (Paicpu(hp1)^.oper[0].val = $ff) Then + Begin + AsmL^.Remove(hp1); + Dispose(hp1, Done); + End; + S_WL: + If (Paicpu(hp1)^.oper[0].val = $ffff) Then + Begin + AsmL^.Remove(hp1); + Dispose(hp1, Done); + End; + End; + {changes some movzx constructs to faster synonims (all examples + are given with eax/ax, but are also valid for other registers)} + If (Paicpu(p)^.oper[1].typ = top_reg) Then + If (Paicpu(p)^.oper[0].typ = top_reg) Then + Case Paicpu(p)^.opsize of + S_BW: + Begin + If (Paicpu(p)^.oper[0].reg = Reg16ToReg8(Paicpu(p)^.oper[1].reg)) And + Not(CS_LittleSize In aktglobalswitches) + Then + {Change "movzbw %al, %ax" to "andw $0x0ffh, %ax"} + Begin + Paicpu(p)^.opcode := A_AND; + Paicpu(p)^.changeopsize(S_W); + Paicpu(p)^.LoadConst(0,$ff); + End + Else + If GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) + Then + {Change "movzbw %reg1, %reg2; andw $const, %reg2" + to "movw %reg1, reg2; andw $(const1 and $ff), %reg2"} + Begin + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.changeopsize(S_W); + Paicpu(p)^.LoadReg(0,Reg8ToReg16(Paicpu(p)^.oper[0].reg)); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ff); + End; + End; + S_BL: + Begin + If (Paicpu(p)^.oper[0].reg = Reg32ToReg8(Paicpu(p)^.oper[1].reg)) And + Not(CS_LittleSize in aktglobalswitches) + Then + {Change "movzbl %al, %eax" to "andl $0x0ffh, %eax"} + Begin + Paicpu(p)^.opcode := A_AND; + Paicpu(p)^.changeopsize(S_L); + Paicpu(p)^.loadconst(0,$ff) + End + Else + If GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) + Then + {Change "movzbl %reg1, %reg2; andl $const, %reg2" + to "movl %reg1, reg2; andl $(const1 and $ff), %reg2"} + Begin + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.changeopsize(S_L); + Paicpu(p)^.LoadReg(0,Reg8ToReg32(Paicpu(p)^.oper[0].reg)); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ff); + End + End; + S_WL: + Begin + If (Paicpu(p)^.oper[0].reg = Reg32ToReg16(Paicpu(p)^.oper[1].reg)) And + Not(CS_LittleSize In aktglobalswitches) + Then + {Change "movzwl %ax, %eax" to "andl $0x0ffffh, %eax"} + Begin + Paicpu(p)^.opcode := A_AND; + Paicpu(p)^.changeopsize(S_L); + Paicpu(p)^.LoadConst(0,$ffff); + End + Else + If GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = top_const) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) + Then + {Change "movzwl %reg1, %reg2; andl $const, %reg2" + to "movl %reg1, reg2; andl $(const1 and $ffff), %reg2"} + Begin + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.changeopsize(S_L); + Paicpu(p)^.LoadReg(0,Reg16ToReg32(Paicpu(p)^.oper[0].reg)); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ffff); + End; + End; + End + Else + If (Paicpu(p)^.oper[0].typ = top_ref) Then + Begin + If GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_AND) And + (Paicpu(hp1)^.oper[0].typ = Top_Const) And + (Paicpu(hp1)^.oper[1].typ = Top_Reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) Then + Begin + Paicpu(p)^.opcode := A_MOV; + Case Paicpu(p)^.opsize Of + S_BL: + Begin + Paicpu(p)^.changeopsize(S_L); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ff); + End; + S_WL: + Begin + Paicpu(p)^.changeopsize(S_L); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ffff); + End; + S_BW: + Begin + Paicpu(p)^.changeopsize(S_W); + Paicpu(hp1)^.LoadConst(0,Paicpu(hp1)^.oper[0].val And $ff); + End; + End; + End; + End; + End; + A_POP: + Begin + if (Paicpu(p)^.oper[0].typ = top_reg) And + GetNextInstruction(p, hp1) And + (pai(hp1)^.typ=ait_instruction) and + (Paicpu(hp1)^.opcode=A_PUSH) and + (Paicpu(hp1)^.oper[0].typ = top_reg) And + (Paicpu(hp1)^.oper[0].reg=Paicpu(p)^.oper[0].reg) then + { This can't be done, because the register which is popped + can still be used after the push (PFV) + If (Not(cs_regalloc in aktglobalswitches)) Then + Begin + hp2:=pai(hp1^.next); + asml^.remove(p); + asml^.remove(hp1); + dispose(p,done); + dispose(hp1,done); + p:=hp2; + continue + End + Else } + Begin + { change it to a two op operation } + Paicpu(p)^.oper[1].typ:=top_none; + Paicpu(p)^.ops:=2; + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.Loadoper(1,Paicpu(p)^.oper[0]); + Reset_reference(tmpref); + TmpRef.base := R_ESP; + Paicpu(p)^.LoadRef(0,newReference(TmpRef)); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End; + end; + A_PUSH: + Begin + If (Paicpu(p)^.opsize = S_W) And + (Paicpu(p)^.oper[0].typ = Top_Const) And + GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_PUSH) And + (Paicpu(hp1)^.oper[0].typ = Top_Const) And + (Paicpu(hp1)^.opsize = S_W) Then + Begin + Paicpu(p)^.changeopsize(S_L); + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val shl 16 + word(Paicpu(hp1)^.oper[0].val)); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End; + End; + A_SHL, A_SAL: + Begin + If (Paicpu(p)^.oper[0].typ = Top_Const) And + (Paicpu(p)^.oper[1].typ = Top_Reg) And + (Paicpu(p)^.opsize = S_L) And + (Paicpu(p)^.oper[0].val <= 3) + {Changes "shl const, %reg32; add const/reg, %reg32" to one lea statement} + Then + Begin + TmpBool1 := True; {should we check the next instruction?} + TmpBool2 := False; {have we found an add/sub which could be + integrated in the lea?} + Reset_reference(tmpref); + TmpRef.index := Paicpu(p)^.oper[1].reg; + TmpRef.scalefactor := 1 shl Paicpu(p)^.oper[0].val; + While TmpBool1 And + GetNextInstruction(p, hp1) And + (Pai(hp1)^.typ = ait_instruction) And + ((Paicpu(hp1)^.opcode = A_ADD) Or + (Paicpu(hp1)^.opcode = A_SUB)) And + (Paicpu(hp1)^.oper[1].typ = Top_Reg) And + (Paicpu(hp1)^.oper[1].reg = Paicpu(p)^.oper[1].reg) Do + Begin + TmpBool1 := False; + If (Paicpu(hp1)^.oper[0].typ = Top_Const) + Then + Begin + TmpBool1 := True; + TmpBool2 := True; + If Paicpu(hp1)^.opcode = A_ADD Then + Inc(TmpRef.offset, Paicpu(hp1)^.oper[0].val) + Else + Dec(TmpRef.offset, Paicpu(hp1)^.oper[0].val); + AsmL^.Remove(hp1); + Dispose(hp1, Done); + End + Else + If (Paicpu(hp1)^.oper[0].typ = Top_Reg) And + (Paicpu(hp1)^.opcode = A_ADD) And + (TmpRef.base = R_NO) Then + Begin + TmpBool1 := True; + TmpBool2 := True; + TmpRef.base := Paicpu(hp1)^.oper[0].reg; + AsmL^.Remove(hp1); + Dispose(hp1, Done); + End; + End; + If TmpBool2 Or + ((aktoptprocessor < ClassP6) And + (Paicpu(p)^.oper[0].val <= 3) And + Not(CS_LittleSize in aktglobalswitches)) + Then + Begin + If Not(TmpBool2) And + (Paicpu(p)^.oper[0].val = 1) + Then + Begin + hp1 := new(Paicpu,op_reg_reg(A_ADD,Paicpu(p)^.opsize, + Paicpu(p)^.oper[1].reg, Paicpu(p)^.oper[1].reg)) + End + Else hp1 := New(Paicpu, op_ref_reg(A_LEA, S_L, newReference(TmpRef), + Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, Done); + p := hp1; + End; + End + Else + If (aktoptprocessor < ClassP6) And + (Paicpu(p)^.oper[0].typ = top_const) And + (Paicpu(p)^.oper[1].typ = top_reg) Then + If (Paicpu(p)^.oper[0].val = 1) + Then + {changes "shl $1, %reg" to "add %reg, %reg", which is the same on a 386, + but faster on a 486, and pairable in both U and V pipes on the Pentium + (unlike shl, which is only pairable in the U pipe)} + Begin + hp1 := new(Paicpu,op_reg_reg(A_ADD,Paicpu(p)^.opsize, + Paicpu(p)^.oper[1].reg, Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, done); + p := hp1; + End + Else If (Paicpu(p)^.opsize = S_L) and + (Paicpu(p)^.oper[0].val<= 3) Then + {changes "shl $2, %reg" to "lea (,%reg,4), %reg" + "shl $3, %reg" to "lea (,%reg,8), %reg} + Begin + Reset_reference(tmpref); + TmpRef.index := Paicpu(p)^.oper[1].reg; + TmpRef.scalefactor := 1 shl Paicpu(p)^.oper[0].val; + hp1 := new(Paicpu,op_ref_reg(A_LEA,S_L,newReference(TmpRef), Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p^.next, hp1); + Dispose(p, done); + p := hp1; + End + End; + A_SAR, A_SHR: + {changes the code sequence + shr/sar const1, x + shl const2, x + to either "sar/and", "shl/and" or just "and" depending on const1 and const2} + Begin + If GetNextInstruction(p, hp1) And + (pai(hp1)^.typ = ait_instruction) and + (Paicpu(hp1)^.opcode = A_SHL) and + (Paicpu(p)^.oper[0].typ = top_const) and + (Paicpu(hp1)^.oper[0].typ = top_const) and + (Paicpu(hp1)^.opsize = Paicpu(p)^.opsize) And + (Paicpu(hp1)^.oper[1].typ = Paicpu(p)^.oper[1].typ) And + OpsEqual(Paicpu(hp1)^.oper[1], Paicpu(p)^.oper[1]) + Then + If (Paicpu(p)^.oper[0].val > Paicpu(hp1)^.oper[0].val) And + Not(CS_LittleSize In aktglobalswitches) + Then + { shr/sar const1, %reg + shl const2, %reg + with const1 > const2 } + Begin + Paicpu(p)^.LoadConst(0,Paicpu(p)^.oper[0].val-Paicpu(hp1)^.oper[0].val); + Paicpu(hp1)^.opcode := A_AND; + l := (1 shl (Paicpu(hp1)^.oper[0].val)) - 1; + Case Paicpu(p)^.opsize Of + S_L: Paicpu(hp1)^.LoadConst(0,l Xor longint(-1)); + S_B: Paicpu(hp1)^.LoadConst(0,l Xor $ff); + S_W: Paicpu(hp1)^.LoadConst(0,l Xor $ffff); + End; + End + Else + If (Paicpu(p)^.oper[0].val= procinfo^.Return_Offset) And + (hp1^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_MOV) And + (Paicpu(hp1)^.opsize = S_B) And + (Paicpu(hp1)^.oper[0].typ = top_ref) And + RefsEqual(Paicpu(hp1)^.oper[0].ref^, Paicpu(p)^.oper[0].ref^) Then + Begin + Paicpu(p)^.LoadReg(0,Paicpu(hp1)^.oper[1].reg); + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End + End; + A_SUB: + { * change "subl $2, %esp; pushw x" to "pushl x"} + { * change "sub/add const1, reg" or "dec reg" followed by + "sub const2, reg" to one "sub ..., reg" } + Begin + If (Paicpu(p)^.oper[0].typ = top_const) And + (Paicpu(p)^.oper[1].typ = top_reg) Then + If (Paicpu(p)^.oper[0].val = 2) And + (Paicpu(p)^.oper[1].reg = R_ESP) and + { Don't do the sub/push optimization if the sub } + { comes from setting up the stack frame (JM) } + (not getLastInstruction(p,hp1) or + (hp1^.typ <> ait_instruction) or + (paicpu(hp1)^.opcode <> A_MOV) or + (paicpu(hp1)^.oper[0].typ <> top_reg) or + (paicpu(hp1)^.oper[0].reg <> R_ESP) or + (paicpu(hp1)^.oper[1].typ <> top_reg) or + (paicpu(hp1)^.oper[1].reg <> R_EBP)) then + Begin + hp1 := Pai(p^.next); + While Assigned(hp1) And + (Pai(hp1)^.typ In [ait_instruction]+SkipInstr) And + Not((Pai(hp1)^.typ = ait_instruction) And + ((Paicpu(hp1)^.opcode = A_CALL) or + (Paicpu(hp1)^.opcode = A_PUSH) or + ((Paicpu(hp1)^.opcode = A_MOV) And + (Paicpu(hp1)^.oper[1].typ = top_ref) And + (Paicpu(hp1)^.oper[1].ref^.base = R_ESP)))) do + hp1 := Pai(hp1^.next); + If Assigned(hp1) And + (Pai(hp1)^.typ = ait_instruction) And + (Paicpu(hp1)^.opcode = A_PUSH) And + (Paicpu(hp1)^.opsize = S_W) + Then + Begin + Paicpu(hp1)^.changeopsize(S_L); + if Paicpu(hp1)^.oper[0].typ=top_reg then + Paicpu(hp1)^.LoadReg(0,Reg16ToReg32(Paicpu(hp1)^.oper[0].reg)); + hp1 := Pai(p^.next); + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue + End; + If DoSubAddOpt(p) Then continue; + End + Else If DoSubAddOpt(p) Then Continue + End; + A_XOR: + If (Paicpu(p)^.oper[0].typ = top_reg) And + (Paicpu(p)^.oper[1].typ = top_reg) And + (Paicpu(p)^.oper[0].reg = Paicpu(p)^.oper[1].reg) then + { temporarily change this to 'mov reg,0' to make it easier } + { for the CSE. Will be changed back in pass 2 } + begin + paicpu(p)^.opcode := A_MOV; + paicpu(p)^.loadconst(0,0); + end; + End; + end; { if is_jmp } + End; +{ ait_label: + Begin + If Not(Pai_Label(p)^.l^.is_used) + Then + Begin + hp1 := Pai(p^.next); + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue + End; + End;} + End; + p:=pai(p^.next); + end; +end; + +{$ifdef foldArithOps} +function isFoldableArithOp(hp1: paicpu; reg: tregister): boolean; +begin + IsFoldableArithOp := False; + case hp1^.opcode of + A_ADD,A_SUB,A_OR,A_XOR,A_AND,A_SHL,A_SHR,A_SAR,A_IMUL: + isFoldableArithOp := + ((paicpu(hp1)^.oper[0].typ = top_reg) or + ((paicpu(hp1)^.oper[0].typ = top_const) and + (hp1^.opcode <> A_IMUL))) and + (paicpu(hp1)^.oper[1].typ = top_reg) and + (paicpu(hp1)^.oper[1].reg = reg); + A_INC,A_DEC: + isFoldableArithOp := + (paicpu(hp1)^.oper[0].typ = top_reg) and + (paicpu(hp1)^.oper[0].reg = reg); + end; +end; +{$endif foldArithOps} + + +Procedure PeepHoleOptPass2(AsmL: PAasmOutput; BlockStart, BlockEnd: Pai); + + function CanBeCMOV(p : pai) : boolean; + + begin + CanBeCMOV:=assigned(p) and (p^.typ=ait_instruction) and + (paicpu(p)^.opcode=A_MOV) and + (paicpu(p)^.opsize in [S_L,S_W]) and + (paicpu(p)^.oper[0].typ in [top_reg,top_ref]) and + (paicpu(p)^.oper[1].typ in [top_reg,top_ref]); + end; + +var + p,hp1,hp2: pai; +{$ifdef USECMOV} + l : longint; + condition : tasmcond; + hp3: pai; +{$endif USECMOV} +{$ifdef foldArithOps} + UsedRegs, TmpUsedRegs: TRegSet; +{$endif foldArithOps} + +Begin + P := BlockStart; +{$ifdef foldArithOps} + UsedRegs := []; +{$endif foldArithOps} + While (P <> BlockEnd) Do + Begin +{$ifdef foldArithOps} + UpdateUsedRegs(UsedRegs, Pai(p^.next)); +{$endif foldArithOps} + Case P^.Typ Of + Ait_Instruction: + Begin + Case Paicpu(p)^.opcode Of + A_CALL: + If (AktOptProcessor < ClassP6) And + GetNextInstruction(p, hp1) And + (hp1^.typ = ait_instruction) And + (paicpu(hp1)^.opcode = A_JMP) Then + Begin + Inc(paicpu(hp1)^.oper[0].sym^.refs); + hp2 := New(Paicpu,op_sym(A_PUSH,S_L,paicpu(hp1)^.oper[0].sym)); + InsertLLItem(AsmL, p^.previous, p, hp2); + Paicpu(p)^.opcode := A_JMP; + AsmL^.Remove(hp1); + Dispose(hp1, Done) + End; + +{$ifdef USECMOV} + A_Jcc: + if (aktspecificoptprocessor=ClassP6) then + begin + { check for + jCC xxx + + xxx: + } + l:=0; + GetNextInstruction(p, hp1); + while assigned(hp1) And + CanBeCMOV(hp1) do + begin + inc(l); + GetNextInstruction(hp1,hp1); + end; + if assigned(hp1) then + begin + if FindLabel(PAsmLabel(paicpu(p)^.oper[0].sym),hp1) then + begin + if (l<=4) and (l>0) then + begin + condition:=inverse_cond[paicpu(p)^.condition]; + GetNextInstruction(p,hp1); + asml^.remove(p); + dispose(p,done); + p:=hp1; + repeat + paicpu(hp1)^.opcode:=A_CMOVcc; + paicpu(hp1)^.condition:=condition; + GetNextInstruction(hp1,hp1); + until not(assigned(hp1)) or + not(CanBeCMOV(hp1)); + asml^.remove(hp1); + dispose(hp1,done); + continue; + end; + end + else + begin + { check further for + jCC xxx + + jmp yyy + xxx: + + yyy: + } + { hp2 points to jmp xxx } + hp2:=hp1; + { skip hp1 to xxx } + GetNextInstruction(hp1, hp1); + if assigned(hp2) and + assigned(hp1) and + (l<=3) and + (hp2^.typ=ait_instruction) and + (paicpu(hp2)^.is_jmp) and + (paicpu(hp2)^.condition=C_None) and + FindLabel(PAsmLabel(paicpu(p)^.oper[0].sym),hp1) then + begin + l:=0; + while assigned(hp1) And + CanBeCMOV(hp1) do + begin + inc(l); + GetNextInstruction(hp1, hp1); + end; + end; + { + if assigned(hp1) and + FindLabel(PAsmLabel(paicpu(hp2)^.oper[0].sym),hp1) then + begin + condition:=inverse_cond[paicpu(p)^.condition]; + GetNextInstruction(p,hp1); + asml^.remove(p); + dispose(p,done); + p:=hp1; + repeat + paicpu(hp1)^.opcode:=A_CMOVcc; + paicpu(hp1)^.condition:=condition; + GetNextInstruction(hp1,hp1); + until not(assigned(hp1)) or + not(CanBeCMOV(hp1)); + hp2:=hp1^.next; + condition:=inverse_cond[condition]; + + asml^.remove(hp1^.next) + dispose(hp1^.next,done); + asml^.remove(hp1); + dispose(hp1,done); + continue; + end; + } + end; + end; + end; +{$endif USECMOV} + A_FSTP,A_FISTP: + if doFpuLoadStoreOpt(asmL,p) then + continue; +{$ifdef foldArithOps} + A_IMUL: + begin + if ((paicpu(p)^.oper[0].typ = top_const) or + (paicpu(p)^.oper[0].typ = top_symbol)) and + (paicpu(p)^.oper[1].typ = top_reg) and + ((paicpu(p)^.oper[2].typ = top_none) or + ((paicpu(p)^.oper[2].typ = top_reg) and + (paicpu(p)^.oper[2].reg = paicpu(p)^.oper[1].reg))) and + getLastInstruction(p,hp1) and + (hp1^.typ = ait_instruction) and + (paicpu(hp1)^.opcode = A_MOV) and + (paicpu(hp1)^.oper[0].typ = top_reg) and + (paicpu(hp1)^.oper[1].typ = top_reg) and + (paicpu(hp1)^.oper[1].reg = paicpu(p)^.oper[1].reg) then + { change "mov reg1,reg2; imul y,reg2" to "imul y,reg1,reg2" } + begin + paicpu(p)^.ops := 3; + paicpu(p)^.loadreg(1,paicpu(hp1)^.oper[0].reg); + paicpu(p)^.loadreg(2,paicpu(hp1)^.oper[1].reg); + asmL^.remove(hp1); + dispose(hp1,done); + end; + end; +{$endif foldArithOps} + A_MOV: + Begin + If (Paicpu(p)^.oper[0].typ = top_reg) And + (Paicpu(p)^.oper[1].typ = top_reg) And + GetNextInstruction(p, hp1) And + (hp1^.typ = ait_Instruction) And + ((Paicpu(hp1)^.opcode = A_MOV) or + (Paicpu(hp1)^.opcode = A_MOVZX) or + (Paicpu(hp1)^.opcode = A_MOVSX)) And + (Paicpu(hp1)^.oper[0].typ = top_ref) And + (Paicpu(hp1)^.oper[1].typ = top_reg) And + ((Paicpu(hp1)^.oper[0].ref^.Base = Paicpu(p)^.oper[1].reg) Or + (Paicpu(hp1)^.oper[0].ref^.Index = Paicpu(p)^.oper[1].reg)) And + (Reg32(Paicpu(hp1)^.oper[1].reg) = Paicpu(p)^.oper[1].reg) Then + {mov reg1, reg2 + mov/zx/sx (reg2, ..), reg2 to mov/zx/sx (reg1, ..), reg2} + Begin + If (Paicpu(hp1)^.oper[0].ref^.Base = Paicpu(p)^.oper[1].reg) Then + Paicpu(hp1)^.oper[0].ref^.Base := Paicpu(p)^.oper[0].reg; + If (Paicpu(hp1)^.oper[0].ref^.Index = Paicpu(p)^.oper[1].reg) Then + Paicpu(hp1)^.oper[0].ref^.Index := Paicpu(p)^.oper[0].reg; + AsmL^.Remove(p); + Dispose(p, Done); + p := hp1; + Continue; + End +{$ifdef foldArithOps} + Else If (Paicpu(p)^.oper[0].typ = top_ref) And + GetNextInstruction(p,hp1) And + (hp1^.typ = ait_instruction) And + IsFoldableArithOp(paicpu(hp1),Paicpu(p)^.oper[1].reg) And + GetNextInstruction(hp1,hp2) And + (hp2^.typ = ait_instruction) And + (Paicpu(hp2)^.opcode = A_MOV) And + (Paicpu(hp2)^.oper[0].typ = top_reg) And + (Paicpu(hp2)^.oper[0].reg = Paicpu(p)^.oper[1].reg) And + (Paicpu(hp2)^.oper[1].typ = top_ref) Then + Begin + TmpUsedRegs := UsedRegs; + UpdateUsedRegs(TmpUsedRegs,Pai(hp1^.next)); + If (RefsEqual(Paicpu(hp2)^.oper[1].ref^, Paicpu(p)^.oper[0].ref^) And + Not(RegUsedAfterInstruction(Paicpu(p)^.oper[1].reg, + hp2, TmpUsedRegs))) + Then + { change mov (ref), reg } + { add/sub/or/... reg2/$const, reg } + { mov reg, (ref) } + { # release reg } + { to add/sub/or/... reg2/$const, (ref) } + Begin + case paicpu(hp1)^.opcode of + A_INC,A_DEC: + paicpu(hp1)^.LoadRef(0,newreference(Paicpu(p)^.oper[0].ref^)) + else + paicpu(hp1)^.LoadRef(1,newreference(Paicpu(p)^.oper[0].ref^)); + end; + AsmL^.Remove(p); + AsmL^.Remove(hp2); + Dispose(p,done); + Dispose(hp2,Done); + p := hp1 + End; + End +{$endif foldArithOps} + else if (Paicpu(p)^.oper[0].typ = Top_Const) And + (Paicpu(p)^.oper[0].val = 0) And + (Paicpu(p)^.oper[1].typ = Top_Reg) Then + { change "mov $0, %reg" into "xor %reg, %reg" } + Begin + Paicpu(p)^.opcode := A_XOR; + Paicpu(p)^.LoadReg(0,Paicpu(p)^.oper[1].reg); + End + End; + A_MOVZX: + Begin + If (Paicpu(p)^.oper[1].typ = top_reg) Then + If (Paicpu(p)^.oper[0].typ = top_reg) + Then + Case Paicpu(p)^.opsize of + S_BL: + Begin + If IsGP32Reg(Paicpu(p)^.oper[1].reg) And + Not(CS_LittleSize in aktglobalswitches) And + (aktoptprocessor = ClassP5) + Then + {Change "movzbl %reg1, %reg2" to + "xorl %reg2, %reg2; movb %reg1, %reg2" for Pentium and + PentiumMMX} + Begin + hp1 := New(Paicpu, op_reg_reg(A_XOR, S_L, + Paicpu(p)^.oper[1].reg, Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p, hp1); + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.changeopsize(S_B); + Paicpu(p)^.LoadReg(1,Reg32ToReg8(Paicpu(p)^.oper[1].reg)); + End; + End; + End + Else + If (Paicpu(p)^.oper[0].typ = top_ref) And + (Paicpu(p)^.oper[0].ref^.base <> Paicpu(p)^.oper[1].reg) And + (Paicpu(p)^.oper[0].ref^.index <> Paicpu(p)^.oper[1].reg) And + Not(CS_LittleSize in aktglobalswitches) And + IsGP32Reg(Paicpu(p)^.oper[1].reg) And + (aktoptprocessor = ClassP5) And + (Paicpu(p)^.opsize = S_BL) + Then + {changes "movzbl mem, %reg" to "xorl %reg, %reg; movb mem, %reg8" for + Pentium and PentiumMMX} + Begin + hp1 := New(Paicpu,op_reg_reg(A_XOR, S_L, Paicpu(p)^.oper[1].reg, + Paicpu(p)^.oper[1].reg)); + Paicpu(p)^.opcode := A_MOV; + Paicpu(p)^.changeopsize(S_B); + Paicpu(p)^.LoadReg(1,Reg32ToReg8(Paicpu(p)^.oper[1].reg)); + InsertLLItem(AsmL,p^.previous, p, hp1); + End; + End; + A_TEST, A_OR: + {removes the line marked with (x) from the sequence + And/or/xor/add/sub/... $x, %y + test/or %y, %y (x) + j(n)z _Label + as the first instruction already adjusts the ZF} + Begin + If OpsEqual(Paicpu(p)^.oper[0],Paicpu(p)^.oper[1]) Then + If GetLastInstruction(p, hp1) And + (pai(hp1)^.typ = ait_instruction) Then + Case Paicpu(hp1)^.opcode Of + A_ADD, A_SUB, A_OR, A_XOR, A_AND, A_SHL, A_SHR: + Begin + If OpsEqual(Paicpu(hp1)^.oper[1],Paicpu(p)^.oper[0]) Then + Begin + hp1 := pai(p^.next); + asml^.remove(p); + dispose(p, done); + p := pai(hp1); + continue + End; + End; + A_DEC, A_INC, A_NEG: + Begin + If OpsEqual(Paicpu(hp1)^.oper[0],Paicpu(p)^.oper[0]) Then + Begin + Case Paicpu(hp1)^.opcode Of + A_DEC, A_INC: + {replace inc/dec with add/sub 1, because inc/dec doesn't set the carry flag} + Begin + Case Paicpu(hp1)^.opcode Of + A_DEC: Paicpu(hp1)^.opcode := A_SUB; + A_INC: Paicpu(hp1)^.opcode := A_ADD; + End; + Paicpu(hp1)^.Loadoper(1,Paicpu(hp1)^.oper[0]); + Paicpu(hp1)^.LoadConst(0,1); + Paicpu(hp1)^.ops:=2; + End + End; + hp1 := pai(p^.next); + asml^.remove(p); + dispose(p, done); + p := pai(hp1); + continue + End; + End + End + End; + End; + End; + End; + p := Pai(p^.next) + End; +End; + +End. + +{ + $Log: not supported by cvs2svn $ + Revision 1.97 2000/07/10 08:00:22 jonas + * real fix for web bug 1032 (removed previous coment since it was false) + + Revision 1.95 2000/07/06 12:30:31 jonas + * moved "; test/or reg,reg" to "" optimization to pass 2 because it caused problems + with -dnewoptimizations + + Revision 1.94 2000/06/14 06:05:06 jonas + + support for inc/dec/imul in foldarithops + + Revision 1.93 2000/05/23 10:58:46 jonas + * fixed bug in "subl $2,%esp; .. ; pushw mem" optimization when the + sub comes from setting up the stack frame instead of from aligning + esp (I hope) + + Revision 1.92 2000/04/23 14:56:36 jonas + * changed "mov reg1, reg2; mov reg2, y" optimization that caused + regalloc info to become invalid (it's still performed, but the + regalloc info stays valid now) + + Revision 1.91 2000/04/16 16:46:43 jonas + * small regalloc fix + + Revision 1.90 2000/03/26 10:58:47 jonas + * some more allocRegBetween fixes (-al didn't function previously + if the compiler was compiled with -OG2p3r) + + Revision 1.89 2000/03/26 08:46:52 jonas + * fixed bug in regUsedAfterInstruction (it didn't convert the reg + to 32bit before checking) + * result: make cycle now works with -OG3p3r!!!! + + Revision 1.88 2000/03/25 18:57:02 jonas + * remove dealloc/alloc of reg1 between "movl %reg1,%reg2; + movl %reg2,%reg1" when removing the second instruction (it + confused the CSE and caused errors with -Or) + + Revision 1.87 2000/02/13 14:21:50 jonas + * modifications to make the compiler functional when compiled with + -Or + + Revision 1.86 2000/02/12 19:28:56 jonas + * fix for imul optimization in popt386 (exclude top_ref as first + argument) + * in csopt386: change "mov reg1,reg2; ; + mov reg2,reg1" to "" (-dnewopt...) + + Revision 1.85 2000/02/12 14:10:15 jonas + + change "mov reg1,reg2;imul x,reg2" to "imul x,reg1,reg2" in popt386 + (-dnewoptimizations) + * shl(d) and shr(d) are considered to have a hardcoded register if + they use cl as shift count (since you can't replace them with + another register) in csopt386 (also for -dnewoptimizations) + + Revision 1.84 2000/02/09 13:22:58 peter + * log truncated + + Revision 1.83 2000/02/04 13:53:04 jonas + * fpuloadstore optimizations are now done before and after the CSE + + Revision 1.82 2000/01/24 12:17:24 florian + * some improvemenst to cmov support + * disabled excpetion frame generation in cosntructors temporarily + + Revision 1.81 2000/01/23 21:29:17 florian + * CMOV support in optimizer (in define USECMOV) + + start of support of exceptions in constructors + + Revision 1.80 2000/01/22 16:05:15 jonas + + change "lea x(reg),reg" to "add x,reg" (-dnewoptimizations) + * detection whether edi is used after instructions (since regalloc + info for it is now available) + * better regUsedAfterInstruction function + + Revision 1.79 2000/01/21 11:26:19 pierre + * bug fix for bug 802 + + Revision 1.78 2000/01/11 17:14:49 jonas + * fixed a serious memory leak + + Revision 1.77 2000/01/09 12:35:02 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.76 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.75 1999/12/30 17:56:44 peter + * fixed and;jmp being translated into test;jmp + + Revision 1.74 1999/12/05 16:48:43 jonas + * CSE of constant loading in regs works properly again + + if a constant is stored into memory using "mov const, ref" and + there is a reg that contains this const, it is changed into + "mov reg, ref" + + Revision 1.73 1999/12/02 11:26:41 peter + * newoptimizations define added + + Revision 1.72 1999/11/30 10:40:45 peter + + ttype, tsymlist + + Revision 1.71 1999/11/27 23:47:55 jonas + + change "mov var,reg; add/shr/... x,reg; mov reg,var" to + "add/shr/... x,var" (if x is a const or reg, suggestion from Peter) + Enable with -dfoldArithOps + + Revision 1.70 1999/11/21 13:09:41 jonas + * fixed some missed optimizations because 8bit regs were not always + taken into account + + Revision 1.69 1999/11/13 19:03:56 jonas + * don't remove align objects between JMP's and labels + + Revision 1.68 1999/11/06 16:24:00 jonas + * getfinaldestination works completely again (a lot of functionality + got lost in the conversion resulting from the removal of + ait_labeled_instruction) + + Revision 1.67 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.66 1999/09/27 23:44:55 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.65 1999/09/05 14:27:19 florian + + fld reg;fxxx to fxxxr reg optimization + + Revision 1.64 1999/08/25 12:00:02 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + +} diff --git a/befpc/compiler/pp.pas b/befpc/compiler/pp.pas new file mode 100644 index 0000000..5f7ef1b --- /dev/null +++ b/befpc/compiler/pp.pas @@ -0,0 +1,351 @@ +{ + $Id: pp.pas,v 1.1.1.1 2001-07-23 17:16:50 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Commandline compiler for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} + +{ + possible compiler switches (* marks a currently required switch): + ----------------------------------------------------------------- + USE_RHIDE generates errors and warning in an format recognized + by rhide + TP to compile the compiler with Turbo or Borland Pascal + GDB* support of the GNU Debugger + I386 generate a compiler for the Intel i386+ + M68K generate a compiler for the M68000 + USEOVERLAY compiles a TP version which uses overlays + DEBUG version with debug code is generated + EXTDEBUG some extra debug code is executed + SUPPORT_MMX only i386: releases the compiler switch + MMX which allows the compiler to generate + MMX instructions + EXTERN_MSG Don't compile the msgfiles in the compiler, always + use external messagefiles, default for TP + NOAG386INT no Intel Assembler output + NOAG386NSM no NASM output + NOAG386BIN leaves out the binary writer, default for TP + LOGMEMBLOCKS adds memory manager which logs the size of + each allocated memory block, the information + is written to memuse.log after compiling + ----------------------------------------------------------------- + + Required switches for a i386 compiler be compiled by Free Pascal Compiler: + GDB;I386 + + Required switches for a i386 compiler be compiled by Turbo Pascal: + GDB;I386;TP + + Required switches for a 68000 compiler be compiled by Turbo Pascal: + GDB;M68k;TP +} + +{$ifdef FPC} + {$ifndef GDB} + { people can try to compile without GDB } + { $error The compiler switch GDB must be defined} + {$endif GDB} + { but I386 or M68K must be defined } + { and only one of the two } + {$ifndef I386} + {$ifndef M68K} + {$fatal One of the switches I386 or M68K must be defined} + {$endif M68K} + {$endif I386} + {$ifdef I386} + {$ifdef M68K} + {$fatal ONLY one of the switches I386 or M68K must be defined} + {$endif M68K} + {$endif I386} + {$ifdef support_mmx} + {$ifndef i386} + {$fatal I386 switch must be on for MMX support} + {$endif i386} + {$endif support_mmx} +{$endif} + +{$ifdef TP} + {$IFNDEF DPMI} + {$M 24000,0,655360} + {$ELSE} + {$M 65000} + {$ENDIF DPMI} + {$E+,N+,F+,S-,R-} +{$endif TP} + + +program pp; + +{$IFDEF TP} + {$UNDEF PROFILE} + {$IFDEF DPMI} + {$UNDEF USEOVERLAY} + {$ENDIF} + {$DEFINE NOAG386BIN} +{$ENDIF} +{$ifdef FPC} + {$UNDEF USEOVERLAY} +{$ENDIF} + +uses +{$ifdef useoverlay} + {$ifopt o+} + Overlay,ppovin, + {$else} + {$error You must compile with the $O+ switch} + {$endif} +{$endif useoverlay} +{$ifdef profile} + profile, +{$endif profile} +{$ifdef FPC} +{$ifdef heaptrc} + ppheap, +{$endif heaptrc} +{$ifdef linux} + catch, +{$endif} +{$ifdef go32v2} + {$ifdef DEBUG} + {$define NOCATCH} + {$endif DEBUG} + catch, +{$endif} +{ we've now a lineinfo unit for all OSes } +{$ifdef DEBUG} +lineinfo, +{$endif DEBUG} +{$endif FPC} + globals,compiler +{$ifdef logmemblocks} +{$ifdef fpc} + ,memlog +{$endif fpc} +{$endif logmemblocks} + ; + +{$ifdef useoverlay} + {$O files} + {$O globals} + {$O hcodegen} + {$O pass_1} + {$O pass_2} + {$O tree} + {$O types} + {$O objects} + {$O options} + {$O cobjects} + {$O globals} + {$O systems} + {$O parser} + {$O pbase} + {$O pdecl} + {$O pexports} + {$O pexpr} + {$O pmodules} + {$O pstatmnt} + {$O psub} + {$O psystem} + {$O ptconst} + {$O script} + {$O switches} + {$O temp_gen} + {$O comphook} + {$O dos} + {$O scanner} + {$O symtable} + {$O objects} + {$O aasm} + {$O link} + {$O assemble} + {$O messages} + {$O gendef} + {$O import} + {$ifdef gdb} + {$O gdb} + {$endif gdb} + {$ifdef i386} + {$O cpubase} + {$O cgai386} + {$O tgeni386} + {$O cg386add} + {$O cg386cal} + {$O cg386cnv} + {$O cg386con} + {$O cg386flw} + {$O cg386ld} + {$O cg386inl} + {$O cg386mat} + {$O cg386set} + {$ifndef NOOPT} + {$O aopt386} + {$O opts386} + {$endif} + {$IfNDef Nora386dir} + {$O ra386dir} + {$endif} + {$IfNDef Nora386int} + {$O ra386int} + {$endif} + {$IfNDef Nora386att} + {$O ra386att} + {$endif} + {$ifndef NoAg386Int} + {$O ag386int} + {$endif} + {$ifndef NoAg386Att} + {$O ag386att} + {$endif} + {$ifndef NoAg386Nsm} + {$O ag386nsm} + {$endif} + {$endif} + {$ifdef m68k} + {$O opts68k} + {$O cpubase} + {$O cga68k} + {$O tgen68k} + {$O cg68kadd} + {$O cg68kcal} + {$O cg68kcnv} + {$O cg68kcon} + {$O cg68kflw} + {$O cg68kld} + {$O cg68kinl} + {$O cg68kmat} + {$O cg68kset} + {$IfNDef Nora68kMot} + {$O ra68kmot} + {$endif} + {$IfNDef Noag68kGas} + {$O ag68kgas} + {$endif} + {$IfNDef Noag68kMot} + {$O ag68kmot} + {$endif} + {$IfNDef Noag68kMit} + {$O ag68kmit} + {$endif} + {$endif} +{$endif useoverlay} + +var + oldexit : pointer; +procedure myexit;{$ifndef FPC}far;{$endif} +begin + exitproc:=oldexit; +{ Show Runtime error if there was an error } + if (erroraddr<>nil) then + begin + + case exitcode of + 100: + begin + erroraddr:=nil; + writeln('Error while reading file'); + end; + 101: + begin + erroraddr:=nil; + writeln('Error while writing file'); + end; + 202: + begin + erroraddr:=nil; + writeln('Error: Stack Overflow'); + end; + 203: + begin + erroraddr:=nil; + writeln('Error: Out of memory'); + end; + end; + { we cannot use aktfilepos.file because all memory might have been + freed already ! + But we can use global parser_current_file var } + Writeln('Compilation aborted ',parser_current_file,':',aktfilepos.line); + end; +end; + +begin + oldexit:=exitproc; + exitproc:=@myexit; +{$ifdef UseOverlay} + InitOverlay; +{$endif} + +{ Call the compiler with empty command, so it will take the parameters } + Halt(compiler.Compile('')); +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.60 2000/04/02 15:22:19 florian + * fixed bug 903: the compiler gives now a nice message if it can't create + the .o file, (same for future .ar) + + Revision 1.59 2000/03/20 09:36:23 florian + * using the directive DEBUG when compiling the compiler will include now + the lineinfo unit on all targets + + Revision 1.58 2000/03/16 10:29:06 florian + * disk full runerror writes now a nice message + + Revision 1.57 2000/03/14 16:30:14 pierre + + lineinfo for win32 with debug + + Revision 1.56 2000/02/18 12:34:43 pierre + DEBUG implies NOCATCH for go32v2 + + Revision 1.55 2000/02/10 23:44:43 florian + * big update for exception handling code generation: possible mem holes + fixed, break/continue/exit should work always now as expected + + Revision 1.54 2000/02/09 13:22:59 peter + * log truncated + + Revision 1.53 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.52 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.51 1999/11/05 13:15:00 florian + * some fixes to get the new cg compiling again + + Revision 1.50 1999/09/17 17:14:10 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.49 1999/09/16 23:05:54 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.48 1999/09/10 18:48:08 florian + * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.47 1999/09/02 18:47:45 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.46 1999/08/28 15:34:20 florian + * bug 519 fixed + + Revision 1.45 1999/08/04 00:23:18 florian + * renamed i386asm and i386base to cpuasm and cpubase +} \ No newline at end of file diff --git a/befpc/compiler/ppc.dpr b/befpc/compiler/ppc.dpr new file mode 100644 index 0000000..2081cea --- /dev/null +++ b/befpc/compiler/ppc.dpr @@ -0,0 +1,370 @@ +{$MINSTACKSIZE $00004000} +{$MAXSTACKSIZE $00100000} +{$IMAGEBASE $00400000} +{$APPTYPE CONSOLE} +{ + $Id: ppc.dpr,v 1.1.1.1 2001-07-23 17:16:50 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Commandline compiler for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} + +{ + possible compiler switches (* marks a currently required switch): + ----------------------------------------------------------------- + USE_RHIDE generates errors and warning in an format recognized + by rhide + TP to compile the compiler with Turbo or Borland Pascal + GDB* support of the GNU Debugger + I386 generate a compiler for the Intel i386+ + M68K generate a compiler for the M68000 + USEOVERLAY compiles a TP version which uses overlays + EXTDEBUG some extra debug code is executed + SUPPORT_MMX only i386: releases the compiler switch + MMX which allows the compiler to generate + MMX instructions + EXTERN_MSG Don't compile the msgfiles in the compiler, always + use external messagefiles, default for TP + NOAG386INT no Intel Assembler output + NOAG386NSM no NASM output + ----------------------------------------------------------------- + + Required switches for a i386 compiler be compiled by Free Pascal Compiler: + GDB;I386 + + Required switches for a i386 compiler be compiled by Turbo Pascal: + GDB;I386;TP + + Required switches for a 68000 compiler be compiled by Turbo Pascal: + GDB;M68k;TP + + To compile the compiler with Delphi do the following: + +} + +{$ifdef FPC} + {$ifndef GDB} + { people can try to compile without GDB } + { $error The compiler switch GDB must be defined} + {$endif GDB} + { but I386 or M68K must be defined } + { and only one of the two } + {$ifndef I386} + {$ifndef M68K} + {$fatal One of the switches I386 or M68K must be defined} + {$endif M68K} + {$endif I386} + {$ifdef I386} + {$ifdef M68K} + {$fatal ONLY one of the switches I386 or M68K must be defined} + {$endif M68K} + {$endif I386} + {$ifdef support_mmx} + {$ifndef i386} + {$fatal I386 switch must be on for MMX support} + {$endif i386} + {$endif support_mmx} +{$endif} + +{$ifndef DELPHI} +{$ifdef TP} + {$IFNDEF DPMI} + {$M 24000,0,655360} + {$ELSE} + {$M 65000} + {$ENDIF DPMI} + {$E+,N+,F+,S-,R-} +{$endif TP} +{$endif DELPHI} + + +program pp; + +{$IFDEF TP} + {$UNDEF PROFILE} + {$IFDEF DPMI} + {$UNDEF USEOVERLAY} + {$ENDIF} +{$ENDIF} +{$ifdef FPC} + {$UNDEF USEOVERLAY} +{$ENDIF} + +uses +{$ifdef useoverlay} + {$ifopt o+} + Overlay,ppovin, + {$else} + {$error You must compile with the $O+ switch} + {$endif} +{$endif useoverlay} +{$ifdef profile} + profile, +{$endif profile} + globals,compiler; + +{$ifdef useoverlay} + {$O files} + {$O globals} + {$O hcodegen} + {$O pass_1} + {$O tree} + {$O types} + {$O objects} + {$O options} + {$O cobjects} + {$O globals} + {$O systems} + {$O parser} + {$O pbase} + {$O pdecl} + {$O pexports} + {$O pexpr} + {$O pmodules} + {$O pstatmnt} + {$O psub} + {$O psystem} + {$O ptconst} + {$O script} + {$O switches} + {$O temp_gen} + {$O comphook} + {$O dos} + {$O scanner} + {$O symtable} + {$O objects} + {$O aasm} + {$O link} + {$O assemble} + {$O messages} + {$O gendef} + {$O import} + {$O os2_targ} + {$O win_targ} + {$O asmutils} + {$ifdef gdb} + {$O gdb} + {$endif gdb} + {$ifdef i386} + {$O opts386} + {$O cgi386} + {$O cg386add} + {$O cg386cal} + {$O cg386cnv} + {$O cg386con} + {$O cg386flw} + {$O cg386ld} + {$O cg386mat} + {$O cg386set} +{$ifndef NOOPT} + {$O aopt386} +{$endif NOOPT} + {$O cgai386} + {$O i386} +{$IfNDef Nora386dir} + {$O ra386dir} +{$endif Nora386dir} +{$IfNDef Nora386int} + {$O ra386int} +{$endif Nora386int} +{$IfNDef Nora386att} + {$O ra386att} +{$endif Nora386att} + {$O tgeni386} +{$ifndef NoAg386Int} + {$O ag386int} +{$endif NoAg386Int} + {$O ag386att} +{$ifndef NoAg386Nsm} + {$O ag386nsm} +{$endif} + {$endif} + {$ifdef m68k} + {$O opts68k} + {$O cg68k} + {$O ra68kmot} + {$O ag68kgas} + {$O ag68kmot} + {$O ag68kmit} + {$endif} +{$endif useoverlay} + +var + oldexit : pointer; +procedure myexit;{$ifndef FPC}far;{$endif} +begin + exitproc:=oldexit; +{ Show Runtime error if there was an error } + if (erroraddr<>nil) then + begin + case exitcode of + 202 : begin + erroraddr:=nil; + Writeln('Error: Stack Overflow'); + end; + 203 : begin + erroraddr:=nil; + Writeln('Error: Out of memory'); + end; + end; + Writeln('Compilation aborted at line ',aktfilepos.line); + end; +end; + +begin + oldexit:=exitproc; + exitproc:=@myexit; +{$ifndef VER0_99_5} + {$ifndef TP} + {$ifndef Delphi} + heapblocks:=true; + {$endif Delphi} + {$endif} +{$endif} +{$ifdef UseOverlay} + InitOverlay; +{$endif} + +{ Call the compiler with empty command, so it will take the parameters } + Halt(Compile('')); +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.4 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.3 1999/07/18 10:20:00 florian + * made it compilable with Dlephi 4 again + + fixed problem with large stack allocations on win32 + + Revision 1.2 1999/05/04 21:44:58 florian + * changes to compile it with Delphi 4.0 + + Revision 1.1 1998/09/18 16:03:44 florian + * some changes to compile with Delphi + + Revision 1.28 1998/08/26 15:31:17 peter + * heapblocks for >0.99.5 + + Revision 1.27 1998/08/11 00:00:00 peter + * fixed dup log + + Revision 1.26 1998/08/10 15:49:40 peter + * small fixes for 0.99.5 + + Revision 1.25 1998/08/10 14:50:16 peter + + localswitches, moduleswitches, globalswitches splitting + + Revision 1.24 1998/08/10 10:18:32 peter + + Compiler,Comphook unit which are the new interface units to the + compiler + + Revision 1.23 1998/08/05 16:00:16 florian + * some fixes for ansi strings + + Revision 1.22 1998/08/04 16:28:40 jonas + * added support for NoRa386* in the $O ... section + + Revision 1.21 1998/07/18 17:11:12 florian + + ansi string constants fixed + + switch $H partial implemented + + Revision 1.20 1998/07/14 14:46:55 peter + * released NEWINPUT + + Revision 1.19 1998/07/07 11:20:04 peter + + NEWINPUT for a better inputfile and scanner object + + Revision 1.18 1998/06/24 14:06:33 peter + * fixed the name changes + + Revision 1.17 1998/06/23 08:59:22 daniel + * Recommitted. + + Revision 1.16 1998/06/17 14:10:17 peter + * small os2 fixes + * fixed interdependent units with newppu (remake3 under linux works now) + + Revision 1.15 1998/06/16 11:32:18 peter + * small cosmetic fixes + + Revision 1.14 1998/06/15 13:43:45 daniel + + + * Updated overlays. + + Revision 1.12 1998/05/23 01:21:23 peter + + aktasmmode, aktoptprocessor, aktoutputformat + + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + + $LIBNAME to set the library name where the unit will be put in + * splitted cgi386 a bit (codeseg to large for bp7) + * nasm, tasm works again. nasm moved to ag386nsm.pas + + Revision 1.11 1998/05/20 09:42:35 pierre + + UseTokenInfo now default + * unit in interface uses and implementation uses gives error now + * only one error for unknown symbol (uses lastsymknown boolean) + the problem came from the label code ! + + first inlined procedures and function work + (warning there might be allowed cases were the result is still wrong !!) + * UseBrower updated gives a global list of all position of all used symbols + with switch -gb + + Revision 1.10 1998/05/12 10:47:00 peter + * moved printstatus to verb_def + + V_Normal which is between V_Error and V_Warning and doesn't have a + prefix like error: warning: and is included in V_Default + * fixed some messages + * first time parameter scan is only for -v and -T + - removed old style messages + + Revision 1.9 1998/05/11 13:07:56 peter + + $ifdef NEWPPU for the new ppuformat + + $define GDB not longer required + * removed all warnings and stripped some log comments + * no findfirst/findnext anymore to remove smartlink *.o files + + Revision 1.8 1998/05/08 09:21:57 michael + + Librarysearchpath is now a linker object field; + + Revision 1.7 1998/05/04 17:54:28 peter + + smartlinking works (only case jumptable left todo) + * redesign of systems.pas to support assemblers and linkers + + Unitname is now also in the PPU-file, increased version to 14 + + Revision 1.6 1998/04/29 13:40:23 peter + + heapblocks:=true + + Revision 1.5 1998/04/29 10:33:59 pierre + + added some code for ansistring (not complete nor working yet) + * corrected operator overloading + * corrected nasm output + + started inline procedures + + added starstarn : use ** for exponentiation (^ gave problems) + + started UseTokenInfo cond to get accurate positions + + Revision 1.3 1998/04/21 10:16:48 peter + * patches from strasbourg + * objects is not used anymore in the fpc compiled version + + Revision 1.2 1998/04/07 13:19:47 pierre + * bugfixes for reset_gdb_info + in MEM parsing for go32v2 + better external symbol creation + support for rhgdb.exe (lowercase file names) +} diff --git a/befpc/compiler/ppheap.pas b/befpc/compiler/ppheap.pas new file mode 100644 index 0000000..7a8f52a --- /dev/null +++ b/befpc/compiler/ppheap.pas @@ -0,0 +1,85 @@ +{ + $Id: ppheap.pas,v 1.1.1.1 2001-07-23 17:16:50 memson Exp $ + Copyright (c) 1998-2000 by Pierre Muller + + Simple unit to add source line and column to each + memory allocation made with heaptrc unit + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} +unit ppheap; + + interface + + uses heaptrc; + + { call this function before any memory allocation + in a unit initialization code (PM) } + + procedure pp_heap_init; + + implementation + + uses + globtype,globals,files; + + procedure ppextra_info(p : pointer); + var pl : plongint; + begin + longint(p^):=aktfilepos.line; + pl:=plongint(cardinal(p)+4); + pl^:=aktfilepos.column; + pl:=plongint(cardinal(p)+8); + if assigned(current_module) then + pl^:=current_module^.unit_index*100000+aktfilepos.fileindex + else + pl^:=aktfilepos.fileindex + end; + + const + pp_heap_inited : boolean = false; + + procedure pp_heap_init; + begin + if not pp_heap_inited then + begin + setheaptraceoutput('heap.log'); +{$ifndef TP} + SetExtraInfo(12,@ppextra_info); +{$else TP} + SetExtraInfo(12,ppextra_info); +{$endif TP} + end; + pp_heap_inited:=true; + end; + + begin + pp_heap_init; + end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.10 2000/02/09 13:22:59 peter + * log truncated + + Revision 1.9 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.8 1999/11/17 17:05:02 pierre + * Notes/hints changes + +} + diff --git a/befpc/compiler/ppovin.pas b/befpc/compiler/ppovin.pas new file mode 100644 index 0000000..22c19c3 --- /dev/null +++ b/befpc/compiler/ppovin.pas @@ -0,0 +1,101 @@ +{ + $Id: ppovin.pas,v 1.1.1.1 2001-07-23 17:16:50 memson Exp $ + Copyright (c) 1998-2000 by Daniel Mantione + + Handles the overlay initialisation for a TP7 compiled version + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ppovin; + +interface + +var + ovrminsize:longint; + +procedure InitOverlay; + +implementation +uses overlay; + + +function _heaperror(size:word):integer;far; +type + heaprecord=record + next:pointer; + values:longint; + end; +var + l,m:longint; +begin + l:=ovrgetbuf-ovrminsize; + if (size>maxavail) and (l>=size) then + begin + m:=((longint(size)+$3fff) and $ffffc000); + {Clear the overlay buffer.} + ovrclearbuf; + {Shrink it.} + ovrheapend:=ovrheapend-m shr 4; + heaprecord(ptr(ovrheapend,0)^).next:=freelist; + heaprecord(ptr(ovrheapend,0)^).values:=m shl 12; + heaporg:=ptr(ovrheapend,0); + freelist:=heaporg; + Writeln('Warning: Overlay buffer was shrunk because of memory shortage'); + _heaperror:=2; + end + else + _heaperror:=0; +end; + +procedure InitOverlay; +begin + heaperror:=@_heaperror; +end; + + +var + s:string; +begin + s:=paramstr(0); + ovrinit(copy(s,1,length(s)-3)+'ovr'); + if ovrresult=ovrok then + begin + {May fail if no EMS memory is available. No need for error + checking, though, as the overlay manager happily runs without + EMS.} + ovrinitEMS; + ovrminsize:=ovrgetbuf; + ovrsetbuf(ovrminsize+$20000); + end + else + { only for real mode TP : runerror ok here PM } + runerror($da); +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.6 2000/02/09 13:22:59 peter + * log truncated + + Revision 1.5 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.4 1999/09/16 11:34:58 pierre + * typo correction + +} + + diff --git a/befpc/compiler/ppu.pas b/befpc/compiler/ppu.pas new file mode 100644 index 0000000..0f85d95 --- /dev/null +++ b/befpc/compiler/ppu.pas @@ -0,0 +1,1008 @@ +{ + $Id: ppu.pas,v 1.1.1.1 2001-07-23 17:16:51 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Routines to read/write ppu files + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif} +unit ppu; +interface + +{ Also write the ppu if only crc if done, this can be used with ppudump to + see the differences between the intf and implementation } +{ define INTFPPU} +{$define ORDERSOURCES} + +{$ifdef Test_Double_checksum} +var + CRCFile : text; +const + CRC_array_Size = 200000; +type + tcrc_array = array[0..crc_array_size] of longint; + pcrc_array = ^tcrc_array; +{$endif Test_Double_checksum} + +const +{$ifdef newcg} +{$ifdef ORDERSOURCES} + CurrentPPUVersion=103; +{$else ORDERSOURCES} + CurrentPPUVersion=102; +{$endif ORDERSOURCES} +{$else newcg} +{$ifdef ORDERSOURCES} + CurrentPPUVersion=21; +{$else ORDERSOURCES} + CurrentPPUVersion=20; +{$endif ORDERSOURCES} +{$endif newcg} + +{ buffer sizes } + maxentrysize = 1024; +{$ifdef TP} + ppubufsize = 1024; +{$else} + ppubufsize = 16384; +{$endif} + +{ppu entries} + mainentryid = 1; + subentryid = 2; + {special} + iberror = 0; + ibstartdefs = 248; + ibenddefs = 249; + ibstartsyms = 250; + ibendsyms = 251; + ibendinterface = 252; + ibendimplementation = 253; + ibendbrowser = 254; + ibend = 255; + {general} + ibmodulename = 1; + ibsourcefiles = 2; + ibloadunit = 3; + ibinitunit = 4; + iblinkunitofiles = 5; + iblinkunitstaticlibs = 6; + iblinkunitsharedlibs = 7; + iblinkotherofiles = 8; + iblinkotherstaticlibs = 9; + iblinkothersharedlibs = 10; + ibdbxcount = 11; + ibsymref = 12; + ibdefref = 13; + ibendsymtablebrowser = 14; + ibbeginsymtablebrowser = 15; + ibusedmacros = 16; + {syms} + ibtypesym = 20; + ibprocsym = 21; + ibvarsym = 22; + ibconstsym = 23; + ibenumsym = 24; + ibtypedconstsym = 25; + ibabsolutesym = 26; + ibpropertysym = 27; + ibvarsym_C = 28; + ibunitsym = 29; { needed for browser } + iblabelsym = 30; + ibfuncretsym = 31; + ibsyssym = 32; + {definitions} + iborddef = 40; + ibpointerdef = 41; + ibarraydef = 42; + ibprocdef = 43; + ibshortstringdef = 44; + ibrecorddef = 45; + ibfiledef = 46; + ibformaldef = 47; + ibobjectdef = 48; + ibenumdef = 49; + ibsetdef = 50; + ibprocvardef = 51; + ibfloatdef = 52; + ibclassrefdef = 53; + iblongstringdef = 54; + ibansistringdef = 55; + ibwidestringdef = 56; + +{ unit flags } + uf_init = $1; + uf_finalize = $2; + uf_big_endian = $4; + uf_has_dbx = $8; + uf_has_browser = $10; + uf_in_library = $20; { is the file in another file than .* ? } + uf_smart_linked = $40; { the ppu can be smartlinked } + uf_static_linked = $80; { the ppu can be linked static } + uf_shared_linked = $100; { the ppu can be linked shared } + uf_local_browser = $200; + uf_no_link = $400; { unit has no .o generated, but can still have + external linking! } + uf_has_resources = $800; { unit has resource section } + +type +{$ifdef m68k} + ppureal=single; +{$else} + ppureal=extended; +{$endif} + + tppuerror=(ppuentrytoobig,ppuentryerror); + + tppuheader=packed record { 40 bytes } + id : array[1..3] of char; { = 'PPU' } + ver : array[1..3] of char; + compiler : word; + cpu : word; + target : word; + flags : longint; + size : longint; { size of the ppufile without header } + checksum : longint; { checksum for this ppufile } + interface_checksum : longint; + future : array[0..2] of longint; + end; + + tppuentry=packed record + id : byte; + nr : byte; + size : longint; + end; + + pppufile=^tppufile; + tppufile=object + f : file; + mode : byte; {0 - Closed, 1 - Reading, 2 - Writing} + error : boolean; + fname : string; + fsize : longint; + + header : tppuheader; + size,crc : longint; +{$ifdef Test_Double_checksum} + crcindex : longint; + crc_index : longint; + crcindex2 : longint; + crc_index2 : longint; + crc_test,crc_test2 : pcrc_array; + +{$endif def Test_Double_checksum} + interface_crc : longint; + do_interface_crc : boolean; + crc_only : boolean; { used to calculate interface_crc before implementation } + do_crc, + change_endian : boolean; + + buf : pchar; + bufstart, + bufsize, + bufidx : longint; + entrybufstart, + entrystart, + entryidx : longint; + entry : tppuentry; + entrytyp : byte; + closed, + tempclosed : boolean; + closepos : longint; + constructor init(fn:string); + destructor done; + procedure flush; + procedure close; + function CheckPPUId:boolean; + function GetPPUVersion:longint; + procedure NewHeader; + procedure NewEntry; + {read} + function open:boolean; + procedure reloadbuf; + procedure readdata(var b;len:longint); + procedure skipdata(len:longint); + function readentry:byte; + function EndOfEntry:boolean; + procedure getdatabuf(var b;len:longint;var result:longint); + procedure getdata(var b;len:longint); + function getbyte:byte; + function getword:word; + function getlongint:longint; + function getreal:ppureal; + function getstring:string; + procedure getnormalset(var b); + procedure getsmallset(var b); + function skipuntilentry(untilb:byte):boolean; + {write} + function create:boolean; + procedure writeheader; + procedure writebuf; + procedure writedata(var b;len:longint); + procedure writeentry(ibnr:byte); + procedure putdata(var b;len:longint); + procedure putbyte(b:byte); + procedure putword(w:word); + procedure putlongint(l:longint); + procedure putreal(d:ppureal); + procedure putstring(s:string); + procedure putnormalset(var b); + procedure putsmallset(var b); + procedure tempclose; + function tempopen:boolean; + end; + +implementation + + uses +{$ifdef Test_Double_checksum} + comphook, +{$endif def Test_Double_checksum} + crc; + +{***************************************************************************** + TPPUFile +*****************************************************************************} + +constructor tppufile.init(fn:string); +begin + fname:=fn; + change_endian:=false; + crc_only:=false; + Mode:=0; + NewHeader; + Error:=false; + closed:=true; + tempclosed:=false; + getmem(buf,ppubufsize); +end; + + +destructor tppufile.done; +begin + close; + if assigned(buf) then + freemem(buf,ppubufsize); +end; + + +procedure tppufile.flush; +begin + if Mode=2 then + writebuf; +end; + + +procedure tppufile.close; +begin + if Mode<>0 then + begin + Flush; + {$I-} + system.close(f); + {$I+} + if ioresult<>0 then; + Mode:=0; + closed:=true; + end; +end; + + +function tppufile.CheckPPUId:boolean; +begin + CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U')); +end; + + +function tppufile.GetPPUVersion:longint; +var + l : longint; + code : integer; +begin + Val(header.ver[1]+header.ver[2]+header.ver[3],l,code); + if code=0 then + GetPPUVersion:=l + else + GetPPUVersion:=0; +end; + + +procedure tppufile.NewHeader; +var + s : string; +begin + fillchar(header,sizeof(tppuheader),0); + str(currentppuversion,s); + while length(s)<3 do + s:='0'+s; + with header do + begin + Id[1]:='P'; + Id[2]:='P'; + Id[3]:='U'; + Ver[1]:=s[1]; + Ver[2]:=s[2]; + Ver[3]:=s[3]; + end; +end; + + +{***************************************************************************** + TPPUFile Reading +*****************************************************************************} + +function tppufile.open:boolean; +var + ofmode : byte; +{$ifdef delphi} + i : integer; +{$else delphi} + i : word; +{$endif delphi} +begin + open:=false; + assign(f,fname); + ofmode:=filemode; + filemode:=$0; + {$I-} + reset(f,1); + {$I+} + filemode:=ofmode; + if ioresult<>0 then + exit; + closed:=false; +{read ppuheader} + fsize:=filesize(f); + if fsize0 do + begin + left:=bufsize-bufidx; + if len>left then + begin + move(buf[bufidx],p[idx],left); + dec(len,left); + inc(idx,left); + reloadbuf; + if bufsize=0 then + exit; + end + else + begin + move(buf[bufidx],p[idx],len); + inc(bufidx,len); + exit; + end; + end; +end; + + +procedure tppufile.skipdata(len:longint); +var + left : longint; +begin + while len>0 do + begin + left:=bufsize-bufidx; + if len>left then + begin + dec(len,left); + reloadbuf; + if bufsize=0 then + exit; + end + else + begin + inc(bufidx,len); + exit; + end; + end; +end; + + +function tppufile.readentry:byte; +begin + if entryidx=entry.size); +end; + + +procedure tppufile.getdatabuf(var b;len:longint;var result:longint); +begin + if entryidx+len>entry.size then + result:=entry.size-entryidx + else + result:=len; + readdata(b,result); + inc(entryidx,result); +end; + + +procedure tppufile.getdata(var b;len:longint); +begin + if entryidx+len>entry.size then + begin + error:=true; + exit; + end; + readdata(b,len); + inc(entryidx,len); +end; + + +function tppufile.getbyte:byte; +var + b : byte; +begin + if entryidx+1>entry.size then + begin + error:=true; + getbyte:=0; + exit; + end; + readdata(b,1); + getbyte:=b; + inc(entryidx); +end; + + +function tppufile.getword:word; +type + pword = ^word; +var + w : word; +begin + if entryidx+2>entry.size then + begin + error:=true; + getword:=0; + exit; + end; + readdata(w,2); + if change_endian then + getword:=swap(w) + else + getword:=w; + inc(entryidx,2); +end; + + +function tppufile.getlongint:longint; +type + plongint = ^longint; +var + l : longint; +begin + if entryidx+4>entry.size then + begin + error:=true; + getlongint:=0; + exit; + end; + readdata(l,4); + if change_endian then + { someone added swap(l : longint) in system unit + this broke the following code !! } + getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16) + else + getlongint:=l; + inc(entryidx,4); +end; + + +function tppufile.getreal:ppureal; +type + pppureal = ^ppureal; +var + d : ppureal; +begin + if entryidx+sizeof(ppureal)>entry.size then + begin + error:=true; + getreal:=0; + exit; + end; + readdata(d,sizeof(ppureal)); + getreal:=d; + inc(entryidx,sizeof(ppureal)); +end; + + +function tppufile.getstring:string; +var + s : string; +begin + {$ifndef TP} + {$ifopt H+} + setlength(s,getbyte); + {$else} + s[0]:=chr(getbyte); + {$endif} + {$else} + s[0]:=chr(getbyte); + {$endif} + if entryidx+length(s)>entry.size then + begin + error:=true; + exit; + end; + ReadData(s[1],length(s)); + getstring:=s; + inc(entryidx,length(s)); +end; + + +procedure tppufile.getsmallset(var b); +begin + getdata(b,4); +end; + + +procedure tppufile.getnormalset(var b); +begin + getdata(b,32); +end; + + +function tppufile.skipuntilentry(untilb:byte):boolean; +var + b : byte; +begin + repeat + b:=readentry; + until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid)); + skipuntilentry:=(b=untilb); +end; + + +{***************************************************************************** + TPPUFile Writing +*****************************************************************************} + +function tppufile.create:boolean; +begin + create:=false; +{$ifdef INTFPPU} + if crc_only then + begin + fname:=fname+'.intf'; + crc_only:=false; + end; +{$endif} + if not crc_only then + begin + assign(f,fname); + {$I-} + rewrite(f,1); + {$I+} + if ioresult<>0 then + exit; + Mode:=2; + {write header for sure} + blockwrite(f,header,sizeof(tppuheader)); + end; + bufsize:=ppubufsize; + bufstart:=sizeof(tppuheader); + bufidx:=0; +{reset} + crc:=$ffffffff; + interface_crc:=$ffffffff; + do_interface_crc:=true; + Error:=false; + do_crc:=true; + size:=0; + entrytyp:=mainentryid; +{start} + NewEntry; + create:=true; +end; + + +procedure tppufile.writeheader; +var + opos : longint; +begin +{ flush buffer } + writebuf; +{ update size (w/o header!) in the header } + header.size:=bufstart-sizeof(tppuheader); +{ write header and restore filepos after it } + opos:=filepos(f); + seek(f,0); + blockwrite(f,header,sizeof(tppuheader)); + seek(f,opos); +end; + + +procedure tppufile.writebuf; +begin + if not crc_only then + blockwrite(f,buf^,bufidx); + inc(bufstart,bufidx); + bufidx:=0; +end; + + +procedure tppufile.writedata(var b;len:longint); +var + p : pchar; + left, + idx : longint; +begin + if crc_only then + exit; + p:=pchar(@b); + idx:=0; + while len>0 do + begin + left:=bufsize-bufidx; + if len>left then + begin + move(p[idx],buf[bufidx],left); + dec(len,left); + inc(idx,left); + inc(bufidx,left); + writebuf; + end + else + begin + move(p[idx],buf[bufidx],len); + inc(bufidx,len); + exit; + end; + end; +end; + + +procedure tppufile.NewEntry; +begin + with entry do + begin + id:=entrytyp; + nr:=ibend; + size:=0; + end; +{Reset Entry State} + entryidx:=0; + entrybufstart:=bufstart; + entrystart:=bufstart+bufidx; +{Alloc in buffer} + writedata(entry,sizeof(tppuentry)); +end; + + +procedure tppufile.writeentry(ibnr:byte); +var + opos : longint; +begin +{create entry} + entry.id:=entrytyp; + entry.nr:=ibnr; + entry.size:=entryidx; +{it's already been sent to disk ?} + if entrybufstart<>bufstart then + begin + if not crc_only then + begin + {flush to be sure} + WriteBuf; + {write entry} + opos:=filepos(f); + seek(f,entrystart); + blockwrite(f,entry,sizeof(tppuentry)); + seek(f,opos); + end; + entrybufstart:=bufstart; + end + else + move(entry,buf[entrystart-bufstart],sizeof(entry)); +{Add New Entry, which is ibend by default} + entrystart:=bufstart+bufidx; {next entry position} + NewEntry; +end; + + +procedure tppufile.putdata(var b;len:longint); +begin + if do_crc then + begin + crc:=UpdateCrc32(crc,b,len); +{$ifdef Test_Double_checksum} + if crc_only then + begin + crc_test2^[crc_index2]:=crc; +{$ifdef Test_Double_checksum_write} + Writeln(CRCFile,crc); +{$endif Test_Double_checksum_write} + if crc_index2crc) then + Do_comment(V_Warning,'impl CRC changed'); +{$ifdef Test_Double_checksum_write} + Writeln(CRCFile,crc); +{$endif Test_Double_checksum_write} + inc(crcindex2); + end; +{$endif def Test_Double_checksum} + if do_interface_crc then + begin + interface_crc:=UpdateCrc32(interface_crc,b,len); +{$ifdef Test_Double_checksum} + if crc_only then + begin + crc_test^[crc_index]:=interface_crc; +{$ifdef Test_Double_checksum_write} + Writeln(CRCFile,interface_crc); +{$endif Test_Double_checksum_write} + if crc_indexinterface_crc) then + Do_comment(V_Warning,'CRC changed'); +{$ifdef Test_Double_checksum_write} + Writeln(CRCFile,interface_crc); +{$endif Test_Double_checksum_write} + inc(crcindex); + end; +{$endif def Test_Double_checksum} + end; + end; + if not crc_only then + writedata(b,len); + inc(entryidx,len); +end; + + +procedure tppufile.putbyte(b:byte); +begin + putdata(b,1); +{ inc(entryidx);} +end; + + +procedure tppufile.putword(w:word); +begin + if change_endian then + w:=swap(w); + putdata(w,2); +end; + + +procedure tppufile.putlongint(l:longint); +begin + if change_endian then + { someone added swap(l : longint) in system unit + this broke the following code !! } + l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16); + putdata(l,4); +end; + + +procedure tppufile.putreal(d:ppureal); +begin + putdata(d,sizeof(ppureal)); +end; + + +procedure tppufile.putstring(s:string); +begin + putdata(s,length(s)+1); +end; + + +procedure tppufile.putsmallset(var b); +begin + putdata(b,4); +end; + + +procedure tppufile.putnormalset(var b); +begin + putdata(b,32); +end; + + + procedure tppufile.tempclose; + begin + if not closed then + begin + closepos:=filepos(f); + {$I-} + system.close(f); + {$I+} + if ioresult<>0 then; + closed:=true; + tempclosed:=true; + end; + end; + + + function tppufile.tempopen:boolean; + var + ofm : byte; + begin + tempopen:=false; + if not closed or not tempclosed then + exit; + ofm:=filemode; + filemode:=0; + {$I-} + reset(f,1); + {$I+} + filemode:=ofm; + if ioresult<>0 then + exit; + closed:=false; + tempclosed:=false; + + { restore state } + seek(f,closepos); + tempopen:=true; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.59 2000/05/15 13:19:04 pierre + CRC stuff moved to CRC unit + + Revision 1.58 2000/05/12 08:58:51 pierre + * adapted to Delphi 3 + + Revision 1.57 2000/05/11 06:54:29 florian + * fixed some vmt problems, especially related to overloaded methods + in objects/classes + + Revision 1.56 2000/02/29 21:58:31 pierre + * ORDERSOURCES released + + Revision 1.55 2000/02/09 13:22:59 peter + * log truncated + + Revision 1.54 2000/01/07 01:14:30 peter + * updated copyright to 2000 + + Revision 1.53 1999/12/02 11:29:07 peter + * INFTPPU define to write the ppu of the interface to .ppu.intf + + Revision 1.52 1999/11/30 10:40:45 peter + + ttype, tsymlist + + Revision 1.51 1999/11/23 09:42:38 peter + * makefile updates to work with new fpcmake + + Revision 1.50 1999/11/21 01:42:37 pierre + * Nextoverloading ordering fix + + Revision 1.49 1999/11/18 15:34:48 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.48 1999/11/17 17:05:02 pierre + * Notes/hints changes + + Revision 1.47 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.46 1999/09/17 09:14:56 peter + * ppu header writting now uses currentppuversion + + Revision 1.45 1999/09/16 13:27:08 pierre + + error if PPU modulename is different from what is searched + (8+3 limitations!) + + cond ORDERSOURCES to allow recompilation of FP + if symppu.inc is changed (need PPUversion change!) + + Revision 1.44 1999/09/16 11:34:58 pierre + * typo correction + + Revision 1.43 1999/09/10 18:48:09 florian + * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.42 1999/08/31 15:47:56 pierre + + startup conditionals stored in PPU file for debug info + + Revision 1.41 1999/08/30 16:21:40 pierre + * tempclosing of ppufiles under dos was wrong + + Revision 1.40 1999/08/27 10:48:40 pierre + + tppufile.tempclose and tempopen added + * some changes so that nothing is writtedn to disk while + calculating CRC only + + Revision 1.39 1999/08/24 12:01:36 michael + + changes for resourcestrings + + Revision 1.38 1999/08/15 10:47:48 peter + + normalset,smallset writing + + Revision 1.37 1999/08/02 23:13:20 florian + * more changes to compile for the Alpha + + Revision 1.36 1999/07/23 16:05:25 peter + * alignment is now saved in the symtable + * C alignment added for records + * PPU version increased to solve .12 <-> .13 probs + +} \ No newline at end of file diff --git a/befpc/compiler/pstatmnt.pas b/befpc/compiler/pstatmnt.pas new file mode 100644 index 0000000..f1de66d --- /dev/null +++ b/befpc/compiler/pstatmnt.pas @@ -0,0 +1,1493 @@ +{ + $Id: pstatmnt.pas,v 1.1.1.1 2001-07-23 17:16:51 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Does the parsing of the statements + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} + +unit pstatmnt; + + interface + + uses tree; + + { reads a block } + function block(islibrary : boolean) : ptree; + + { reads an assembler block } + function assembler_block : ptree; + + implementation + + uses + globtype,systems,tokens, + strings,cobjects,globals,files,verbose, + symconst,symtable,aasm,pass_1,types,scanner, +{$ifdef newcg} + cgbase, +{$else} + hcodegen, +{$endif} + ppu + ,pbase,pexpr,pdecl,cpubase,cpuasm +{$ifdef i386} + ,tgeni386 + {$ifndef NoRa386Int} + ,ra386int + {$endif NoRa386Int} + {$ifndef NoRa386Att} + ,ra386att + {$endif NoRa386Att} + {$ifndef NoRa386Dir} + ,ra386dir + {$endif NoRa386Dir} +{$endif i386} +{$ifdef m68k} + ,tgen68k + {$ifndef NoRa68kMot} + ,ra68kmot + {$endif NoRa68kMot} +{$endif m68k} +{$ifdef alpha} + ,tgeni386 { this is a dummy!! } +{$endif alpha} +{$ifdef powerpc} + ,tgeni386 { this is a dummy!! } +{$endif powerpc} + ; + + + const + statement_level : longint = 0; + + function statement : ptree;forward; + + + function if_statement : ptree; + var + ex,if_a,else_a : ptree; + begin + consume(_IF); + ex:=comp_expr(true); + consume(_THEN); + if token<>_ELSE then + if_a:=statement + else + if_a:=nil; + + if try_to_consume(_ELSE) then + else_a:=statement + else + else_a:=nil; + if_statement:=genloopnode(ifn,ex,if_a,else_a,false); + end; + + { creates a block (list) of statements, til the next END token } + function statements_til_end : ptree; + + var + first,last : ptree; + + begin + first:=nil; + while token<>_END do + begin + if first=nil then + begin + last:=gennode(statementn,nil,statement); + first:=last; + end + else + begin + last^.left:=gennode(statementn,nil,statement); + last:=last^.left; + end; + if not try_to_consume(_SEMICOLON) then + break; + emptystats; + end; + consume(_END); + statements_til_end:=gensinglenode(blockn,first); + end; + + function case_statement : ptree; + + var + { contains the label number of currently parsed case block } + aktcaselabel : pasmlabel; + firstlabel : boolean; + root : pcaserecord; + + { the typ of the case expression } + casedef : pdef; + + procedure newcaselabel(l,h : longint;first:boolean); + + var + hcaselabel : pcaserecord; + + procedure insertlabel(var p : pcaserecord); + + begin + if p=nil then p:=hcaselabel + else + if (p^._low>hcaselabel^._low) and + (p^._low>hcaselabel^._high) then + if (hcaselabel^.statement = p^.statement) and + (p^._low = hcaselabel^._high + 1) then + begin + p^._low := hcaselabel^._low; + dispose(hcaselabel); + end + else + insertlabel(p^.less) + else + if (p^._highhl2 then + CGMessage(parser_e_case_lower_less_than_upper_bound); + if not casedeferror then + begin + testrange(casedef,hl1); + testrange(casedef,hl2); + end; + end + else + CGMessage(parser_e_case_mismatch); + newcaselabel(hl1,hl2,firstlabel); + end + else + begin + { type checking for case statements } + if not is_subequal(casedef, p^.resulttype) then + CGMessage(parser_e_case_mismatch); + hl1:=get_ordinal_value(p); + if not casedeferror then + testrange(casedef,hl1); + newcaselabel(hl1,hl1,firstlabel); + end; + disposetree(p); + if token=_COMMA then + consume(_COMMA) + else + break; + firstlabel:=false; + until false; + consume(_COLON); + + { handles instruction block } + p:=gensinglenode(labeln,statement); + p^.labelnr:=aktcaselabel; + + { concats instruction } + instruc:=gennode(statementn,instruc,p); + + if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then + consume(_SEMICOLON); + until (token=_ELSE) or (token=_OTHERWISE) or (token=_END); + + if (token=_ELSE) or (token=_OTHERWISE) then + begin + if not try_to_consume(_ELSE) then + consume(_OTHERWISE); + elseblock:=statements_til_end; + end + else + begin + elseblock:=nil; + consume(_END); + end; + dec(statement_level); + + code:=gencasenode(caseexpr,instruc,root); + + code^.elseblock:=elseblock; + + case_statement:=code; + end; + + + function repeat_statement : ptree; + + var + first,last,p_e : ptree; + + begin + consume(_REPEAT); + first:=nil; + inc(statement_level); + + while token<>_UNTIL do + begin + if first=nil then + begin + last:=gennode(statementn,nil,statement); + first:=last; + end + else + begin + last^.left:=gennode(statementn,nil,statement); + last:=last^.left; + end; + if not try_to_consume(_SEMICOLON) then + break; + emptystats; + end; + consume(_UNTIL); + dec(statement_level); + + first:=gensinglenode(blockn,first); + p_e:=comp_expr(true); + repeat_statement:=genloopnode(repeatn,p_e,first,nil,false); + end; + + + function while_statement : ptree; + + var + p_e,p_a : ptree; + + begin + consume(_WHILE); + p_e:=comp_expr(true); + consume(_DO); + p_a:=statement; + while_statement:=genloopnode(whilen,p_e,p_a,nil,false); + end; + + + function for_statement : ptree; + + var + p_e,tovalue,p_a : ptree; + backward : boolean; + + begin + { parse loop header } + consume(_FOR); + p_e:=expr; + if token=_DOWNTO then + begin + consume(_DOWNTO); + backward:=true; + end + else + begin + consume(_TO); + backward:=false; + end; + tovalue:=comp_expr(true); + consume(_DO); + + { ... now the instruction } + p_a:=statement; + for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward); + end; + + + function _with_statement : ptree; + + var + right,p : ptree; + i,levelcount : longint; + withsymtable,symtab : psymtable; + obj : pobjectdef; +{$ifdef tp} + hp : ptree; +{$endif} + begin + p:=comp_expr(true); + do_firstpass(p); + set_varstate(p,false); + right:=nil; + if (not codegenerror) and + (p^.resulttype^.deftype in [objectdef,recorddef]) then + begin + case p^.resulttype^.deftype of + objectdef : begin + obj:=pobjectdef(p^.resulttype); + withsymtable:=new(pwithsymtable,init); + withsymtable^.symsearch:=obj^.symtable^.symsearch; + withsymtable^.defowner:=obj; + symtab:=withsymtable; + if (p^.treetype=loadn) and + (p^.symtable=aktprocsym^.definition^.localst) then + pwithsymtable(symtab)^.direct_with:=true; + {symtab^.withnode:=p; not yet allocated !! } + pwithsymtable(symtab)^.withrefnode:=p; + levelcount:=1; + obj:=obj^.childof; + while assigned(obj) do + begin + symtab^.next:=new(pwithsymtable,init); + symtab:=symtab^.next; + symtab^.symsearch:=obj^.symtable^.symsearch; + if (p^.treetype=loadn) and + (p^.symtable=aktprocsym^.definition^.localst) then + pwithsymtable(symtab)^.direct_with:=true; + {symtab^.withnode:=p; not yet allocated !! } + pwithsymtable(symtab)^.withrefnode:=p; + symtab^.defowner:=obj; + obj:=obj^.childof; + inc(levelcount); + end; + symtab^.next:=symtablestack; + symtablestack:=withsymtable; + end; + recorddef : begin + symtab:=precorddef(p^.resulttype)^.symtable; + levelcount:=1; + withsymtable:=new(pwithsymtable,init); + withsymtable^.symsearch:=symtab^.symsearch; + withsymtable^.next:=symtablestack; + if (p^.treetype=loadn) and + (p^.symtable=aktprocsym^.definition^.localst) then + pwithsymtable(withsymtable)^.direct_with:=true; + {symtab^.withnode:=p; not yet allocated !! } + pwithsymtable(withsymtable)^.withrefnode:=p; + withsymtable^.defowner:=precorddef(p^.resulttype); + symtablestack:=withsymtable; + end; + end; + if token=_COMMA then + begin + consume(_COMMA); + right:=_with_statement{$ifndef tp}(){$endif}; + end + else + begin + consume(_DO); + if token<>_SEMICOLON then + right:=statement + else + right:=nil; + end; + for i:=1 to levelcount do + symtablestack:=symtablestack^.next; + _with_statement:=genwithnode(pwithsymtable(withsymtable),p,right,levelcount); + end + else + begin + Message(parser_e_false_with_expr); + { try to recover from error } + if token=_COMMA then + begin + consume(_COMMA); +{$ifdef tp} + hp:=_with_statement; +{$else} + _with_statement(); +{$endif} + end + else + begin + consume(_DO); + { ignore all } + if token<>_SEMICOLON then + statement; + end; + _with_statement:=nil; + end; + end; + + + function with_statement : ptree; + begin + consume(_WITH); + with_statement:=_with_statement; + end; + + + function raise_statement : ptree; + + var + p,pobj,paddr,pframe : ptree; + + begin + pobj:=nil; + paddr:=nil; + pframe:=nil; + consume(_RAISE); + if not(token in [_SEMICOLON,_END]) then + begin + { object } + pobj:=comp_expr(true); + if try_to_consume(_AT) then + begin + paddr:=comp_expr(true); + if try_to_consume(_COMMA) then + pframe:=comp_expr(true); + end; + end + else + begin + if (block_type<>bt_except) then + Message(parser_e_no_reraise_possible); + end; + p:=gennode(raisen,pobj,paddr); + p^.frametree:=pframe; + raise_statement:=p; + end; + + + function try_statement : ptree; + + var + p_try_block,p_finally_block,first,last, + p_default,p_specific,hp : ptree; + ot : pobjectdef; + sym : pvarsym; + old_block_type : tblock_type; + exceptsymtable : psymtable; + objname : stringid; + + begin + procinfo^.flags:=procinfo^.flags or + pi_uses_exceptions; + + p_default:=nil; + p_specific:=nil; + + { read statements to try } + consume(_TRY); + first:=nil; + inc(statement_level); + + while (token<>_FINALLY) and (token<>_EXCEPT) do + begin + if first=nil then + begin + last:=gennode(statementn,nil,statement); + first:=last; + end + else + begin + last^.left:=gennode(statementn,nil,statement); + last:=last^.left; + end; + if not try_to_consume(_SEMICOLON) then + break; + emptystats; + end; + p_try_block:=gensinglenode(blockn,first); + + if try_to_consume(_FINALLY) then + begin + p_finally_block:=statements_til_end; + try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block); + dec(statement_level); + + end + else + begin + consume(_EXCEPT); + old_block_type:=block_type; + block_type:=bt_except; + p_specific:=nil; + if token=_ON then + { catch specific exceptions } + begin + repeat + consume(_ON); + if token=_ID then + begin + objname:=pattern; + getsym(objname,false); + consume(_ID); + { is a explicit name for the exception given ? } + if try_to_consume(_COLON) then + begin + getsym(pattern,true); + consume(_ID); + if srsym^.typ=unitsym then + begin + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + consume(_ID); + end; + if (srsym^.typ=typesym) and + (ptypesym(srsym)^.restype.def^.deftype=objectdef) and + pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then + begin + ot:=pobjectdef(ptypesym(srsym)^.restype.def); + sym:=new(pvarsym,initdef(objname,ot)); + end + else + begin + sym:=new(pvarsym,initdef(objname,new(perrordef,init))); + if (srsym^.typ=typesym) then + Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename) + else + Message1(type_e_class_type_expected,ot^.typename); + end; + exceptsymtable:=new(psymtable,init(stt_exceptsymtable)); + exceptsymtable^.insert(sym); + { insert the exception symtable stack } + exceptsymtable^.next:=symtablestack; + symtablestack:=exceptsymtable; + end + else + begin + { check if type is valid, must be done here because + with "e: Exception" the e is not necessary } + if srsym=nil then + begin + Message1(sym_e_id_not_found,objname); + srsym:=generrorsym; + end; + { only exception type } + if srsym^.typ=unitsym then + begin + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + consume(_ID); + end; + if (srsym^.typ=typesym) and + (ptypesym(srsym)^.restype.def^.deftype=objectdef) and + pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then + ot:=pobjectdef(ptypesym(srsym)^.restype.def) + else + begin + ot:=pobjectdef(generrordef); + if (srsym^.typ=typesym) then + Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename) + else + Message1(type_e_class_type_expected,ot^.typename); + end; + exceptsymtable:=nil; + end; + end + else + consume(_ID); + consume(_DO); + hp:=gennode(onn,nil,statement); + if ot^.deftype=errordef then + begin + disposetree(hp); + hp:=genzeronode(errorn); + end; + if p_specific=nil then + begin + last:=hp; + p_specific:=last; + end + else + begin + last^.left:=hp; + last:=last^.left; + end; + { set the informations } + last^.excepttype:=ot; + last^.exceptsymtable:=exceptsymtable; + last^.disposetyp:=dt_onn; + { remove exception symtable } + if assigned(exceptsymtable) then + dellexlevel; + if not try_to_consume(_SEMICOLON) then + break; + emptystats; + until (token=_END) or(token=_ELSE); + if token=_ELSE then + { catch the other exceptions } + begin + consume(_ELSE); + p_default:=statements_til_end; + end + else + consume(_END); + end + else + { catch all exceptions } + begin + p_default:=statements_til_end; + end; + dec(statement_level); + + block_type:=old_block_type; + try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false); + end; + end; + + + function exit_statement : ptree; + + var + p : ptree; + + begin + consume(_EXIT); + if try_to_consume(_LKLAMMER) then + begin + p:=comp_expr(true); + consume(_RKLAMMER); + if (block_type=bt_except) then + Message(parser_e_exit_with_argument_not__possible); + if procinfo^.returntype.def=pdef(voiddef) then + Message(parser_e_void_function); + end + else + p:=nil; + p:=gensinglenode(exitn,p); + p^.resulttype:=procinfo^.returntype.def; + exit_statement:=p; + end; + + + function _asm_statement : ptree; + var + asmstat : ptree; + Marker : Pai; + begin + Inside_asm_statement:=true; + case aktasmmode of + asmmode_none : ; { just be there to allow to a compile without + any assembler readers } +{$ifdef i386} + {$ifndef NoRA386Att} + asmmode_i386_att: + asmstat:=ra386att.assemble; + {$endif NoRA386Att} + {$ifndef NoRA386Int} + asmmode_i386_intel: + asmstat:=ra386int.assemble; + {$endif NoRA386Int} + {$ifndef NoRA386Dir} + asmmode_i386_direct: + begin + if not target_asm.allowdirect then + Message(parser_f_direct_assembler_not_allowed); + if (pocall_inline in aktprocsym^.definition^.proccalloptions) then + Begin + Message1(parser_w_not_supported_for_inline,'direct asm'); + Message(parser_w_inlining_disabled); +{$ifdef INCLUDEOK} + exclude(aktprocsym^.definition^.proccalloptions,pocall_inline); +{$else} + aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions-[pocall_inline]; +{$endif} + End; + asmstat:=ra386dir.assemble; + end; + {$endif NoRA386Dir} +{$endif} +{$ifdef m68k} + {$ifndef NoRA68kMot} + asmmode_m68k_mot: + asmstat:=ra68kmot.assemble; + {$endif NoRA68kMot} +{$endif} + else + Message(parser_f_assembler_reader_not_supported); + end; + + { Read first the _ASM statement } + consume(_ASM); + +{$ifndef newcg} + { END is read } + if try_to_consume(_LECKKLAMMER) then + begin + { it's possible to specify the modified registers } + asmstat^.object_preserved:=true; + if token<>_RECKKLAMMER then + repeat + { uppercase, because it's a CSTRING } + uppervar(pattern); +{$ifdef i386} + if pattern='EAX' then + usedinproc:=usedinproc or ($80 shr byte(R_EAX)) + else if pattern='EBX' then + usedinproc:=usedinproc or ($80 shr byte(R_EBX)) + else if pattern='ECX' then + usedinproc:=usedinproc or ($80 shr byte(R_ECX)) + else if pattern='EDX' then + usedinproc:=usedinproc or ($80 shr byte(R_EDX)) + else if pattern='ESI' then + begin + usedinproc:=usedinproc or ($80 shr byte(R_ESI)); + asmstat^.object_preserved:=false; + end + else if pattern='EDI' then + usedinproc:=usedinproc or ($80 shr byte(R_EDI)) +{$endif i386} +{$ifdef m68k} + if pattern='D0' then + usedinproc:=usedinproc or ($800 shr word(R_D0)) + else if pattern='D1' then + usedinproc:=usedinproc or ($800 shr word(R_D1)) + else if pattern='D6' then + usedinproc:=usedinproc or ($800 shr word(R_D6)) + else if pattern='A0' then + usedinproc:=usedinproc or ($800 shr word(R_A0)) + else if pattern='A1' then + usedinproc:=usedinproc or ($800 shr word(R_A1)) +{$endif m68k} + else consume(_RECKKLAMMER); + consume(_CSTRING); + if not try_to_consume(_COMMA) then + break; + until false; + consume(_RECKKLAMMER); + end + else usedinproc:=$ff; +{$endif newcg} + +{ mark the start and the end of the assembler block for the optimizer } + + If Assigned(AsmStat^.p_asm) Then + Begin + Marker := New(Pai_Marker, Init(AsmBlockStart)); + AsmStat^.p_asm^.Insert(Marker); + Marker := New(Pai_Marker, Init(AsmBlockEnd)); + AsmStat^.p_asm^.Concat(Marker); + End; + Inside_asm_statement:=false; + + _asm_statement:=asmstat; + end; + + + function new_dispose_statement : ptree; + var + p,p2 : ptree; + ht : ttoken; + again : boolean; { dummy for do_proc_call } + destructorname : stringid; + sym : psym; + classh : pobjectdef; + pd,pd2 : pdef; + destructorpos,storepos : tfileposinfo; + tt : ttreetyp; + begin + ht:=token; + if try_to_consume(_NEW) then + tt:=hnewn + else + begin + consume(_DISPOSE); + tt:=hdisposen; + end; + consume(_LKLAMMER); + + + p:=comp_expr(true); + + { calc return type } + cleartempgen; + do_firstpass(p); + set_varstate(p,tt=hdisposen); + + {var o:Pobject; + begin + new(o,init); (*Also a valid new statement*) + end;} + + if try_to_consume(_COMMA) then + begin + { extended syntax of new and dispose } + { function styled new is handled in factor } + { destructors have no parameters } + destructorname:=pattern; + destructorpos:=tokenpos; + consume(_ID); + + pd:=p^.resulttype; + if pd=nil then + pd:=generrordef; + pd2:=pd; + if (pd^.deftype<>pointerdef) then + begin + Message1(type_e_pointer_type_expected,pd^.typename); + p:=factor(false); + consume(_RKLAMMER); + new_dispose_statement:=genzeronode(errorn); + exit; + end; + { first parameter must be an object or class } + if ppointerdef(pd)^.pointertype.def^.deftype<>objectdef then + begin + Message(parser_e_pointer_to_class_expected); + new_dispose_statement:=factor(false); + consume_all_until(_RKLAMMER); + consume(_RKLAMMER); + exit; + end; + { check, if the first parameter is a pointer to a _class_ } + classh:=pobjectdef(ppointerdef(pd)^.pointertype.def); + if classh^.is_class then + begin + Message(parser_e_no_new_or_dispose_for_classes); + new_dispose_statement:=factor(false); + consume_all_until(_RKLAMMER); + consume(_RKLAMMER); + exit; + end; + { search cons-/destructor, also in parent classes } + storepos:=tokenpos; + tokenpos:=destructorpos; + sym:=search_class_member(classh,destructorname); + tokenpos:=storepos; + + { the second parameter of new/dispose must be a call } + { to a cons-/destructor } + if (not assigned(sym)) or (sym^.typ<>procsym) then + begin + if tt=hnewn then + Message(parser_e_expr_have_to_be_constructor_call) + else + Message(parser_e_expr_have_to_be_destructor_call); + new_dispose_statement:=genzeronode(errorn); + end + else + begin + p2:=gensinglenode(tt,p); + if ht=_NEW then + begin + { Constructors can take parameters.} + p2^.resulttype:=ppointerdef(pd)^.pointertype.def; + do_member_read(false,sym,p2,pd,again); + end + else + begin + if (m_tp in aktmodeswitches) then + begin + { Constructors can take parameters.} + p2^.resulttype:=ppointerdef(pd)^.pointertype.def; + do_member_read(false,sym,p2,pd,again); + end + else + begin + p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2); + { support dispose(p,done()); } + if try_to_consume(_LKLAMMER) then + begin + if not try_to_consume(_RKLAMMER) then + begin + Message(parser_e_no_paras_for_destructor); + consume_all_until(_RKLAMMER); + consume(_RKLAMMER); + end; + end; + end; + end; + + { we need the real called method } + cleartempgen; + do_firstpass(p2); + + if not codegenerror then + begin + if (ht=_NEW) and (p2^.procdefinition^.proctypeoption<>potype_constructor) then + Message(parser_e_expr_have_to_be_constructor_call); + if (ht=_DISPOSE) and (p2^.procdefinition^.proctypeoption<>potype_destructor) then + Message(parser_e_expr_have_to_be_destructor_call); + + if ht=_NEW then + begin + p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2)); + p2^.right^.resulttype:=pd2; + end; + end; + new_dispose_statement:=p2; + end; + end + else + begin + if p^.resulttype=nil then + p^.resulttype:=generrordef; + if (p^.resulttype^.deftype<>pointerdef) then + Begin + Message1(type_e_pointer_type_expected,p^.resulttype^.typename); + new_dispose_statement:=genzeronode(errorn); + end + else + begin + if (ppointerdef(p^.resulttype)^.pointertype.def^.deftype=objectdef) and + (oo_has_vmt in pobjectdef(ppointerdef(p^.resulttype)^.pointertype.def)^.objectoptions) then + Message(parser_w_use_extended_syntax_for_objects); + if (ppointerdef(p^.resulttype)^.pointertype.def^.deftype=orddef) and + (porddef(ppointerdef(p^.resulttype)^.pointertype.def)^.typ=uvoid) then + if (m_tp in aktmodeswitches) or + (m_delphi in aktmodeswitches) then + Message(parser_w_no_new_dispose_on_void_pointers) + else + Message(parser_e_no_new_dispose_on_void_pointers); + + case ht of + _NEW : new_dispose_statement:=gensinglenode(simplenewn,p); + _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p); + end; + end; + end; + consume(_RKLAMMER); + end; + + + function statement_block(starttoken : ttoken) : ptree; + + var + first,last : ptree; + filepos : tfileposinfo; + + begin + first:=nil; + filepos:=tokenpos; + consume(starttoken); + inc(statement_level); + + while not(token in [_END,_FINALIZATION]) do + begin + if first=nil then + begin + last:=gennode(statementn,nil,statement); + first:=last; + end + else + begin + last^.left:=gennode(statementn,nil,statement); + last:=last^.left; + end; + if (token in [_END,_FINALIZATION]) then + break + else + begin + { if no semicolon, then error and go on } + if token<>_SEMICOLON then + begin + consume(_SEMICOLON); + consume_all_until(_SEMICOLON); + end; + consume(_SEMICOLON); + end; + emptystats; + end; + + { don't consume the finalization token, it is consumed when + reading the finalization block, but allow it only after + an initalization ! } + if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then + consume(_END); + + dec(statement_level); + + last:=gensinglenode(blockn,first); + set_tree_filepos(last,filepos); + statement_block:=last; + end; + + + function statement : ptree; + + var + p : ptree; + code : ptree; + labelnr : pasmlabel; + filepos : tfileposinfo; + sr : plabelsym; + + label + ready; + + begin + filepos:=tokenpos; + case token of + _GOTO : begin + if not(cs_support_goto in aktmoduleswitches)then + Message(sym_e_goto_and_label_not_supported); + consume(_GOTO); + if (token<>_INTCONST) and (token<>_ID) then + begin + Message(sym_e_label_not_found); + code:=genzeronode(errorn); + end + else + begin + getsym(pattern,true); + consume(token); + if srsym^.typ<>labelsym then + begin + Message(sym_e_id_is_no_label_id); + code:=genzeronode(errorn); + end + else + begin + code:=genlabelnode(goton,plabelsym(srsym)^.lab); + code^.labsym:=plabelsym(srsym); + { set flag that this label is used } + plabelsym(srsym)^.used:=true; + end; + end; + end; + _BEGIN : code:=statement_block(_BEGIN); + _IF : code:=if_statement; + _CASE : code:=case_statement; + _REPEAT : code:=repeat_statement; + _WHILE : code:=while_statement; + _FOR : code:=for_statement; + _NEW,_DISPOSE : code:=new_dispose_statement; + + _WITH : code:=with_statement; + _TRY : code:=try_statement; + _RAISE : code:=raise_statement; + { semicolons,else until and end are ignored } + _SEMICOLON, + _ELSE, + _UNTIL, + _END: + code:=genzeronode(niln); + _FAIL : begin + { internalerror(100); } + if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then + Message(parser_e_fail_only_in_constructor); + consume(_FAIL); + code:=genzeronode(failn); + end; + _EXIT : code:=exit_statement; + _ASM : begin + code:=_asm_statement; + end; + _EOF : begin + Message(scan_f_end_of_file); + end; + else + begin + if (token in [_INTCONST,_ID]) then + begin + getsym(pattern,true); + lastsymknown:=true; + lastsrsym:=srsym; + { it is NOT necessarily the owner + it can be a withsymtable !!! } + lastsrsymtable:=srsymtable; + if assigned(srsym) and (srsym^.typ=labelsym) then + begin + consume(token); + consume(_COLON); + { we must preserve srsym to set code later } + sr:=plabelsym(srsym); + if sr^.defined then + Message(sym_e_label_already_defined); + sr^.defined:=true; + + { statement modifies srsym } + labelnr:=sr^.lab; + lastsymknown:=false; + { the pointer to the following instruction } + { isn't a very clean way } + code:=gensinglenode(labeln,statement{$ifndef tp}(){$endif}); + code^.labelnr:=labelnr; + sr^.code:=code; + { sorry, but there is a jump the easiest way } + goto ready; + end; + end; + p:=expr; + if not(p^.treetype in [calln,assignn,breakn,inlinen, + continuen]) then + Message(cg_e_illegal_expression); + { specify that we don't use the value returned by the call } + { Question : can this be also improtant + for inlinen ?? + it is used for : + - dispose of temp stack space + - dispose on FPU stack } + if p^.treetype=calln then + p^.return_value_used:=false; + code:=p; + end; + end; + ready: + if assigned(code) then + set_tree_filepos(code,filepos); + statement:=code; + end; + + function block(islibrary : boolean) : ptree; + + var + funcretsym : pfuncretsym; + storepos : tfileposinfo; + + begin + { do we have an assembler block without the po_assembler? + we should allow this for Delphi compatibility (PFV) } + if (token=_ASM) and (m_delphi in aktmodeswitches) then + begin + include(aktprocsym^.definition^.procoptions,po_assembler); + block:=assembler_block; + exit; + end; + if procinfo^.returntype.def<>pdef(voiddef) then + begin + { if the current is a function aktprocsym is non nil } + { and there is a local symtable set } + storepos:=tokenpos; + tokenpos:=aktprocsym^.fileinfo; + funcretsym:=new(pfuncretsym,init(aktprocsym^.name,procinfo)); + { insert in local symtable } + symtablestack^.insert(funcretsym); + tokenpos:=storepos; + if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then + procinfo^.return_offset:=-funcretsym^.address; + procinfo^.funcretsym:=funcretsym; + { insert result also if support is on } + if (m_result in aktmodeswitches) then + begin + procinfo^.resultfuncretsym:=new(pfuncretsym,init('RESULT',procinfo)); + symtablestack^.insert(procinfo^.resultfuncretsym); + end; + end; + read_declarations(islibrary); + + { temporary space is set, while the BEGIN of the procedure } + if (symtablestack^.symtabletype=localsymtable) then + procinfo^.firsttemp_offset := -symtablestack^.datasize + else + procinfo^.firsttemp_offset := 0; + + { space for the return value } + { !!!!! this means that we can not set the return value + in a subfunction !!!!! } + { because we don't know yet where the address is } + if procinfo^.returntype.def<>pdef(voiddef) then + begin + if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then + { if (procinfo^.retdef^.deftype=orddef) or + (procinfo^.retdef^.deftype=pointerdef) or + (procinfo^.retdef^.deftype=enumdef) or + (procinfo^.retdef^.deftype=procvardef) or + (procinfo^.retdef^.deftype=floatdef) or + ( + (procinfo^.retdef^.deftype=setdef) and + (psetdef(procinfo^.retdef)^.settype=smallset) + ) then } + begin + { the space has been set in the local symtable } + procinfo^.return_offset:=-funcretsym^.address; + if ((procinfo^.flags and pi_operator)<>0) and + assigned(opsym) then + {opsym^.address:=procinfo^.para_offset; is wrong PM } + opsym^.address:=-procinfo^.return_offset; + { eax is modified by a function } +{$ifndef newcg} +{$ifdef i386} + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + + if is_64bitint(procinfo^.returntype.def) then + usedinproc:=usedinproc or ($80 shr byte(R_EDX)) +{$endif} +{$ifdef m68k} + usedinproc:=usedinproc or ($800 shr word(R_D0)); + + if is_64bitint(procinfo^.retdef) then + usedinproc:=usedinproc or ($800 shr byte(R_D1)) +{$endif} +{$endif newcg} + end; + end; + + {Unit initialization?.} + if (lexlevel=unit_init_level) and (current_module^.is_unit) + or islibrary then + begin + if (token=_END) then + begin + consume(_END); + { We need at least a node, else the entry/exit code is not + generated and thus no PASCALMAIN symbol which we need (PFV) } + if islibrary then + block:=genzeronode(nothingn) + else + block:=nil; + end + else + begin + if token=_INITIALIZATION then + begin + current_module^.flags:=current_module^.flags or uf_init; + block:=statement_block(_INITIALIZATION); + end + else if (token=_FINALIZATION) then + begin + if (current_module^.flags and uf_finalize)<>0 then + block:=statement_block(_FINALIZATION) + else + begin + { can we allow no INITIALIZATION for DLL ?? + I think it should work PM } + block:=nil; + exit; + end; + end + else + begin + current_module^.flags:=current_module^.flags or uf_init; + block:=statement_block(_BEGIN); + end; + end; + end + else + block:=statement_block(_BEGIN); + end; + + function assembler_block : ptree; + + begin + read_declarations(false); + { temporary space is set, while the BEGIN of the procedure } + if symtablestack^.symtabletype=localsymtable then + procinfo^.firsttemp_offset := -symtablestack^.datasize + else + procinfo^.firsttemp_offset := 0; + + { assembler code does not allocate } + { space for the return value } + if procinfo^.returntype.def<>pdef(voiddef) then + begin + if ret_in_acc(procinfo^.returntype.def) then + begin + { in assembler code the result should be directly in %eax + procinfo^.retoffset:=procinfo^.firsttemp-procinfo^.retdef^.size; + procinfo^.firsttemp:=procinfo^.retoffset; } + +{$ifndef newcg} +{$ifdef i386} + usedinproc:=usedinproc or ($80 shr byte(R_EAX)) +{$endif} +{$ifdef m68k} + usedinproc:=usedinproc or ($800 shr word(R_D0)) +{$endif} +{$endif newcg} + end + { + else if not is_fpu(procinfo^.retdef) then + should we allow assembler functions of big elements ? + YES (FK)!! + Message(parser_e_asm_incomp_with_function_return); + } + end; + { set the framepointer to esp for assembler functions } + { but only if the are no local variables } + { added no parameter also (PM) } + { disable for methods, because self pointer is expected } + { at -8(%ebp) (JM) } + { why if se use %esp then self is still at the correct address PM } + if {not(assigned(procinfo^._class)) and} + (po_assembler in aktprocsym^.definition^.procoptions) and + (aktprocsym^.definition^.localst^.datasize=0) and + (aktprocsym^.definition^.parast^.datasize=0) and + not(ret_in_param(aktprocsym^.definition^.rettype.def)) then + begin + procinfo^.framepointer:=stack_pointer; + { set the right value for parameters } + dec(aktprocsym^.definition^.parast^.address_fixup,target_os.size_of_pointer); + dec(procinfo^.para_offset,target_os.size_of_pointer); + end; + { force the asm statement } + if token<>_ASM then + consume(_ASM); + procinfo^.Flags := procinfo^.Flags Or pi_is_assembler; + assembler_block:=_asm_statement; + { becuase the END is already read we need to get the + last_endtoken_filepos here (PFV) } + last_endtoken_filepos:=tokenpos; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.131 2000/06/30 22:15:39 peter + * fixed internalerror 2002 when case expr is not correct, by creating + a temp correct case expression + + Revision 1.130 2000/05/04 12:59:10 pierre + * bug found by Kovacs Attila Zoltan corrected + + Revision 1.129 2000/04/29 12:50:14 peter + * support asm block without assembler directive for -Sd + + Revision 1.128 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.127 2000/03/19 14:17:05 florian + * crash when using exception classes without sysutils unit fixed + + Revision 1.126 2000/03/19 11:16:44 peter + * check for unknown id in on exception + + Revision 1.125 2000/03/16 15:12:06 pierre + assembler method code does not need ebp framepointer + + Revision 1.124 2000/03/14 16:37:25 pierre + * destructor can have args in TP mode only (bug825 and 839) + + Revision 1.123 2000/02/29 23:59:47 pierre + Use $GOTO ON + + Revision 1.122 2000/02/09 13:22:59 peter + * log truncated + + Revision 1.121 2000/01/23 16:33:49 peter + * fixed destructor parsing with preprocessor things + * support dipsoe(p,done()) + * fixed constructor message with dispose(p,) + + Revision 1.120 2000/01/16 22:17:12 peter + * renamed call_offset to para_offset + + Revision 1.119 2000/01/12 10:30:50 peter + * fixed library with only end. + + Revision 1.118 2000/01/07 01:14:31 peter + * updated copyright to 2000 + + Revision 1.117 1999/12/22 01:01:52 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.116 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.115 1999/12/01 22:43:17 peter + * fixed sigsegv with casedef=nil + + Revision 1.114 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.113 1999/11/30 10:40:45 peter + + ttype, tsymlist + + Revision 1.112 1999/11/20 01:19:10 pierre + * DLL index used for win32 target with DEF file + + DLL initialization/finalization support + + Revision 1.111 1999/11/18 15:34:48 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.110 1999/11/17 17:05:02 pierre + * Notes/hints changes + + Revision 1.109 1999/11/15 22:00:48 peter + * labels used but not defined give error instead of warning, the warning + is now only with declared but not defined and not used. + + Revision 1.108 1999/11/10 00:24:02 pierre + * more browser details + + Revision 1.107 1999/11/09 13:02:46 peter + * fixed 'raise end;' + + Revision 1.106 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.105 1999/10/22 10:39:35 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.104 1999/10/14 14:57:54 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.103 1999/09/27 23:44:56 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.102 1999/09/16 23:05:54 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} \ No newline at end of file diff --git a/befpc/compiler/psub.pas b/befpc/compiler/psub.pas new file mode 100644 index 0000000..136e0f1 --- /dev/null +++ b/befpc/compiler/psub.pas @@ -0,0 +1,2238 @@ +{ + $Id: psub.pas,v 1.1.1.1 2001-07-23 17:16:53 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Daniel Mantione + + Does the parsing of the procedures/functions + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit psub; +interface + +uses + cobjects, + symconst,tokens,symtable; + +const + pd_global = $1; { directive must be global } + pd_body = $2; { directive needs a body } + pd_implemen = $4; { directive can be used implementation section } + pd_interface = $8; { directive can be used interface section } + pd_object = $10; { directive can be used object declaration } + pd_procvar = $20; { directive can be used procvar declaration } + pd_notobject = $40;{ directive can not be used object declaration } + +procedure compile_proc_body(const proc_names:Tstringcontainer; + make_global,parent_has_class:boolean); +procedure parse_proc_head(options:tproctypeoption); +procedure parse_proc_dec; +function is_proc_directive(tok:ttoken):boolean; +procedure parse_var_proc_directives(var sym : psym); +procedure parse_object_proc_directives(var sym : pprocsym); +procedure read_proc; + +implementation + +uses + globtype,systems, + strings,globals,verbose,files, + scanner,aasm,tree,types, + import,gendef,htypechk, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen,temp_gen, +{$endif newcg} + pass_1,cpubase,cpuasm +{$ifndef NOPASS2} + ,pass_2 +{$endif} +{$ifdef GDB} + ,gdb +{$endif GDB} +{$ifdef newcg} + {$ifndef NOOPT} + ,aopt + {$endif} +{$else} + {$ifdef i386} + ,tgeni386 + ,cgai386 + {$ifndef NOOPT} + ,aopt386 + {$endif} + {$endif} + {$ifdef m68k} + ,tgen68k,cga68k + {$endif} +{$endif newcg} + { parser specific stuff } + ,pbase,ptype,pdecl,pexpr,pstatmnt +{$ifdef newcg} + ,tgcpu,convtree,cgobj,tgeni386 { for the new code generator tgeni386 is only a dummy } +{$endif newcg} + ; + +var + realname:string; { contains the real name of a procedure as it's typed } + + +procedure parse_proc_head(options:tproctypeoption); +var sp:stringid; + pd:Pprocdef; + paramoffset:longint; + sym:Psym; + hs:string; + st : psymtable; + overloaded_level:word; + storepos,procstartfilepos : tfileposinfo; +begin +{ Save the position where this procedure really starts and set col to 1 which + looks nicer } + procstartfilepos:=tokenpos; +{ procstartfilepos.column:=1; I do not agree here !! + lets keep excat position PM } + + if (options=potype_operator) then + begin + sp:=overloaded_names[optoken]; + realname:=sp; + end + else + begin + sp:=pattern; + realname:=orgpattern; + consume(_ID); + end; + +{ method ? } + if not(parse_only) and + (lexlevel=normal_function_level) and + try_to_consume(_POINT) then + begin + storepos:=tokenpos; + tokenpos:=procstartfilepos; + getsym(sp,true); + sym:=srsym; + tokenpos:=storepos; + { load proc name } + sp:=pattern; + realname:=orgpattern; + procstartfilepos:=tokenpos; + { qualifier is class name ? } + if (sym^.typ<>typesym) or + (ptypesym(sym)^.restype.def^.deftype<>objectdef) then + begin + Message(parser_e_class_id_expected); + aktprocsym:=nil; + consume(_ID); + end + else + begin + { used to allow private syms to be seen } + aktobjectdef:=pobjectdef(ptypesym(sym)^.restype.def); + procinfo^._class:=pobjectdef(ptypesym(sym)^.restype.def); + aktprocsym:=pprocsym(procinfo^._class^.symtable^.search(sp)); + consume(_ID); + {The procedure has been found. So it is + a global one. Set the flags to mark this.} + procinfo^.flags:=procinfo^.flags or pi_is_global; + aktobjectdef:=nil; + { we solve this below } + if not(assigned(aktprocsym)) then + Message(parser_e_methode_id_expected); + end; + end + else + begin + { check for constructor/destructor which is not allowed here } + if (not parse_only) and + (options in [potype_constructor,potype_destructor]) then + Message(parser_e_constructors_always_objects); + + tokenpos:=procstartfilepos; + aktprocsym:=pprocsym(symtablestack^.search(sp)); + + if not(parse_only) then + begin + {The procedure we prepare for is in the implementation + part of the unit we compile. It is also possible that we + are compiling a program, which is also some kind of + implementaion part. + + We need to find out if the procedure is global. If it is + global, it is in the global symtable.} + if not assigned(aktprocsym) and + (symtablestack^.symtabletype=staticsymtable) then + begin + {Search the procedure in the global symtable.} + aktprocsym:=Pprocsym(search_a_symtable(sp,globalsymtable)); + if assigned(aktprocsym) then + begin + {Check if it is a procedure.} + if aktprocsym^.typ<>procsym then + DuplicateSym(aktprocsym); + {The procedure has been found. So it is + a global one. Set the flags to mark this.} + procinfo^.flags:=procinfo^.flags or pi_is_global; + end; + end; + end; + end; + +{ Create the mangledname } +{$ifndef UseNiceNames} + if assigned(procinfo^._class) then + begin + if (pos('_$$_',procprefix)=0) then + hs:=procprefix+'_$$_'+procinfo^._class^.objname^+'_$$_'+sp + else + hs:=procprefix+'_$'+sp; + end + else + begin + if lexlevel=normal_function_level then + hs:=procprefix+'_'+sp + else + hs:=procprefix+'_$'+sp; + end; +{$else UseNiceNames} + if assigned(procinfo^._class) then + begin + if (pos('_5Class_',procprefix)=0) then + hs:=procprefix+'_5Class_'+procinfo^._class^.name^+'_'+tostr(length(sp))+sp + else + hs:=procprefix+'_'+tostr(length(sp))+sp; + end + else + begin + if lexlevel=normal_function_level then + hs:=procprefix+'_'+tostr(length(sp))+sp + else + hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp; + end; +{$endif UseNiceNames} + + if assigned(aktprocsym) then + begin + { Check if overloaded is a procsym, we use a different error message + for tp7 so it looks more compatible } + if aktprocsym^.typ<>procsym then + begin + if (m_fpc in aktmodeswitches) then + Message1(parser_e_overloaded_no_procedure,aktprocsym^.name) + else + DuplicateSym(aktprocsym); + { try to recover by creating a new aktprocsym } + tokenpos:=procstartfilepos; + aktprocsym:=new(pprocsym,init(sp)); + end; + end + else + begin + { create a new procsym and set the real filepos } + tokenpos:=procstartfilepos; + aktprocsym:=new(pprocsym,init(sp)); + { for operator we have only one definition for each overloaded + operation } + if (options=potype_operator) then + begin + { the only problem is that nextoverloaded might not be in a unit + known for the unit itself } + { not anymore PM } + if assigned(overloaded_operators[optoken]) then + aktprocsym^.definition:=overloaded_operators[optoken]^.definition; +{$ifndef DONOTCHAINOPERATORS} + overloaded_operators[optoken]:=aktprocsym; +{$endif DONOTCHAINOPERATORS} + end; + symtablestack^.insert(aktprocsym); + end; + + st:=symtablestack; + pd:=new(pprocdef,init); + pd^.symtablelevel:=symtablestack^.symtablelevel; + + if assigned(procinfo^._class) then + pd^._class := procinfo^._class; + + { set the options from the caller (podestructor or poconstructor) } + pd^.proctypeoption:=options; + + { calculate the offset of the parameters } + paramoffset:=8; + + { calculate frame pointer offset } + if lexlevel>normal_function_level then + begin + procinfo^.framepointer_offset:=paramoffset; + inc(paramoffset,target_os.size_of_pointer); + { this is needed to get correct framepointer push for local + forward functions !! } + pd^.parast^.symtablelevel:=lexlevel; + end; + + if assigned (procinfo^._Class) and + not(procinfo^._Class^.is_class) and + (pd^.proctypeoption in [potype_constructor,potype_destructor]) then + inc(paramoffset,target_os.size_of_pointer); + + { self pointer offset } + { self isn't pushed in nested procedure of methods } + if assigned(procinfo^._class) and (lexlevel=normal_function_level) then + begin + procinfo^.selfpointer_offset:=paramoffset; + if assigned(aktprocsym^.definition) and + not(po_containsself in aktprocsym^.definition^.procoptions) then + inc(paramoffset,target_os.size_of_pointer); + end; + + { con/-destructor flag ? } + if assigned (procinfo^._Class) and + procinfo^._class^.is_class and + (pd^.proctypeoption in [potype_destructor,potype_constructor]) then + inc(paramoffset,target_os.size_of_pointer); + + procinfo^.para_offset:=paramoffset; + + pd^.parast^.datasize:=0; + + pd^.nextoverloaded:=aktprocsym^.definition; + aktprocsym^.definition:=pd; + { this is probably obsolete now PM } + aktprocsym^.definition^.fileinfo:=procstartfilepos; + aktprocsym^.definition^.setmangledname(hs); + aktprocsym^.definition^.procsym:=aktprocsym; + + if not parse_only then + begin + overloaded_level:=0; + { we need another procprefix !!! } + { count, but only those in the same unit !!} + while assigned(pd) and + (pd^.owner^.symtabletype in [globalsymtable,staticsymtable]) do + begin + { only count already implemented functions } + if not(pd^.forwarddef) then + inc(overloaded_level); + pd:=pd^.nextoverloaded; + end; + if overloaded_level>0 then + procprefix:=hs+'$'+tostr(overloaded_level)+'$' + else + procprefix:=hs+'$'; + end; + + { this must also be inserted in the right symtable !! PM } + { otherwise we get subbtle problems with + definitions of args defs in staticsymtable for + implementation of a global method } + if token=_LKLAMMER then + parameter_dec(aktprocsym^.definition); + + { so we only restore the symtable now } + symtablestack:=st; + if (options=potype_operator) then + overloaded_operators[optoken]:=aktprocsym; +end; + + +procedure parse_proc_dec; +var + hs : string; + isclassmethod : boolean; +begin + inc(lexlevel); +{ read class method } + if token=_CLASS then + begin + consume(_CLASS); + isclassmethod:=true; + end + else + isclassmethod:=false; + case token of + _FUNCTION : begin + consume(_FUNCTION); + parse_proc_head(potype_none); + if token<>_COLON then + begin + if not(aktprocsym^.definition^.forwarddef) or + (m_repeat_forward in aktmodeswitches) then + begin + consume(_COLON); + consume_all_until(_SEMICOLON); + end; + end + else + begin + consume(_COLON); + inc(testcurobject); + single_type(aktprocsym^.definition^.rettype,hs,false); + aktprocsym^.definition^.test_if_fpu_result; + dec(testcurobject); + end; + end; + _PROCEDURE : begin + consume(_PROCEDURE); + parse_proc_head(potype_none); + aktprocsym^.definition^.rettype.def:=voiddef; + end; + _CONSTRUCTOR : begin + consume(_CONSTRUCTOR); + parse_proc_head(potype_constructor); + if assigned(procinfo^._class) and + procinfo^._class^.is_class then + begin + { CLASS constructors return the created instance } + aktprocsym^.definition^.rettype.def:=procinfo^._class; + end + else + begin + { OBJECT constructors return a boolean } +{$IfDef GDB} + { GDB doesn't like unnamed types !} + aktprocsym^.definition^.rettype.def:=globaldef('boolean'); +{$else GDB} + aktprocsym^.definition^.rettype.def:=new(porddef,init(bool8bit,0,1)); +{$Endif GDB} + end; + end; + _DESTRUCTOR : begin + consume(_DESTRUCTOR); + parse_proc_head(potype_destructor); + aktprocsym^.definition^.rettype.def:=voiddef; + end; + _OPERATOR : begin + if lexlevel>normal_function_level then + Message(parser_e_no_local_operator); + consume(_OPERATOR); + if not(token in [_PLUS..last_overloaded]) then + Message(parser_e_overload_operator_failed); + optoken:=token; + consume(Token); + procinfo^.flags:=procinfo^.flags or pi_operator; + parse_proc_head(potype_operator); + if token<>_ID then + begin + opsym:=nil; + if not(m_result in aktmodeswitches) then + consume(_ID); + end + else + begin + opsym:=new(pvarsym,initdef(pattern,voiddef)); + consume(_ID); + end; + if not try_to_consume(_COLON) then + begin + consume(_COLON); + aktprocsym^.definition^.rettype.def:=generrordef; + consume_all_until(_SEMICOLON); + end + else + begin + single_type(aktprocsym^.definition^.rettype,hs,false); + aktprocsym^.definition^.test_if_fpu_result; + if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and + ((aktprocsym^.definition^.rettype.def^.deftype<> + orddef) or (porddef(aktprocsym^.definition^. + rettype.def)^.typ<>bool8bit)) then + Message(parser_e_comparative_operator_return_boolean); + if assigned(opsym) then + opsym^.vartype.def:=aktprocsym^.definition^.rettype.def; + { We need to add the return type in the mangledname + to allow overloading with just different results !! (PM) } + aktprocsym^.definition^.setmangledname( + aktprocsym^.definition^.mangledname+'$$'+hs); + if (optoken=_ASSIGNMENT) and + is_equal(aktprocsym^.definition^.rettype.def, + pvarsym(aktprocsym^.definition^.parast^.symindex^.first)^.vartype.def) then + message(parser_e_no_such_assignment) + else if not isoperatoracceptable(aktprocsym^.definition,optoken) then + Message(parser_e_overload_impossible); + end; + end; + end; + if isclassmethod and + assigned(aktprocsym) then +{$ifdef INCLUDEOK} + include(aktprocsym^.definition^.procoptions,po_classmethod); +{$else} + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_classmethod]; +{$endif} + consume(_SEMICOLON); + dec(lexlevel); +end; + + +{**************************************************************************** + Procedure directive handlers +****************************************************************************} + +{$ifdef tp} + {$F+} +{$endif} + +procedure pd_far(const procnames:Tstringcontainer); +begin + Message(parser_w_proc_far_ignored); +end; + +procedure pd_near(const procnames:Tstringcontainer); +begin + Message(parser_w_proc_near_ignored); +end; + +procedure pd_export(const procnames:Tstringcontainer); +begin + if assigned(procinfo^._class) then + Message(parser_e_methods_dont_be_export); + if lexlevel<>normal_function_level then + Message(parser_e_dont_nest_export); + { only os/2 needs this } + if target_info.target=target_i386_os2 then + begin + procnames.insert(realname); + procinfo^.exported:=true; + if cs_link_deffile in aktglobalswitches then + deffile.AddExport(aktprocsym^.definition^.mangledname); + end; +end; + +procedure pd_inline(const procnames:Tstringcontainer); +begin + if not(cs_support_inline in aktmoduleswitches) then + Message(parser_e_proc_inline_not_supported); +end; + +procedure pd_forward(const procnames:Tstringcontainer); +begin + aktprocsym^.definition^.forwarddef:=true; +end; + +procedure pd_stdcall(const procnames:Tstringcontainer); +begin +end; + +procedure pd_safecall(const procnames:Tstringcontainer); +begin +end; + +procedure pd_alias(const procnames:Tstringcontainer); +begin + consume(_COLON); + procnames.insert(get_stringconst); +end; + +procedure pd_asmname(const procnames:Tstringcontainer); +begin + aktprocsym^.definition^.setmangledname(target_os.Cprefix+pattern); + if token=_CCHAR then + consume(_CCHAR) + else + consume(_CSTRING); + { we don't need anything else } + aktprocsym^.definition^.forwarddef:=false; +end; + +procedure pd_intern(const procnames:Tstringcontainer); +begin + consume(_COLON); + aktprocsym^.definition^.extnumber:=get_intconst; +end; + +procedure pd_interrupt(const procnames:Tstringcontainer); +begin +{$ifndef i386} + Message(parser_w_proc_interrupt_ignored); +{$else i386} + if lexlevel<>normal_function_level then + Message(parser_e_dont_nest_interrupt); +{$endif i386} +end; + +procedure pd_system(const procnames:Tstringcontainer); +begin + aktprocsym^.definition^.setmangledname(realname); +end; + +procedure pd_abstract(const procnames:Tstringcontainer); +begin + if (po_virtualmethod in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktprocsym^.definition^.procoptions,po_abstractmethod) +{$else} + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_abstractmethod] +{$endif} + else + Message(parser_e_only_virtual_methods_abstract); + { the method is defined } + aktprocsym^.definition^.forwarddef:=false; +end; + +procedure pd_virtual(const procnames:Tstringcontainer); +{$ifdef WITHDMT} +var + pt : ptree; +{$endif WITHDMT} +begin + if (aktprocsym^.definition^.proctypeoption=potype_constructor) and + not(aktprocsym^.definition^._class^.is_class) then + Message(parser_e_constructor_cannot_be_not_virtual); +{$ifdef WITHDMT} + if not(aktprocsym^.definition^._class^.is_class) and + (token<>_SEMICOLON) then + begin + { any type of parameter is allowed here! } + + pt:=comp_expr(true); + do_firstpass(pt); + if is_constintnode(pt) then + begin + include(aktprocsym^.definition^.procoptions,po_msgint); + aktprocsym^.definition^.messageinf.i:=pt^.value; + end + else + Message(parser_e_ill_msg_expr); + disposetree(pt); + end; +{$endif WITHDMT} +end; + +procedure pd_static(const procnames:Tstringcontainer); +begin + if (cs_static_keyword in aktmoduleswitches) then + begin +{$ifdef INCLUDEOK} + include(aktprocsym^.symoptions,sp_static); + include(aktprocsym^.definition^.procoptions,po_staticmethod); +{$else} + aktprocsym^.symoptions:=aktprocsym^.symoptions+[sp_static]; + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_staticmethod]; +{$endif} + end; +end; + +procedure pd_override(const procnames:Tstringcontainer); +begin + if not(aktprocsym^.definition^._class^.is_class) then + Message(parser_e_no_object_override); +end; + +procedure pd_overload(const procnames:Tstringcontainer); +begin +end; + +procedure pd_message(const procnames:Tstringcontainer); +var + pt : ptree; +begin + { check parameter type } + if not(po_containsself in aktprocsym^.definition^.procoptions) and + ((aktprocsym^.definition^.para^.count<>1) or + (pparaitem(aktprocsym^.definition^.para^.first)^.paratyp<>vs_var)) then + Message(parser_e_ill_msg_param); + pt:=comp_expr(true); + do_firstpass(pt); + if pt^.treetype=stringconstn then + begin +{$ifdef INCLUDEOK} + include(aktprocsym^.definition^.procoptions,po_msgstr); +{$else} + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_msgstr]; +{$endif} + aktprocsym^.definition^.messageinf.str:=strnew(pt^.value_str); + end + else + if is_constintnode(pt) then + begin +{$ifdef INCLUDEOK} + include(aktprocsym^.definition^.procoptions,po_msgint); +{$else} + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_msgint]; +{$endif} + aktprocsym^.definition^.messageinf.i:=pt^.value; + end + else + Message(parser_e_ill_msg_expr); + disposetree(pt); +end; + + +procedure resetvaluepara(p:pnamedindexobject);{$ifndef FPC}far;{$endif} +begin + if psym(p)^.typ=varsym then + with pvarsym(p)^ do + if copy(name,1,3)='val' then + aktprocsym^.definition^.parast^.symsearch^.rename(name,copy(name,4,length(name))); +end; + + +procedure pd_cdecl(const procnames:Tstringcontainer); +begin + if aktprocsym^.definition^.deftype<>procvardef then + aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname); + { do not copy on local !! } + if (aktprocsym^.definition^.deftype=procdef) and + assigned(aktprocsym^.definition^.parast) then + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}resetvaluepara); +end; + + +procedure pd_pascal(const procnames:Tstringcontainer); +var st,parast : psymtable; + lastps,ps : psym; +begin + new(st,init(parasymtable)); + parast:=aktprocsym^.definition^.parast; + lastps:=nil; + while assigned(parast^.symindex^.first) and (lastps<>psym(parast^.symindex^.first)) do + begin + ps:=psym(parast^.symindex^.first); + while assigned(ps^.next) and (psym(ps^.next)<>lastps) do + ps:=psym(ps^.next); + ps^.owner:=st; + { recalculate the corrected offset } + { the really_insert_in_data procedure + for parasymtable should only calculateoffset PM } + ps^.insert_in_data; + { reset the owner correctly } + ps^.owner:=parast; + lastps:=ps; + end; +end; + + +procedure pd_register(const procnames:Tstringcontainer); +begin + Message1(parser_w_proc_directive_ignored,'REGISTER'); +end; + + +procedure pd_reintroduce(const procnames:Tstringcontainer); +begin + Message1(parser_w_proc_directive_ignored,'REINTRODUCE'); +end; + + +procedure pd_syscall(const procnames:Tstringcontainer); +begin + aktprocsym^.definition^.forwarddef:=false; + aktprocsym^.definition^.extnumber:=get_intconst; +end; + + +procedure pd_external(const procnames:Tstringcontainer); +{ + If import_dll=nil the procedure is assumed to be in another + object file. In that object file it should have the name to + which import_name is pointing to. Otherwise, the procedure is + assumed to be in the DLL to which import_dll is pointing to. In + that case either import_nr<>0 or import_name<>nil is true, so + the procedure is either imported by number or by name. (DM) +} +var + import_dll, + import_name : string; + import_nr : word; +begin + aktprocsym^.definition^.forwarddef:=false; +{ If the procedure should be imported from a DLL, a constant string follows. + This isn't really correct, an contant string expression follows + so we check if an semicolon follows, else a string constant have to + follow (FK) } + import_nr:=0; + import_name:=''; + if not(token=_SEMICOLON) and not(idtoken=_NAME) then + begin + import_dll:=get_stringconst; + if (idtoken=_NAME) then + begin + consume(_NAME); + import_name:=get_stringconst; + end; + if (idtoken=_INDEX) then + begin + {After the word index follows the index number in the DLL.} + consume(_INDEX); + import_nr:=get_intconst; + end; + if (import_nr=0) and (import_name='') then + {if (aktprocsym^.definition^.options and pocdecl)<>0 then + import_name:=aktprocsym^.definition^.mangledname + else + Message(parser_w_empty_import_name);} + { this should work both for win32 and Linux !! PM } + import_name:=realname; + if not(current_module^.uses_imports) then + begin + current_module^.uses_imports:=true; + importlib^.preparelib(current_module^.modulename^); + end; + if not(m_repeat_forward in aktmodeswitches) then + begin + { we can only have one overloaded here ! } + if assigned(aktprocsym^.definition^.nextoverloaded) then + importlib^.importprocedure(aktprocsym^.definition^.nextoverloaded^.mangledname, + import_dll,import_nr,import_name) + else + importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name); + end + else + importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name); + end + else + begin + if (idtoken=_NAME) then + begin + consume(_NAME); + import_name:=get_stringconst; + aktprocsym^.definition^.setmangledname(import_name); + end + else + begin + { external shouldn't override the cdecl/system name } + if not (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then + aktprocsym^.definition^.setmangledname(aktprocsym^.name); + end; + end; +end; + +{$ifdef TP} + {$F-} +{$endif} + +{$ifdef Delphi} + {$define TP} +{$endif Delphi} + +{const + namelength=15;} +type + pd_handler=procedure(const procnames:Tstringcontainer); + proc_dir_rec=record + idtok : ttoken; + pd_flags : longint; + handler : pd_handler; + pocall : tproccalloptions; + pooption : tprocoptions; + mutexclpocall : tproccalloptions; + mutexclpotype : tproctypeoptions; + mutexclpo : tprocoptions; + end; +const + {Should contain the number of procedure directives we support.} + num_proc_directives=31; + proc_direcdata:array[1..num_proc_directives] of proc_dir_rec= + ( + ( + idtok:_ABSTRACT; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_abstract; + pocall : []; + pooption : [po_abstractmethod]; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : [potype_constructor,potype_destructor]; + mutexclpo : [po_exports,po_interrupt,po_external] + ),( + idtok:_ALIAS; + pd_flags : pd_implemen+pd_body; + handler : {$ifndef TP}@{$endif}pd_alias; + pocall : []; + pooption : []; + mutexclpocall : [pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_ASMNAME; + pd_flags : pd_interface+pd_implemen; + handler : {$ifndef TP}@{$endif}pd_asmname; + pocall : [pocall_cdecl,pocall_clearstack]; + pooption : [po_external]; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_ASSEMBLER; + pd_flags : pd_implemen+pd_body; + handler : nil; + pocall : []; + pooption : [po_assembler]; + mutexclpocall : []; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_CDECL; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_cdecl; + pocall : [pocall_cdecl,pocall_clearstack]; + pooption : [po_savestdregs]; + mutexclpocall : [pocall_internproc,pocall_leftright,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_assembler,po_external] + ),( + idtok:_DYNAMIC; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_virtual; + pocall : []; + pooption : [po_virtualmethod]; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_exports,po_interrupt,po_external] + ),( + idtok:_EXPORT; + pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??}; + handler : {$ifndef TP}@{$endif}pd_export; + pocall : []; + pooption : [po_exports]; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_external,po_interrupt] + ),( + idtok:_EXTERNAL; + pd_flags : pd_implemen+pd_interface; + handler : {$ifndef TP}@{$endif}pd_external; + pocall : []; + pooption : [po_external]; + mutexclpocall : [pocall_internproc,pocall_inline,pocall_palmossyscall]; + mutexclpotype : []; + mutexclpo : [po_exports,po_interrupt,po_assembler] + ),( + idtok:_FAR; + pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_far; + pocall : []; + pooption : []; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [] + ),( + idtok:_FORWARD; + pd_flags : pd_implemen; + handler : {$ifndef TP}@{$endif}pd_forward; + pocall : []; + pooption : []; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_INLINE; + pd_flags : pd_implemen+pd_body; + handler : {$ifndef TP}@{$endif}pd_inline; + pocall : [pocall_inline]; + pooption : []; + mutexclpocall : [pocall_internproc]; + mutexclpotype : [potype_constructor,potype_destructor]; + mutexclpo : [po_exports,po_external,po_interrupt] + ),( + idtok:_INTERNCONST; + pd_flags : pd_implemen+pd_body; + handler : {$ifndef TP}@{$endif}pd_intern; + pocall : [pocall_internconst]; + pooption : []; + mutexclpocall : []; + mutexclpotype : [potype_operator]; + mutexclpo : [] + ),( + idtok:_INTERNPROC; + pd_flags : pd_implemen; + handler : {$ifndef TP}@{$endif}pd_intern; + pocall : [pocall_internproc]; + pooption : []; + mutexclpocall : [pocall_inline,pocall_clearstack,pocall_leftright,pocall_cdecl]; + mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; + mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck] + ),( + idtok:_INTERRUPT; + pd_flags : pd_implemen+pd_body; + handler : {$ifndef TP}@{$endif}pd_interrupt; + pocall : []; + pooption : [po_interrupt]; + mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_clearstack,pocall_leftright,pocall_inline]; + mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; + mutexclpo : [po_external] + ),( + idtok:_IOCHECK; + pd_flags : pd_implemen+pd_body; + handler : nil; + pocall : []; + pooption : [po_iocheck]; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_MESSAGE; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_message; + pocall : []; + pooption : []; { can be po_msgstr or po_msgint } + mutexclpocall : [pocall_inline,pocall_internproc]; + mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; + mutexclpo : [po_interrupt,po_external] + ),( + idtok:_NEAR; + pd_flags : pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_near; + pocall : []; + pooption : []; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [] + ),( + idtok:_OVERLOAD; + pd_flags : pd_implemen+pd_interface+pd_body; + handler : {$ifndef TP}@{$endif}pd_overload; + pocall : []; + pooption : [po_overload]; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [] + ),( + idtok:_OVERRIDE; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_override; + pocall : []; + pooption : [po_overridingmethod,po_virtualmethod]; + mutexclpocall : [pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_exports,po_external,po_interrupt] + ),( + idtok:_PASCAL; + pd_flags : pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_pascal; + pocall : [pocall_leftright]; + pooption : []; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_POPSTACK; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : nil; + pocall : [pocall_clearstack]; + pooption : []; + mutexclpocall : [pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_assembler,po_external] + ),( + idtok:_PUBLIC; + pd_flags : pd_implemen+pd_body+pd_global+pd_notobject; + handler : nil; + pocall : []; + pooption : []; + mutexclpocall : [pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_REGISTER; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_register; + pocall : [pocall_register]; + pooption : []; + mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_REINTRODUCE; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_reintroduce; + pocall : []; + pooption : []; + mutexclpocall : []; + mutexclpotype : []; + mutexclpo : [] + ),( + idtok:_SAFECALL; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_safecall; + pocall : [pocall_safecall]; + pooption : [po_savestdregs]; + mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc,pocall_inline]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_SAVEREGISTERS; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : nil; + pocall : []; + pooption : [po_saveregisters]; + mutexclpocall : [pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_STATIC; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_static; + pocall : []; + pooption : [po_staticmethod]; + mutexclpocall : [pocall_inline,pocall_internproc]; + mutexclpotype : [potype_constructor,potype_destructor]; + mutexclpo : [po_external,po_interrupt,po_exports] + ),( + idtok:_STDCALL; + pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; + handler : {$ifndef TP}@{$endif}pd_stdcall; + pocall : [pocall_stdcall]; + pooption : [po_savestdregs]; + mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external] + ),( + idtok:_SYSCALL; + pd_flags : pd_interface; + handler : {$ifndef TP}@{$endif}pd_syscall; + pocall : [pocall_palmossyscall]; + pooption : []; + mutexclpocall : [pocall_cdecl,pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external,po_assembler,po_interrupt,po_exports] + ),( + idtok:_SYSTEM; + pd_flags : pd_implemen; + handler : {$ifndef TP}@{$endif}pd_system; + pocall : [pocall_clearstack]; + pooption : []; + mutexclpocall : [pocall_leftright,pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external,po_assembler,po_interrupt] + ),( + idtok:_VIRTUAL; + pd_flags : pd_interface+pd_object; + handler : {$ifndef TP}@{$endif}pd_virtual; + pocall : []; + pooption : [po_virtualmethod]; + mutexclpocall : [pocall_inline,pocall_internproc]; + mutexclpotype : []; + mutexclpo : [po_external,po_interrupt,po_exports] + ) + ); + + +function is_proc_directive(tok:ttoken):boolean; +var + i : longint; +begin + is_proc_directive:=false; + for i:=1 to num_proc_directives do + if proc_direcdata[i].idtok=idtoken then + begin + is_proc_directive:=true; + exit; + end; +end; + + +function parse_proc_direc(const proc_names:Tstringcontainer;var pdflags:word):boolean; +{ + Parse the procedure directive, returns true if a correct directive is found +} +var + p : longint; + found : boolean; + name : string; +begin + parse_proc_direc:=false; + name:=pattern; + found:=false; + for p:=1 to num_proc_directives do + if proc_direcdata[p].idtok=idtoken then + begin + found:=true; + break; + end; + +{ Check if the procedure directive is known } + if not found then + begin + { parsing a procvar type the name can be any + next variable !! } + if (pdflags and (pd_procvar or pd_object))=0 then + Message1(parser_w_unknown_proc_directive_ignored,name); + exit; + end; + + { static needs a special treatment } + if (idtoken=_STATIC) and not (cs_static_keyword in aktmoduleswitches) then + exit; + +{ Conflicts between directives ? } + if (aktprocsym^.definition^.proctypeoption in proc_direcdata[p].mutexclpotype) or + ((aktprocsym^.definition^.proccalloptions*proc_direcdata[p].mutexclpocall)<>[]) or + ((aktprocsym^.definition^.procoptions*proc_direcdata[p].mutexclpo)<>[]) then + begin + Message1(parser_e_proc_dir_conflict,name); + exit; + end; + +{ Check if the directive is only for objects } + if ((proc_direcdata[p].pd_flags and pd_object)<>0) and + not assigned(aktprocsym^.definition^._class) then + begin + exit; + end; +{ check if method and directive not for object public } + if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and + assigned(aktprocsym^.definition^._class) then + begin + exit; + end; + +{ consume directive, and turn flag on } + consume(token); + parse_proc_direc:=true; + +{ Check the pd_flags if the directive should be allowed } + if ((pdflags and pd_interface)<>0) and + ((proc_direcdata[p].pd_flags and pd_interface)=0) then + begin + Message1(parser_e_proc_dir_not_allowed_in_interface,name); + exit; + end; + if ((pdflags and pd_implemen)<>0) and + ((proc_direcdata[p].pd_flags and pd_implemen)=0) then + begin + Message1(parser_e_proc_dir_not_allowed_in_implementation,name); + exit; + end; + if ((pdflags and pd_procvar)<>0) and + ((proc_direcdata[p].pd_flags and pd_procvar)=0) then + begin + Message1(parser_e_proc_dir_not_allowed_in_procvar,name); + exit; + end; + +{ Return the new pd_flags } + if (proc_direcdata[p].pd_flags and pd_body)=0 then + pdflags:=pdflags and (not pd_body); + if (proc_direcdata[p].pd_flags and pd_global)<>0 then + pdflags:=pdflags or pd_global; + +{ Add the correct flag } + aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions+proc_direcdata[p].pocall; + aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+proc_direcdata[p].pooption; + + { Adjust positions of args for cdecl or stdcall } + if (aktprocsym^.definition^.deftype=procdef) and + (([pocall_cdecl,pocall_stdcall]*aktprocsym^.definition^.proccalloptions)<>[]) then + aktprocsym^.definition^.parast^.set_alignment(target_os.size_of_longint); + +{ Call the handler } + if pointer({$ifndef FPC}@{$endif}proc_direcdata[p].handler)<>nil then + proc_direcdata[p].handler(proc_names); +end; + +{***************************************************************************} + +function check_identical(var p : pprocdef) : boolean; +{ + Search for idendical definitions, + if there is a forward, then kill this. + + Returns the result of the forward check. + + Removed from unter_dec to keep the source readable +} +var + hd,pd : Pprocdef; + storeparast : psymtable; + ad,fd : psym; + s : string; +begin + check_identical:=false; + p:=nil; + pd:=aktprocsym^.definition; + if assigned(pd) then + begin + { Is there an overload/forward ? } + if assigned(pd^.nextoverloaded) then + begin + { walk the procdef list } + while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do + begin + hd:=pd^.nextoverloaded; + { check for allowing overloading } + if not(m_fpc in aktmodeswitches) then + begin + { if one of the two has overload directive then + we should issue an other error } + if (po_overload in pd^.procoptions) or + (po_overload in hd^.procoptions) then + begin + if not((po_overload in pd^.procoptions) and + (po_overload in hd^.procoptions)) then + Message1(parser_e_no_overload_for_all_procs,aktprocsym^.name); + end + else + begin + if not(hd^.forwarddef) then + Message(parser_e_procedure_overloading_is_off); + end; + end; + { check the parameters } + if (not(m_repeat_forward in aktmodeswitches) and + (aktprocsym^.definition^.para^.count=0)) or + (equal_paras(aktprocsym^.definition^.para,hd^.para,cp_none) and + { for operators equal_paras is not enough !! } + ((aktprocsym^.definition^.proctypeoption<>potype_operator) or (optoken<>_ASSIGNMENT) or + is_equal(pd^.nextoverloaded^.rettype.def,aktprocsym^.definition^.rettype.def))) then + begin + if not equal_paras(aktprocsym^.definition^.para,hd^.para,cp_all) and + ((m_repeat_forward in aktmodeswitches) or (aktprocsym^.definition^.para^.count>0)) then + begin + Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName); + exit; + end; + if hd^.forwarddef then + { remove the forward definition but don't delete it, } + { the symtable is the owner !! } + begin + { Check if the procedure type and return type are correct } + if (hd^.proctypeoption<>aktprocsym^.definition^.proctypeoption) or + (not(is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def)) and + (m_repeat_forward in aktmodeswitches)) then + begin + Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName); + exit; + end; + { Check calling convention, no check for internconst,internproc which + are only defined in interface or implementation } + if (hd^.proccalloptions-[pocall_internconst,pocall_internproc]<> + aktprocsym^.definition^.proccalloptions-[pocall_internconst,pocall_internproc]) then + begin + { only trigger an error, becuase it doesn't hurt } + Message(parser_e_call_convention_dont_match_forward); + { set the mangledname to the interface name so it doesn't trigger + the Note about different manglednames (PFV) } + aktprocsym^.definition^.setmangledname(hd^.mangledname); + end; + { manglednames are equal? } + hd^.count:=false; + if (m_repeat_forward in aktmodeswitches) or + aktprocsym^.definition^.haspara then + begin + if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then + begin + { When overloading is not possible then we issue an error } + { This is not true, tp7/delphi don't give an error when a renamed + type is used in the other declaration (PFV) + if not(m_repeat_forward in aktmodeswitches) then + begin + Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName); + exit; + end; } + + if not(po_external in aktprocsym^.definition^.procoptions) then + Message2(parser_n_interface_name_diff_implementation_name,hd^.mangledname, + aktprocsym^.definition^.mangledname); + { reset the mangledname of the interface part to be sure } + { this is wrong because the mangled name might have been used already !! } + if hd^.is_used then + renameasmsymbol(hd^.mangledname,aktprocsym^.definition^.mangledname); + hd^.setmangledname(aktprocsym^.definition^.mangledname); + { so we need to keep the name of interface !! + No!!!! The procedure directives can change the mangledname. + I fixed this by first calling check_identical and then doing + the proc directives, but this is not a good solution.(DM)} + { this is also wrong (PM) + aktprocsym^.definition^.setmangledname(hd^.mangledname);} + end + else + begin + { If mangled names are equal, therefore } + { they have the same number of parameters } + { Therefore we can check the name of these } + { parameters... } + if hd^.forwarddef and aktprocsym^.definition^.forwarddef then + begin + Message1(parser_e_function_already_declared_public_forward,aktprocsym^.demangledName); + Check_identical:=true; + { Remove other forward from the list to reduce errors } + pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded; + exit; + end; + ad:=psym(hd^.parast^.symindex^.first); + fd:=psym(aktprocsym^.definition^.parast^.symindex^.first); + if assigned(ad) and assigned(fd) then + begin + while assigned(ad) and assigned(fd) do + begin + s:=ad^.name; + if s<>fd^.name then + begin + Message3(parser_e_header_different_var_names, + aktprocsym^.name,s,fd^.name); + break; + end; + { it is impossible to have a nil pointer } + { for only one parameter - since they } + { have the same number of parameters. } + { Left = next parameter. } + ad:=psym(ad^.left); + fd:=psym(fd^.left); + end; + end; + end; + end; + { also the para_offset } + hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup; + hd^.count:=true; + + { remove pd^.nextoverloaded from the list } + { and add aktprocsym^.definition } + pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded; + hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded; + { Alert! All fields of aktprocsym^.definition that are modified + by the procdir handlers must be copied here!.} + hd^.forwarddef:=false; + hd^.proccalloptions:=hd^.proccalloptions + aktprocsym^.definition^.proccalloptions; + hd^.procoptions:=hd^.procoptions + aktprocsym^.definition^.procoptions; + if aktprocsym^.definition^.extnumber=-1 then + aktprocsym^.definition^.extnumber:=hd^.extnumber + else + if hd^.extnumber=-1 then + hd^.extnumber:=aktprocsym^.definition^.extnumber; + { switch parast for warning in implementation PM } + if (m_repeat_forward in aktmodeswitches) or + aktprocsym^.definition^.haspara then + begin + storeparast:=hd^.parast; + hd^.parast:=aktprocsym^.definition^.parast; + aktprocsym^.definition^.parast:=storeparast; + end; + if pd=aktprocsym^.definition then + p:=nil + else + p:=pd; + aktprocsym^.definition:=hd; + check_identical:=true; + end + else + { abstract methods aren't forward defined, but this } + { needs another error message } + if not(po_abstractmethod in pd^.nextoverloaded^.procoptions) then + Message(parser_e_overloaded_have_same_parameters) + else + Message(parser_e_abstract_no_definition); + break; + end; + pd:=pd^.nextoverloaded; + end; + end + else + begin + { there is no overloaded, so its always identical with itself } + check_identical:=true; + end; + end; +{ insert opsym only in the right symtable } + if ((procinfo^.flags and pi_operator)<>0) and assigned(opsym) + and not parse_only then + begin + if ret_in_param(aktprocsym^.definition^.rettype.def) then + begin + pprocdef(aktprocsym^.definition)^.parast^.insert(opsym); + { this increases the data size } + { correct this to get the right ret $value } + dec(pprocdef(aktprocsym^.definition)^.parast^.datasize,opsym^.getpushsize); + { this allows to read the funcretoffset } + opsym^.address:=-4; + opsym^.varspez:=vs_var; + end + else + pprocdef(aktprocsym^.definition)^.localst^.insert(opsym); + end; +end; + +procedure compile_proc_body(const proc_names:Tstringcontainer; + make_global,parent_has_class:boolean); +{ + Compile the body of a procedure +} +var + oldexitlabel,oldexit2label : pasmlabel; + oldfaillabel,oldquickexitlabel:Pasmlabel; + _class,hp:Pobjectdef; + { switches can change inside the procedure } + entryswitches, exitswitches : tlocalswitches; + oldaktmaxfpuregisters,localmaxfpuregisters : longint; + { code for the subroutine as tree } +{$ifdef newcg} + code:ptree; +{$else newcg} + code:ptree; +{$endif newcg} + { size of the local strackframe } + stackframe:longint; + { true when no stackframe is required } + nostackframe:boolean; + { number of bytes which have to be cleared by RET } + parasize:longint; + { filepositions } + entrypos, + savepos, + exitpos : tfileposinfo; +begin + { calculate the lexical level } + inc(lexlevel); + if lexlevel>32 then + Message(parser_e_too_much_lexlevel); + + { static is also important for local procedures !! } + if (po_staticmethod in aktprocsym^.definition^.procoptions) then + allow_only_static:=true + else if (lexlevel=normal_function_level) then + allow_only_static:=false; + + { save old labels } + oldexitlabel:=aktexitlabel; + oldexit2label:=aktexit2label; + oldquickexitlabel:=quickexitlabel; + oldfaillabel:=faillabel; + { get new labels } + getlabel(aktexitlabel); + getlabel(aktexit2label); + { exit for fail in constructors } + if (aktprocsym^.definition^.proctypeoption=potype_constructor) then + begin + getlabel(faillabel); + getlabel(quickexitlabel); + end; + { reset break and continue labels } + block_type:=bt_general; + aktbreaklabel:=nil; + aktcontinuelabel:=nil; + + { insert symtables for the class, by only if it is no nested function } + if assigned(procinfo^._class) and not(parent_has_class) then + begin + { insert them in the reverse order ! } + hp:=nil; + repeat + _class:=procinfo^._class; + while _class^.childof<>hp do + _class:=_class^.childof; + hp:=_class; + _class^.symtable^.next:=symtablestack; + symtablestack:=_class^.symtable; + until hp=procinfo^._class; + end; + + { insert parasymtable in symtablestack} + { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble + for checking of same names used in interface and implementation !! } + if lexlevel>=normal_function_level then + begin + aktprocsym^.definition^.parast^.next:=symtablestack; + symtablestack:=aktprocsym^.definition^.parast; + symtablestack^.symtablelevel:=lexlevel; + end; + { insert localsymtable in symtablestack} + aktprocsym^.definition^.localst^.next:=symtablestack; + symtablestack:=aktprocsym^.definition^.localst; + symtablestack^.symtablelevel:=lexlevel; + { constant symbols are inserted in this symboltable } + constsymtable:=symtablestack; + + { reset the temporary memory } + cleartempgen; + +{$ifdef newcg} + tg.usedinproc:=[]; +{$else newcg} + { no registers are used } + usedinproc:=0; +{$endif newcg} + { save entry info } + entrypos:=aktfilepos; + entryswitches:=aktlocalswitches; + localmaxfpuregisters:=aktmaxfpuregisters; +{$ifdef newcg} +{$ifdef dummy} + { parse the code ... } + if (po_assembler in aktprocsym^.definition^.procoptions) then + code:=convtree2node(assembler_block) + else + code:=convtree2node(block(current_module^.islibrary)); +{$endif dummy} + { parse the code ... } + if (po_assembler in aktprocsym^.definition^.procoptions) then + code:=assembler_block + else + code:=block(current_module^.islibrary); +{$else newcg} + { parse the code ... } + if (po_assembler in aktprocsym^.definition^.procoptions) then + code:=assembler_block + else + code:=block(current_module^.islibrary); +{$endif newcg} + + { get a better entry point } + if assigned(code) then + entrypos:=code^.fileinfo; + + { save exit info } + exitswitches:=aktlocalswitches; + exitpos:=last_endtoken_filepos; + + { save current filepos } + savepos:=aktfilepos; + + {When we are called to compile the body of a unit, aktprocsym should + point to the unit initialization. If the unit has no initialization, + aktprocsym=nil. But in that case code=nil. hus we should check for + code=nil, when we use aktprocsym.} + + { set the framepointer to esp for assembler functions } + { but only if the are no local variables } + { already done in assembler_block } +{$ifdef newcg} + tg.setfirsttemp(procinfo^.firsttemp_offset); +{$else newcg} + setfirsttemp(procinfo^.firsttemp_offset); +{$endif newcg} + + { ... and generate assembler } + { but set the right switches for entry !! } + aktlocalswitches:=entryswitches; + oldaktmaxfpuregisters:=aktmaxfpuregisters; + aktmaxfpuregisters:=localmaxfpuregisters; +{$ifndef NOPASS2} +{$ifdef newcg} + if assigned(code) then + generatecode(code); +{$else newcg} + if assigned(code) then + generatecode(code); +{$endif newcg} + { set switches to status at end of procedure } + aktlocalswitches:=exitswitches; + + if assigned(code) then + begin + aktprocsym^.definition^.code:=code; + + { the procedure is now defined } + aktprocsym^.definition^.forwarddef:=false; +{$ifdef newcg} + aktprocsym^.definition^.usedregisters:=tg.usedinproc; +{$else newcg} + aktprocsym^.definition^.usedregisters:=usedinproc; +{$endif newcg} + end; + +{$ifdef newcg} + stackframe:=tg.gettempsize; +{$else newcg} + stackframe:=gettempsize; +{$endif newcg} + + { first generate entry code with the correct position and switches } + aktfilepos:=entrypos; + aktlocalswitches:=entryswitches; +{$ifdef newcg} + if assigned(code) then + cg^.g_entrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false); +{$else newcg} + if assigned(code) then + genentrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false); +{$endif newcg} + + { now generate exit code with the correct position and switches } + aktfilepos:=exitpos; + aktlocalswitches:=exitswitches; + if assigned(code) then + begin +{$ifdef newcg} + cg^.g_exitcode(procinfo^.aktexitcode,parasize,nostackframe,false); +{$else newcg} + genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false); +{$endif newcg} + procinfo^.aktproccode^.insertlist(procinfo^.aktentrycode); + procinfo^.aktproccode^.concatlist(procinfo^.aktexitcode); +{$ifdef i386} + {$ifndef NoOpt} + if (cs_optimize in aktglobalswitches) and + { do not optimize pure assembler procedures } + ((procinfo^.flags and pi_is_assembler)=0) then + Optimize(procinfo^.aktproccode); + {$endif NoOpt} +{$endif} + { save local data (casetable) also in the same file } + if assigned(procinfo^.aktlocaldata) and + (not procinfo^.aktlocaldata^.empty) then + begin + procinfo^.aktproccode^.concat(new(pai_section,init(sec_data))); + procinfo^.aktproccode^.concatlist(procinfo^.aktlocaldata); + procinfo^.aktproccode^.concat(new(pai_section,init(sec_code))); + end; + { now we can insert a cut } + if (cs_create_smart in aktmoduleswitches) then + codesegment^.concat(new(pai_cut,init)); + + { add the procedure to the codesegment } + codesegment^.concatlist(procinfo^.aktproccode); + end; +{$else} + if assigned(code) then + firstpass(code); +{$endif NOPASS2} + + { ... remove symbol tables, for the browser leave the static table } +{ if (cs_browser in aktmoduleswitches) and (symtablestack^.symtabletype=staticsymtable) then + symtablestack^.next:=symtablestack^.next^.next + else } + if lexlevel>=normal_function_level then + symtablestack:=symtablestack^.next^.next + else + symtablestack:=symtablestack^.next; + + { ... check for unused symbols } + { but only if there is no asm block } + if assigned(code) then + begin + if (Errorcount=0) then + begin + aktprocsym^.definition^.localst^.check_forwards; + aktprocsym^.definition^.localst^.checklabels; + end; + if (procinfo^.flags and pi_uses_asm)=0 then + begin + { not for unit init, becuase the var can be used in finalize, + it will be done in proc_unit } + if not(aktprocsym^.definition^.proctypeoption + in [potype_proginit,potype_unitinit,potype_unitfinalize]) then + aktprocsym^.definition^.localst^.allsymbolsused; + aktprocsym^.definition^.parast^.allsymbolsused; + end; + end; + + { the local symtables can be deleted, but the parast } + { doesn't, (checking definitons when calling a } + { function } + { not for a inline procedure !! (PM) } + { at lexlevel = 1 localst is the staticsymtable itself } + { so no dispose here !! } + if assigned(code) and + not(cs_browser in aktmoduleswitches) and + not(pocall_inline in aktprocsym^.definition^.proccalloptions) then + begin + if lexlevel>=normal_function_level then + dispose(aktprocsym^.definition^.localst,done); + aktprocsym^.definition^.localst:=nil; + end; + +{$ifdef newcg} + { all registers can be used again } + tg.resetusableregisters; + { only now we can remove the temps } + tg.resettempgen; +{$else newcg} + { all registers can be used again } + resetusableregisters; + { only now we can remove the temps } + resettempgen; +{$endif newcg} + + { remove code tree, if not inline procedure } + if assigned(code) and not(pocall_inline in aktprocsym^.definition^.proccalloptions) then +{$ifdef newcg} + {!!!!!!! dispose(code,done); } + disposetree(code); +{$else newcg} + disposetree(code); +{$endif newcg} + + { remove class member symbol tables } + while symtablestack^.symtabletype=objectsymtable do + symtablestack:=symtablestack^.next; + + aktmaxfpuregisters:=oldaktmaxfpuregisters; + + { restore filepos, the switches are already set } + aktfilepos:=savepos; + { restore labels } + aktexitlabel:=oldexitlabel; + aktexit2label:=oldexit2label; + quickexitlabel:=oldquickexitlabel; + faillabel:=oldfaillabel; + + { reset to normal non static function } + if (lexlevel=normal_function_level) then + allow_only_static:=false; + { previous lexlevel } + dec(lexlevel); +end; + + +procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word); +{ + Parse the procedure directives. It does not matter if procedure directives + are written using ;procdir; or ['procdir'] syntax. +} +var + res : boolean; +begin + while token in [_ID,_LECKKLAMMER] do + begin + if try_to_consume(_LECKKLAMMER) then + begin + repeat + parse_proc_direc(Anames^,pdflags); + until not try_to_consume(_COMMA); + consume(_RECKKLAMMER); + { we always expect at least '[];' } + res:=true; + end + else + res:=parse_proc_direc(Anames^,pdflags); + { A procedure directive normally followed by a semicolon, but in + a const section we should stop when _EQUAL is found } + if res then + begin + if (block_type=bt_const) and + (token=_EQUAL) then + break; + { support procedure proc;stdcall export; in Delphi mode only } + if not((m_delphi in aktmodeswitches) and + is_proc_directive(token)) then + consume(_SEMICOLON); + end + else + break; + end; +end; + +procedure parse_var_proc_directives(var sym : psym); +var + anames : pstringcontainer; + pdflags : word; + oldsym : pprocsym; + pd : pabstractprocdef; +begin + oldsym:=aktprocsym; + anames:=new(pstringcontainer,init); + pdflags:=pd_procvar; + { we create a temporary aktprocsym to read the directives } + aktprocsym:=new(pprocsym,init(sym^.name)); + case sym^.typ of + varsym : + pd:=pabstractprocdef(pvarsym(sym)^.vartype.def); + typedconstsym : + pd:=pabstractprocdef(ptypedconstsym(sym)^.typedconsttype.def); + typesym : + pd:=pabstractprocdef(ptypesym(sym)^.restype.def); + else + internalerror(994932432); + end; + if pd^.deftype<>procvardef then + internalerror(994932433); + pabstractprocdef(aktprocsym^.definition):=pd; + { names should never be used anyway } + inc(lexlevel); + parse_proc_directives(anames,pdflags); + dec(lexlevel); + aktprocsym^.definition:=nil; + dispose(aktprocsym,done); + dispose(anames,done); + aktprocsym:=oldsym; +end; + +procedure parse_object_proc_directives(var sym : pprocsym); +var + anames : pstringcontainer; + pdflags : word; +begin + pdflags:=pd_object; + anames:=new(pstringcontainer,init); + inc(lexlevel); + parse_proc_directives(anames,pdflags); + dec(lexlevel); + dispose(anames,done); + if (po_containsself in aktprocsym^.definition^.procoptions) and + (([po_msgstr,po_msgint]*aktprocsym^.definition^.procoptions)=[]) then + Message(parser_e_self_in_non_message_handler); +end; + +procedure checkvaluepara(p:pnamedindexobject);{$ifndef FPC}far;{$endif} +var + vs : pvarsym; + s : string; +begin + with pvarsym(p)^ do + begin + if copy(name,1,3)='val' then + begin + s:=Copy(name,4,255); + if not(po_assembler in aktprocsym^.definition^.procoptions) then + begin + vs:=new(Pvarsym,initdef(s,vartype.def)); + vs^.fileinfo:=fileinfo; + vs^.varspez:=varspez; + aktprocsym^.definition^.localst^.insert(vs); +{$ifdef INCLUDEOK} + include(vs^.varoptions,vo_is_local_copy); +{$else} + vs^.varoptions:=vs^.varoptions+[vo_is_local_copy]; +{$endif} + vs^.varstate:=vs_assigned; + localvarsym:=vs; + inc(refs); { the para was used to set the local copy ! } + { warnings only on local copy ! } + varstate:=vs_used; + end + else + begin + aktprocsym^.definition^.parast^.rename(name,s); + end; + end; + end; +end; + + +procedure read_proc; +{ + Parses the procedure directives, then parses the procedure body, then + generates the code for it +} +var + oldprefix : string; + oldprocsym : Pprocsym; + oldprocinfo : pprocinfo; + oldconstsymtable : Psymtable; + oldfilepos : tfileposinfo; + names : Pstringcontainer; + pdflags : word; + prevdef,stdef : pprocdef; +begin +{ save old state } + oldprocsym:=aktprocsym; + oldprefix:=procprefix; + oldconstsymtable:=constsymtable; + oldprocinfo:=procinfo; +{ create a new procedure } + new(names,init); +{$ifdef fixLeaksOnError} + strContStack.push(names); +{$endif fixLeaksOnError} + codegen_newprocedure; + with procinfo^ do + begin + parent:=oldprocinfo; + { clear flags } + flags:=0; + { standard frame pointer } + framepointer:=frame_pointer; + { funcret_is_valid:=false; } + funcret_state:=vs_declared; + { is this a nested function of a method ? } + if assigned(oldprocinfo) then + _class:=oldprocinfo^._class; + end; + + parse_proc_dec; + + procinfo^.sym:=aktprocsym; + procinfo^.def:=aktprocsym^.definition; + +{ set the default function options } + if parse_only then + begin + aktprocsym^.definition^.forwarddef:=true; + { set also the interface flag, for better error message when the + implementation doesn't much this header } + aktprocsym^.definition^.interfacedef:=true; + pdflags:=pd_interface; + end + else + begin + pdflags:=pd_body; + if current_module^.in_implementation then + pdflags:=pdflags or pd_implemen; + if (not current_module^.is_unit) or (cs_create_smart in aktmoduleswitches) then + pdflags:=pdflags or pd_global; + procinfo^.exported:=false; + aktprocsym^.definition^.forwarddef:=false; + end; + +{ parse the directives that may follow } + inc(lexlevel); + parse_proc_directives(names,pdflags); + dec(lexlevel); + +{ set aktfilepos to the beginning of the function declaration } + oldfilepos:=aktfilepos; + aktfilepos:=aktprocsym^.definition^.fileinfo; + +{ search for forward declarations } + if not check_identical(prevdef) then + begin + { A method must be forward defined (in the object declaration) } + if assigned(procinfo^._class) and (not assigned(oldprocinfo^._class)) then + Message(parser_e_header_dont_match_any_member); + { Give a better error if there is a forward def in the interface and only + a single implementation } + if (not aktprocsym^.definition^.forwarddef) and + assigned(aktprocsym^.definition^.nextoverloaded) and + aktprocsym^.definition^.nextoverloaded^.forwarddef and + aktprocsym^.definition^.nextoverloaded^.interfacedef and + not(assigned(aktprocsym^.definition^.nextoverloaded^.nextoverloaded)) then + Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName) + else + begin + { check the global flag } + if (procinfo^.flags and pi_is_global)<>0 then + Message(parser_e_overloaded_must_be_all_global); + end + end; + +{ set return type here, becuase the aktprocsym^.definition can be + changed by check_identical (PFV) } + procinfo^.returntype.def:=aktprocsym^.definition^.rettype.def; + +{$ifdef i386} + if (po_interrupt in aktprocsym^.definition^.procoptions) then + begin + { we push Flags and CS as long + to cope with the IRETD + and we save 6 register + 4 selectors } + inc(procinfo^.para_offset,8+6*4+4*2); + end; +{$endif i386} + + { pointer to the return value ? } + if ret_in_param(procinfo^.returntype.def) then + begin + procinfo^.return_offset:=procinfo^.para_offset; + inc(procinfo^.para_offset,target_os.size_of_pointer); + end; + { allows to access the parameters of main functions in nested functions } + aktprocsym^.definition^.parast^.address_fixup:=procinfo^.para_offset; + + { when it is a value para and it needs a local copy then rename + the parameter and insert a copy in the localst. This is not done + for assembler procedures } + if (not parse_only) and (not aktprocsym^.definition^.forwarddef) then + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}checkvaluepara); + +{ restore file pos } + aktfilepos:=oldfilepos; + +{ compile procedure when a body is needed } + if (pdflags and pd_body)<>0 then + begin + Message1(parser_p_procedure_start,aktprocsym^.demangledname); + names^.insert(aktprocsym^.definition^.mangledname); + { set _FAIL as keyword if constructor } + if (aktprocsym^.definition^.proctypeoption=potype_constructor) then + tokeninfo^[_FAIL].keyword:=m_all; + if assigned(aktprocsym^.definition^._class) then + tokeninfo^[_SELF].keyword:=m_all; + + compile_proc_body(names^,((pdflags and pd_global)<>0),assigned(oldprocinfo^._class)); + + { reset _FAIL as normal } + if (aktprocsym^.definition^.proctypeoption=potype_constructor) then + tokeninfo^[_FAIL].keyword:=m_none; + if assigned(aktprocsym^.definition^._class) and (lexlevel=main_program_level) then + tokeninfo^[_SELF].keyword:=m_none; + consume(_SEMICOLON); + end; +{ close } +{$ifdef fixLeaksOnError} + if names <> strContStack.pop then + writeln('problem with strContStack in psub!'); +{$endif fixLeaksOnError} + dispose(names,done); + codegen_doneprocedure; +{ Restore old state } + constsymtable:=oldconstsymtable; + { from now on all refernece to mangledname means + that the function is already used } + aktprocsym^.definition^.count:=true; + { restore the interface order to maintain CRC values PM } + if assigned(prevdef) and assigned(aktprocsym^.definition^.nextoverloaded) then + begin + stdef:=aktprocsym^.definition; + aktprocsym^.definition:=stdef^.nextoverloaded; + stdef^.nextoverloaded:=prevdef^.nextoverloaded; + prevdef^.nextoverloaded:=stdef; + end; + aktprocsym:=oldprocsym; + procprefix:=oldprefix; + procinfo:=oldprocinfo; + opsym:=nil; +end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.67 2000/07/07 20:42:55 pierre + * get a failure on webtbf/tbug890 + + Revision 1.66 2000/07/06 19:04:59 peter + * allow in delphi mode directives without semicolons between + + Revision 1.65 2000/06/25 20:13:51 florian + * fixed a problem with forward declarations in TP mode, probably introduced by + Pierre's last changes + + Revision 1.64 2000/06/20 12:47:52 pierre + * equal_paras and convertable_paras changed by transforming third parameter + into an enum with three possible values: + cp_none, cp_value_equal_const and cp_all. + + Revision 1.63 2000/06/18 18:12:40 peter + * support overload keyword + + Revision 1.62 2000/06/02 21:24:48 pierre + * operator overloading now uses isbinaryoperatoracceptable + and is unaryoperatoracceptable + + Revision 1.61 2000/05/10 19:22:51 pierre + * Delphi defines TP so that code compiles + sent by Kovacs Attila Zoltan + + Revision 1.60 2000/05/09 14:19:08 pierre + * calculate para_offset for interrupt procedures + + Revision 1.59 2000/04/26 08:54:19 pierre + * More changes for operator bug + Order_overloaded method removed because it conflicted with + new implementation where the defs are ordered + according to the unit loading order ! + + Revision 1.58 2000/04/25 23:55:29 pierre + + Hint about unused unit + * Testop bug fixed !! + Now the operators are only applied if the unit is explicitly loaded + + Revision 1.57 2000/04/24 12:48:37 peter + * removed unused vars + + Revision 1.56 2000/03/31 22:56:47 pierre + * fix the handling of value parameters in cdecl function + + Revision 1.55 2000/03/27 11:57:22 pierre + * fix for bug 890 + + Revision 1.54 2000/03/23 22:17:51 pierre + * fix tf000008 bug + + Revision 1.53 2000/03/16 16:41:13 pierre + * fix for bug 807 + + Revision 1.52 2000/03/15 23:10:00 pierre + * fix for bug 848 (that still genrated wrong code) + + better testing for variables used in assembler + (gives an error if variable is not directly reachable !) + + Revision 1.51 2000/02/27 14:44:39 peter + * if calling convention doesn't match don't print note about + different manglednames + + Revision 1.50 2000/02/20 20:49:45 florian + * newcg is compiling + * fixed the dup id problem reported by Paul Y. + + Revision 1.49 2000/02/17 14:53:42 florian + * some updates for the newcg + + Revision 1.48 2000/02/09 13:23:00 peter + * log truncated + + Revision 1.47 2000/02/08 13:55:13 peter + * reset section back to code after localdata + + Revision 1.46 2000/02/04 20:00:22 florian + * an exception in a construcor calls now the destructor (this applies only + to classes) + + Revision 1.45 2000/02/04 14:54:17 jonas + * moved call to resetusableregs to compile_proc_body (put it right before the + reset of the temp generator) so the optimizer can know which registers are + regvars + + Revision 1.44 2000/01/28 23:17:53 florian + * virtual XXXX; support for objects, only if -dWITHDMT is defined + + Revision 1.43 2000/01/21 22:06:16 florian + * fixed for the fix of bug 793 + * fpu variables modified by nested subroutines aren't regable anymore + * $maxfpuregisters doesn't modify anymore the behavior of a procedure before + + Revision 1.42 2000/01/16 22:17:12 peter + * renamed call_offset to para_offset + + Revision 1.41 2000/01/11 17:16:06 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.40 2000/01/07 01:14:31 peter + * updated copyright to 2000 + + Revision 1.39 1999/12/22 01:01:52 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.38 1999/12/06 18:17:09 peter + * newcg compiler compiles again + + Revision 1.37 1999/11/30 10:40:48 peter + + ttype, tsymlist + + Revision 1.36 1999/11/22 00:23:09 pierre + * also complain about unused functions in program + + Revision 1.35 1999/11/17 17:05:02 pierre + * Notes/hints changes + + Revision 1.34 1999/11/10 00:24:02 pierre + * more browser details + + Revision 1.33 1999/11/09 23:43:08 pierre + * better browser info + + Revision 1.32 1999/11/09 23:06:45 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.31 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.30 1999/10/26 12:30:44 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.29 1999/10/22 10:39:35 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + + Revision 1.28 1999/10/13 10:37:36 peter + * moved mangledname creation of normal proc so it also handles a wrong + method proc + +} \ No newline at end of file diff --git a/befpc/compiler/psystem.pas b/befpc/compiler/psystem.pas new file mode 100644 index 0000000..0ad68fa --- /dev/null +++ b/befpc/compiler/psystem.pas @@ -0,0 +1,283 @@ +{ + $Id: psystem.pas,v 1.1.1.1 2001-07-23 17:16:53 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Load the system unit, create required defs for systemunit + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit psystem; +interface +uses symtable; + +procedure insertinternsyms(p : psymtable); +procedure insert_intern_types(p : psymtable); + +procedure readconstdefs; +procedure createconstdefs; + +implementation + +uses + globtype,globals,symconst,tree; + +procedure insertinternsyms(p : psymtable); +{ + all intern procedures for system unit +} +begin + p^.insert(new(psyssym,init('CONCAT',in_concat_x))); + p^.insert(new(psyssym,init('WRITE',in_write_x))); + p^.insert(new(psyssym,init('WRITELN',in_writeln_x))); + p^.insert(new(psyssym,init('ASSIGNED',in_assigned_x))); + p^.insert(new(psyssym,init('READ',in_read_x))); + p^.insert(new(psyssym,init('READLN',in_readln_x))); + p^.insert(new(psyssym,init('OFS',in_ofs_x))); + p^.insert(new(psyssym,init('SIZEOF',in_sizeof_x))); + p^.insert(new(psyssym,init('TYPEOF',in_typeof_x))); + p^.insert(new(psyssym,init('LOW',in_low_x))); + p^.insert(new(psyssym,init('HIGH',in_high_x))); + p^.insert(new(psyssym,init('SEG',in_seg_x))); + p^.insert(new(psyssym,init('ORD',in_ord_x))); + p^.insert(new(psyssym,init('PRED',in_pred_x))); + p^.insert(new(psyssym,init('SUCC',in_succ_x))); + p^.insert(new(psyssym,init('EXCLUDE',in_exclude_x_y))); + p^.insert(new(psyssym,init('INCLUDE',in_include_x_y))); + p^.insert(new(psyssym,init('BREAK',in_break))); + p^.insert(new(psyssym,init('CONTINUE',in_continue))); + p^.insert(new(psyssym,init('DEC',in_dec_x))); + p^.insert(new(psyssym,init('INC',in_inc_x))); + p^.insert(new(psyssym,init('STR',in_str_x_string))); + p^.insert(new(psyssym,init('ASSERT',in_assert_x_y))); + p^.insert(new(psyssym,init('VAL',in_val_x))); + p^.insert(new(psyssym,init('ADDR',in_addr_x))); +end; + + +procedure insert_intern_types(p : psymtable); +{ + all the types inserted into the system unit +} +var + { several defs to simulate more or less C++ objects for GDB } + vmtdef : precorddef; + vmtarraydef : parraydef; + vmtsymtable : psymtable; +begin +{ Internal types } + p^.insert(new(ptypesym,initdef('formal',cformaldef))); + p^.insert(new(ptypesym,initdef('void',voiddef))); + p^.insert(new(ptypesym,initdef('byte',u8bitdef))); + p^.insert(new(ptypesym,initdef('word',u16bitdef))); + p^.insert(new(ptypesym,initdef('ulong',u32bitdef))); + p^.insert(new(ptypesym,initdef('longint',s32bitdef))); + p^.insert(new(ptypesym,initdef('qword',cu64bitdef))); + p^.insert(new(ptypesym,initdef('int64',cs64bitdef))); + p^.insert(new(ptypesym,initdef('char',cchardef))); + p^.insert(new(ptypesym,initdef('widechar',cwidechardef))); + p^.insert(new(ptypesym,initdef('shortstring',cshortstringdef))); + p^.insert(new(ptypesym,initdef('longstring',clongstringdef))); + p^.insert(new(ptypesym,initdef('ansistring',cansistringdef))); + p^.insert(new(ptypesym,initdef('widestring',cwidestringdef))); + p^.insert(new(ptypesym,initdef('openshortstring',openshortstringdef))); + p^.insert(new(ptypesym,initdef('boolean',booldef))); + p^.insert(new(ptypesym,initdef('void_pointer',voidpointerdef))); + p^.insert(new(ptypesym,initdef('char_pointer',charpointerdef))); + p^.insert(new(ptypesym,initdef('void_farpointer',voidfarpointerdef))); + p^.insert(new(ptypesym,initdef('openchararray',openchararraydef))); + p^.insert(new(ptypesym,initdef('file',cfiledef))); + p^.insert(new(ptypesym,initdef('s32real',s32floatdef))); + p^.insert(new(ptypesym,initdef('s64real',s64floatdef))); + p^.insert(new(ptypesym,initdef('s80real',s80floatdef))); +{$ifdef SUPPORT_FIXED} + p^.insert(new(ptypesym,initdef('s32fixed',s32fixeddef))); +{$endif SUPPORT_FIXED} + { Add a type for virtual method tables in lowercase } + { so it isn't reachable! } + vmtsymtable:=new(psymtable,init(recordsymtable)); + vmtdef:=new(precorddef,init(vmtsymtable)); + pvmtdef:=new(ppointerdef,initdef(vmtdef)); + vmtsymtable^.insert(new(pvarsym,initdef('parent',pvmtdef))); + vmtsymtable^.insert(new(pvarsym,initdef('length',globaldef('longint')))); + vmtsymtable^.insert(new(pvarsym,initdef('mlength',globaldef('longint')))); + vmtarraydef:=new(parraydef,init(0,1,s32bitdef)); + vmtarraydef^.elementtype.setdef(voidpointerdef); + vmtsymtable^.insert(new(pvarsym,initdef('__pfn',vmtarraydef))); + p^.insert(new(ptypesym,initdef('__vtbl_ptr_type',vmtdef))); + p^.insert(new(ptypesym,initdef('pvmt',pvmtdef))); + vmtarraydef:=new(parraydef,init(0,1,s32bitdef)); + vmtarraydef^.elementtype.setdef(pvmtdef); + p^.insert(new(ptypesym,initdef('vtblarray',vmtarraydef))); + insertinternsyms(p); +{ Normal types } + p^.insert(new(ptypesym,initdef('SINGLE',s32floatdef))); + p^.insert(new(ptypesym,initdef('DOUBLE',s64floatdef))); + p^.insert(new(ptypesym,initdef('EXTENDED',s80floatdef))); + p^.insert(new(ptypesym,initdef('REAL',s64floatdef))); +{$ifdef i386} + p^.insert(new(ptypesym,initdef('COMP',new(pfloatdef,init(s64comp))))); +{$endif} + p^.insert(new(ptypesym,initdef('POINTER',voidpointerdef))); + p^.insert(new(ptypesym,initdef('FARPOINTER',voidfarpointerdef))); + p^.insert(new(ptypesym,initdef('SHORTSTRING',cshortstringdef))); + p^.insert(new(ptypesym,initdef('LONGSTRING',clongstringdef))); + p^.insert(new(ptypesym,initdef('ANSISTRING',cansistringdef))); + p^.insert(new(ptypesym,initdef('WIDESTRING',cwidestringdef))); + p^.insert(new(ptypesym,initdef('BOOLEAN',booldef))); + p^.insert(new(ptypesym,initdef('BYTEBOOL',booldef))); + p^.insert(new(ptypesym,initdef('WORDBOOL',new(porddef,init(bool16bit,0,1))))); + p^.insert(new(ptypesym,initdef('LONGBOOL',new(porddef,init(bool32bit,0,1))))); + p^.insert(new(ptypesym,initdef('CHAR',cchardef))); + p^.insert(new(ptypesym,initdef('WIDECHAR',cwidechardef))); + p^.insert(new(ptypesym,initdef('TEXT',new(pfiledef,inittext)))); + p^.insert(new(ptypesym,initdef('CARDINAL',u32bitdef))); +{$ifdef SUPPORT_FIXED} + p^.insert(new(ptypesym,initdef('FIXED',new(pfloatdef,init(f32bit))))); + p^.insert(new(ptypesym,initdef('FIXED16',new(pfloatdef,init(f16bit))))); +{$endif SUPPORT_FIXED} + p^.insert(new(ptypesym,initdef('QWORD',cu64bitdef))); + p^.insert(new(ptypesym,initdef('INT64',cs64bitdef))); + p^.insert(new(ptypesym,initdef('TYPEDFILE',new(pfiledef,inittypeddef(voiddef))))); +end; + + +procedure readconstdefs; +{ + Load all default definitions for consts from the system unit +} +begin + u8bitdef:=porddef(globaldef('byte')); + u16bitdef:=porddef(globaldef('word')); + u32bitdef:=porddef(globaldef('ulong')); + s32bitdef:=porddef(globaldef('longint')); + cu64bitdef:=porddef(globaldef('qword')); + cs64bitdef:=porddef(globaldef('int64')); + cformaldef:=pformaldef(globaldef('formal')); + voiddef:=porddef(globaldef('void')); + cchardef:=porddef(globaldef('char')); + cwidechardef:=porddef(globaldef('char')); + cshortstringdef:=pstringdef(globaldef('shortstring')); + clongstringdef:=pstringdef(globaldef('longstring')); + cansistringdef:=pstringdef(globaldef('ansistring')); + cwidestringdef:=pstringdef(globaldef('widestring')); + openshortstringdef:=pstringdef(globaldef('openshortstring')); + openchararraydef:=parraydef(globaldef('openchararray')); + s32floatdef:=pfloatdef(globaldef('s32real')); + s64floatdef:=pfloatdef(globaldef('s64real')); + s80floatdef:=pfloatdef(globaldef('s80real')); +{$ifdef SUPPORT_FIXED} + s32fixeddef:=pfloatdef(globaldef('s32fixed')); +{$endif SUPPORT_FIXED} + booldef:=porddef(globaldef('boolean')); + voidpointerdef:=ppointerdef(globaldef('void_pointer')); + charpointerdef:=ppointerdef(globaldef('char_pointer')); + voidfarpointerdef:=ppointerdef(globaldef('void_farpointer')); + cfiledef:=pfiledef(globaldef('file')); + pvmtdef:=ppointerdef(globaldef('pvmt')); +end; + + +procedure createconstdefs; +{ + Create all default definitions for consts for the system unit +} +var + oldregisterdef : boolean; +begin + { create definitions for constants } + oldregisterdef:=registerdef; + registerdef:=false; + cformaldef:=new(pformaldef,init); + voiddef:=new(porddef,init(uvoid,0,0)); + u8bitdef:=new(porddef,init(u8bit,0,255)); + u16bitdef:=new(porddef,init(u16bit,0,65535)); + u32bitdef:=new(porddef,init(u32bit,0,$ffffffff)); + s32bitdef:=new(porddef,init(s32bit,$80000000,$7fffffff)); + cu64bitdef:=new(porddef,init(u64bit,0,0)); + cs64bitdef:=new(porddef,init(s64bit,0,0)); + booldef:=new(porddef,init(bool8bit,0,1)); + cchardef:=new(porddef,init(uchar,0,255)); + cwidechardef:=new(porddef,init(uwidechar,0,65535)); + cshortstringdef:=new(pstringdef,shortinit(255)); + { should we give a length to the default long and ansi string definition ?? } + clongstringdef:=new(pstringdef,longinit(-1)); + cansistringdef:=new(pstringdef,ansiinit(-1)); + cwidestringdef:=new(pstringdef,wideinit(-1)); + { length=0 for shortstring is open string (needed for readln(string) } + openshortstringdef:=new(pstringdef,shortinit(0)); + openchararraydef:=new(parraydef,init(0,-1,s32bitdef)); + parraydef(openchararraydef)^.elementtype.setdef(cchardef); +{$ifdef i386} + s32floatdef:=new(pfloatdef,init(s32real)); + s64floatdef:=new(pfloatdef,init(s64real)); + s80floatdef:=new(pfloatdef,init(s80real)); +{$endif} +{$ifdef m68k} + s32floatdef:=new(pfloatdef,init(s32real)); + s64floatdef:=new(pfloatdef,init(s64real)); + if (cs_fp_emulation in aktmoduleswitches) then + s80floatdef:=new(pfloatdef,init(s32real)) + else + s80floatdef:=new(pfloatdef,init(s80real)); +{$endif} +{$ifdef SUPPORT_FIXED} + s32fixeddef:=new(pfloatdef,init(f32bit)); +{$endif SUPPORT_FIXED} + { some other definitions } + voidpointerdef:=new(ppointerdef,initdef(voiddef)); + charpointerdef:=new(ppointerdef,initdef(cchardef)); + voidfarpointerdef:=new(ppointerdef,initfardef(voiddef)); + cfiledef:=new(pfiledef,inituntyped); + registerdef:=oldregisterdef; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.34 2000/02/15 14:36:45 florian + * disable FIXED data type per default + + Revision 1.33 2000/02/09 13:23:00 peter + * log truncated + + Revision 1.32 2000/01/07 01:14:33 peter + * updated copyright to 2000 + + Revision 1.31 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.30 1999/11/30 10:40:51 peter + + ttype, tsymlist + + Revision 1.29 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.28 1999/09/16 23:05:55 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.27 1999/08/13 14:24:17 pierre + + stabs for classes and classref working, + a class still needs an ^ to get that content of it, + but the class fields inside a class don't result into an + infinite loop anymore! + + Revision 1.26 1999/08/03 22:03:07 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/ptconst.pas b/befpc/compiler/ptconst.pas new file mode 100644 index 0000000..2f0f002 --- /dev/null +++ b/befpc/compiler/ptconst.pas @@ -0,0 +1,875 @@ +{ + $Id: ptconst.pas,v 1.1.1.1 2001-07-23 17:16:54 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Reads typed constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ptconst; + + interface + + uses symtable; + + { this procedure reads typed constants } + { sym is only needed for ansi strings } + { the assembler label is in the middle (PM) } + procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean); + + implementation + + uses +{$ifdef Delphi} + sysutils, +{$else} + strings, +{$endif Delphi} + globtype,systems,tokens, + cobjects,globals,scanner, + symconst,aasm,types,verbose, + tree,pass_1, + { parser specific stuff } + pbase,pexpr, + { processor specific stuff } + cpubase, + { codegen } +{$ifdef newcg} + cgbase, +{$else} + hcodegen, +{$endif} + hcgdata; + + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + { this procedure reads typed constants } + procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean); + + var +{$ifdef m68k} + j : longint; +{$endif m68k} + len,base : longint; + p,hp : ptree; + i,l,offset, + strlength : longint; + curconstsegment : paasmoutput; + ll : pasmlabel; + s : string; + ca : pchar; + aktpos : longint; + obj : pobjectdef; + symt : psymtable; + value : bestreal; + strval : pchar; + + procedure check_range; + begin + if ((p^.value>porddef(def)^.high) or + (p^.valueaddrn) then + begin + getdatalabel(ll); + curconstsegment^.concat(new(pai_const_symbol,init(ll))); + consts^.concat(new(pai_label,init(ll))); + if p^.treetype=stringconstn then + begin + getmem(ca,p^.length+2); + move(p^.value_str^,ca^,p^.length+1); + consts^.concat(new(pai_string,init_length_pchar(ca,p^.length+1))); + end + else + if is_constcharnode(p) then + consts^.concat(new(pai_string,init(char(byte(p^.value))+#0))) + else + Message(cg_e_illegal_expression); + end + else + if p^.treetype=addrn then + begin + hp:=p^.left; + while assigned(hp) and (hp^.treetype in [subscriptn,vecn]) do + hp:=hp^.left; + if (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,ppointerdef(def)^.pointertype.def) or + (is_equal(ppointerdef(p^.resulttype)^.pointertype.def,voiddef)) or + (is_equal(ppointerdef(def)^.pointertype.def,voiddef))) and + (hp^.treetype=loadn) then + begin + do_firstpass(p^.left); + hp:=p^.left; + offset:=0; + while assigned(hp) and (hp^.treetype<>loadn) do + begin + case hp^.treetype of + vecn : + begin + if (hp^.left^.resulttype^.deftype=stringdef) then + begin + { this seems OK for shortstring and ansistrings PM } + { it is wrong for widestrings !! } + len:=1; + base:=0; + end + else if (hp^.left^.resulttype^.deftype=arraydef) then + begin + len:=parraydef(hp^.left^.resulttype)^.elesize; + base:=parraydef(hp^.left^.resulttype)^.lowrange; + end + else + Message(cg_e_illegal_expression); + if is_constintnode(hp^.right) then + inc(offset,len*(get_ordinal_value(hp^.right)-base)) + else + Message(cg_e_illegal_expression); + {internalerror(9779);} + end; + + subscriptn : inc(offset,hp^.vs^.address) + else + Message(cg_e_illegal_expression); + end; + hp:=hp^.left; + end; + if hp^.symtableentry^.typ=constsym then + Message(type_e_variable_id_expected); + curconstsegment^.concat(new(pai_const_symbol,initname_offset(hp^.symtableentry^.mangledname,offset))); + (*if token=POINT then + begin + offset:=0; + while token=_POINT do + begin + consume(_POINT); + lsym:=pvarsym(precdef( + ppointerdef(p^.resulttype)^.pointertype.def)^.symtable^.search(pattern)); + if assigned(sym) then + offset:=offset+lsym^.address + else + begin + Message1(sym_e_illegal_field,pattern); + end; + consume(_ID); + end; + curconstsegment^.concat(new(pai_const_symbol_offset,init( + strpnew(p^.left^.symtableentry^.mangledname),offset))); + end + else + begin + curconstsegment^.concat(new(pai_const,init_symbol( + strpnew(p^.left^.symtableentry^.mangledname)))); + end; *) + end + else + Message(cg_e_illegal_expression); + end + else + { allow typeof(Object type)} + if (p^.treetype=inlinen) and + (p^.inlinenumber=in_typeof_x) then + begin + if (p^.left^.treetype=typen) then + begin + curconstsegment^.concat(new(pai_const_symbol, + initname(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))); + end + else + Message(cg_e_illegal_expression); + end + else + Message(cg_e_illegal_expression); + disposetree(p); + end; + setdef: + begin + p:=comp_expr(true); + do_firstpass(p); + if p^.treetype=setconstn then + begin + { we only allow const sets } + if assigned(p^.left) then + Message(cg_e_illegal_expression) + else + begin +{$ifdef i386} + for l:=0 to def^.size-1 do + curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l]))); +{$endif} +{$ifdef m68k} + j:=0; + for l:=0 to ((def^.size-1) div 4) do + { HORRIBLE HACK because of endian } + { now use intel endian for constant sets } + begin + curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3]))); + curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2]))); + curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1]))); + curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j]))); + Inc(j,4); + end; +{$endif} + end; + end + else + Message(cg_e_illegal_expression); + disposetree(p); + end; + enumdef: + begin + p:=comp_expr(true); + do_firstpass(p); + if p^.treetype=ordconstn then + begin + if is_equal(p^.resulttype,def) then + curconstsegment^.concat(new(pai_const,init_32bit(p^.value))) + else + Message(cg_e_illegal_expression); + end + else + Message(cg_e_illegal_expression); + disposetree(p); + end; + stringdef: + begin + p:=comp_expr(true); + do_firstpass(p); + { load strval and strlength of the constant tree } + if p^.treetype=stringconstn then + begin + strlength:=p^.length; + strval:=p^.value_str; + end + else if is_constcharnode(p) then + begin + strval:=pchar(@p^.value); + strlength:=1 + end + else if is_constresourcestringnode(p) then + begin + strval:=pchar(pconstsym(p^.symtableentry)^.value); + strlength:=pconstsym(p^.symtableentry)^.len; + end + else + begin + Message(cg_e_illegal_expression); + strlength:=-1; + end; + if strlength>=0 then + begin + case pstringdef(def)^.string_typ of + st_shortstring: + begin + if strlength>=def^.size then + begin + message2(parser_w_string_too_long,strpas(strval),tostr(def^.size-1)); + strlength:=def^.size-1; + end; + curconstsegment^.concat(new(pai_const,init_8bit(strlength))); + { this can also handle longer strings } + getmem(ca,strlength+1); + move(strval^,ca^,strlength); + ca[strlength]:=#0; + curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength))); + { fillup with spaces if size is shorter } + if def^.size>strlength then + begin + getmem(ca,def^.size-strlength); + { def^.size contains also the leading length, so we } + { we have to subtract one } + fillchar(ca[0],def^.size-strlength-1,' '); + ca[def^.size-strlength-1]:=#0; + { this can also handle longer strings } + curconstsegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1))); + end; + end; +{$ifdef UseLongString} + st_longstring: + begin + { first write the maximum size } + curconstsegment^.concat(new(pai_const,init_32bit(strlength))))); + { fill byte } + curconstsegment^.concat(new(pai_const,init_8bit(0))); + getmem(ca,strlength+1); + move(strval^,ca^,strlength); + ca[strlength]:=#0; + generate_pascii(consts,ca,strlength); + curconstsegment^.concat(new(pai_const,init_8bit(0))); + end; +{$endif UseLongString} + st_ansistring: + begin + { an empty ansi string is nil! } + if (strlength=0) then + curconstsegment^.concat(new(pai_const,init_32bit(0))) + else + begin + getdatalabel(ll); + curconstsegment^.concat(new(pai_const_symbol,init(ll))); + { first write the maximum size } + consts^.concat(new(pai_const,init_32bit(strlength))); + { second write the real length } + consts^.concat(new(pai_const,init_32bit(strlength))); + { redondent with maxlength but who knows ... (PM) } + { third write use count (set to -1 for safety ) } + consts^.concat(new(pai_const,init_32bit(-1))); + consts^.concat(new(pai_label,init(ll))); + getmem(ca,strlength+2); + move(strval^,ca^,strlength); + { The terminating #0 to be stored in the .data section (JM) } + ca[strlength]:=#0; + { End of the PChar. The memory has to be allocated because in } + { tai_string.done, there is a freemem(len+1) (JM) } + ca[strlength+1]:=#0; + consts^.concat(new(pai_string,init_length_pchar(ca,strlength+1))); + end; + end; + end; + end; + disposetree(p); + end; + arraydef: + begin + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do + begin + readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed); + consume(_COMMA); + end; + readtypedconst(parraydef(def)^.elementtype.def,nil,no_change_allowed); + consume(_RKLAMMER); + end + else + { if array of char then we allow also a string } + if is_char(parraydef(def)^.elementtype.def) then + begin + p:=comp_expr(true); + do_firstpass(p); + if p^.treetype=stringconstn then + begin + if p^.length>255 then + len:=255 + else + len:=p^.length; + {$ifndef TP} + {$ifopt H+} + setlength(s,len); + {$else} + s[0]:=chr(len); + {$endif} + {$else} + s[0]:=chr(len); + {$endif} + move(p^.value_str^,s[1],len); + end + else + if is_constcharnode(p) then + s:=char(byte(p^.value)) + else + begin + Message(cg_e_illegal_expression); + s:=''; + end; + disposetree(p); + l:=length(s); + for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do + begin + if i+1-Parraydef(def)^.lowrange<=l then + begin + curconstsegment^.concat(new(pai_const,init_8bit(byte(s[1])))); + delete(s,1,1); + end + else + {Fill the remaining positions with #0.} + curconstsegment^.concat(new(pai_const,init_8bit(0))); + end; + if length(s)>0 then + Message(parser_e_string_larger_array); + end + else + begin + { we want the ( } + consume(_LKLAMMER); + end; + end; + procvardef: + begin + { Procvars and pointers are no longer compatible. } + { under tp: =nil or =var under fpc: =nil or =@var } + if token=_NIL then + begin + curconstsegment^.concat(new(pai_const,init_32bit(0))); + consume(_NIL); + exit; + end + else + if not(m_tp_procvar in aktmodeswitches) then + if token=_KLAMMERAFFE then + consume(_KLAMMERAFFE); + getprocvar:=true; + getprocvardef:=pprocvardef(def); + p:=comp_expr(true); + getprocvar:=false; + do_firstpass(p); + if codegenerror then + begin + disposetree(p); + exit; + end; + { convert calln to loadn } + if p^.treetype=calln then + begin + if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and + (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then + hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc, + getcopy(p^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc); + disposetree(p); + do_firstpass(hp); + p:=hp; + if codegenerror then + begin + disposetree(p); + exit; + end; + end + else if (p^.treetype=addrn) and assigned(p^.left) and + (p^.left^.treetype=calln) then + begin + if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and + (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) then + hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry), + p^.left^.symtableproc,getcopy(p^.left^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry), + p^.left^.symtableproc); + disposetree(p); + do_firstpass(hp); + p:=hp; + if codegenerror then + begin + disposetree(p); + exit; + end; + end; + { let type conversion check everything needed } + p:=gentypeconvnode(p,def); + do_firstpass(p); + if codegenerror then + begin + disposetree(p); + exit; + end; + { remove typeconvn, that will normally insert a lea + instruction which is not necessary for us } + if p^.treetype=typeconvn then + begin + hp:=p^.left; + putnode(p); + p:=hp; + end; + { remove addrn which we also don't need here } + if p^.treetype=addrn then + begin + hp:=p^.left; + putnode(p); + p:=hp; + end; + { we now need to have a loadn with a procsym } + if (p^.treetype=loadn) and + (p^.symtableentry^.typ=procsym) then + begin + curconstsegment^.concat(new(pai_const_symbol, + initname(pprocsym(p^.symtableentry)^.definition^.mangledname))); + end + else + Message(cg_e_illegal_expression); + disposetree(p); + end; + { reads a typed constant record } + recorddef: + begin + consume(_LKLAMMER); + aktpos:=0; + while token<>_RKLAMMER do + begin + s:=pattern; + consume(_ID); + consume(_COLON); + srsym:=precorddef(def)^.symtable^.search(s); + if srsym=nil then + begin + Message1(sym_e_id_not_found,s); + consume_all_until(_SEMICOLON); + end + else + begin + { check position } + if pvarsym(srsym)^.addressaktpos then + for i:=1 to pvarsym(srsym)^.address-aktpos do + curconstsegment^.concat(new(pai_const,init_8bit(0))); + + { new position } + aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size; + + { read the data } + readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed); + + if token=_SEMICOLON then + consume(_SEMICOLON) + else break; + end; + end; + for i:=1 to def^.size-aktpos do + curconstsegment^.concat(new(pai_const,init_8bit(0))); + consume(_RKLAMMER); + end; + { reads a typed object } + objectdef: + begin + if ([oo_has_vmt,oo_is_class]*pobjectdef(def)^.objectoptions)<>[] then + begin + Message(parser_e_type_const_not_possible); + consume_all_until(_RKLAMMER); + end + else + begin + consume(_LKLAMMER); + aktpos:=0; + while token<>_RKLAMMER do + begin + s:=pattern; + consume(_ID); + consume(_COLON); + srsym:=nil; + obj:=pobjectdef(def); + symt:=obj^.symtable; + while (srsym=nil) and assigned(symt) do + begin + srsym:=symt^.search(s); + if assigned(obj) then + obj:=obj^.childof; + if assigned(obj) then + symt:=obj^.symtable + else + symt:=nil; + end; + + if srsym=nil then + begin + Message1(sym_e_id_not_found,s); + consume_all_until(_SEMICOLON); + end + else + begin + { check position } + if pvarsym(srsym)^.addressaktpos then + for i:=1 to pvarsym(srsym)^.address-aktpos do + curconstsegment^.concat(new(pai_const,init_8bit(0))); + + { new position } + aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size; + + { read the data } + readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed); + + if token=_SEMICOLON then + consume(_SEMICOLON) + else break; + end; + end; + for i:=1 to def^.size-aktpos do + curconstsegment^.concat(new(pai_const,init_8bit(0))); + consume(_RKLAMMER); + end; + end; + errordef: + begin + { try to consume something useful } + if token=_LKLAMMER then + consume_all_until(_RKLAMMER) + else + consume_all_until(_SEMICOLON); + end; + else Message(parser_e_type_const_not_possible); + end; + end; +{$ifdef fpc} +{$maxfpuregisters default} +{$endif fpc} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.68 2000/06/06 13:06:17 jonas + * ansistring constants now also get a trailing #0 (bug reported by + Thomas Schatzl) + + Revision 1.67 2000/05/17 17:10:06 peter + * add support for loading of typed const strings with resourcestrings, + made the loading also a bit more generic + + Revision 1.66 2000/05/12 06:02:01 pierre + * * get it to compile with Delphi by Kovacs Attila Zoltan + + Revision 1.65 2000/05/11 09:15:15 pierre + + add a warning if a const string is longer than the + length of the string type + + Revision 1.64 2000/04/02 09:12:51 florian + + constant procedure variables can have a @ in front: + const p : procedure = @p; + til now only + const p : procedure = p; + was allowed + + Revision 1.63 2000/02/13 14:21:51 jonas + * modifications to make the compiler functional when compiled with + -Or + + Revision 1.62 2000/02/09 13:23:01 peter + * log truncated + + Revision 1.61 2000/01/07 01:14:33 peter + * updated copyright to 2000 + + Revision 1.60 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.59 1999/11/30 10:40:51 peter + + ttype, tsymlist + + Revision 1.58 1999/11/08 18:50:11 florian + * disposetree for classrefdef added + + Revision 1.57 1999/11/08 16:24:28 pierre + * missing disposetree added to avoid memory loss + + Revision 1.56 1999/11/08 14:02:16 florian + * problem with "index X"-properties solved + * typed constants of class references are now allowed + + Revision 1.55 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.54 1999/10/14 14:57:54 florian + - removed the hcodegen use in the new cg, use cgbase instead + + Revision 1.53 1999/09/26 21:30:20 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.52 1999/08/10 12:30:02 pierre + * avoid unused locals + + Revision 1.51 1999/08/04 13:03:02 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.50 1999/08/04 00:23:21 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.49 1999/08/03 22:03:08 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.48 1999/07/23 16:05:26 peter + * alignment is now saved in the symtable + * C alignment added for records + * PPU version increased to solve .12 <-> .13 probs + +} \ No newline at end of file diff --git a/befpc/compiler/ptype.pas b/befpc/compiler/ptype.pas new file mode 100644 index 0000000..33e32ed --- /dev/null +++ b/befpc/compiler/ptype.pas @@ -0,0 +1,1691 @@ +{ + $Id: ptype.pas,v 1.1.1.1 2001-07-23 17:16:55 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Does parsing types for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ptype; +interface + +uses + globtype,symtable + {$IFDEF NEWST} + ,symbols,defs + {$ENDIF NEWST}; + + + const + { forward types should only be possible inside a TYPE statement } + typecanbeforward : boolean = false; + + var + { hack, which allows to use the current parsed } + { object type as function argument type } + testcurobject : byte; + curobjectname : stringid; + + { parses a string declaration } + function string_dec : pdef; + + { parses a object declaration } + function object_dec(const n : stringid;fd : pobjectdef) : pdef; + + + { reads a string, file type or a type id and returns a name and } + { pdef } +{$IFDEF NEWST} + procedure single_type(var tt:Tdef;var s : string;isforwarddef:boolean); + + procedure read_type(var tt:Tdef;const name : stringid); +{$ELSE} + procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean); + + procedure read_type(var tt:ttype;const name : stringid); +{$ENDIF NEWST} + + +implementation + +uses + cobjects,globals,verbose,systems,tokens, + aasm,symconst,types, +{$ifdef GDB} + gdb, +{$endif} + tree,hcodegen,hcgdata, + scanner,pbase,pexpr,pdecl,psub, +{$ifdef newcg} + cgbase, +{$else} + tccnv, +{$endif} + pass_1; + + + function string_dec : pdef; + { reads a string type with optional length } + { and returns a pointer to the string } + { definition } + var + p : ptree; + d : pdef; + begin + consume(_STRING); + if token=_LECKKLAMMER then + begin + consume(_LECKKLAMMER); + p:=comp_expr(true); + do_firstpass(p); + if not is_constintnode(p) then + Message(cg_e_illegal_expression); + if (p^.value<=0) then + begin + Message(parser_e_invalid_string_size); + p^.value:=255; + end; + consume(_RECKKLAMMER); + if p^.value>255 then + d:=new(pstringdef,longinit(p^.value)) + else + if p^.value<>255 then + d:=new(pstringdef,shortinit(p^.value)) + else + d:=cshortstringdef; + disposetree(p); + end + else + begin + if cs_ansistrings in aktlocalswitches then + d:=cansistringdef + else + d:=cshortstringdef; + end; + string_dec:=d; + end; + + + procedure id_type(var tt : ttype;var s : string;isforwarddef:boolean); + { reads a type definition } + { to a appropriating pdef, s gets the name of } + { the type to allow name mangling } + var + is_unit_specific : boolean; + pos : tfileposinfo; + begin + s:=pattern; + pos:=tokenpos; + { classes can be used also in classes } + if (curobjectname=pattern) and aktobjectdef^.is_class then + begin + tt.setdef(aktobjectdef); + consume(_ID); + exit; + end; + { objects can be parameters } + if (testcurobject=2) and (curobjectname=pattern) then + begin + tt.setdef(aktobjectdef); + consume(_ID); + exit; + end; + { try to load the symbol to see if it's a unitsym } + is_unit_specific:=false; + getsym(s,false); + consume(_ID); + if assigned(srsym) and + (srsym^.typ=unitsym) then + begin + consume(_POINT); + getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); + pos:=tokenpos; + s:=pattern; + consume(_ID); + is_unit_specific:=true; + end; + { are we parsing a possible forward def ? } + if isforwarddef and + not(is_unit_specific) then + begin + tt.setdef(new(pforwarddef,init(s,pos))); + exit; + end; + { unknown sym ? } + if not assigned(srsym) then + begin + Message1(sym_e_id_not_found,s); + tt.setdef(generrordef); + exit; + end; + if (srsym^.typ<>typesym) then + begin + Message(type_e_type_id_expected); + tt.setdef(generrordef); + exit; + end; + { Only use the definitions for system/current unit, becuase + they can be refered from the parameters and symbols are not + loaded at that time. A symbol reference to an other unit + is still possible, because it's already loaded (PFV) + can't use in [] here, becuase unitid can be > 255 } + if (ptypesym(srsym)^.owner^.unitid=0) or + (ptypesym(srsym)^.owner^.unitid=1) then + tt.setdef(ptypesym(srsym)^.restype.def) + else + tt.setsym(srsym); + end; + + + procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean); + { reads a string, file type or a type id and returns a name and } + { pdef } + var + hs : string; + t2 : ttype; + begin + case token of + _STRING: + begin + tt.setdef(string_dec); + s:='STRING'; + end; + _FILE: + begin + consume(_FILE); + if token=_OF then + begin + consume(_OF); + single_type(t2,hs,false); + tt.setdef(new(pfiledef,inittyped(t2))); + s:='FILE$OF$'+hs; + end + else + begin + tt.setdef(cfiledef); + s:='FILE'; + end; + end; + else + begin + id_type(tt,s,isforwarddef); + end; + end; + end; + + + function object_dec(const n : stringid;fd : pobjectdef) : pdef; + { this function parses an object or class declaration } + var + actmembertype : tsymoptions; + there_is_a_destructor : boolean; + is_a_class : boolean; + childof : pobjectdef; + aktclass : pobjectdef; + + procedure constructor_head; + + begin + consume(_CONSTRUCTOR); + { must be at same level as in implementation } + inc(lexlevel); + parse_proc_head(potype_constructor); + dec(lexlevel); + + if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'INIT') then + Message(parser_e_constructorname_must_be_init); + +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_constructor); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_constructor]; +{$endif} + consume(_SEMICOLON); + begin + if (aktclass^.is_class) then + begin + { CLASS constructors return the created instance } + aktprocsym^.definition^.rettype.def:=aktclass; + end + else + begin + { OBJECT constructors return a boolean } + aktprocsym^.definition^.rettype.setdef(booldef); + end; + end; + end; + + + procedure property_dec; + + var + sym : psym; + propertyparas : plinkedlist; + + { returns the matching procedure to access a property } + function get_procdef : pprocdef; + + var + p : pprocdef; + + begin + p:=pprocsym(sym)^.definition; + get_procdef:=nil; + while assigned(p) do + begin + if equal_paras(p^.para,propertyparas,cp_value_equal_const) then + break; + p:=p^.nextoverloaded; + end; + get_procdef:=p; + end; + + var + hp2,datacoll : pparaitem; + p : ppropertysym; + overriden : psym; + hs : string; + varspez : tvarspez; + sc : pstringcontainer; + s : string; + tt : ttype; + declarepos : tfileposinfo; + pp : pprocdef; + pt : ptree; + propname : stringid; + + begin + { check for a class } + if not(aktclass^.is_class) then + Message(parser_e_syntax_error); + consume(_PROPERTY); + new(propertyparas,init); + datacoll:=nil; + if token=_ID then + begin + p:=new(ppropertysym,init(pattern)); + propname:=pattern; + consume(_ID); + { property parameters ? } + if token=_LECKKLAMMER then + begin + if (sp_published in current_object_option) then + Message(parser_e_cant_publish_that_property); + + { create a list of the parameters in propertyparas } + consume(_LECKKLAMMER); + inc(testcurobject); + repeat + if token=_VAR then + begin + consume(_VAR); + varspez:=vs_var; + end + else if token=_CONST then + begin + consume(_CONST); + varspez:=vs_const; + end + else varspez:=vs_value; + sc:=idlist; +{$ifdef fixLeaksOnError} + strContStack.push(sc); +{$endif fixLeaksOnError} + if token=_COLON then + begin + consume(_COLON); + if token=_ARRAY then + begin + { + if (varspez<>vs_const) and + (varspez<>vs_var) then + begin + varspez:=vs_const; + Message(parser_e_illegal_open_parameter); + end; + } + consume(_ARRAY); + consume(_OF); + { define range and type of range } + tt.setdef(new(parraydef,init(0,-1,s32bitdef))); + { define field type } + single_type(parraydef(tt.def)^.elementtype,s,false); + end + else + single_type(tt,s,false); + end + else + tt.setdef(cformaldef); + repeat + s:=sc^.get_with_tokeninfo(declarepos); + if s='' then + break; + new(hp2,init); + hp2^.paratyp:=varspez; + hp2^.paratype:=tt; + propertyparas^.insert(hp2); + until false; +{$ifdef fixLeaksOnError} + if strContStack.pop <> sc then + writeln('problem with strContStack in ptype'); +{$endif fixLeaksOnError} + dispose(sc,done); + until not try_to_consume(_SEMICOLON); + dec(testcurobject); + consume(_RECKKLAMMER); + end; + { overriden property ? } + { force property interface, if there is a property parameter } + if (token=_COLON) or not(propertyparas^.empty) then + begin + consume(_COLON); + single_type(p^.proptype,hs,false); + if (idtoken=_INDEX) then + begin + consume(_INDEX); + pt:=comp_expr(true); + do_firstpass(pt); + if not(is_ordinal(pt^.resulttype)) or + is_64bitint(pt^.resulttype) then + Message(parser_e_invalid_property_index_value); + p^.index:=pt^.value; + p^.indextype.setdef(pt^.resulttype); + include(p^.propoptions,ppo_indexed); + { concat a longint to the para template } + new(hp2,init); + hp2^.paratyp:=vs_value; + hp2^.paratype:=p^.indextype; + propertyparas^.insert(hp2); + disposetree(pt); + end; + { the parser need to know if a property has parameters } + if not(propertyparas^.empty) then + p^.propoptions:=p^.propoptions+[ppo_hasparameters]; + end + else + begin + { do an property override } + overriden:=search_class_member(aktclass,propname); + if assigned(overriden) and (overriden^.typ=propertysym) then + begin + p^.dooverride(ppropertysym(overriden)); + end + else + begin + p^.proptype.setdef(generrordef); + message(parser_e_no_property_found_to_override); + end; + end; + if (sp_published in current_object_option) and + not(p^.proptype.def^.is_publishable) then + Message(parser_e_cant_publish_that_property); + + { create data defcoll to allow correct parameter checks } + new(datacoll,init); + datacoll^.paratyp:=vs_value; + datacoll^.paratype:=p^.proptype; + + if (idtoken=_READ) then + begin + p^.readaccess^.clear; + consume(_READ); + sym:=search_class_member(aktclass,pattern); + if not(assigned(sym)) then + begin + Message1(sym_e_unknown_id,pattern); + consume(_ID); + end + else + begin + consume(_ID); + while (token=_POINT) and + ((sym^.typ=varsym) and + (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do + begin + p^.readaccess^.addsym(sym); + consume(_POINT); + getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern); + if not assigned(srsym) then + Message1(sym_e_illegal_field,pattern); + sym:=srsym; + consume(_ID); + end; + end; + + if assigned(sym) then + begin + { search the matching definition } + case sym^.typ of + procsym : + begin + pp:=get_procdef; + if not(assigned(pp)) or + not(is_equal(pp^.rettype.def,p^.proptype.def)) then + Message(parser_e_ill_property_access_sym); + p^.readaccess^.setdef(pp); + end; + varsym : + begin + if not(propertyparas^.empty) or + not(is_equal(pvarsym(sym)^.vartype.def,p^.proptype.def)) then + Message(parser_e_ill_property_access_sym); + end; + else + Message(parser_e_ill_property_access_sym); + end; + p^.readaccess^.addsym(sym); + end; + end; + if (idtoken=_WRITE) then + begin + p^.writeaccess^.clear; + consume(_WRITE); + sym:=search_class_member(aktclass,pattern); + if not(assigned(sym)) then + begin + Message1(sym_e_unknown_id,pattern); + consume(_ID); + end + else + begin + consume(_ID); + while (token=_POINT) and + ((sym^.typ=varsym) and + (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do + begin + p^.writeaccess^.addsym(sym); + consume(_POINT); + getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern); + if not assigned(srsym) then + Message1(sym_e_illegal_field,pattern); + sym:=srsym; + consume(_ID); + end; + end; + + if assigned(sym) then + begin + { search the matching definition } + case sym^.typ of + procsym : + begin + { insert data entry to check access method } + propertyparas^.insert(datacoll); + pp:=get_procdef; + { ... and remove it } + propertyparas^.remove(datacoll); + if not(assigned(pp)) then + Message(parser_e_ill_property_access_sym); + p^.writeaccess^.setdef(pp); + end; + varsym : + begin + if not(propertyparas^.empty) or + not(is_equal(pvarsym(sym)^.vartype.def,p^.proptype.def)) then + Message(parser_e_ill_property_access_sym); + end + else + Message(parser_e_ill_property_access_sym); + end; + p^.writeaccess^.addsym(sym); + end; + end; + include(p^.propoptions,ppo_stored); + if (idtoken=_STORED) then + begin + consume(_STORED); + p^.storedaccess^.clear; + case token of + _ID: + { in the case that idtoken=_DEFAULT } + { we have to do nothing except } + { setting ppo_stored, it's the same } + { as stored true } + if idtoken<>_DEFAULT then + begin + sym:=search_class_member(aktclass,pattern); + if not(assigned(sym)) then + begin + Message1(sym_e_unknown_id,pattern); + consume(_ID); + end + else + begin + consume(_ID); + while (token=_POINT) and + ((sym^.typ=varsym) and + (pvarsym(sym)^.vartype.def^.deftype=recorddef)) do + begin + p^.storedaccess^.addsym(sym); + consume(_POINT); + getsymonlyin(precorddef(pvarsym(sym)^.vartype.def)^.symtable,pattern); + if not assigned(srsym) then + Message1(sym_e_illegal_field,pattern); + sym:=srsym; + consume(_ID); + end; + end; + + if assigned(sym) then + begin + { only non array properties can be stored } + case sym^.typ of + procsym : + begin + pp:=pprocsym(sym)^.definition; + while assigned(pp) do + begin + { the stored function shouldn't have any parameters } + if pp^.para^.empty then + break; + pp:=pp^.nextoverloaded; + end; + { found we a procedure and does it really return a bool? } + if not(assigned(pp)) or + not(is_equal(pp^.rettype.def,booldef)) then + Message(parser_e_ill_property_storage_sym); + p^.storedaccess^.setdef(pp); + end; + varsym : + begin + if not(propertyparas^.empty) or + not(is_equal(pvarsym(sym)^.vartype.def,booldef)) then + Message(parser_e_stored_property_must_be_boolean); + end; + else + Message(parser_e_ill_property_storage_sym); + end; + p^.storedaccess^.addsym(sym); + end; + end; + _FALSE: + begin + consume(_FALSE); + exclude(p^.propoptions,ppo_stored); + end; + _TRUE: + consume(_TRUE); + end; + end; + if (idtoken=_DEFAULT) then + begin + consume(_DEFAULT); + if not(is_ordinal(p^.proptype.def) or + is_64bitint(p^.proptype.def) or + ((p^.proptype.def^.deftype=setdef) and + (psetdef(p^.proptype.def)^.settype=smallset))) or + not(propertyparas^.empty) then + Message(parser_e_property_cant_have_a_default_value); + { Get the result of the default, the firstpass is + needed to support values like -1 } + pt:=comp_expr(true); + do_firstpass(pt); + if p^.proptype.def^.deftype=setdef then + begin +{$ifndef newcg} + {!!!!!!!!!!} + arrayconstructor_to_set(pt); +{$endif newcg} + do_firstpass(pt); + end; + pt:=gentypeconvnode(pt,p^.proptype.def); + do_firstpass(pt); + if not(is_constnode(pt)) then + Message(parser_e_property_default_value_must_const); + + if pt^.treetype=setconstn then + p^.default:=plongint(pt^.value_set)^ + else + p^.default:=pt^.value; + disposetree(pt); + end + else if (idtoken=_NODEFAULT) then + begin + consume(_NODEFAULT); + p^.default:=0; + end; + symtablestack^.insert(p); + { default property ? } + consume(_SEMICOLON); + if (idtoken=_DEFAULT) then + begin + consume(_DEFAULT); + { overriding a default propertyp is allowed + p2:=search_default_property(aktclass); + if assigned(p2) then + message1(parser_e_only_one_default_property, + pobjectdef(p2^.owner^.defowner)^.objname^) + else + } + begin + include(p^.propoptions,ppo_defaultproperty); + if propertyparas^.empty then + message(parser_e_property_need_paras); + end; + consume(_SEMICOLON); + end; + { clean up } + if assigned(datacoll) then + dispose(datacoll,done); + end + else + begin + consume(_ID); + consume(_SEMICOLON); + end; + dispose(propertyparas,done); + end; + + + procedure destructor_head; + begin + consume(_DESTRUCTOR); + inc(lexlevel); + parse_proc_head(potype_destructor); + dec(lexlevel); + if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'DONE') then + Message(parser_e_destructorname_must_be_done); +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_destructor); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_destructor]; +{$endif} + consume(_SEMICOLON); + if not(aktprocsym^.definition^.para^.empty) then + if not (m_tp in aktmodeswitches) then + Message(parser_e_no_paras_for_destructor); + { no return value } + aktprocsym^.definition^.rettype.def:=voiddef; + end; + + var + hs : string; + pcrd : pclassrefdef; + tt : ttype; + oldprocinfo : pprocinfo; + oldprocsym : pprocsym; + oldparse_only : boolean; + methodnametable,intmessagetable, + strmessagetable,classnamelabel, + fieldtablelabel : pasmlabel; + storetypecanbeforward : boolean; + + procedure setclassattributes; + + begin + if is_a_class then + begin +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_is_class); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_class]; +{$endif} + if (cs_generate_rtti in aktlocalswitches) or + (assigned(aktclass^.childof) and + (oo_can_have_published in aktclass^.childof^.objectoptions)) then + begin + include(aktclass^.objectoptions,oo_can_have_published); + { in "publishable" classes the default access type is published } + actmembertype:=[sp_published]; + { don't know if this is necessary (FK) } + current_object_option:=[sp_published]; + end; + end; + end; + + procedure setclassparent; + + begin + { is the current class tobject? } + { so you could define your own tobject } + if (cs_compilesystem in aktmoduleswitches) and + (n='TOBJECT') then + begin + if assigned(fd) then + aktclass:=fd + else + aktclass:=new(pobjectdef,init(n,nil)); + class_tobject:=aktclass; + end + else + begin + childof:=class_tobject; + if assigned(fd) then + begin + { the forward of the child must be resolved to get + correct field addresses + } + if (oo_is_forward in childof^.objectoptions) then + Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^); + aktclass:=fd; + aktclass^.set_parent(childof); + end + else + begin + aktclass:=new(pobjectdef,init(n,childof)); + aktclass^.set_parent(childof); + end; + end; + end; + + { generates the vmt for classes as well as for objects } + procedure writevmt; + + var + vmtlist : taasmoutput; +{$ifdef WITHDMT} + dmtlabel : pasmlabel; +{$endif WITHDMT} + + begin +{$ifdef WITHDMT} + dmtlabel:=gendmt(aktclass); +{$endif WITHDMT} + { this generates the entries } + vmtlist.init; + genvmt(@vmtlist,aktclass); + + { write tables for classes, this must be done before the actual + class is written, because we need the labels defined } + if is_a_class then + begin + methodnametable:=genpublishedmethodstable(aktclass); + fieldtablelabel:=aktclass^.generate_field_table; + { rtti } + if (oo_can_have_published in aktclass^.objectoptions) then + aktclass^.generate_rtti; + { write class name } + getdatalabel(classnamelabel); + datasegment^.concat(new(pai_label,init(classnamelabel))); + datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.objname^)))); + datasegment^.concat(new(pai_string,init(aktclass^.objname^))); + { generate message and dynamic tables } + if (oo_has_msgstr in aktclass^.objectoptions) then + strmessagetable:=genstrmsgtab(aktclass); + if (oo_has_msgint in aktclass^.objectoptions) then + intmessagetable:=genintmsgtab(aktclass) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + end; + + { write debug info } +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) then + begin + do_count_dbx:=true; + if assigned(aktclass^.owner) and assigned(aktclass^.owner^.name) then + datasegment^.concat(new(pai_stabs,init(strpnew('"vmt_'+aktclass^.owner^.name^+n+':S'+ + typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+aktclass^.vmt_mangledname)))); + end; +{$endif GDB} + datasegment^.concat(new(pai_symbol,initname_global(aktclass^.vmt_mangledname,0))); + + { determine the size with symtable^.datasize, because } + { size gives back 4 for classes } + datasegment^.concat(new(pai_const,init_32bit(aktclass^.symtable^.datasize))); + datasegment^.concat(new(pai_const,init_32bit(-aktclass^.symtable^.datasize))); +{$ifdef WITHDMT} + if not(is_a_class) then + begin + if assigned(dmtlabel) then + datasegment^.concat(new(pai_const_symbol,init(dmtlabel))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + end; +{$endif WITHDMT} + { write pointer to parent VMT, this isn't implemented in TP } + { but this is not used in FPC ? (PM) } + { it's not used yet, but the delphi-operators as and is need it (FK) } + { it is not written for parents that don't have any vmt !! } + if assigned(aktclass^.childof) and + (oo_has_vmt in aktclass^.childof^.objectoptions) then + datasegment^.concat(new(pai_const_symbol,initname(aktclass^.childof^.vmt_mangledname))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + + { write extended info for classes, for the order see rtl/inc/objpash.inc } + if is_a_class then + begin + { pointer to class name string } + datasegment^.concat(new(pai_const_symbol,init(classnamelabel))); + { pointer to dynamic table } + if (oo_has_msgint in aktclass^.objectoptions) then + datasegment^.concat(new(pai_const_symbol,init(intmessagetable))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + { pointer to method table } + if assigned(methodnametable) then + datasegment^.concat(new(pai_const_symbol,init(methodnametable))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + { pointer to field table } + datasegment^.concat(new(pai_const_symbol,init(fieldtablelabel))); + { pointer to type info of published section } + if (oo_can_have_published in aktclass^.objectoptions) then + datasegment^.concat(new(pai_const_symbol,initname(aktclass^.rtti_name))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + { inittable for con-/destruction } + { + if aktclass^.needs_inittable then + } + { we generate the init table for classes always, because needs_inittable } + { for classes is always false, it applies only for objects } + datasegment^.concat(new(pai_const_symbol,init(aktclass^.get_inittable_label))); + { + else + datasegment^.concat(new(pai_const,init_32bit(0))); + } + { auto table } + datasegment^.concat(new(pai_const,init_32bit(0))); + { interface table } + datasegment^.concat(new(pai_const,init_32bit(0))); + { table for string messages } + if (oo_has_msgstr in aktclass^.objectoptions) then + datasegment^.concat(new(pai_const_symbol,init(strmessagetable))) + else + datasegment^.concat(new(pai_const,init_32bit(0))); + end; + datasegment^.concatlist(@vmtlist); + vmtlist.done; + { write the size of the VMT } + datasegment^.concat(new(pai_symbol_end,initname(aktclass^.vmt_mangledname))); + end; + + procedure readparentclasses; + + begin + { reads the parent class } + if token=_LKLAMMER then + begin + consume(_LKLAMMER); + id_type(tt,pattern,false); + childof:=pobjectdef(tt.def); + if (childof^.deftype<>objectdef) then + begin + Message1(type_e_class_type_expected,childof^.typename); + childof:=nil; + aktclass:=new(pobjectdef,init(n,nil)); + end + else + begin + { a mix of class and object isn't allowed } + if (childof^.is_class and not is_a_class) or + (not childof^.is_class and is_a_class) then + Message(parser_e_mix_of_classes_and_objects); + { the forward of the child must be resolved to get + correct field addresses } + if assigned(fd) then + begin + if (oo_is_forward in childof^.objectoptions) then + Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^); + aktclass:=fd; + { we must inherit several options !! + this was missing !! + all is now done in set_parent + including symtable datasize setting PM } + fd^.set_parent(childof); + end + else + aktclass:=new(pobjectdef,init(n,childof)); + end; + consume(_RKLAMMER); + end + { if no parent class, then a class get tobject as parent } + else if is_a_class then + setclassparent + else + aktclass:=new(pobjectdef,init(n,nil)); + end; + + begin + {Nowadays aktprocsym may already have a value, so we need to save + it.} + oldprocsym:=aktprocsym; + { forward is resolved } + if assigned(fd) then + exclude(fd^.objectoptions,oo_is_forward); + + there_is_a_destructor:=false; + actmembertype:=[sp_public]; + + { objects and class types can't be declared local } + if (symtablestack^.symtabletype<>globalsymtable) and + (symtablestack^.symtabletype<>staticsymtable) then + Message(parser_e_no_local_objects); + + storetypecanbeforward:=typecanbeforward; + { for tp mode don't allow forward types } + if (m_tp in aktmodeswitches) and + not (m_delphi in aktmodeswitches) then + typecanbeforward:=false; + + { distinguish classes and objects } + case token of + _OBJECT: + begin + is_a_class:=false; + consume(_OBJECT) + end; + _CPPCLASS: + begin + internalerror(2003001); + end; + _INTERFACE: + begin + internalerror(2003002); + end; + _CLASS: + begin + is_a_class:=true; + consume(_CLASS); + if not(assigned(fd)) and (token=_OF) then + begin + { a hack, but it's easy to handle } + { class reference type } + consume(_OF); + single_type(tt,hs,typecanbeforward); + + { accept hp1, if is a forward def or a class } + if (tt.def^.deftype=forwarddef) or + ((tt.def^.deftype=objectdef) and pobjectdef(tt.def)^.is_class) then + begin + pcrd:=new(pclassrefdef,init(tt.def)); + object_dec:=pcrd; + end + else + begin + object_dec:=generrordef; + Message1(type_e_class_type_expected,generrordef^.typename); + end; + typecanbeforward:=storetypecanbeforward; + exit; + end + { forward class } + else if not(assigned(fd)) and (token=_SEMICOLON) then + begin + { also anonym objects aren't allow (o : object a : longint; end;) } + if n='' then + begin + Message(parser_f_no_anonym_objects) + end; + if (cs_compilesystem in aktmoduleswitches) and + (n='TOBJECT') then + begin + aktclass:=new(pobjectdef,init(n,nil)); + class_tobject:=aktclass; + end + else + aktclass:=new(pobjectdef,init(n,nil)); + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_class,oo_is_forward]; + { all classes must have a vmt !! at offset zero } + if not(oo_has_vmt in aktclass^.objectoptions) then + aktclass^.insertvmt; + + object_dec:=aktclass; + typecanbeforward:=storetypecanbeforward; + exit; + end; + end; + else + consume(_OBJECT); + end; + + { also anonym objects aren't allow (o : object a : longint; end;) } + if n='' then + Message(parser_f_no_anonym_objects); + + readparentclasses; + + { default access is public } + actmembertype:=[sp_public]; + + { set class flags and inherits published, if necessary? } + setclassattributes; + + aktobjectdef:=aktclass; + aktclass^.symtable^.next:=symtablestack; + symtablestack:=aktclass^.symtable; + testcurobject:=1; + curobjectname:=n; + + { new procinfo } + oldprocinfo:=procinfo; + new(procinfo,init); + procinfo^._class:=aktclass; + + + { short class declaration ? } + if (not is_a_class) or (token<>_SEMICOLON) then + begin + { Parse componenten } + repeat + if (sp_private in actmembertype) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_private); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_private]; +{$endif} + if (sp_protected in actmembertype) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_protected); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_protected]; +{$endif} + case token of + _ID : begin + case idtoken of + _PRIVATE : begin + consume(_PRIVATE); + actmembertype:=[sp_private]; + current_object_option:=[sp_private]; + end; + _PROTECTED : begin + consume(_PROTECTED); + current_object_option:=[sp_protected]; + actmembertype:=[sp_protected]; + end; + _PUBLIC : begin + consume(_PUBLIC); + current_object_option:=[sp_public]; + actmembertype:=[sp_public]; + end; + _PUBLISHED : begin + if not(oo_can_have_published in aktclass^.objectoptions) then + Message(parser_e_cant_have_published); + consume(_PUBLISHED); + current_object_option:=[sp_published]; + actmembertype:=[sp_published]; + end; + else + read_var_decs(false,true,false); + end; + end; + _PROPERTY : property_dec; + _PROCEDURE, + _FUNCTION, + _CLASS : begin + oldparse_only:=parse_only; + parse_only:=true; + parse_proc_dec; +{$ifndef newcg} + parse_object_proc_directives(aktprocsym); +{$endif newcg} + if (po_msgint in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_msgint); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_msgint]; +{$endif} + if (po_msgstr in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_msgstr); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_msgstr]; +{$endif} + if (po_virtualmethod in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_virtual); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_virtual]; +{$endif} + parse_only:=oldparse_only; + end; + _CONSTRUCTOR : begin + if not(sp_public in actmembertype) then + Message(parser_w_constructor_should_be_public); + oldparse_only:=parse_only; + parse_only:=true; + constructor_head; +{$ifndef newcg} + parse_object_proc_directives(aktprocsym); +{$endif newcg} + if (po_virtualmethod in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_virtual); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_virtual]; +{$endif} + parse_only:=oldparse_only; + end; + _DESTRUCTOR : begin + if there_is_a_destructor then + Message(parser_n_only_one_destructor); + there_is_a_destructor:=true; + if not(sp_public in actmembertype) then + Message(parser_w_destructor_should_be_public); + oldparse_only:=parse_only; + parse_only:=true; + destructor_head; +{$ifndef newcg} + parse_object_proc_directives(aktprocsym); +{$endif newcg} + if (po_virtualmethod in aktprocsym^.definition^.procoptions) then +{$ifdef INCLUDEOK} + include(aktclass^.objectoptions,oo_has_virtual); +{$else} + aktclass^.objectoptions:=aktclass^.objectoptions+[oo_has_virtual]; +{$endif} + parse_only:=oldparse_only; + end; + _END : begin + consume(_END); + break; + end; + else + consume(_ID); { Give a ident expected message, like tp7 } + end; + until false; + current_object_option:=[sp_public]; + end; + testcurobject:=0; + curobjectname:=''; + typecanbeforward:=storetypecanbeforward; + + { generate vmt space if needed } + if not(oo_has_vmt in aktclass^.objectoptions) and + ([oo_has_virtual,oo_has_constructor,oo_has_destructor,oo_is_class]*aktclass^.objectoptions<>[]) then + aktclass^.insertvmt; + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_cut,init)); + + if (oo_has_vmt in aktclass^.objectoptions) then + writevmt; + + { restore old state } + symtablestack:=symtablestack^.next; + aktobjectdef:=nil; + {Restore procinfo} + dispose(procinfo,done); + procinfo:=oldprocinfo; + {Restore the aktprocsym.} + aktprocsym:=oldprocsym; + + object_dec:=aktclass; + end; + + + { reads a record declaration } + function record_dec : pdef; + + var + symtable : psymtable; + storetypecanbeforward : boolean; + + begin + { create recdef } + symtable:=new(psymtable,init(recordsymtable)); + record_dec:=new(precorddef,init(symtable)); + { update symtable stack } + symtable^.next:=symtablestack; + symtablestack:=symtable; + { parse record } + consume(_RECORD); + storetypecanbeforward:=typecanbeforward; + { for tp mode don't allow forward types } + if m_tp in aktmodeswitches then + typecanbeforward:=false; + read_var_decs(true,false,false); + consume(_END); + typecanbeforward:=storetypecanbeforward; + { may be scale record size to a size of n*4 ? } + symtablestack^.datasize:=align(symtablestack^.datasize,symtablestack^.dataalignment); + { restore symtable stack } + symtablestack:=symtable^.next; + end; + + + { reads a type definition and returns a pointer to it } + procedure read_type(var tt : ttype;const name : stringid); + var + pt : ptree; + tt2 : ttype; + aktenumdef : penumdef; + ap : parraydef; + s : stringid; + l,v : longint; + oldaktpackrecords : tpackrecords; + hs : string; + defpos,storepos : tfileposinfo; + + procedure expr_type; + var + pt1,pt2 : ptree; + begin + { use of current parsed object ? } + if (token=_ID) and (testcurobject=2) and (curobjectname=pattern) then + begin + consume(_ID); + tt.setdef(aktobjectdef); + exit; + end; + { classes can be used also in classes } + if (curobjectname=pattern) and aktobjectdef^.is_class then + begin + tt.setdef(aktobjectdef); + consume(_ID); + exit; + end; + { we can't accept a equal in type } + pt1:=comp_expr(not(ignore_equal)); + do_firstpass(pt1); + if (token=_POINTPOINT) then + begin + consume(_POINTPOINT); + { get high value of range } + pt2:=comp_expr(not(ignore_equal)); + do_firstpass(pt2); + { both must be evaluated to constants now } + if (pt1^.treetype<>ordconstn) or (pt2^.treetype<>ordconstn) then + Message(sym_e_error_in_type_def) + else + begin + { check types } + if CheckTypes(pt1^.resulttype,pt2^.resulttype) then + begin + { Check bounds } + if pt2^.value=0 then + tt.setdef(new(psetdef,init(tt2.def,penumdef(tt2.def)^.max))) + else + Message(sym_e_ill_type_decl_set); + orddef : + begin + case porddef(tt2.def)^.typ of + uchar : + tt.setdef(new(psetdef,init(tt2.def,255))); + u8bit,u16bit,u32bit, + s8bit,s16bit,s32bit : + begin + if (porddef(tt2.def)^.low>=0) then + tt.setdef(new(psetdef,init(tt2.def,porddef(tt2.def)^.high))) + else + Message(sym_e_ill_type_decl_set); + end; + else + Message(sym_e_ill_type_decl_set); + end; + end; + else + Message(sym_e_ill_type_decl_set); + end; + end + else + tt.setdef(generrordef); + end; + _CARET: + begin + consume(_CARET); + single_type(tt2,hs,typecanbeforward); + tt.setdef(new(ppointerdef,init(tt2))); + end; + _RECORD: + begin + tt.setdef(record_dec); + end; + _PACKED: + begin + consume(_PACKED); + if token=_ARRAY then + array_dec + else + begin + oldaktpackrecords:=aktpackrecords; + aktpackrecords:=packrecord_1; + if token in [_CLASS,_OBJECT] then + tt.setdef(object_dec(name,nil)) + else + tt.setdef(record_dec); + aktpackrecords:=oldaktpackrecords; + end; + end; + _CLASS, +{$ifdef SUPPORTCPPCLASS} + _CPPCLASS, +{$endif SUPPORTCPPCLASS} +{$ifdef SUPPORTINTERFACES} + _INTERFACE, +{$endif SUPPORTINTERFACES} + _OBJECT: + begin + tt.setdef(object_dec(name,nil)); + end; + _PROCEDURE: + begin + consume(_PROCEDURE); + tt.setdef(new(pprocvardef,init)); + if token=_LKLAMMER then + parameter_dec(pprocvardef(tt.def)); + if token=_OF then + begin + consume(_OF); + consume(_OBJECT); +{$ifdef INCLUDEOK} + include(pprocvardef(tt.def)^.procoptions,po_methodpointer); +{$else} + pprocvardef(tt.def)^.procoptions:=pprocvardef(tt.def)^.procoptions+[po_methodpointer]; +{$endif} + end; + end; + _FUNCTION: + begin + consume(_FUNCTION); + tt.def:=new(pprocvardef,init); + if token=_LKLAMMER then + parameter_dec(pprocvardef(tt.def)); + consume(_COLON); + single_type(pprocvardef(tt.def)^.rettype,hs,false); + if token=_OF then + begin + consume(_OF); + consume(_OBJECT); +{$ifdef INCLUDEOK} + include(pprocvardef(tt.def)^.procoptions,po_methodpointer); +{$else} + pprocvardef(tt.def)^.procoptions:=pprocvardef(tt.def)^.procoptions+[po_methodpointer]; +{$endif} + end; + end; + else + expr_type; + end; + if tt.def=nil then + tt.setdef(generrordef); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.28 2000/06/20 12:47:53 pierre + * equal_paras and convertable_paras changed by transforming third parameter + into an enum with three possible values: + cp_none, cp_value_equal_const and cp_all. + + Revision 1.27 2000/06/18 18:16:38 peter + * don't allow enum assignments in tp/delphi mode + + Revision 1.26 2000/06/13 17:09:56 kaz + * array type property can have default value, fixed. + + Revision 1.25 2000/06/02 18:48:47 florian + + fieldtable support for classes + + Revision 1.24 2000/03/27 21:51:19 pierre + * fix for bug 739 + + Revision 1.23 2000/03/19 14:56:38 florian + * bug 873 fixed + * some cleanup in objectdec + + Revision 1.22 2000/03/14 16:37:26 pierre + * destructor can have args in TP mode only (bug825 and 839) + + Revision 1.21 2000/03/11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.20 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.19 2000/02/21 22:17:49 florian + * fixed 819 + + Revision 1.18 2000/02/09 13:23:01 peter + * log truncated + + Revision 1.17 2000/02/05 14:33:32 florian + * fixed init table generation for classes and arrays + + Revision 1.16 2000/01/28 23:17:53 florian + * virtual XXXX; support for objects, only if -dWITHDMT is defined + + Revision 1.15 2000/01/27 16:31:40 florian + * bug 738 fixed + + Revision 1.14 2000/01/11 17:16:06 jonas + * removed a lot of memory leaks when an error is encountered (caused by + procinfo and pstringcontainers). There are still plenty left though :) + + Revision 1.13 2000/01/07 01:14:34 peter + * updated copyright to 2000 + + Revision 1.12 1999/11/30 10:40:52 peter + + ttype, tsymlist + + Revision 1.11 1999/11/26 00:19:12 peter + * property overriding dereference fix, but it need a bigger redesign + which i'll do tomorrow. This quick hack is for the lazarus ppl so + they can hack on mwcustomedit. + + Revision 1.10 1999/11/17 17:05:03 pierre + * Notes/hints changes + + Revision 1.9 1999/11/11 00:56:54 pierre + * Enum element reference location corrected + + Revision 1.8 1999/11/09 23:43:09 pierre + * better browser info + + Revision 1.7 1999/11/08 14:02:16 florian + * problem with "index X"-properties solved + * typed constants of class references are now allowed + + Revision 1.6 1999/11/07 23:16:49 florian + * finally bug 517 solved ... + + Revision 1.5 1999/10/27 16:04:06 peter + * fixed property reading + + Revision 1.4 1999/10/27 14:17:08 florian + * property overriding fixed + + Revision 1.3 1999/10/26 12:30:45 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.2 1999/10/22 14:37:30 peter + * error when properties are passed to var parameters + + Revision 1.1 1999/10/22 10:39:35 peter + * split type reading from pdecl to ptype unit + * parameter_dec routine is now used for procedure and procvars + +} \ No newline at end of file diff --git a/befpc/compiler/ra386.pas b/befpc/compiler/ra386.pas new file mode 100644 index 0000000..26bbe94 --- /dev/null +++ b/befpc/compiler/ra386.pas @@ -0,0 +1,482 @@ +{ + $Id: ra386.pas,v 1.1.1.1 2001-07-23 17:16:55 memson Exp $ + Copyright (c) 1998-2000 by Carl Eric Codere and Peter Vreman + + Handles the common i386 assembler reader routines + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit Ra386; +interface + +uses + aasm,cpubase,RAUtils; + +{ Parser helpers } +function is_prefix(t:tasmop):boolean; +function is_override(t:tasmop):boolean; +Function CheckPrefix(prefixop,op:tasmop): Boolean; +Function CheckOverride(overrideop,op:tasmop): Boolean; +Procedure FWaitWarning; + +type + P386Operand=^T386Operand; + T386Operand=object(TOperand) + Procedure SetCorrectSize(opcode:tasmop);virtual; + end; + + P386Instruction=^T386Instruction; + T386Instruction=object(TInstruction) + { Operand sizes } + procedure AddReferenceSizes; + procedure SetInstructionOpsize; + procedure CheckOperandSizes; + procedure CheckNonCommutativeOpcodes; + { opcode adding } + procedure ConcatInstruction(p : paasmoutput);virtual; + end; + + +implementation + +uses + globtype,systems,globals,verbose,cpuasm; + + +{***************************************************************************** + Parser Helpers +*****************************************************************************} + +function is_prefix(t:tasmop):boolean; +var + i : longint; +Begin + is_prefix:=false; + for i:=1 to AsmPrefixes do + if t=AsmPrefix[i-1] then + begin + is_prefix:=true; + exit; + end; +end; + + +function is_override(t:tasmop):boolean; +var + i : longint; +Begin + is_override:=false; + for i:=1 to AsmOverrides do + if t=AsmOverride[i-1] then + begin + is_override:=true; + exit; + end; +end; + + +Function CheckPrefix(prefixop,op:tasmop): Boolean; +{ Checks if the prefix is valid with the following opcode } +{ return false if not, otherwise true } +Begin + CheckPrefix := TRUE; +(* Case prefix of + A_REP,A_REPNE,A_REPE: + Case opcode Of + A_SCASB,A_SCASW,A_SCASD, + A_INS,A_OUTS,A_MOVS,A_CMPS,A_LODS,A_STOS:; + Else + Begin + CheckPrefix := FALSE; + exit; + end; + end; { case } + A_LOCK: + Case opcode Of + A_BT,A_BTS,A_BTR,A_BTC,A_XCHG,A_ADD,A_OR,A_ADC,A_SBB,A_AND,A_SUB, + A_XOR,A_NOT,A_NEG,A_INC,A_DEC:; + Else + Begin + CheckPrefix := FALSE; + Exit; + end; + end; { case } + A_NONE: exit; { no prefix here } + else + CheckPrefix := FALSE; + end; { end case } *) +end; + + +Function CheckOverride(overrideop,op:tasmop): Boolean; +{ Check if the override is valid, and if so then } +{ update the instr variable accordingly. } +Begin + CheckOverride := true; +{ Case instr.getinstruction of + A_MOVS,A_XLAT,A_CMPS: + Begin + CheckOverride := TRUE; + Message(assem_e_segment_override_not_supported); + end + end } +end; + + +Procedure FWaitWarning; +begin + if (target_info.target=target_i386_GO32V2) and (cs_fp_emulation in aktmoduleswitches) then + Message(asmr_w_fwait_emu_prob); +end; + +{***************************************************************************** + T386Operand +*****************************************************************************} + +Procedure T386Operand.SetCorrectSize(opcode:tasmop); +begin + if att_needsuffix[opcode]=attsufFPU then + begin + case size of + S_L : size:=S_FS; + S_IQ : size:=S_FL; + end; + end + else if att_needsuffix[opcode]=attsufFPUint then + begin + case size of + S_W : size:=S_IS; + S_L : size:=S_IL; + end; + end; +end; + +{***************************************************************************** + T386Instruction +*****************************************************************************} + +procedure T386Instruction.AddReferenceSizes; +{ this will add the sizes for references like [esi] which do not + have the size set yet, it will take only the size if the other + operand is a register } +var + operand2,i : longint; + s : pasmsymbol; + so : longint; +begin + for i:=1to ops do + begin + operands[i]^.SetCorrectSize(opcode); + if (operands[i]^.size=S_NO) then + begin + case operands[i]^.Opr.Typ of + OPR_REFERENCE : + begin + if i=2 then + operand2:=1 + else + operand2:=2; + { Only allow register as operand to take the size from } + if operands[operand2]^.opr.typ=OPR_REGISTER then + operands[i]^.size:=operands[operand2]^.size + else + begin + { if no register then take the opsize (which is available with ATT) } + if opsize<>S_NO then + operands[i]^.size:=opsize; + end; + end; + OPR_SYMBOL : + begin + { Fix lea which need a reference } + if opcode=A_LEA then + begin + s:=operands[i]^.opr.symbol; + so:=operands[i]^.opr.symofs; + operands[i]^.opr.typ:=OPR_REFERENCE; + reset_reference(operands[i]^.opr.ref); + operands[i]^.opr.ref.symbol:=s; + operands[i]^.opr.ref.offset:=so; + end; + operands[i]^.size:=S_L; + end; + end; + end; + end; +end; + + +procedure T386Instruction.SetInstructionOpsize; +begin + if opsize<>S_NO then + exit; + case ops of + 0 : ; + 1 : + { "push es" must be stored as a long PM } + if ((opcode=A_PUSH) or + (opcode=A_POP)) and + (operands[1]^.opr.typ=OPR_REGISTER) and + ((operands[1]^.opr.reg>=firstsreg) and + (operands[1]^.opr.reg<=lastsreg)) then + opsize:=S_L + else + opsize:=operands[1]^.size; + 2 : + begin + case opcode of + A_MOVZX,A_MOVSX : + begin + case operands[1]^.size of + S_W : + case operands[2]^.size of + S_L : + opsize:=S_WL; + end; + S_B : + case operands[2]^.size of + S_W : + opsize:=S_BW; + S_L : + opsize:=S_BL; + end; + end; + end; + A_OUT : + opsize:=operands[1]^.size; + else + opsize:=operands[2]^.size; + end; + end; + 3 : + opsize:=operands[3]^.size; + end; +end; + + +procedure T386Instruction.CheckOperandSizes; +var + sizeerr : boolean; + i : longint; +begin + { Check only the most common opcodes here, the others are done in + the assembler pass } + case opcode of + A_PUSH,A_POP,A_DEC,A_INC,A_NOT,A_NEG, + A_CMP,A_MOV, + A_ADD,A_SUB,A_ADC,A_SBB, + A_AND,A_OR,A_TEST,A_XOR: ; + else + exit; + end; + { Handle the BW,BL,WL separatly } + sizeerr:=false; + { special push/pop selector case } + if ((opcode=A_PUSH) or + (opcode=A_POP)) and + (operands[1]^.opr.typ=OPR_REGISTER) and + ((operands[1]^.opr.reg>=firstsreg) and + (operands[1]^.opr.reg<=lastsreg)) then + exit; + if opsize in [S_BW,S_BL,S_WL] then + begin + if ops<>2 then + sizeerr:=true + else + begin + case opsize of + S_BW : + sizeerr:=(operands[1]^.size<>S_B) or (operands[2]^.size<>S_W); + S_BL : + sizeerr:=(operands[1]^.size<>S_B) or (operands[2]^.size<>S_L); + S_WL : + sizeerr:=(operands[1]^.size<>S_W) or (operands[2]^.size<>S_L); + end; + end; + end + else + begin + for i:=1to ops do + begin + if (operands[i]^.opr.typ<>OPR_CONSTANT) and + (operands[i]^.size in [S_B,S_W,S_L]) and + (operands[i]^.size<>opsize) then + sizeerr:=true; + end; + end; + if sizeerr then + begin + { if range checks are on then generate an error } + if (cs_compilesystem in aktmoduleswitches) or + not (cs_check_range in aktlocalswitches) then + Message(asmr_w_size_suffix_and_dest_dont_match) + else + Message(asmr_e_size_suffix_and_dest_dont_match); + end; +end; + + +{ This check must be done with the operand in ATT order + i.e.after swapping in the intel reader + but before swapping in the NASM and TASM writers PM } +procedure T386Instruction.CheckNonCommutativeOpcodes; +begin + if ((ops=2) and + (operands[1]^.opr.typ=OPR_REGISTER) and + (operands[2]^.opr.typ=OPR_REGISTER) and + { if the first is ST and the second is also a register + it is necessarily ST1 .. ST7 } + (operands[1]^.opr.reg=R_ST)) or + ((ops=1) and + (operands[1]^.opr.typ=OPR_REGISTER) and + (operands[1]^.opr.reg in [R_ST1..R_ST7])) or + (ops=0) then + if opcode=A_FSUBR then + opcode:=A_FSUB + else if opcode=A_FSUB then + opcode:=A_FSUBR + else if opcode=A_FDIVR then + opcode:=A_FDIV + else if opcode=A_FDIV then + opcode:=A_FDIVR + else if opcode=A_FSUBRP then + opcode:=A_FSUBP + else if opcode=A_FSUBP then + opcode:=A_FSUBRP + else if opcode=A_FDIVRP then + opcode:=A_FDIVP + else if opcode=A_FDIVP then + opcode:=A_FDIVRP; +end; + +{***************************************************************************** + opcode Adding +*****************************************************************************} + +procedure T386Instruction.ConcatInstruction(p : paasmoutput); +var + siz : topsize; + i : longint; + ai : paicpu; +begin +{ Get Opsize } + if (opsize<>S_NO) or (Ops=0) then + siz:=opsize + else + begin + if (Ops=2) and (operands[1]^.opr.typ=OPR_REGISTER) then + siz:=operands[1]^.size + else + siz:=operands[Ops]^.size; + end; + + { NASM does not support FADD without args + as alias of FADDP + and GNU AS interprets FADD without operand differently + for version 2.9.1 and 2.9.5 !! } + if (opcode=A_FADD) and (ops=0) then + begin + opcode:=A_FADDP; + message(asmr_w_fadd_to_faddp); + end; + + { I tried to convince Linus Torwald to add + code to support ENTER instruction + (when raising a stack page fault) + but he replied that ENTER is a bad instruction and + Linux does not need to support it + So I think its at least a good idea to add a warning + if someone uses this in assembler code + FPC itself does not use it at all PM } + if (opcode=A_ENTER) and (target_info.target=target_i386_linux) then + begin + message(asmr_w_enter_not_supported_by_linux); + end; + + ai:=new(paicpu,op_none(opcode,siz)); + ai^.Ops:=Ops; + for i:=1to Ops do + begin + case operands[i]^.opr.typ of + OPR_CONSTANT : + ai^.loadconst(i-1,operands[i]^.opr.val); + OPR_REGISTER: + ai^.loadreg(i-1,operands[i]^.opr.reg); + OPR_SYMBOL: + ai^.loadsymbol(i-1,operands[i]^.opr.symbol,operands[i]^.opr.symofs); + OPR_REFERENCE: + ai^.loadref(i-1,newreference(operands[i]^.opr.ref)); + end; + end; + + { Condition ? } + if condition<>C_None then + ai^.SetCondition(condition); + + { Concat the opcode or give an error } + if assigned(ai) then + p^.concat(ai) + else + Message(asmr_e_invalid_opcode_and_operand); +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.19 2000/05/17 11:08:27 pierre + + add a warning if using ENTER instruction with linux target + + Revision 1.18 2000/05/15 14:08:49 pierre + * FADD without operand translated into FADDP + + Revision 1.17 2000/05/12 21:26:22 pierre + * fix the FDIV FDIVR FSUB FSUBR and popping equivalent + simply by swapping from reverse to normal and vice-versa + when passing from one syntax to the other ! + + Revision 1.16 2000/05/10 08:55:08 pierre + * no warning nor error for pushl of segment register + + Revision 1.15 2000/05/09 21:44:28 pierre + * add .byte 066h to force correct pushw %es + * handle push es as a pushl %es + + Revision 1.14 2000/04/14 12:26:33 pierre + avoid to reset operand size of opsize is S_NO + + Revision 1.13 2000/04/04 13:48:44 pierre + + TOperand.SetCorrectSize virtual method added + to be able to change the suffix according to the instruction + (FIADD word ptr w need a s as ATT suffix + wheras FILD word ptr w need a w suffix :( ) + + Revision 1.12 2000/02/09 13:23:01 peter + * log truncated + + Revision 1.11 2000/01/07 01:14:34 peter + * updated copyright to 2000 + + Revision 1.10 1999/12/12 12:59:34 peter + * only check suffixsize for byte,word,long + + Revision 1.9 1999/08/25 12:00:05 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.8 1999/08/04 00:23:23 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/ra386att.pas b/befpc/compiler/ra386att.pas new file mode 100644 index 0000000..1c39a25 --- /dev/null +++ b/befpc/compiler/ra386att.pas @@ -0,0 +1,2226 @@ +{ + $Id: ra386att.pas,v 1.1.1.1 2001-07-23 17:16:57 memson Exp $ + Copyright (c) 1998-2000 by Carl Eric Codere and Peter Vreman + + Does the parsing for the AT&T styled inline assembler. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$N+,E+} +{$endif TP} +Unit Ra386att; +Interface + +uses + tree; + + function assemble: ptree; + + +Implementation + +Uses + globtype, + strings,cobjects,systems,verbose,globals, + files,aasm,types,symconst,symtable,scanner,cpubase, +{$ifdef NEWCG} + cgbase, +{$else} + hcodegen, +{$endif} + rautils,ra386; + +type + tasmtoken = ( + AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_INTNUM, + AS_REALNUM,AS_COMMA,AS_LPAREN, + AS_RPAREN,AS_COLON,AS_DOT,AS_PLUS,AS_MINUS,AS_STAR, + AS_SEPARATOR,AS_ID,AS_REGISTER,AS_OPCODE,AS_SLASH,AS_DOLLAR, + {------------------ Assembler directives --------------------} + AS_DB,AS_DW,AS_DD,AS_DQ,AS_GLOBAL, + AS_ALIGN,AS_BALIGN,AS_P2ALIGN,AS_ASCII, + AS_ASCIIZ,AS_LCOMM,AS_COMM,AS_SINGLE,AS_DOUBLE,AS_EXTENDED, + AS_DATA,AS_TEXT,AS_END, + {------------------ Assembler Operators --------------------} + AS_TYPE,AS_MOD,AS_SHL,AS_SHR,AS_NOT,AS_AND,AS_OR,AS_XOR,AS_NOR); + + tasmkeyword = string[10]; + +const + { These tokens should be modified accordingly to the modifications } + { in the different enumerations. } + firstdirective = AS_DB; + lastdirective = AS_END; + + _count_asmprefixes = 5; + _count_asmspecialops = 25; + _count_asmoverrides = 3; + + token2str : array[tasmtoken] of tasmkeyword=( + '','Label','LLabel','string','integer', + 'float',',','(', + ')',':','.','+','-','*', + ';','identifier','register','opcode','/','$', + '.byte','.word','.long','.quad','.globl', + '.align','.balign','.p2align','.ascii', + '.asciz','.lcomm','.comm','.single','.double','.tfloat', + '.data','.text','END', + 'TYPE','%','<<','>>','!','&','|','^','~'); + +const + newline = #10; + firsttoken : boolean = TRUE; +var + _asmsorted : boolean; + curlist : paasmoutput; + c : char; + actasmtoken : tasmtoken; + prevasmtoken : tasmtoken; + actasmpattern : string; + actopcode : tasmop; + actasmregister : tregister; + actopsize : topsize; + actcondition : tasmcond; + iasmops : Pdictionary; + iasmregs : ^reg2strtable; + + +Procedure SetupTables; +{ creates uppercased symbol tables for speed access } +var + i : tasmop; + j : tregister; + str2opentry: pstr2opentry; +Begin + { opcodes } + new(iasmops,init); + for i:=firstop to lastop do + begin + new(str2opentry,initname(upper(att_op2str[i]))); + str2opentry^.op:=i; + iasmops^.insert(str2opentry); + end; + { registers } + new(iasmregs); + for j:=firstreg to lastreg do + iasmregs^[j] := upper(att_reg2str[j]); +end; + + + {---------------------------------------------------------------------} + { Routines for the tokenizing } + {---------------------------------------------------------------------} + +function is_asmopcode(const s: string):boolean; +const + { We need first to check the long prefixes, else we get probs + with things like movsbl } + att_sizesuffixstr : array[0..9] of string[2] = ( + '','BW','BL','WL','B','W','L','S','Q','T' + ); + att_sizesuffix : array[0..9] of topsize = ( + S_NO,S_BW,S_BL,S_WL,S_B,S_W,S_L,S_FS,S_IQ,S_FX + ); + att_sizefpusuffix : array[0..9] of topsize = ( + S_NO,S_NO,S_NO,S_NO,S_NO,S_NO,S_FL,S_FS,S_IQ,S_FX + ); + att_sizefpuintsuffix : array[0..9] of topsize = ( + S_NO,S_NO,S_NO,S_NO,S_NO,S_NO,S_IL,S_IS,S_IQ,S_NO + ); +var + str2opentry: pstr2opentry; + cond : string[4]; + cnd : tasmcond; + len, + j, + sufidx : longint; +Begin + is_asmopcode:=FALSE; + + actopcode:=A_None; + actcondition:=C_None; + actopsize:=S_NO; + + { search for all possible suffixes } + for sufidx:=low(att_sizesuffixstr) to high(att_sizesuffixstr) do + begin + len:=length(s)-length(att_sizesuffixstr[sufidx]); + if copy(s,len+1,length(att_sizesuffixstr[sufidx]))=att_sizesuffixstr[sufidx] then + begin + { here we search the entire table... } + str2opentry:=nil; + if {(length(s)>0) and} (len>0) then + str2opentry:=pstr2opentry(iasmops^.search(copy(s,1,len))); + if assigned(str2opentry) then + begin + actopcode:=str2opentry^.op; + if att_needsuffix[actopcode]=attsufFPU then + actopsize:=att_sizefpusuffix[sufidx] + else if att_needsuffix[actopcode]=attsufFPUint then + actopsize:=att_sizefpuintsuffix[sufidx] + else + actopsize:=att_sizesuffix[sufidx]; + actasmtoken:=AS_OPCODE; + is_asmopcode:=TRUE; + exit; + end; + { not found, check condition opcodes } + j:=0; + while (j'' then + begin + for cnd:=low(TasmCond) to high(TasmCond) do + if Cond=Upper(cond2str[cnd]) then + begin + actopcode:=CondASmOp[j]; + if att_needsuffix[actopcode]=attsufFPU then + actopsize:=att_sizefpusuffix[sufidx] + else if att_needsuffix[actopcode]=attsufFPUint then + actopsize:=att_sizefpuintsuffix[sufidx] + else + actopsize:=att_sizesuffix[sufidx]; + actcondition:=cnd; + actasmtoken:=AS_OPCODE; + is_asmopcode:=TRUE; + exit; + end; + end; + end; + inc(j); + end; + end; + end; +end; + + +Function is_asmdirective(const s: string):boolean; +var + i : tasmtoken; + hs : string; +Begin + { GNU as is also not casesensitive with this } + hs:=lower(s); + for i:=firstdirective to lastdirective do + if hs=token2str[i] then + begin + actasmtoken:=i; + is_asmdirective:=true; + exit; + end; + is_asmdirective:=false; +end; + + +Function is_register(const s: string):boolean; +Var + i : tregister; +Begin + actasmregister:=R_NO; + for i:=firstreg to lastreg do + if s=iasmregs^[i] then + begin + actasmtoken:=AS_REGISTER; + actasmregister:=i; + is_register:=true; + exit; + end; + is_register:=false; +end; + + +Function is_locallabel(const s: string):boolean; +begin + is_locallabel:=(length(s)>=2) and (s[1]='.') and (s[2]='L'); +end; + + +Procedure GetToken; +var + len : longint; +begin + { save old token and reset new token } + prevasmtoken:=actasmtoken; + actasmtoken:=AS_NONE; + { reset } + actasmpattern:=''; + { while space and tab , continue scan... } + while c in [' ',#9] do + c:=current_scanner^.asmgetchar; + { get token pos } + if not (c in [newline,#13,'{',';']) then + current_scanner^.gettokenpos; +{ Local Label, Label, Directive, Prefix or Opcode } + if firsttoken and not(c in [newline,#13,'{',';']) then + begin + firsttoken:=FALSE; + len:=0; + { directive or local label } + if c = '.' then + begin + inc(len); + actasmpattern[len]:=c; + { Let us point to the next character } + c:=current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do + begin + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + { this is a local label... } + if (c=':') and is_locallabel(actasmpattern) then + Begin + { local variables are case sensitive } + actasmtoken:=AS_LLABEL; + c:=current_scanner^.asmgetchar; + firsttoken:=true; + exit; + end + { must be a directive } + else + Begin + { directives are case sensitive!! } + if is_asmdirective(actasmpattern) then + exit; + Message1(asmr_e_not_directive_or_local_symbol,actasmpattern); + end; + end; + { only opcodes and global labels are allowed now. } + while c in ['A'..'Z','a'..'z','0'..'9','_'] do + begin + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + { Label ? } + if c = ':' then + begin + actasmtoken:=AS_LABEL; + { let us point to the next character } + c:=current_scanner^.asmgetchar; + firsttoken:=true; + exit; + end; + { Opcode ? } + If is_asmopcode(upper(actasmpattern)) then + Begin + uppervar(actasmpattern); + exit; + end; + { End of assemblerblock ? } + if upper(actasmpattern) = 'END' then + begin + actasmtoken:=AS_END; + exit; + end; + message1(asmr_e_unknown_opcode,actasmpattern); + actasmtoken:=AS_NONE; + end + else { else firsttoken } + { Here we must handle all possible cases } + begin + case c of + '.' : { possiblities : - local label reference , such as in jmp @local1 } + { - field of object/record } + { - directive. } + begin + if (prevasmtoken in [AS_ID,AS_RPAREN]) then + begin + c:=current_scanner^.asmgetchar; + actasmtoken:=AS_DOT; + exit; + end; + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + if is_asmdirective(actasmpattern) then + exit; + { local label references and directives } + { are case sensitive } + actasmtoken:=AS_ID; + exit; + end; + + { identifier, register, prefix or directive } + '_','A'..'Z','a'..'z': + begin + len:=0; + while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do + begin + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + uppervar(actasmpattern); + { Opcode, can only be when the previous was a prefix } + If is_prefix(actopcode) and is_asmopcode(upper(actasmpattern)) then + Begin + uppervar(actasmpattern); + exit; + end; + { check for end which is a reserved word unlike the opcodes } + if actasmpattern = 'END' then + Begin + actasmtoken:=AS_END; + exit; + end; + if actasmpattern = 'TYPE' then + Begin + actasmtoken:=AS_TYPE; + exit; + end; + actasmtoken:=AS_ID; + exit; + end; + + '%' : { register or modulo } + begin + len:=1; + actasmpattern[len]:='%'; + c:=current_scanner^.asmgetchar; + { to be a register there must be a letter and not a number } + if c in ['0'..'9'] then + begin + actasmtoken:=AS_MOD; + {Message(asmr_w_modulo_not_supported);} + end + else + begin + while c in ['a'..'z','A'..'Z','0'..'9'] do + Begin + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + uppervar(actasmpattern); + if (actasmpattern = '%ST') and (c='(') then + Begin + actasmpattern:=actasmpattern+c; + c:=current_scanner^.asmgetchar; + if c in ['0'..'9'] then + actasmpattern:=actasmpattern + c + else + Message(asmr_e_invalid_fpu_register); + c:=current_scanner^.asmgetchar; + if c <> ')' then + Message(asmr_e_invalid_fpu_register) + else + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; { let us point to next character. } + end; + end; + if is_register(actasmpattern) then + exit; + Message(asmr_e_invalid_register); + actasmtoken:=AS_NONE; + end; + end; + + '1'..'9': { integer number } + begin + len:=0; + while c in ['0'..'9'] do + Begin + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + actasmpattern:=tostr(ValDecimal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + '0' : { octal,hexa,real or binary number. } + begin + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + case upcase(c) of + 'B': { binary } + Begin + c:=current_scanner^.asmgetchar; + while c in ['0','1'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern:=tostr(ValBinary(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + 'D': { real } + Begin + c:=current_scanner^.asmgetchar; + { get ridd of the 0d } + if (c in ['+','-']) then + begin + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + end + else + actasmpattern:=''; + while c in ['0'..'9'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + if c='.' then + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + while c in ['0'..'9'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + if upcase(c) = 'E' then + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + if (c in ['+','-']) then + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + while c in ['0'..'9'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + end; + actasmtoken:=AS_REALNUM; + exit; + end + else + begin + Message1(asmr_e_invalid_float_const,actasmpattern+c); + actasmtoken:=AS_NONE; + end; + end; + 'X': { hexadecimal } + Begin + c:=current_scanner^.asmgetchar; + while c in ['0'..'9','a'..'f','A'..'F'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern:=tostr(ValHexaDecimal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + '1'..'7': { octal } + begin + actasmpattern:=actasmpattern + c; + while c in ['0'..'7'] do + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern:=tostr(ValOctal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + else { octal number zero value...} + Begin + actasmpattern:=tostr(ValOctal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + end; { end case } + end; + + '&' : + begin + c:=current_scanner^.asmgetchar; + actasmtoken:=AS_AND; + end; + + '''' : { char } + begin + actasmpattern:=''; + repeat + c:=current_scanner^.asmgetchar; + case c of + '\' : + begin + { copy also the next char so \" is parsed correctly } + c:=current_scanner^.asmgetchar; + actasmpattern:=actasmpattern+c; + end; + '''' : + begin + c:=current_scanner^.asmgetchar; + break; + end; + newline: + Message(scan_f_string_exceeds_line); + else + actasmpattern:=actasmpattern+c; + end; + until false; + actasmpattern:=EscapeToPascal(actasmpattern); + actasmtoken:=AS_STRING; + exit; + end; + + '"' : { string } + begin + actasmpattern:=''; + repeat + c:=current_scanner^.asmgetchar; + case c of + '\' : + begin + { copy also the next char so \" is parsed correctly } + c:=current_scanner^.asmgetchar; + actasmpattern:=actasmpattern+c; + end; + '"' : + begin + c:=current_scanner^.asmgetchar; + break; + end; + newline: + Message(scan_f_string_exceeds_line); + else + actasmpattern:=actasmpattern+c; + end; + until false; + actasmpattern:=EscapeToPascal(actasmpattern); + actasmtoken:=AS_STRING; + exit; + end; + + '$' : + begin + actasmtoken:=AS_DOLLAR; + c:=current_scanner^.asmgetchar; + exit; + end; + + ',' : + begin + actasmtoken:=AS_COMMA; + c:=current_scanner^.asmgetchar; + exit; + end; + + '<' : + begin + actasmtoken:=AS_SHL; + c:=current_scanner^.asmgetchar; + if c = '<' then + c:=current_scanner^.asmgetchar; + exit; + end; + + '>' : + begin + actasmtoken:=AS_SHL; + c:=current_scanner^.asmgetchar; + if c = '>' then + c:=current_scanner^.asmgetchar; + exit; + end; + + '|' : + begin + actasmtoken:=AS_OR; + c:=current_scanner^.asmgetchar; + exit; + end; + + '^' : + begin + actasmtoken:=AS_XOR; + c:=current_scanner^.asmgetchar; + exit; + end; + + '!' : + begin + Message(asmr_e_nor_not_supported); + c:=current_scanner^.asmgetchar; + actasmtoken:=AS_NONE; + exit; + end; + + '(' : + begin + actasmtoken:=AS_LPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + + ')' : + begin + actasmtoken:=AS_RPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + + ':' : + begin + actasmtoken:=AS_COLON; + c:=current_scanner^.asmgetchar; + exit; + end; + + '+' : + begin + actasmtoken:=AS_PLUS; + c:=current_scanner^.asmgetchar; + exit; + end; + + '-' : + begin + actasmtoken:=AS_MINUS; + c:=current_scanner^.asmgetchar; + exit; + end; + + '*' : + begin + actasmtoken:=AS_STAR; + c:=current_scanner^.asmgetchar; + exit; + end; + + '/' : + begin + c:=current_scanner^.asmgetchar; + actasmtoken:=AS_SLASH; + exit; + end; + + '{',#13,newline,';' : + begin + { the comment is read by asmgetchar } + c:=current_scanner^.asmgetchar; + firsttoken:=TRUE; + actasmtoken:=AS_SEPARATOR; + exit; + end; + + else + current_scanner^.illegal_char(c); + end; + end; +end; + + +function consume(t : tasmtoken):boolean; +begin + Consume:=true; + if t<>actasmtoken then + begin + Message2(scan_f_syn_expected,token2str[t],token2str[actasmtoken]); + Consume:=false; + end; + repeat + gettoken; + until actasmtoken<>AS_NONE; +end; + + +procedure RecoverConsume(allowcomma:boolean); +begin + While not (actasmtoken in [AS_SEPARATOR,AS_END]) do + begin + if allowcomma and (actasmtoken=AS_COMMA) then + break; + Consume(actasmtoken); + end; +end; + + +{***************************************************************************** + Parsing Helpers +*****************************************************************************} + +Procedure BuildRecordOffsetSize(const expr: string;var offset:longint;var size:longint); +{ Description: This routine builds up a record offset after a AS_DOT } +{ token is encountered. } +{ On entry actasmtoken should be equal to AS_DOT } +var + s : string; +Begin + offset:=0; + size:=0; + s:=expr; + while (actasmtoken=AS_DOT) do + begin + Consume(AS_DOT); + if actasmtoken=AS_ID then + s:=s+'.'+actasmpattern; + if not Consume(AS_ID) then + begin + RecoverConsume(true); + break; + end; + end; + if not GetRecordOffsetSize(s,offset,size) then + Message(asmr_e_building_record_offset); +end; + + +Procedure BuildConstSymbolExpression(allowref,betweenbracket,needofs:boolean;var value:longint;var asmsym:string); +var + hs,tempstr,expr : string; + parenlevel,l,k : longint; + errorflag : boolean; + prevtok : tasmtoken; + sym : psym; + hl : PAsmLabel; +Begin + asmsym:=''; + value:=0; + errorflag:=FALSE; + tempstr:=''; + expr:=''; + parenlevel:=0; + Repeat + Case actasmtoken of + AS_LPAREN: + Begin + { Exit if ref? } + if allowref and (prevasmtoken in [AS_INTNUM,AS_ID]) then + break; + Consume(AS_LPAREN); + expr:=expr + '('; + inc(parenlevel); + end; + AS_RPAREN: + Begin + { end of ref ? } + if (parenlevel=0) and betweenbracket then + break; + Consume(AS_RPAREN); + expr:=expr + ')'; + dec(parenlevel); + end; + AS_SHL: + Begin + Consume(AS_SHL); + expr:=expr + '<'; + end; + AS_SHR: + Begin + Consume(AS_SHR); + expr:=expr + '>'; + end; + AS_SLASH: + Begin + Consume(AS_SLASH); + expr:=expr + '/'; + end; + AS_MOD: + Begin + Consume(AS_MOD); + expr:=expr + '%'; + end; + AS_STAR: + Begin + Consume(AS_STAR); + expr:=expr + '*'; + end; + AS_PLUS: + Begin + Consume(AS_PLUS); + expr:=expr + '+'; + end; + AS_MINUS: + Begin + Consume(AS_MINUS); + expr:=expr + '-'; + end; + AS_AND: + Begin + Consume(AS_AND); + expr:=expr + '&'; + end; + AS_NOT: + Begin + Consume(AS_NOT); + expr:=expr + '~'; + end; + AS_XOR: + Begin + Consume(AS_XOR); + expr:=expr + '^'; + end; + AS_OR: + Begin + Consume(AS_OR); + expr:=expr + '|'; + end; + AS_INTNUM: + Begin + expr:=expr + actasmpattern; + Consume(AS_INTNUM); + end; + AS_DOLLAR: + begin + Consume(AS_DOLLAR); + if actasmtoken<>AS_ID then + Message(asmr_e_dollar_without_identifier); + end; + AS_STRING: + Begin + l:=0; + case Length(actasmpattern) of + 1 : + l:=ord(actasmpattern[1]); + 2 : + l:=ord(actasmpattern[2]) + ord(actasmpattern[1]) shl 8; + 3 : + l:=ord(actasmpattern[3]) + + Ord(actasmpattern[2]) shl 8 + ord(actasmpattern[1]) shl 16; + 4 : + l:=ord(actasmpattern[4]) + ord(actasmpattern[3]) shl 8 + + Ord(actasmpattern[2]) shl 16 + ord(actasmpattern[1]) shl 24; + else + Message1(asmr_e_invalid_string_as_opcode_operand,actasmpattern); + end; + str(l, tempstr); + expr:=expr + tempstr; + Consume(AS_STRING); + end; + AS_TYPE: + begin + l:=0; + Consume(AS_TYPE); + if actasmtoken<>AS_ID then + Message(asmr_e_type_without_identifier) + else + begin + tempstr:=actasmpattern; + Consume(AS_ID); + if actasmtoken=AS_DOT then + BuildRecordOffsetSize(tempstr,k,l) + else + begin + getsym(tempstr,false); + if assigned(srsym) then + begin + case srsym^.typ of + varsym : + l:=pvarsym(srsym)^.getsize; + typedconstsym : + l:=ptypedconstsym(srsym)^.getsize; + typesym : + l:=ptypesym(srsym)^.restype.def^.size; + else + Message(asmr_e_wrong_sym_type); + end; + end + else + Message1(sym_e_unknown_id,tempstr); + end; + end; + str(l, tempstr); + expr:=expr + tempstr; + end; + AS_ID: + Begin + hs:=''; + tempstr:=actasmpattern; + prevtok:=prevasmtoken; + consume(AS_ID); + if SearchIConstant(tempstr,l) then + begin + str(l, tempstr); + expr:=expr + tempstr; + end + else + begin + if is_locallabel(tempstr) then + begin + CreateLocalLabel(tempstr,hl,false); + hs:=hl^.name + end + else + if SearchLabel(tempstr,hl,false) then + hs:=hl^.name + else + begin + getsym(tempstr,false); + sym:=srsym; + if assigned(sym) then + begin + case srsym^.typ of + varsym : + begin + if sym^.owner^.symtabletype in [localsymtable,parasymtable] then + Message(asmr_e_no_local_or_para_allowed); + hs:=pvarsym(srsym)^.mangledname; + end; + typedconstsym : + hs:=ptypedconstsym(srsym)^.mangledname; + procsym : + hs:=pprocsym(srsym)^.mangledname; + typesym : + begin + if not(ptypesym(srsym)^.restype.def^.deftype in [recorddef,objectdef]) then + Message(asmr_e_wrong_sym_type); + end; + else + Message(asmr_e_wrong_sym_type); + end; + end + else + Message1(sym_e_unknown_id,tempstr); + end; + { symbol found? } + if hs<>'' then + begin + if needofs and (prevtok<>AS_DOLLAR) then + Message(asmr_e_need_dollar); + if asmsym='' then + asmsym:=hs + else + Message(asmr_e_cant_have_multiple_relocatable_symbols); + if (expr='') or (expr[length(expr)]='+') then + begin + { don't remove the + if there could be a record field } + if actasmtoken<>AS_DOT then + delete(expr,length(expr),1); + end + else + Message(asmr_e_only_add_relocatable_symbol); + end; + if actasmtoken=AS_DOT then + begin + BuildRecordOffsetSize(tempstr,l,k); + str(l, tempstr); + expr:=expr + tempstr; + end + else + begin + if (expr='') or (expr[length(expr)] in ['+','-','/','*']) then + delete(expr,length(expr),1); + end; + end; + { check if there are wrong operator used like / or mod etc. } + if (hs<>'') and not(actasmtoken in [AS_MINUS,AS_PLUS,AS_COMMA,AS_SEPARATOR,AS_LPAREN,AS_END]) then + Message(asmr_e_only_add_relocatable_symbol); + end; + AS_END, + AS_SEPARATOR, + AS_COMMA: + Begin + break; + end; + else + Begin + { write error only once. } + if not errorflag then + Message(asmr_e_invalid_constant_expression); + { consume tokens until we find COMMA or SEPARATOR } + Consume(actasmtoken); + errorflag:=TRUE; + end; + end; + Until false; + { calculate expression } + if not ErrorFlag then + value:=CalculateExpression(expr) + else + value:=0; +end; + + +Function BuildConstExpression(allowref,betweenbracket:boolean): longint; +var + l : longint; + hs : string; +begin + BuildConstSymbolExpression(allowref,betweenbracket,false,l,hs); + if hs<>'' then + Message(asmr_e_relocatable_symbol_not_allowed); + BuildConstExpression:=l; +end; + + +{**************************************************************************** + T386ATTOperand +****************************************************************************} + +type + P386ATTOperand=^T386ATTOperand; + T386ATTOperand=object(T386Operand) + Procedure BuildOperand;virtual; + private + Procedure BuildReference; + Procedure BuildConstant; + end; + + +Procedure T386ATTOperand.BuildReference; + + procedure Consume_RParen; + begin + if actasmtoken <> AS_RPAREN then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + end + else + begin + Consume(AS_RPAREN); + if not (actasmtoken in [AS_COMMA,AS_SEPARATOR,AS_END]) then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + end; + end; + end; + + procedure Consume_Scale; + var + l : longint; + begin + { we have to process the scaling } + l:=BuildConstExpression(false,true); + if ((l = 2) or (l = 4) or (l = 8) or (l = 1)) then + opr.ref.scalefactor:=l + else + Begin + Message(asmr_e_wrong_scale_factor); + opr.ref.scalefactor:=0; + end; + end; + +Begin + Consume(AS_LPAREN); + Case actasmtoken of + AS_INTNUM, + AS_MINUS, + AS_PLUS: { absolute offset, such as fs:(0x046c) } + Begin + { offset(offset) is invalid } + If opr.Ref.Offset <> 0 Then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + End + Else + Begin + opr.Ref.Offset:=BuildConstExpression(false,true); + Consume_RParen; + end; + exit; + End; + AS_REGISTER: { (reg ... } + Begin + { Check if there is already a base (mostly ebp,esp) than this is + not allowed,becuase it will give crashing code } + if opr.ref.base<>R_NO then + Message(asmr_e_cannot_index_relative_var); + opr.ref.base:=actasmregister; + Consume(AS_REGISTER); + { can either be a register or a right parenthesis } + { (reg) } + if actasmtoken=AS_RPAREN then + Begin + Consume_RParen; + exit; + end; + { (reg,reg .. } + Consume(AS_COMMA); + if actasmtoken=AS_REGISTER then + Begin + opr.ref.index:=actasmregister; + Consume(AS_REGISTER); + { check for scaling ... } + case actasmtoken of + AS_RPAREN: + Begin + Consume_RParen; + exit; + end; + AS_COMMA: + Begin + Consume(AS_COMMA); + Consume_Scale; + Consume_RParen; + end; + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; { end case } + end + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; {end case } + AS_COMMA: { (, ... can either be scaling, or index } + Begin + Consume(AS_COMMA); + { Index } + if (actasmtoken=AS_REGISTER) then + Begin + opr.ref.index:=actasmregister; + Consume(AS_REGISTER); + { check for scaling ... } + case actasmtoken of + AS_RPAREN: + Begin + Consume_RParen; + exit; + end; + AS_COMMA: + Begin + Consume(AS_COMMA); + Consume_Scale; + Consume_RParen; + end; + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; {end case } + end + { Scaling } + else + Begin + Consume_Scale; + Consume_RParen; + exit; + end; + end; + + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; +end; + + +Procedure T386ATTOperand.BuildConstant; +var + l : longint; + tempstr : string; +begin + BuildConstSymbolExpression(false,false,true,l,tempstr); + if tempstr<>'' then + begin + opr.typ:=OPR_SYMBOL; + opr.symofs:=l; + opr.symbol:=newasmsymbol(tempstr); + end + else + begin + opr.typ:=OPR_CONSTANT; + opr.val:=l; + end; +end; + + +Procedure T386ATTOperand.BuildOperand; +var + tempstr,tempstr2, + expr : string; + l,k : longint; + + procedure AddLabelOperand(hl:pasmlabel); + begin + if not(actasmtoken in [AS_PLUS,AS_MINUS,AS_LPAREN]) and + is_calljmp(actopcode) then + begin + opr.typ:=OPR_SYMBOL; + opr.symbol:=hl; + end + else + begin + InitRef; + opr.ref.symbol:=hl; + end; + end; + + procedure MaybeRecordOffset; + var + hasdot : boolean; + l, + toffset, + tsize : longint; + begin + if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then + exit; + l:=0; + hasdot:=(actasmtoken=AS_DOT); + if hasdot then + begin + if expr<>'' then + begin + BuildRecordOffsetSize(expr,toffset,tsize); + inc(l,toffset); + SetSize(tsize,true); + end; + end; + if actasmtoken in [AS_PLUS,AS_MINUS] then + inc(l,BuildConstExpression(true,false)); + if opr.typ=OPR_REFERENCE then + begin + if hasdot and (not hastype) and (opr.ref.options=ref_parafixup) then + Message(asmr_e_cannot_access_field_directly_for_parameters); + inc(opr.ref.offset,l) + end + else + inc(opr.val,l); + end; + + function MaybeBuildReference:boolean; + { Try to create a reference, if not a reference is found then false + is returned } + begin + MaybeBuildReference:=true; + case actasmtoken of + AS_INTNUM, + AS_MINUS, + AS_PLUS: + Begin + opr.ref.offset:=BuildConstExpression(True,False); + if actasmtoken<>AS_LPAREN then + Message(asmr_e_invalid_reference_syntax) + else + BuildReference; + end; + AS_LPAREN: + BuildReference; + AS_ID: { only a variable is allowed ... } + Begin + tempstr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(tempstr) then + begin + hastype:=true; + Consume(AS_LPAREN); + tempstr2:=actasmpattern; + Consume(AS_ID); + Consume(AS_RPAREN); + if not SetupVar(tempstr2,false) then + Message1(sym_e_unknown_id,tempstr2); + end + else + if not SetupVar(tempstr,false) then + Message1(sym_e_unknown_id,tempstr); + { record.field ? } + if actasmtoken=AS_DOT then + begin + BuildRecordOffsetSize(tempstr,l,k); + inc(opr.ref.offset,l); + end; + case actasmtoken of + AS_END, + AS_SEPARATOR, + AS_COMMA: ; + AS_LPAREN: BuildReference; + else + Begin + Message(asmr_e_invalid_reference_syntax); + Consume(actasmtoken); + end; + end; {end case } + end; + else + MaybeBuildReference:=false; + end; { end case } + end; + +var + tempreg : tregister; + hl : PAsmLabel; +Begin + expr:=''; + case actasmtoken of + AS_LPAREN: { Memory reference or constant expression } + Begin + InitRef; + BuildReference; + end; + + AS_DOLLAR: { Constant expression } + Begin + Consume(AS_DOLLAR); + BuildConstant; + end; + + AS_INTNUM, + AS_MINUS, + AS_PLUS: + Begin + { Constant memory offset } + { This must absolutely be followed by ( } + InitRef; + opr.ref.offset:=BuildConstExpression(True,False); + if actasmtoken<>AS_LPAREN then + Message(asmr_e_invalid_reference_syntax) + else + BuildReference; + end; + + AS_STAR: { Call from memory address } + Begin + Consume(AS_STAR); + if actasmtoken=AS_REGISTER then + begin + opr.typ:=OPR_REGISTER; + opr.reg:=actasmregister; + size:=reg_2_opsize[actasmregister]; + Consume(AS_REGISTER); + end + else + begin + InitRef; + if not MaybeBuildReference then + Message(asmr_e_syn_operand); + end; + { this is only allowed for call's and jmp's } + if not is_calljmp(actopcode) then + Message(asmr_e_syn_operand); + end; + + AS_ID: { A constant expression, or a Variable ref. } + Begin + { Local Label ? } + if is_locallabel(actasmpattern) then + begin + CreateLocalLabel(actasmpattern,hl,false); + Consume(AS_ID); + AddLabelOperand(hl); + end + else + { Check for label } + if SearchLabel(actasmpattern,hl,false) then + begin + Consume(AS_ID); + AddLabelOperand(hl); + end + else + { probably a variable or normal expression } + { or a procedure (such as in CALL ID) } + Begin + { is it a constant ? } + if SearchIConstant(actasmpattern,l) then + Begin + if not (opr.typ in [OPR_NONE,OPR_CONSTANT]) then + Message(asmr_e_invalid_operand_type); + BuildConstant; + end + else + begin + InitRef; + expr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(expr) then + begin + hastype:=true; + Consume(AS_LPAREN); + tempstr:=actasmpattern; + Consume(AS_ID); + Consume(AS_RPAREN); + if SetupVar(tempstr,false) then + begin + MaybeRecordOffset; + { add a constant expression? } + if (actasmtoken=AS_PLUS) then + begin + l:=BuildConstExpression(true,false); + if opr.typ=OPR_CONSTANT then + inc(opr.val,l) + else + inc(opr.ref.offset,l); + end + end + else + Message1(sym_e_unknown_id,tempstr); + end + else + begin + if SetupVar(expr,false) then + begin + MaybeRecordOffset; + { add a constant expression? } + if (actasmtoken=AS_PLUS) then + begin + l:=BuildConstExpression(true,false); + if opr.typ=OPR_CONSTANT then + inc(opr.val,l) + else + inc(opr.ref.offset,l); + end + end + else + Begin + { look for special symbols ... } + if expr = '__RESULT' then + SetUpResult + else + if expr = '__SELF' then + SetupSelf + else + if expr = '__OLDEBP' then + SetupOldEBP + else + { check for direct symbolic names } + { only if compiling the system unit } + if (cs_compilesystem in aktmoduleswitches) then + begin + if not SetupDirectVar(expr) then + Begin + { not found, finally ... add it anyways ... } + Message1(asmr_w_id_supposed_external,expr); + opr.ref.symbol:=newasmsymbol(expr); + end; + end + else + Message1(sym_e_unknown_id,expr); + end; + end; + end; + end; + { Do we have a indexing reference, then parse it also } + if actasmtoken=AS_LPAREN then + begin + if (opr.typ=OPR_CONSTANT) then + begin + l:=opr.val; + opr.typ:=OPR_REFERENCE; + reset_reference(opr.Ref); + opr.Ref.Offset:=l; + end; + BuildReference; + end; + end; + + AS_REGISTER: { Register, a variable reference or a constant reference } + Begin + { save the type of register used. } + tempreg:=actasmregister; + Consume(AS_REGISTER); + if actasmtoken = AS_COLON then + Begin + Consume(AS_COLON); + InitRef; + opr.ref.segment:=tempreg; + { This must absolutely be followed by a reference } + if not MaybeBuildReference then + Begin + Message(asmr_e_invalid_seg_override); + Consume(actasmtoken); + end; + end + { Simple register } + else if (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then + Begin + if not (opr.typ in [OPR_NONE,OPR_REGISTER]) then + Message(asmr_e_invalid_operand_type); + opr.typ:=OPR_REGISTER; + opr.reg:=tempreg; + size:=reg_2_opsize[tempreg]; + end + else + Message(asmr_e_syn_operand); + end; + AS_END, + AS_SEPARATOR, + AS_COMMA: ; + else + Begin + Message(asmr_e_syn_operand); + Consume(actasmtoken); + end; + end; { end case } +end; + +{***************************************************************************** + T386ATTInstruction +*****************************************************************************} + +type + P386AttInstruction=^T386AttInstruction; + T386AttInstruction=object(T386Instruction) + procedure InitOperands;virtual; + procedure BuildOpcode;virtual; + end; + +procedure T386AttInstruction.InitOperands; +var + i : longint; +begin + for i:=1to 3 do + Operands[i]:=new(P386AttOperand,Init); +end; + + +Procedure T386AttInstruction.BuildOpCode; +var + operandnum : longint; + PrefixOp,OverrideOp: tasmop; +Begin + PrefixOp:=A_None; + OverrideOp:=A_None; + { prefix seg opcode / prefix opcode } + repeat + if is_prefix(actopcode) then + begin + PrefixOp:=ActOpcode; + opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + ConcatInstruction(curlist); + Consume(AS_OPCODE); + end + else + if is_override(actopcode) then + begin + OverrideOp:=ActOpcode; + opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + ConcatInstruction(curlist); + Consume(AS_OPCODE); + end + else + break; + { allow for newline as in gas styled syntax } + while actasmtoken=AS_SEPARATOR do + Consume(AS_SEPARATOR); + until (actasmtoken<>AS_OPCODE); + { opcode } + if (actasmtoken <> AS_OPCODE) then + Begin + Message(asmr_e_invalid_or_missing_opcode); + RecoverConsume(true); + exit; + end; + { Fill the instr object with the current state } + Opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + { Valid combination of prefix/override and instruction ? } + if (prefixop<>A_NONE) and (NOT CheckPrefix(PrefixOp,actopcode)) then + Message1(asmr_e_invalid_prefix_and_opcode,actasmpattern); + if (overrideop<>A_NONE) and (NOT CheckOverride(OverrideOp,ActOpcode)) then + Message1(asmr_e_invalid_override_and_opcode,actasmpattern); + { We are reading operands, so opcode will be an AS_ID } + operandnum:=1; + Consume(AS_OPCODE); + { Zero operand opcode ? } + if actasmtoken in [AS_SEPARATOR,AS_END] then + begin + operandnum:=0; + exit; + end; +{ Read the operands } + repeat + case actasmtoken of + AS_COMMA: { Operand delimiter } + Begin + if operandnum > MaxOperands then + Message(asmr_e_too_many_operands) + else + Inc(operandnum); + Consume(AS_COMMA); + end; + AS_SEPARATOR, + AS_END : { End of asm operands for this opcode } + begin + break; + end; + else + Operands[operandnum]^.BuildOperand; + end; { end case } + until false; + Ops:=operandnum; +end; + + + +Procedure BuildConstant(maxvalue: longint); +var + asmsym, + expr: string; + value : longint; +Begin + Repeat + Case actasmtoken of + AS_STRING: + Begin + expr:=actasmpattern; + if length(expr) > 1 then + Message(asmr_e_string_not_allowed_as_const); + Consume(AS_STRING); + Case actasmtoken of + AS_COMMA: Consume(AS_COMMA); + AS_END, + AS_SEPARATOR: ; + else + Message(asmr_e_invalid_string_expression); + end; { end case } + ConcatString(curlist,expr); + end; + AS_INTNUM, + AS_PLUS, + AS_MINUS, + AS_LPAREN, + AS_NOT, + AS_ID : + Begin + BuildConstSymbolExpression(false,false,false,value,asmsym); + if asmsym<>'' then + begin + if maxvalue<>longint($ffffffff) then + Message(asmr_w_32bit_const_for_address); + ConcatConstSymbol(curlist,asmsym,value) + end + else + ConcatConstant(curlist,value,maxvalue); + end; + AS_COMMA: + Consume(AS_COMMA); + AS_END, + AS_SEPARATOR: + break; + else + begin + Message(asmr_e_syn_constant); + RecoverConsume(false); + end + end; { end case } + Until false; +end; + + +Procedure BuildRealConstant(typ : tfloattype); +var + expr : string; + r : bestreal; + code : integer; + negativ : boolean; + errorflag: boolean; +Begin + errorflag:=FALSE; + Repeat + negativ:=false; + expr:=''; + if actasmtoken=AS_PLUS then + Consume(AS_PLUS) + else + if actasmtoken=AS_MINUS then + begin + negativ:=true; + consume(AS_MINUS); + end; + Case actasmtoken of + AS_INTNUM: + Begin + expr:=actasmpattern; + Consume(AS_INTNUM); + if negativ then + expr:='-'+expr; + val(expr,r,code); + if code<>0 then + Begin + r:=0; + Message(asmr_e_invalid_float_expr); + End; + ConcatRealConstant(curlist,r,typ); + end; + AS_REALNUM: + Begin + expr:=actasmpattern; + Consume(AS_REALNUM); + { in ATT syntax you have 0d in front of the real } + { should this be forced ? yes i think so, as to } + { conform to gas as much as possible. } + if (expr[1]='0') and (upper(expr[2])='D') then + Delete(expr,1,2); + if negativ then + expr:='-'+expr; + val(expr,r,code); + if code<>0 then + Begin + r:=0; + Message(asmr_e_invalid_float_expr); + End; + ConcatRealConstant(curlist,r,typ); + end; + AS_COMMA: + begin + Consume(AS_COMMA); + end; + AS_END, + AS_SEPARATOR: + begin + break; + end; + else + Begin + Consume(actasmtoken); + if not errorflag then + Message(asmr_e_invalid_float_expr); + errorflag:=TRUE; + end; + end; + Until false; +end; + + +Procedure BuildStringConstant(asciiz: boolean); +var + expr: string; + errorflag : boolean; +Begin + errorflag:=FALSE; + Repeat + Case actasmtoken of + AS_STRING: + Begin + expr:=actasmpattern; + if asciiz then + expr:=expr+#0; + ConcatPasString(curlist,expr); + Consume(AS_STRING); + end; + AS_COMMA: + begin + Consume(AS_COMMA); + end; + AS_END, + AS_SEPARATOR: + begin + break; + end; + else + Begin + Consume(actasmtoken); + if not errorflag then + Message(asmr_e_invalid_string_expression); + errorflag:=TRUE; + end; + end; + Until false; +end; + + +Function Assemble: Ptree; +Var + hl : PAsmLabel; + commname : string; + lastsec : tsection; + l1,l2 : longint; + instr : T386ATTInstruction; +Begin + Message1(asmr_d_start_reading,'AT&T'); + firsttoken:=TRUE; + if assigned(procinfo^.returntype.def) and + (is_fpu(procinfo^.returntype.def) or + ret_in_acc(procinfo^.returntype.def)) then + procinfo^.funcret_state:=vs_assigned; + { sets up all opcode and register tables in uppercase } + if not _asmsorted then + Begin + SetupTables; + _asmsorted:=TRUE; + end; + curlist:=new(paasmoutput,init); + lastsec:=sec_code; + { setup label linked list } + new(LocalLabelList,Init); + { start tokenizer } + c:=current_scanner^.asmgetchar; + gettoken; + { main loop } + repeat + case actasmtoken of + AS_LLABEL: + Begin + if CreateLocalLabel(actasmpattern,hl,true) then + ConcatLabel(curlist,hl); + Consume(AS_LLABEL); + end; + + AS_LABEL: + Begin + if SearchLabel(upper(actasmpattern),hl,true) then + ConcatLabel(curlist,hl) + else + Message1(asmr_e_unknown_label_identifier,actasmpattern); + Consume(AS_LABEL); + end; + + AS_DW: + Begin + Consume(AS_DW); + BuildConstant($ffff); + end; + + AS_DATA: + Begin + curlist^.Concat(new(pai_section,init(sec_data))); + lastsec:=sec_data; + Consume(AS_DATA); + end; + + AS_TEXT: + Begin + curlist^.Concat(new(pai_section,init(sec_code))); + lastsec:=sec_code; + Consume(AS_TEXT); + end; + + AS_DB: + Begin + Consume(AS_DB); + BuildConstant($ff); + end; + + AS_DD: + Begin + Consume(AS_DD); + BuildConstant($ffffffff); + end; + + AS_DQ: + Begin + Consume(AS_DQ); + BuildRealConstant(s64comp); + end; + + AS_SINGLE: + Begin + Consume(AS_SINGLE); + BuildRealConstant(s32real); + end; + + AS_DOUBLE: + Begin + Consume(AS_DOUBLE); + BuildRealConstant(s64real); + end; + + AS_EXTENDED: + Begin + Consume(AS_EXTENDED); + BuildRealConstant(s80real); + end; + + AS_GLOBAL: + Begin + Consume(AS_GLOBAL); + if actasmtoken=AS_ID then + ConcatPublic(curlist,actasmpattern); + Consume(AS_ID); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + + AS_ALIGN: + Begin + Consume(AS_ALIGN); + l1:=BuildConstExpression(false,false); + if (target_info.target in [target_i386_GO32V1,target_i386_GO32V2]) then + begin + l2:=1; + if (l1>=0) and (l1<=16) then + while (l1>0) do + begin + l2:=2*l2; + dec(l1); + end; + l1:=l2; + end; + ConcatAlign(curlist,l1); + Message(asmr_n_align_is_target_specific); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + + AS_BALIGN: + Begin + Consume(AS_BALIGN); + ConcatAlign(curlist,BuildConstExpression(false,false)); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + + AS_P2ALIGN: + Begin + Consume(AS_P2ALIGN); + l1:=BuildConstExpression(false,false); + l2:=1; + if (l1>=0) and (l1<=16) then + while (l1>0) do + begin + l2:=2*l2; + dec(l1); + end; + l1:=l2; + ConcatAlign(curlist,l1); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + + AS_ASCIIZ: + Begin + Consume(AS_ASCIIZ); + BuildStringConstant(TRUE); + end; + + AS_ASCII: + Begin + Consume(AS_ASCII); + BuildStringConstant(FALSE); + end; + + AS_LCOMM: + Begin + Consume(AS_LCOMM); + commname:=actasmpattern; + Consume(AS_ID); + Consume(AS_COMMA); + ConcatLocalBss(commname,BuildConstExpression(false,false)); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + + AS_COMM: + Begin + Consume(AS_COMM); + commname:=actasmpattern; + Consume(AS_ID); + Consume(AS_COMMA); + ConcatGlobalBss(commname,BuildConstExpression(false,false)); + if actasmtoken<>AS_SEPARATOR then + Consume(AS_SEPARATOR); + end; + AS_OPCODE: + Begin + instr.init; + instr.BuildOpcode; + instr.AddReferenceSizes; + instr.SetInstructionOpsize; + instr.CheckOperandSizes; + instr.ConcatInstruction(curlist); + instr.done; + end; + + AS_SEPARATOR: + Begin + Consume(AS_SEPARATOR); + end; + + AS_END: + begin + break; { end assembly block } + end; + + else + Begin + Message(asmr_e_syntax_error); + RecoverConsume(false); + end; + end; + until false; + { Check LocalLabelList } + LocalLabelList^.CheckEmitted; + dispose(LocalLabelList,Done); + { are we back in the code section? } + if lastsec<>sec_code then + begin + Message(asmr_w_assembler_code_not_returned_to_text); + curlist^.Concat(new(pai_section,init(sec_code))); + end; + { Return the list in an asmnode } + assemble:=genasmnode(curlist); + Message1(asmr_d_finish_reading,'AT&T'); +end; + + +{***************************************************************************** + Initialize +*****************************************************************************} + +var + old_exit : pointer; + +procedure ra386att_exit;{$ifndef FPC}far;{$endif} +begin + if assigned(iasmops) then + dispose(iasmops,done); + if assigned(iasmregs) then + dispose(iasmregs); + exitproc:=old_exit; +end; + + +begin + old_exit:=exitproc; + exitproc:=@ra386att_exit; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.85 2000/06/18 19:09:31 peter + * fixed + record.field expressions + + Revision 1.84 2000/06/18 18:07:06 peter + * use new illegal_char method + + Revision 1.83 2000/06/15 18:07:07 peter + * fix constant parsing which gave an error when constants were used + + Revision 1.82 2000/06/14 19:02:41 peter + * fixed TYPE with records and fields + * added TYPE support for ATT reader else it wouldn't be possible to + get the size of a type/variable + + Revision 1.81 2000/05/26 18:23:11 peter + * fixed % parsing and added modulo support + * changed some evaulator errors to more generic illegal expresion + + Revision 1.80 2000/05/23 20:36:28 peter + + typecasting support for variables, but be carefull as word,byte can't + be used because they are reserved assembler keywords + + Revision 1.79 2000/05/18 17:05:16 peter + * fixed size of const parameters in asm readers + + Revision 1.78 2000/05/12 21:57:02 pierre + + use of a dictionary object + for faster opcode searching in assembler readers + implemented by Kovacs Attila Zoltan + + Revision 1.77 2000/05/11 09:56:21 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.76 2000/05/09 11:56:25 pierre + * Issue an error if opcode is not found + + Revision 1.75 2000/05/08 13:23:03 peter + * fixed reference parsing + + Revision 1.74 2000/04/29 12:51:33 peter + * fixed offset support intel reader, the gotoffset variable was not + always reset + * moved check for local/para to be only used for varsym + + Revision 1.73 2000/04/04 13:48:44 pierre + + TOperand.SetCorrectSize virtual method added + to be able to change the suffix according to the instruction + (FIADD word ptr w need a s as ATT suffix + wheras FILD word ptr w need a w suffix :( ) + + Revision 1.72 2000/03/15 23:10:01 pierre + * fix for bug 848 (that still genrated wrong code) + + better testing for variables used in assembler + (gives an error if variable is not directly reachable !) + + Revision 1.71 2000/02/09 13:23:01 peter + * log truncated + + Revision 1.70 2000/01/28 09:41:39 peter + * fixed fpu suffix parsing for att reader + + Revision 1.69 2000/01/21 10:10:25 daniel + * should work on linux also + + Revision 1.68 2000/01/21 00:46:47 peter + * ifdef'd my previous fix as it broken a make cycle sometimes + + Revision 1.67 2000/01/20 23:35:01 peter + * fixed fldl where suffix would get S_L instead of S_FL + + Revision 1.66 2000/01/07 01:14:34 peter + * updated copyright to 2000 + + Revision 1.65 1999/12/12 12:57:59 peter + * allow para+offset + + Revision 1.64 1999/11/30 10:40:52 peter + + ttype, tsymlist + + Revision 1.63 1999/11/17 17:05:03 pierre + * Notes/hints changes + + Revision 1.62 1999/11/09 23:06:46 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.61 1999/11/06 14:34:23 peter + * truncated log to 20 revs + + Revision 1.60 1999/10/01 07:59:20 peter + * fixed object field parsing + + Revision 1.59 1999/09/27 23:44:57 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.58 1999/09/08 16:04:01 peter + * better support for object fields and more error checks for + field accesses which create buggy code + + Revision 1.57 1999/08/05 16:53:08 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.56 1999/08/04 00:23:25 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.55 1999/08/03 22:03:09 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.54 1999/07/24 11:17:12 peter + * suffix parsing for at&t fixed for things like movsbl + * string constants are now handle correctly and also allowed in + constant expressions + +} diff --git a/befpc/compiler/ra386dir.pas b/befpc/compiler/ra386dir.pas new file mode 100644 index 0000000..ec6c600 --- /dev/null +++ b/befpc/compiler/ra386dir.pas @@ -0,0 +1,330 @@ +{ + $Id: ra386dir.pas,v 1.1.1.1 2001-07-23 17:16:57 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Reads inline assembler and writes the lines direct to the output + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit Ra386dir; + + interface + + uses + tree; + + function assemble : ptree; + + implementation + + uses + files,globals,scanner,aasm,cpubase,cpuasm, + cobjects,symconst,symtable,types,verbose, +{$ifdef NEWCG} + cgbase, +{$else} + hcodegen, +{$endif} + rautils,ra386; + + function assemble : ptree; + + var + retstr,s,hs : string; + c : char; + ende : boolean; + sym : psym; + code : paasmoutput; + i,l : longint; + + procedure writeasmline; + var + i : longint; + begin + i:=length(s); + while (i>0) and (s[i] in [' ',#9]) do + dec(i); + {$ifndef TP} + {$ifopt H+} + setlength(s,i); + {$else} + s[0]:=chr(i); + {$endif} + {$else} + s[0]:=chr(i); + {$endif} + if s<>'' then + code^.concat(new(pai_direct,init(strpnew(s)))); + { consider it set function set if the offset was loaded } + if assigned(procinfo^.returntype.def) and + (pos(retstr,upper(s))>0) then + procinfo^.funcret_state:=vs_assigned; + s:=''; + end; + + begin + ende:=false; + s:=''; + if assigned(procinfo^.returntype.def) and + is_fpu(procinfo^.returntype.def) then + procinfo^.funcret_state:=vs_assigned; + if assigned(procinfo^.returntype.def) and + (procinfo^.returntype.def<>pdef(voiddef)) then + retstr:=upper(tostr(procinfo^.return_offset)+'('+att_reg2str[procinfo^.framepointer]+')') + else + retstr:=''; + c:=current_scanner^.asmgetchar; + code:=new(paasmoutput,init); + while not(ende) do + begin + { wrong placement + current_scanner^.gettokenpos; } + case c of + 'A'..'Z','a'..'z','_' : begin + current_scanner^.gettokenpos; + i:=0; + hs:=''; + while ((ord(c)>=ord('A')) and (ord(c)<=ord('Z'))) + or ((ord(c)>=ord('a')) and (ord(c)<=ord('z'))) + or ((ord(c)>=ord('0')) and (ord(c)<=ord('9'))) + or (c='_') do + begin + inc(i); + hs[i]:=c; + c:=current_scanner^.asmgetchar; + end; + {$ifndef TP} + {$ifopt H+} + setlength(hs,i); + {$else} + hs[0]:=chr(i); + {$endif} + {$else} + hs[0]:=chr(i); + {$endif} + if upper(hs)='END' then + ende:=true + else + begin + if c=':' then + begin + getsym(upper(hs),false); + if srsym<>nil then + if (srsym^.typ = labelsym) then + Begin + hs:=plabelsym(srsym)^.lab^.name; + plabelsym(srsym)^.lab^.is_set:=true; + end + else + Message(asmr_w_using_defined_as_local); + end + else if upper(hs)='FWAIT' then + FwaitWarning + else + { access to local variables } + if assigned(aktprocsym) then + begin + { is the last written character an special } + { char ? } + if (s[length(s)]='%') and + ret_in_acc(procinfo^.returntype.def) and + ((pos('AX',upper(hs))>0) or + (pos('AL',upper(hs))>0)) then + procinfo^.funcret_state:=vs_assigned; + if (s[length(s)]<>'%') and + (s[length(s)]<>'$') and + ((s[length(s)]<>'0') or (hs[1]<>'x')) then + begin + if assigned(aktprocsym^.definition^.localst) and + (lexlevel >= normal_function_level) then + sym:=aktprocsym^.definition^.localst^.search(upper(hs)) + else + sym:=nil; + if assigned(sym) then + begin + if (sym^.typ = labelsym) then + Begin + hs:=plabelsym(sym)^.lab^.name; + end + else if sym^.typ=varsym then + begin + {variables set are after a comma } + {like in movl %eax,I } + if pos(',',s) > 0 then + pvarsym(sym)^.varstate:=vs_used + else + if (pos('MOV',upper(s)) > 0) and (pvarsym(sym)^.varstate=vs_declared) then + Message1(sym_n_uninitialized_local_variable,hs); + if (vo_is_external in pvarsym(sym)^.varoptions) then + hs:=pvarsym(sym)^.mangledname + else + hs:='-'+tostr(pvarsym(sym)^.address)+ + '('+att_reg2str[procinfo^.framepointer]+')'; + end + else + { call to local function } + if (sym^.typ=procsym) and ((pos('CALL',upper(s))>0) or + (pos('LEA',upper(s))>0)) then + begin + hs:=pprocsym(sym)^.definition^.mangledname; + end; + end + else + begin + if assigned(aktprocsym^.definition^.parast) then + sym:=aktprocsym^.definition^.parast^.search(upper(hs)) + else + sym:=nil; + if assigned(sym) then + begin + if sym^.typ=varsym then + begin + l:=pvarsym(sym)^.address; + { set offset } + inc(l,aktprocsym^.definition^.parast^.address_fixup); + hs:=tostr(l)+'('+att_reg2str[procinfo^.framepointer]+')'; + if pos(',',s) > 0 then + pvarsym(sym)^.varstate:=vs_used; + end; + end + { I added that but it creates a problem in line.ppi + because there is a local label wbuffer and + a static variable WBUFFER ... + what would you decide, florian ?} + else + + begin +{$ifndef IGNOREGLOBALVAR} + getsym(upper(hs),false); + sym:=srsym; + if assigned(sym) and (sym^.owner^.symtabletype in [unitsymtable, + globalsymtable,staticsymtable]) then + begin + if (sym^.typ = varsym) or (sym^.typ = typedconstsym) then + begin + Message2(asmr_h_direct_global_to_mangled,hs,sym^.mangledname); + hs:=sym^.mangledname; + if sym^.typ=varsym then + inc(pvarsym(sym)^.refs); + end; + { procs can be called or the address can be loaded } + if (sym^.typ=procsym) and + ((pos('CALL',upper(s))>0) or (pos('LEA',upper(s))>0)) then + begin + if assigned(pprocsym(sym)^.definition^.nextoverloaded) then + Message1(asmr_w_direct_global_is_overloaded_func,hs); + Message2(asmr_h_direct_global_to_mangled,hs,sym^.mangledname); + hs:=sym^.mangledname; + end; + end + else +{$endif TESTGLOBALVAR} + if upper(hs)='__SELF' then + begin + if assigned(procinfo^._class) then + hs:=tostr(procinfo^.selfpointer_offset)+ + '('+att_reg2str[procinfo^.framepointer]+')' + else + Message(asmr_e_cannot_use_SELF_outside_a_method); + end + else if upper(hs)='__RESULT' then + begin + if assigned(procinfo^.returntype.def) and + (procinfo^.returntype.def<>pdef(voiddef)) then + hs:=retstr + else + Message(asmr_e_void_function); + end + else if upper(hs)='__OLDEBP' then + begin + { complicate to check there } + { we do it: } + if lexlevel>normal_function_level then + hs:=tostr(procinfo^.framepointer_offset)+ + '('+att_reg2str[procinfo^.framepointer]+')' + else + Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure); + end; + end; + end; + end; + end; + s:=s+hs; + end; + end; + '{',';',#10,#13 : begin + if pos(retstr,s) > 0 then + procinfo^.funcret_state:=vs_assigned; + writeasmline; + c:=current_scanner^.asmgetchar; + end; + #26 : Message(scan_f_end_of_file); + else + begin + current_scanner^.gettokenpos; + {$ifndef TP} + {$ifopt H+} + setlength(s,length(s)+1); + {$else} + inc(byte(s[0])); + {$endif} + {$else} + inc(byte(s[0])); + {$endif} + s[length(s)]:=c; + c:=current_scanner^.asmgetchar; + end; + end; + end; + writeasmline; + assemble:=genasmnode(code); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.30 2000/02/09 13:23:02 peter + * log truncated + + Revision 1.29 2000/01/07 01:14:36 peter + * updated copyright to 2000 + + Revision 1.28 1999/11/30 10:40:53 peter + + ttype, tsymlist + + Revision 1.27 1999/11/17 17:05:03 pierre + * Notes/hints changes + + Revision 1.26 1999/11/09 23:06:46 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.25 1999/11/06 14:34:24 peter + * truncated log to 20 revs + + Revision 1.24 1999/09/27 23:44:58 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.23 1999/08/04 00:23:26 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.22 1999/08/03 22:03:11 peter + * moved bitmask constants to sets + * some other type/const renamings + +} diff --git a/befpc/compiler/ra386int.pas b/befpc/compiler/ra386int.pas new file mode 100644 index 0000000..8b44d4d --- /dev/null +++ b/befpc/compiler/ra386int.pas @@ -0,0 +1,2043 @@ +{ + $Id: ra386int.pas,v 1.1.1.1 2001-07-23 17:16:58 memson Exp $ + Copyright (c) 1998-2000 by Carl Eric Codere and Peter Vreman + + Does the parsing process for the intel styled inline assembler. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$E+,N+} +{$endif} +Unit Ra386int; +Interface + +uses + tree; + + function assemble: ptree; + + + +Implementation + +Uses + globtype, + strings,cobjects,systems,verbose,globals, + files,aasm,types,scanner,symconst,symtable,cpubase, +{$ifdef NEWCG} + cgbase, +{$else} + hcodegen, +{$endif} + rautils,ra386; + + +type + tasmtoken = ( + AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_INTNUM, + AS_COMMA,AS_LBRACKET,AS_RBRACKET,AS_LPAREN, + AS_RPAREN,AS_COLON,AS_DOT,AS_PLUS,AS_MINUS,AS_STAR, + AS_SEPARATOR,AS_ID,AS_REGISTER,AS_OPCODE,AS_SLASH, + {------------------ Assembler directives --------------------} + AS_DB,AS_DW,AS_DD,AS_END, + {------------------ Assembler Operators --------------------} + AS_BYTE,AS_WORD,AS_DWORD,AS_QWORD,AS_TBYTE,AS_NEAR,AS_FAR, + AS_HIGH,AS_LOW,AS_OFFSET,AS_SEG,AS_TYPE,AS_PTR,AS_MOD,AS_SHL,AS_SHR,AS_NOT, + AS_AND,AS_OR,AS_XOR); + + tasmkeyword = string[6]; +const + { These tokens should be modified accordingly to the modifications } + { in the different enumerations. } + firstdirective = AS_DB; + lastdirective = AS_END; + firstoperator = AS_BYTE; + lastoperator = AS_XOR; + firstsreg = R_CS; + lastsreg = R_SS; + + _count_asmdirectives = longint(lastdirective)-longint(firstdirective); + _count_asmoperators = longint(lastoperator)-longint(firstoperator); + _count_asmprefixes = 5; + _count_asmspecialops = 25; + _count_asmoverrides = 3; + + _asmdirectives : array[0.._count_asmdirectives] of tasmkeyword = + ('DB','DW','DD','END'); + + { problems with shl,shr,not,and,or and xor, they are } + { context sensitive. } + _asmoperators : array[0.._count_asmoperators] of tasmkeyword = ( + 'BYTE','WORD','DWORD','QWORD','TBYTE','NEAR','FAR','HIGH', + 'LOW','OFFSET','SEG','TYPE','PTR','MOD','SHL','SHR','NOT','AND', + 'OR','XOR'); + + token2str : array[tasmtoken] of string[10] = ( + '','Label','LLabel','String','Integer', + ',','[',']','(', + ')',':','.','+','-','*', + ';','identifier','register','opcode','/', + '','','','END', + '','','','','','','','', + '','','','type','ptr','mod','shl','shr','not', + 'and','or','xor' + ); + +const + newline = #10; + firsttoken : boolean = TRUE; +var + _asmsorted : boolean; + inexpression : boolean; + curlist : paasmoutput; + c : char; + prevasmtoken : tasmtoken; + actasmtoken : tasmtoken; + actasmpattern : string; + actasmregister : tregister; + actopcode : tasmop; + actopsize : topsize; + actcondition : tasmcond; + iasmops : Pdictionary; + iasmregs : ^reg2strtable; + + +Procedure SetupTables; +{ creates uppercased symbol tables for speed access } +var + i : tasmop; + j : tregister; + str2opentry: pstr2opentry; +Begin + { opcodes } + new(iasmops,init); + for i:=firstop to lastop do + begin + new(str2opentry,initname(upper(int_op2str[i]))); + str2opentry^.op:=i; + iasmops^.insert(str2opentry); + end; + { registers } + new(iasmregs); + for j:=firstreg to lastreg do + iasmregs^[j] := upper(int_reg2str[j]); +end; + + + {---------------------------------------------------------------------} + { Routines for the tokenizing } + {---------------------------------------------------------------------} + + + function is_asmopcode(const s: string):boolean; + var + str2opentry: pstr2opentry; + cond : string[4]; + cnd : tasmcond; + j: longint; + Begin + is_asmopcode:=FALSE; + + actopcode:=A_None; + actcondition:=C_None; + actopsize:=S_NO; + + str2opentry:=pstr2opentry(iasmops^.search(s)); + if assigned(str2opentry) then + begin + actopcode:=str2opentry^.op; + actasmtoken:=AS_OPCODE; + is_asmopcode:=TRUE; + exit; + end; + { not found yet, check condition opcodes } + j:=0; + while (j'' then + begin + for cnd:=low(TasmCond) to high(TasmCond) do + if Cond=Upper(cond2str[cnd]) then + begin + actopcode:=CondASmOp[j]; + actcondition:=cnd; + is_asmopcode:=TRUE; + actasmtoken:=AS_OPCODE; + exit + end; + end; + end; + inc(j); + end; + end; + + +function is_asmoperator(const s: string):boolean; +var + i : longint; +Begin + for i:=0 to _count_asmoperators do + if s=_asmoperators[i] then + begin + actasmtoken:=tasmtoken(longint(firstoperator)+i); + is_asmoperator:=true; + exit; + end; + is_asmoperator:=false; +end; + + +Function is_asmdirective(const s: string):boolean; +var + i : longint; +Begin + for i:=0 to _count_asmdirectives do + if s=_asmdirectives[i] then + begin + actasmtoken:=tasmtoken(longint(firstdirective)+i); + is_asmdirective:=true; + exit; + end; + is_asmdirective:=false; +end; + + +Function is_register(const s: string):boolean; +Var + i : tregister; +Begin + actasmregister:=R_NO; + for i:=firstreg to lastreg do + if s=iasmregs^[i] then + begin + actasmtoken:=AS_REGISTER; + actasmregister:=i; + is_register:=true; + exit; + end; + is_register:=false; +end; + + +function is_locallabel(const s:string):boolean; +begin + is_locallabel:=(length(s)>1) and (s[1]='@'); +end; + + +Procedure GetToken; +var + len : longint; + forcelabel : boolean; +begin + { save old token and reset new token } + prevasmtoken:=actasmtoken; + actasmtoken:=AS_NONE; + { reset } + forcelabel:=FALSE; + actasmpattern:=''; + { while space and tab , continue scan... } + while (c in [' ',#9]) do + c:=current_scanner^.asmgetchar; + { get token pos } + if not (c in [newline,#13,'{',';']) then + current_scanner^.gettokenpos; +{ Local Label, Label, Directive, Prefix or Opcode } + if firsttoken and not (c in [newline,#13,'{',';']) then + begin + firsttoken:=FALSE; + len:=0; + while c in ['A'..'Z','a'..'z','0'..'9','_','@'] do + begin + { if there is an at_sign, then this must absolutely be a label } + if c = '@' then + forcelabel:=TRUE; + inc(len); + actasmpattern[len]:=c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern[0]:=chr(len); + uppervar(actasmpattern); + { label ? } + if c = ':' then + begin + if actasmpattern[1]='@' then + actasmtoken:=AS_LLABEL + else + actasmtoken:=AS_LABEL; + { let us point to the next character } + c:=current_scanner^.asmgetchar; + firsttoken:=true; + exit; + end; + { Are we trying to create an identifier with } + { an at-sign...? } + if forcelabel then + Message(asmr_e_none_label_contain_at); + { opcode ? } + If is_asmopcode(actasmpattern) then + Begin + { check if we are in an expression } + { then continue with asm directives } + if not inexpression then + exit; + end; + if is_asmdirective(actasmpattern) then + exit; + message1(asmr_e_unknown_opcode,actasmpattern); + actasmtoken:=AS_NONE; + exit; + end + else { else firsttoken } + begin + case c of + '@' : { possiblities : - local label reference , such as in jmp @local1 } + { - @Result, @Code or @Data special variables. } + begin + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_','@'] do + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + uppervar(actasmpattern); + actasmtoken:=AS_ID; + exit; + end; + + 'A'..'Z','a'..'z','_': { identifier, register, opcode, prefix or directive } + begin + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_'] do + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + uppervar(actasmpattern); + { after prefix we allow also a new opcode } + If is_prefix(actopcode) and is_asmopcode(actasmpattern) then + Begin + { if we are not in a constant } + { expression than this is an } + { opcode. } + if not inexpression then + exit; + end; + { support st(X) for fpu registers } + if (actasmpattern = 'ST') and (c='(') then + Begin + actasmpattern:=actasmpattern+c; + c:=current_scanner^.asmgetchar; + if c in ['0'..'7'] then + actasmpattern:=actasmpattern + c + else + Message(asmr_e_invalid_fpu_register); + c:=current_scanner^.asmgetchar; + if c <> ')' then + Message(asmr_e_invalid_fpu_register) + else + Begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + end; + if is_register(actasmpattern) then + exit; + if is_asmdirective(actasmpattern) then + exit; + if is_asmoperator(actasmpattern) then + exit; + actasmtoken:=AS_ID; + exit; + end; + + '&' : { override operator... not supported } + begin + Message(asmr_w_override_op_not_supported); + c:=current_scanner^.asmgetchar; + actasmtoken:=AS_NONE; + end; + + '''' : { string or character } + begin + actasmpattern:=''; + repeat + if c = '''' then + begin + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + repeat + if c='''' then + begin + c:=current_scanner^.asmgetchar; + if c='''' then + begin + actasmpattern:=actasmpattern+''''; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + end + else + break; + end + else + begin + actasmpattern:=actasmpattern+c; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break + end; + end; + until false; { end repeat } + end + else + break; { end if } + until false; + actasmtoken:=AS_STRING; + exit; + end; + + '"' : { string or character } + begin + actasmpattern:=''; + repeat + if c = '"' then + begin + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + repeat + if c='"' then + begin + c:=current_scanner^.asmgetchar; + if c='"' then + begin + actasmpattern:=actasmpattern+'"'; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + end + else + break; + end + else + begin + actasmpattern:=actasmpattern+c; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break + end; + end; + until false; { end repeat } + end + else + break; { end if } + until false; + actasmtoken:=AS_STRING; + exit; + end; + + '$' : + begin + c:=current_scanner^.asmgetchar; + while c in ['0'..'9','A'..'F','a'..'f'] do + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + actasmpattern:=tostr(ValHexaDecimal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + + ',' : + begin + actasmtoken:=AS_COMMA; + c:=current_scanner^.asmgetchar; + exit; + end; + + '[' : + begin + actasmtoken:=AS_LBRACKET; + c:=current_scanner^.asmgetchar; + exit; + end; + + ']' : + begin + actasmtoken:=AS_RBRACKET; + c:=current_scanner^.asmgetchar; + exit; + end; + + '(' : + begin + actasmtoken:=AS_LPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + + ')' : + begin + actasmtoken:=AS_RPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + + ':' : + begin + actasmtoken:=AS_COLON; + c:=current_scanner^.asmgetchar; + exit; + end; + + '.' : + begin + actasmtoken:=AS_DOT; + c:=current_scanner^.asmgetchar; + exit; + end; + + '+' : + begin + actasmtoken:=AS_PLUS; + c:=current_scanner^.asmgetchar; + exit; + end; + + '-' : + begin + actasmtoken:=AS_MINUS; + c:=current_scanner^.asmgetchar; + exit; + end; + + '*' : + begin + actasmtoken:=AS_STAR; + c:=current_scanner^.asmgetchar; + exit; + end; + + '/' : + begin + actasmtoken:=AS_SLASH; + c:=current_scanner^.asmgetchar; + exit; + end; + + '0'..'9': + begin + actasmpattern:=c; + c:=current_scanner^.asmgetchar; + { Get the possible characters } + while c in ['0'..'9','A'..'F','a'..'f'] do + begin + actasmpattern:=actasmpattern + c; + c:=current_scanner^.asmgetchar; + end; + { Get ending character } + uppervar(actasmpattern); + c:=upcase(c); + { possibly a binary number. } + if (actasmpattern[length(actasmpattern)] = 'B') and (c <> 'H') then + Begin + { Delete the last binary specifier } + delete(actasmpattern,length(actasmpattern),1); + actasmpattern:=tostr(ValBinary(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end + else + Begin + case c of + 'O' : + Begin + actasmpattern:=tostr(ValOctal(actasmpattern)); + actasmtoken:=AS_INTNUM; + c:=current_scanner^.asmgetchar; + exit; + end; + 'H' : + Begin + actasmpattern:=tostr(ValHexaDecimal(actasmpattern)); + actasmtoken:=AS_INTNUM; + c:=current_scanner^.asmgetchar; + exit; + end; + else { must be an integer number } + begin + actasmpattern:=tostr(ValDecimal(actasmpattern)); + actasmtoken:=AS_INTNUM; + exit; + end; + end; + end; + end; + + ';','{',#13,newline : + begin + c:=current_scanner^.asmgetchar; + firsttoken:=TRUE; + actasmtoken:=AS_SEPARATOR; + exit; + end; + + else + current_scanner^.illegal_char(c); + end; + end; +end; + + +function consume(t : tasmtoken):boolean; +begin + Consume:=true; + if t<>actasmtoken then + begin + Message2(scan_f_syn_expected,token2str[t],token2str[actasmtoken]); + Consume:=false; + end; + repeat + gettoken; + until actasmtoken<>AS_NONE; +end; + + +procedure RecoverConsume(allowcomma:boolean); +begin + While not (actasmtoken in [AS_SEPARATOR,AS_END]) do + begin + if allowcomma and (actasmtoken=AS_COMMA) then + break; + Consume(actasmtoken); + end; +end; + + +{***************************************************************************** + Parsing Helpers +*****************************************************************************} + +Procedure BuildRecordOffsetSize(const expr: string;var offset:longint;var size:longint); +{ Description: This routine builds up a record offset after a AS_DOT } +{ token is encountered. } +{ On entry actasmtoken should be equal to AS_DOT } +var + s : string; +Begin + offset:=0; + size:=0; + s:=expr; + while (actasmtoken=AS_DOT) do + begin + Consume(AS_DOT); + if actasmtoken=AS_ID then + s:=s+'.'+actasmpattern; + if not Consume(AS_ID) then + begin + RecoverConsume(true); + break; + end; + end; + if not GetRecordOffsetSize(s,offset,size) then + Message(asmr_e_building_record_offset); +end; + + +Procedure BuildConstSymbolExpression(needofs,exitreg:boolean;var value:longint;var asmsym:string); +var + tempstr,expr,hs : string; + parenlevel,l,k : longint; + errorflag : boolean; + prevtok : tasmtoken; + hl : PAsmLabel; + sym : psym; +Begin + { reset } + value:=0; + asmsym:=''; + errorflag:=FALSE; + tempstr:=''; + expr:=''; + inexpression:=TRUE; + parenlevel:=0; + Repeat + Case actasmtoken of + AS_LPAREN: + Begin + Consume(AS_LPAREN); + expr:=expr + '('; + inc(parenlevel); + end; + AS_RPAREN: + Begin + Consume(AS_RPAREN); + expr:=expr + ')'; + dec(parenlevel); + end; + AS_SHL: + Begin + Consume(AS_SHL); + expr:=expr + '<'; + end; + AS_SHR: + Begin + Consume(AS_SHR); + expr:=expr + '>'; + end; + AS_SLASH: + Begin + Consume(AS_SLASH); + expr:=expr + '/'; + end; + AS_MOD: + Begin + Consume(AS_MOD); + expr:=expr + '%'; + end; + AS_STAR: + Begin + Consume(AS_STAR); + if exitreg and (actasmtoken=AS_REGISTER) then + break; + expr:=expr + '*'; + end; + AS_PLUS: + Begin + Consume(AS_PLUS); + if exitreg and (actasmtoken=AS_REGISTER) then + break; + expr:=expr + '+'; + end; + AS_MINUS: + Begin + Consume(AS_MINUS); + expr:=expr + '-'; + end; + AS_AND: + Begin + Consume(AS_AND); + expr:=expr + '&'; + end; + AS_NOT: + Begin + Consume(AS_NOT); + expr:=expr + '~'; + end; + AS_XOR: + Begin + Consume(AS_XOR); + expr:=expr + '^'; + end; + AS_OR: + Begin + Consume(AS_OR); + expr:=expr + '|'; + end; + AS_INTNUM: + Begin + expr:=expr + actasmpattern; + Consume(AS_INTNUM); + end; + AS_OFFSET: + begin + Consume(AS_OFFSET); + if actasmtoken<>AS_ID then + Message(asmr_e_offset_without_identifier); + end; + AS_TYPE: + begin + l:=0; + Consume(AS_TYPE); + if actasmtoken<>AS_ID then + Message(asmr_e_type_without_identifier) + else + begin + tempstr:=actasmpattern; + Consume(AS_ID); + if actasmtoken=AS_DOT then + BuildRecordOffsetSize(tempstr,k,l) + else + begin + getsym(tempstr,false); + if assigned(srsym) then + begin + case srsym^.typ of + varsym : + l:=pvarsym(srsym)^.getsize; + typedconstsym : + l:=ptypedconstsym(srsym)^.getsize; + typesym : + l:=ptypesym(srsym)^.restype.def^.size; + else + Message(asmr_e_wrong_sym_type); + end; + end + else + Message1(sym_e_unknown_id,tempstr); + end; + end; + str(l, tempstr); + expr:=expr + tempstr; + end; + AS_STRING: + Begin + l:=0; + case Length(actasmpattern) of + 1 : + l:=ord(actasmpattern[1]); + 2 : + l:=ord(actasmpattern[2]) + ord(actasmpattern[1]) shl 8; + 3 : + l:=ord(actasmpattern[3]) + + Ord(actasmpattern[2]) shl 8 + ord(actasmpattern[1]) shl 16; + 4 : + l:=ord(actasmpattern[4]) + ord(actasmpattern[3]) shl 8 + + Ord(actasmpattern[2]) shl 16 + ord(actasmpattern[1]) shl 24; + else + Message1(asmr_e_invalid_string_as_opcode_operand,actasmpattern); + end; + str(l, tempstr); + expr:=expr + tempstr; + Consume(AS_STRING); + end; + AS_ID: + Begin + hs:=''; + tempstr:=actasmpattern; + prevtok:=prevasmtoken; + consume(AS_ID); + if SearchIConstant(tempstr,l) then + begin + str(l, tempstr); + expr:=expr + tempstr; + end + else + begin + if is_locallabel(tempstr) then + begin + CreateLocalLabel(tempstr,hl,false); + hs:=hl^.name + end + else + if SearchLabel(tempstr,hl,false) then + hs:=hl^.name + else + begin + getsym(tempstr,false); + sym:=srsym; + if assigned(sym) then + begin + case srsym^.typ of + varsym : + begin + if sym^.owner^.symtabletype in [localsymtable,parasymtable] then + Message(asmr_e_no_local_or_para_allowed); + hs:=pvarsym(srsym)^.mangledname; + end; + typedconstsym : + hs:=ptypedconstsym(srsym)^.mangledname; + procsym : + hs:=pprocsym(srsym)^.mangledname; + typesym : + begin + if not(ptypesym(srsym)^.restype.def^.deftype in [recorddef,objectdef]) then + Message(asmr_e_wrong_sym_type); + end; + else + Message(asmr_e_wrong_sym_type); + end; + end + else + Message1(sym_e_unknown_id,tempstr); + end; + { symbol found? } + if hs<>'' then + begin + if needofs and (prevtok<>AS_OFFSET) then + Message(asmr_e_need_offset); + if asmsym='' then + asmsym:=hs + else + Message(asmr_e_cant_have_multiple_relocatable_symbols); + if (expr='') or (expr[length(expr)]='+') then + begin + { don't remove the + if there could be a record field } + if actasmtoken<>AS_DOT then + delete(expr,length(expr),1); + end + else + Message(asmr_e_only_add_relocatable_symbol); + end; + if actasmtoken=AS_DOT then + begin + BuildRecordOffsetSize(tempstr,l,k); + str(l, tempstr); + expr:=expr + tempstr; + end + else + begin + if (expr='') or (expr[length(expr)] in ['+','-','/','*']) then + delete(expr,length(expr),1); + end; + end; + { check if there are wrong operator used like / or mod etc. } + if (hs<>'') and not(actasmtoken in [AS_MINUS,AS_PLUS,AS_COMMA,AS_SEPARATOR,AS_END,AS_RBRACKET]) then + Message(asmr_e_only_add_relocatable_symbol); + end; + AS_END, + AS_RBRACKET, + AS_SEPARATOR, + AS_COMMA: + Begin + break; + end; + else + Begin + { write error only once. } + if not errorflag then + Message(asmr_e_invalid_constant_expression); + { consume tokens until we find COMMA or SEPARATOR } + Consume(actasmtoken); + errorflag:=TRUE; + end; + end; + Until false; + { calculate expression } + if not ErrorFlag then + value:=CalculateExpression(expr) + else + value:=0; + { no longer in an expression } + inexpression:=FALSE; +end; + + + +Function BuildConstExpression:longint; +var + l : longint; + hs : string; +begin + BuildConstSymbolExpression(false,false,l,hs); + if hs<>'' then + Message(asmr_e_relocatable_symbol_not_allowed); + BuildConstExpression:=l; +end; + + +Function BuildRefConstExpression:longint; +var + l : longint; + hs : string; +begin + BuildConstSymbolExpression(false,true,l,hs); + if hs<>'' then + Message(asmr_e_relocatable_symbol_not_allowed); + BuildRefConstExpression:=l; +end; + + +{**************************************************************************** + T386IntelOperand +****************************************************************************} + +type + P386IntelOperand=^T386IntelOperand; + T386IntelOperand=object(T386Operand) + Procedure BuildOperand;virtual; + private + Procedure BuildReference; + Procedure BuildConstant; + end; + + + +Procedure T386IntelOperand.BuildReference; +var + k,l : longint; + tempstr2, + tempstr,hs : string; + code : integer; + hreg, + oldbase : tregister; + GotStar,GotOffset,HadVar, + GotPlus,Negative : boolean; +Begin + Consume(AS_LBRACKET); + InitRef; + GotStar:=false; + GotPlus:=true; + GotOffset:=false; + Negative:=false; + repeat + if GotOffset and (actasmtoken<>AS_ID) then + Message(asmr_e_invalid_reference_syntax); + + Case actasmtoken of + + AS_ID: { Constant reference expression OR variable reference expression } + Begin + if not GotPlus then + Message(asmr_e_invalid_reference_syntax); + if actasmpattern[1] = '@' then + Message(asmr_e_local_label_not_allowed_as_ref); + GotStar:=false; + GotPlus:=false; + if SearchIConstant(actasmpattern,l) or + SearchRecordType(actasmpattern) then + begin + l:=BuildRefConstExpression; + GotPlus:=(prevasmtoken=AS_PLUS); + GotStar:=(prevasmtoken=AS_STAR); + if GotStar then + opr.ref.scalefactor:=l + else + begin + if negative then + Dec(opr.ref.offset,l) + else + Inc(opr.ref.offset,l); + end; + end + else + Begin + if hasvar and not GotOffset then + Message(asmr_e_cant_have_multiple_relocatable_symbols); + HadVar:=hasvar and GotOffset; + if negative then + Message(asmr_e_only_add_relocatable_symbol); + oldbase:=opr.ref.base; + opr.ref.base:=R_NO; + tempstr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(tempstr) then + begin + hastype:=true; + Consume(AS_LPAREN); + tempstr2:=actasmpattern; + Consume(AS_ID); + Consume(AS_RPAREN); + if not SetupVar(tempstr2,GotOffset) then + Message1(sym_e_unknown_id,tempstr2); + end + else + if not SetupVar(tempstr,GotOffset) then + Message1(sym_e_unknown_id,tempstr); + { record.field ? } + if actasmtoken=AS_DOT then + begin + BuildRecordOffsetSize(tempstr,l,k); + inc(opr.ref.offset,l); + end; + if GotOffset then + begin + if hasvar and (opr.ref.base=procinfo^.framepointer) then + begin + opr.ref.base:=R_NO; + hasvar:=hadvar; + end + else + begin + if hasvar and hadvar then + Message(asmr_e_cant_have_multiple_relocatable_symbols); + { should we allow ?? } + end; + end; + { is the base register loaded by the var ? } + if (opr.ref.base<>R_NO) then + begin + { check if we can move the old base to the index register } + if (opr.ref.index<>R_NO) then + Message(asmr_e_wrong_base_index) + else if assigned(procinfo^._class) and + (oldbase=self_pointer) and + (opr.ref.base=self_pointer) then + begin + Message(asmr_w_possible_object_field_bug); + { warn but accept... who knows what people + caninvent in assembler ! } + opr.ref.index:=oldbase; + end + else + opr.ref.index:=oldbase; + end + else + opr.ref.base:=oldbase; + { we can't have a Constant here so add the constant value to the + offset } + if opr.typ=OPR_CONSTANT then + begin + opr.typ:=OPR_REFERENCE; + inc(opr.ref.offset,opr.val); + end; + end; + GotOffset:=false; + end; + + AS_PLUS : + Begin + Consume(AS_PLUS); + Negative:=false; + GotPlus:=true; + GotStar:=false; + end; + + AS_MINUS : + begin + Consume(AS_MINUS); + Negative:=true; + GotPlus:=true; + GotStar:=false; + end; + + AS_STAR : { Scaling, with eax*4 order } + begin + Consume(AS_STAR); + hs:=''; + l:=0; + case actasmtoken of + AS_LPAREN : + l:=BuildConstExpression; + AS_INTNUM: + Begin + hs:=actasmpattern; + Consume(AS_INTNUM); + end; + AS_REGISTER : + begin + if opr.ref.scalefactor=0 then + Message(asmr_e_wrong_scale_factor); + end; + else + Message(asmr_e_invalid_reference_syntax); + end; + if actasmtoken<>AS_REGISTER then + begin + if hs<>'' then + val(hs,l,code); + opr.ref.scalefactor:=l; + if l>8 then + Message(asmr_e_wrong_scale_factor); + end; + GotPlus:=false; + GotStar:=false; + end; + + AS_REGISTER : + begin + if (not GotPlus) and (not GotStar) then + Message(asmr_e_invalid_reference_syntax); + hreg:=actasmregister; + Consume(AS_REGISTER); + { this register will be the index: + 1. just read a * + 2. next token is a * + 3. base register is already used } + if (GotStar) or + (actasmtoken=AS_STAR) or + (opr.ref.base<>R_NO) then + begin + if (opr.ref.index<>R_NO) then + Message(asmr_e_multiple_index); + opr.ref.index:=hreg; + end + else + opr.ref.base:=hreg; + GotPlus:=false; + GotStar:=false; + end; + + AS_OFFSET : + begin + Consume(AS_OFFSET); + GotOffset:=true; + end; + + AS_TYPE, + AS_NOT, + AS_INTNUM, + AS_LPAREN : { Constant reference expression } + begin + if not GotPlus then + Message(asmr_e_invalid_reference_syntax); + BuildConstSymbolExpression(true,true,l,tempstr); + if tempstr<>'' then + begin + if GotStar then + Message(asmr_e_only_add_relocatable_symbol); + if not assigned(opr.ref.symbol) then + opr.ref.symbol:=newasmsymbol(tempstr) + else + Message(asmr_e_cant_have_multiple_relocatable_symbols); + end; + if GotStar then + opr.ref.scalefactor:=l + else + begin + if negative then + Dec(opr.ref.offset,l) + else + Inc(opr.ref.offset,l); + end; + GotPlus:=(prevasmtoken=AS_PLUS); + GotStar:=(prevasmtoken=AS_STAR); + end; + + AS_RBRACKET : + begin + if GotPlus then + Message(asmr_e_invalid_reference_syntax); + Consume(AS_RBRACKET); + break; + end; + + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + break; + end; + end; + until false; +end; + + +Procedure T386IntelOperand.BuildConstant; +var + l : longint; + tempstr : string; +begin + BuildConstSymbolExpression(true,false,l,tempstr); + if tempstr<>'' then + begin + opr.typ:=OPR_SYMBOL; + opr.symofs:=l; + opr.symbol:=newasmsymbol(tempstr); + end + else + begin + opr.typ:=OPR_CONSTANT; + opr.val:=l; + end; +end; + + +Procedure T386IntelOperand.BuildOperand; +var + tempstr, + expr : string; + tempreg : tregister; + l : longint; + hl : PAsmLabel; + + procedure AddLabelOperand(hl:pasmlabel); + begin + if is_calljmp(actopcode) then + begin + opr.typ:=OPR_SYMBOL; + opr.symbol:=hl; + end + else + begin + InitRef; + opr.ref.symbol:=hl; + end; + end; + + procedure MaybeRecordOffset; + var + l, + toffset, + tsize : longint; + begin + if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then + exit; + l:=0; + if actasmtoken=AS_DOT then + begin + { if no type was specified before the [] then we expect the + first ID to be the type } + if expr='' then + begin + consume(AS_DOT); + if actasmtoken=AS_ID then + begin + expr:=actasmpattern; + consume(AS_ID); + { now the next one must the be the dot } + if actasmtoken<>AS_DOT then + begin + Message(asmr_e_building_record_offset); + expr:=''; + end; + end + else + Message(asmr_e_no_var_type_specified) + end; + if expr<>'' then + begin + BuildRecordOffsetSize(expr,toffset,tsize); + inc(l,toffset); + SetSize(tsize,true); + end; + end; + if actasmtoken in [AS_PLUS,AS_MINUS] then + inc(l,BuildConstExpression); + if (opr.typ=OPR_REFERENCE) then + begin + { don't allow direct access to fields of parameters, becuase that + will generate buggy code. Allow it only for explicit typecasting } + if (not hastype) then + begin + case opr.ref.options of + ref_parafixup : + Message(asmr_e_cannot_access_field_directly_for_parameters); + ref_selffixup : + Message(asmr_e_cannot_access_object_field_directly); + end; + end; + inc(opr.ref.offset,l) + end + else + inc(opr.val,l); + end; + +Begin + expr:=''; + case actasmtoken of + + AS_OFFSET, + AS_TYPE, + AS_INTNUM, + AS_PLUS, + AS_MINUS, + AS_NOT, + AS_LPAREN, + AS_STRING : + Begin + if not (opr.typ in [OPR_NONE,OPR_CONSTANT]) then + Message(asmr_e_invalid_operand_type); + BuildConstant; + end; + + AS_ID : { A constant expression, or a Variable ref. } + Begin + { Label or Special symbol reference? } + if actasmpattern[1] = '@' then + Begin + if actasmpattern = '@RESULT' then + Begin + InitRef; + SetupResult; + Consume(AS_ID); + end + else + if (actasmpattern = '@CODE') or (actasmpattern = '@DATA') then + begin + Message(asmr_w_CODE_and_DATA_not_supported); + Consume(AS_ID); + end + else + { Local Label } + begin + CreateLocalLabel(actasmpattern,hl,false); + Consume(AS_ID); + AddLabelOperand(hl); + if not (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then + Message(asmr_e_syntax_error); + end; + end + else + { support result for delphi modes } + if (m_objpas in aktmodeswitches) and (actasmpattern='RESULT') then + begin + InitRef; + SetUpResult; + Consume(AS_ID); + end + { probably a variable or normal expression } + { or a procedure (such as in CALL ID) } + else + Begin + { is it a constant ? } + if SearchIConstant(actasmpattern,l) then + Begin + if not (opr.typ in [OPR_NONE,OPR_CONSTANT]) then + Message(asmr_e_invalid_operand_type); + BuildConstant; + end + else + { Check for pascal label } + if SearchLabel(actasmpattern,hl,false) then + begin + Consume(AS_ID); + AddLabelOperand(hl); + if not (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then + Message(asmr_e_syntax_error); + end + else + { is it a normal variable ? } + Begin + InitRef; + expr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(expr) then + begin + hastype:=true; + Consume(AS_LPAREN); + tempstr:=actasmpattern; + Consume(AS_ID); + Consume(AS_RPAREN); + if SetupVar(tempstr,false) then + begin + MaybeRecordOffset; + { add a constant expression? } + if (actasmtoken=AS_PLUS) then + begin + l:=BuildConstExpression; + if opr.typ=OPR_CONSTANT then + inc(opr.val,l) + else + inc(opr.ref.offset,l); + end + end + else + Message1(sym_e_unknown_id,tempstr); + end + else + begin + if SetupVar(expr,false) then + begin + MaybeRecordOffset; + { add a constant expression? } + if (actasmtoken=AS_PLUS) then + begin + l:=BuildConstExpression; + if opr.typ=OPR_CONSTANT then + inc(opr.val,l) + else + inc(opr.ref.offset,l); + end + end + else + Begin + { not a variable, check special variables.. } + if expr = 'SELF' then + SetupSelf + else + Message1(sym_e_unknown_id,expr); + end; + end; + end; + { handle references } + if actasmtoken=AS_LBRACKET then + begin + if opr.typ=OPR_CONSTANT then + begin + l:=opr.val; + opr.typ:=OPR_REFERENCE; + reset_reference(opr.Ref); + opr.Ref.Offset:=l; + end; + BuildReference; + MaybeRecordOffset; + end; + end; + end; + + AS_REGISTER : { Register, a variable reference or a constant reference } + Begin + { save the type of register used. } + tempreg:=actasmregister; + Consume(AS_REGISTER); + if actasmtoken = AS_COLON then + Begin + Consume(AS_COLON); + InitRef; + opr.ref.segment:=tempreg; + BuildReference; + end + else + { Simple register } + begin + if not (opr.typ in [OPR_NONE,OPR_REGISTER]) then + Message(asmr_e_invalid_operand_type); + opr.typ:=OPR_REGISTER; + opr.reg:=tempreg; + size:=reg_2_opsize[opr.reg]; + end; + end; + + AS_LBRACKET: { a variable reference, register ref. or a constant reference } + Begin + InitRef; + BuildReference; + MaybeRecordOffset; + end; + + AS_SEG : + Begin + Message(asmr_e_seg_not_supported); + Consume(actasmtoken); + end; + + AS_SEPARATOR, + AS_END, + AS_COMMA: ; + + else + Message(asmr_e_syn_operand); + end; + if not(actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then + begin + Message(asmr_e_syntax_error); + RecoverConsume(true); + end; +end; + + +{***************************************************************************** + T386IntelInstruction +*****************************************************************************} + +type + P386IntelInstruction=^T386IntelInstruction; + T386IntelInstruction=object(T386Instruction) + procedure InitOperands;virtual; + procedure BuildOpcode;virtual; + end; + +procedure T386IntelInstruction.InitOperands; +var + i : longint; +begin + for i:=1 to 3 do + Operands[i]:=new(P386IntelOperand,Init); +end; + + +Procedure T386IntelInstruction.BuildOpCode; +var + PrefixOp,OverrideOp: tasmop; + size : topsize; + operandnum : longint; +Begin + PrefixOp:=A_None; + OverrideOp:=A_None; + { prefix seg opcode / prefix opcode } + repeat + if is_prefix(actopcode) then + begin + PrefixOp:=ActOpcode; + opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + ConcatInstruction(curlist); + Consume(AS_OPCODE); + end + else + if is_override(actopcode) then + begin + OverrideOp:=ActOpcode; + opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + ConcatInstruction(curlist); + Consume(AS_OPCODE); + end + else + break; + { allow for newline after prefix or override } + while actasmtoken=AS_SEPARATOR do + Consume(AS_SEPARATOR); + until (actasmtoken<>AS_OPCODE); + { opcode } + if (actasmtoken <> AS_OPCODE) then + Begin + Message(asmr_e_invalid_or_missing_opcode); + RecoverConsume(false); + exit; + end; + { Fill the instr object with the current state } + Opcode:=ActOpcode; + condition:=ActCondition; + opsize:=ActOpsize; + { Valid combination of prefix/override and instruction ? } + if (prefixop<>A_NONE) and (NOT CheckPrefix(PrefixOp,actopcode)) then + Message1(asmr_e_invalid_prefix_and_opcode,actasmpattern); + if (overrideop<>A_NONE) and (NOT CheckOverride(OverrideOp,ActOpcode)) then + Message1(asmr_e_invalid_override_and_opcode,actasmpattern); + { We are reading operands, so opcode will be an AS_ID } + operandnum:=1; + Consume(AS_OPCODE); + { Zero operand opcode ? } + if actasmtoken in [AS_SEPARATOR,AS_END] then + begin + operandnum:=0; + exit; + end; + { Read Operands } + repeat + case actasmtoken of + + { End of asm operands for this opcode } + AS_END, + AS_SEPARATOR : + break; + + { Operand delimiter } + AS_COMMA : + Begin + if operandnum > MaxOperands then + Message(asmr_e_too_many_operands) + else + Inc(operandnum); + Consume(AS_COMMA); + end; + + { Typecast, Constant Expression, Type Specifier } + AS_DWORD, + AS_BYTE, + AS_WORD, + AS_TBYTE, + AS_QWORD : + Begin + { load the size in a temp variable, so it can be set when the + operand is read } + Case actasmtoken of + AS_DWORD : size:=S_L; + AS_WORD : size:=S_W; + AS_BYTE : size:=S_B; + AS_QWORD : begin + if (opcode=A_FCOM) or + (opcode=A_FCOMP) or + (opcode=A_FDIV) or + (opcode=A_FDIVR) or + (opcode=A_FMUL) or + (opcode=A_FSUB) or + (opcode=A_FSUBR) or + (opcode=A_FLD) or + (opcode=A_FST) or + (opcode=A_FSTP) or + (opcode=A_FADD) then + size:=S_FL + else + size:=S_IQ; + end; + AS_TBYTE : size:=S_FX; + end; + Consume(actasmtoken); + if actasmtoken=AS_PTR then + begin + Consume(AS_PTR); + Operands[operandnum]^.InitRef; + end; + Operands[operandnum]^.BuildOperand; + { now set the size which was specified by the override } + Operands[operandnum]^.size:=size; + end; + + { Type specifier } + AS_NEAR, + AS_FAR : + Begin + if actasmtoken = AS_NEAR then + Message(asmr_w_near_ignored) + else + Message(asmr_w_far_ignored); + Consume(actasmtoken); + if actasmtoken=AS_PTR then + begin + Consume(AS_PTR); + Operands[operandnum]^.InitRef; + end; + Operands[operandnum]^.BuildOperand; + end; + + else + Operands[operandnum]^.BuildOperand; + end; { end case } + until false; + Ops:=operandnum; +end; + + +Procedure BuildConstant(maxvalue: longint); +var + strlength: byte; + asmsym, + expr: string; + value : longint; +Begin + strlength:=0; { assume it is a DB } + Repeat + Case actasmtoken of + AS_STRING: + Begin + if maxvalue = $ffff then + strlength:=2 + else + if maxvalue = longint($ffffffff) then + strlength:=4; + { DD and DW cases } + if strlength <> 0 then + Begin + if Not PadZero(actasmpattern,strlength) then + Message(scan_f_string_exceeds_line); + end; + expr:=actasmpattern; + Consume(AS_STRING); + Case actasmtoken of + AS_COMMA: + Consume(AS_COMMA); + AS_END, + AS_SEPARATOR: ; + else + Message(asmr_e_invalid_string_expression); + end; + ConcatString(curlist,expr); + end; + AS_PLUS, + AS_MINUS, + AS_LPAREN, + AS_NOT, + AS_INTNUM, + AS_ID : + Begin + BuildConstSymbolExpression(false,false,value,asmsym); + if asmsym<>'' then + begin + if maxvalue<>longint($ffffffff) then + Message(asmr_w_const32bit_for_address); + ConcatConstSymbol(curlist,asmsym,value) + end + else + ConcatConstant(curlist,value,maxvalue); + end; + AS_COMMA: + Consume(AS_COMMA); + AS_END, + AS_SEPARATOR: + break; + else + begin + Message(asmr_e_syn_constant); + RecoverConsume(false); + end + end; + Until false; +end; + + +Function Assemble: Ptree; +Var + hl : PAsmLabel; + instr : T386IntelInstruction; +Begin + Message1(asmr_d_start_reading,'intel'); + inexpression:=FALSE; + firsttoken:=TRUE; + if assigned(procinfo^.returntype.def) and + (is_fpu(procinfo^.returntype.def) or + ret_in_acc(procinfo^.returntype.def)) then + procinfo^.funcret_state:=vs_assigned; + { sets up all opcode and register tables in uppercase } + if not _asmsorted then + Begin + SetupTables; + _asmsorted:=TRUE; + end; + curlist:=new(paasmoutput,init); + { setup label linked list } + new(LocalLabelList,Init); + { start tokenizer } + c:=current_scanner^.asmgetchar; + gettoken; + { main loop } + repeat + case actasmtoken of + AS_LLABEL: + Begin + if CreateLocalLabel(actasmpattern,hl,true) then + ConcatLabel(curlist,hl); + Consume(AS_LLABEL); + end; + + AS_LABEL: + Begin + if SearchLabel(upper(actasmpattern),hl,true) then + ConcatLabel(curlist,hl) + else + Message1(asmr_e_unknown_label_identifier,actasmpattern); + Consume(AS_LABEL); + end; + + AS_DW : + Begin + inexpression:=true; + Consume(AS_DW); + BuildConstant($ffff); + inexpression:=false; + end; + + AS_DB : + Begin + inexpression:=true; + Consume(AS_DB); + BuildConstant($ff); + inexpression:=false; + end; + + AS_DD : + Begin + inexpression:=true; + Consume(AS_DD); + BuildConstant($ffffffff); + inexpression:=false; + end; + + AS_OPCODE : + Begin + instr.init; + instr.BuildOpcode; + { We need AT&T style operands } + instr.SwapOperands; + { Must be done with args in ATT order } + instr.CheckNonCommutativeOpcodes; + instr.AddReferenceSizes; + instr.SetInstructionOpsize; + instr.CheckOperandSizes; + instr.ConcatInstruction(curlist); + instr.done; + end; + + AS_SEPARATOR : + Begin + Consume(AS_SEPARATOR); + end; + + AS_END : + break; { end assembly block } + + else + Begin + Message(asmr_e_syntax_error); + RecoverConsume(false); + end; + end; { end case } + until false; + { Check LocalLabelList } + LocalLabelList^.CheckEmitted; + dispose(LocalLabelList,Done); + { Return the list in an asmnode } + assemble:=genasmnode(curlist); + Message1(asmr_d_finish_reading,'intel'); +end; + + +{***************************************************************************** + Initialize +*****************************************************************************} + +var + old_exit : pointer; + +procedure ra386int_exit;{$ifndef FPC}far;{$endif} +begin + if assigned(iasmops) then + dispose(iasmops,done); + if assigned(iasmregs) then + dispose(iasmregs); + exitproc:=old_exit; +end; + + +begin + old_exit:=exitproc; + exitproc:=@ra386int_exit; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.76 2000/06/18 19:09:30 peter + * fixed + record.field expressions + + Revision 1.75 2000/06/18 18:07:06 peter + * use new illegal_char method + + Revision 1.74 2000/06/15 18:07:08 peter + * fix constant parsing which gave an error when constants were used + + Revision 1.73 2000/06/14 19:02:41 peter + * fixed TYPE with records and fields + * added TYPE support for ATT reader else it wouldn't be possible to + get the size of a type/variable + + Revision 1.72 2000/06/14 16:52:09 peter + * fixed reference parsing + + Revision 1.71 2000/05/23 20:36:28 peter + + typecasting support for variables, but be carefull as word,byte can't + be used because they are reserved assembler keywords + + Revision 1.70 2000/05/18 17:05:16 peter + * fixed size of const parameters in asm readers + + Revision 1.69 2000/05/12 21:57:02 pierre + + use of a dictionary object + for faster opcode searching in assembler readers + implemented by Kovacs Attila Zoltan + + Revision 1.68 2000/05/12 21:26:23 pierre + * fix the FDIV FDIVR FSUB FSUBR and popping equivalent + simply by swapping from reverse to normal and vice-versa + when passing from one syntax to the other ! + + Revision 1.67 2000/05/11 09:56:21 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.66 2000/05/09 11:56:26 pierre + * Issue an error if opcode is not found + + Revision 1.65 2000/05/08 13:23:04 peter + * fixed reference parsing + + Revision 1.64 2000/04/29 12:51:34 peter + * fixed offset support intel reader, the gotoffset variable was not + always reset + * moved check for local/para to be only used for varsym + + Revision 1.63 2000/03/28 22:11:48 pierre + + add a warning if esi is base and index in object assembler code + + Revision 1.62 2000/03/27 21:18:55 pierre + * "segss" prefix in Intel is converted into "ss" in ATT + and vice-versa. Fixes web bug 892. + + Revision 1.61 2000/03/15 23:10:01 pierre + * fix for bug 848 (that still genrated wrong code) + + better testing for variables used in assembler + (gives an error if variable is not directly reachable !) + + Revision 1.60 2000/03/02 11:48:31 pierre + * fix for bug 848 + + Revision 1.59 2000/02/13 22:46:28 florian + * fixed an internalerror with writeln + * fixed arrayconstructor_to_set to force the generation of better code + and added a more strict type checking + + Revision 1.58 2000/02/09 13:23:02 peter + * log truncated + + Revision 1.57 2000/01/07 01:14:36 peter + * updated copyright to 2000 + + Revision 1.56 1999/12/18 20:00:33 florian + * Bug reported by Marco fixed: Intel assembler reader: fld qword ptr x + was read as fldq x but it must be fldl x + + Revision 1.55 1999/12/01 12:42:32 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.54 1999/11/30 10:40:53 peter + + ttype, tsymlist + + Revision 1.53 1999/11/17 17:05:03 pierre + * Notes/hints changes + + Revision 1.52 1999/11/09 23:06:46 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.51 1999/11/06 14:34:24 peter + * truncated log to 20 revs + + Revision 1.50 1999/10/01 07:59:21 peter + * fixed object field parsing + + Revision 1.49 1999/09/27 23:44:58 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.48 1999/09/20 16:39:01 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.47 1999/09/15 20:35:43 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.46 1999/09/08 16:04:03 peter + * better support for object fields and more error checks for + field accesses which create buggy code + + Revision 1.45 1999/09/07 13:03:10 peter + * better OFFSET support for reference reading + + Revision 1.44 1999/09/07 07:45:41 peter + * TYPE support + + Revision 1.43 1999/08/13 21:28:36 peter + * more reference types support + * arraydef size returns elementsize, also for multiple indexing array + + Revision 1.42 1999/08/04 00:23:27 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.41 1999/07/24 11:17:16 peter + * suffix parsing for at&t fixed for things like movsbl + * string constants are now handle correctly and also allowed in + constant expressions + +} diff --git a/befpc/compiler/ra68kmot.pas b/befpc/compiler/ra68kmot.pas new file mode 100644 index 0000000..34ed20e --- /dev/null +++ b/befpc/compiler/ra68kmot.pas @@ -0,0 +1,2198 @@ +{ + $Id: ra68kmot.pas,v 1.1.1.1 2001-07-23 17:17:00 memson Exp $ + Copyright (c) 1998-2000 by Carl Eric Codere + + This unit does the parsing process for the motorola inline assembler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +Unit Ra68kMot; +{**********************************************************************} +{ WARNING } +{**********************************************************************} +{ Any modification in the order or removal of terms in the tables } +{ in m68k.pas and asmo68k.pas will BREAK the code in this unit, } +{ unless the appropriate changes are made to this unit. Addition } +{ of terms though, will not change the code herein. } +{**********************************************************************} + +{---------------------------------------------------------------------------} +{ LEFT TO DO } +{---------------------------------------------------------------------------} +{ o Add support for sized indexing such as in d0.l } +{ presently only (an,dn) is supported for indexing -- } +{ size defaults to LONG. } +{ o Add support for MC68020 opcodes. } +{ o Add support for MC68020 adressing modes. } +{ o Add operand checking with m68k opcode table in ConcatOpCode } +{ o Add Floating point support } +{---------------------------------------------------------------------------} + +Interface + +Uses + globtype,cpubase,tree; + + function assemble: ptree; + +const + { this variable is TRUE if the lookup tables have already been setup } + { for fast access. On the first call to assemble the tables are setup } + { and stay set up. } + _asmsorted: boolean = FALSE; + firstreg = R_D0; + lastreg = R_FPSR; + +type + tiasmops = array[firstop..lastop] of string[7]; + piasmops = ^tiasmops; + + tasmkeyword = string[6]; + +var + { sorted tables of opcodes } + iasmops: piasmops; + { uppercased tables of registers } + iasmregs: array[firstreg..lastreg] of string[6]; + + +Implementation + +uses + files,globals,systems,RAUtils,strings,hcodegen,scanner,aasm, + cobjects,verbose,symtable; + + +type + tmotorolatoken = ( + AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_HEXNUM,AS_OCTALNUM, + AS_BINNUM,AS_COMMA,AS_LBRACKET,AS_RBRACKET,AS_LPAREN, + AS_RPAREN,AS_COLON,AS_DOT,AS_PLUS,AS_MINUS,AS_STAR,AS_INTNUM, + AS_SEPARATOR,AS_ID,AS_REGISTER,AS_OPCODE,AS_SLASH,AS_APPT,AS_REALNUM, + AS_ALIGN, + {------------------ Assembler directives --------------------} + AS_DB,AS_DW,AS_DD,AS_XDEF,AS_END, + {------------------ Assembler Operators --------------------} + AS_MOD,AS_SHL,AS_SHR,AS_NOT,AS_AND,AS_OR,AS_XOR); + +const + firstdirective = AS_DB; + lastdirective = AS_END; + firstoperator = AS_MOD; + lastoperator = AS_XOR; + + _count_asmdirectives = longint(lastdirective)-longint(firstdirective); + _count_asmoperators = longint(lastoperator)-longint(firstoperator); + + _asmdirectives : array[0.._count_asmdirectives] of tasmkeyword = + ('DC.B','DC.W','DC.L','XDEF','END'); + + { problems with shl,shr,not,and,or and xor, they are } + { context sensitive. } + _asmoperators : array[0.._count_asmoperators] of tasmkeyword = ( + 'MOD','SHL','SHR','NOT','AND','OR','XOR'); + + +const + newline = #10; + firsttoken : boolean = TRUE; + operandnum : byte = 0; +var + p : paasmoutput; + actasmtoken: tmotorolatoken; + actasmpattern: string; + c: char; + Instr: TInstruction; + labellist: TAsmLabelList; + old_exit : pointer; + + Procedure SetupTables; + { creates uppercased symbol tables for speed access } + var + i: tasmop; + j: tregister; + Begin + Message(assem_d_creating_lookup_tables); + { opcodes } + new(iasmops); + for i:=firstop to lastop do + iasmops^[i] := upper(mot_op2str[i]); + { opcodes } + for j:=firstreg to lastreg do + iasmregs[j] := upper(mot_reg2str[j]); + end; + + + {---------------------------------------------------------------------} + { Routines for the tokenizing } + {---------------------------------------------------------------------} + + + function is_asmopcode(s: string):Boolean; + {*********************************************************************} + { FUNCTION is_asmopcode(s: string):Boolean } + { Description: Determines if the s string is a valid opcode } + { if so returns TRUE otherwise returns FALSE. } + { Remark: Suffixes are also checked, as long as they are valid. } + {*********************************************************************} + var + i: tasmop; + j: byte; + Begin + is_asmopcode := FALSE; + { first of all we remove the suffix } + j:=pos('.',s); + if j<>0 then + delete(s,j,2); + for i:=firstop to lastop do + begin + if s = iasmops^[i] then + begin + is_asmopcode:=TRUE; + exit; + end; + end; + end; + + + + Procedure is_asmdirective(const s: string; var token: tmotorolatoken); + {*********************************************************************} + { FUNCTION is_asmdirective(s: string; var token: tinteltoken):Boolean } + { Description: Determines if the s string is a valid directive } + { (an operator can occur in operand fields, while a directive cannot) } + { if so returns the directive token, otherwise does not change token.} + {*********************************************************************} + var + i:byte; + Begin + for i:=0 to _count_asmdirectives do + begin + if s=_asmdirectives[i] then + begin + token := tmotorolatoken(longint(firstdirective)+i); + exit; + end; + end; + end; + + + Procedure is_register(const s: string; var token: tmotorolatoken); + {*********************************************************************} + { PROCEDURE is_register(s: string; var token: tinteltoken); } + { Description: Determines if the s string is a valid register, if } + { so return token equal to A_REGISTER, otherwise does not change token} + {*********************************************************************} + Var + i: tregister; + Begin + for i:=firstreg to lastreg do + begin + if s=iasmregs[i] then + begin + token := AS_REGISTER; + exit; + end; + end; + { take care of other name for sp } + if s = 'A7' then + begin + token:=AS_REGISTER; + exit; + end; + end; + + + + Function GetToken: tmotorolatoken; + {*********************************************************************} + { FUNCTION GetToken: tinteltoken; } + { Description: This routine returns intel assembler tokens and } + { does some minor syntax error checking. } + {*********************************************************************} + var + j: integer; + token: tmotorolatoken; + forcelabel: boolean; + errorflag : boolean; + begin + errorflag := FALSE; + forcelabel := FALSE; + actasmpattern :=''; + {* INIT TOKEN TO NOTHING *} + token := AS_NONE; + { while space and tab , continue scan... } + while c in [' ',#9] do + c:=current_scanner^.asmgetchar; + current_scanner^.gettokenpos; + { Possiblities for first token in a statement: } + { Local Label, Label, Directive, Prefix or Opcode.... } + if firsttoken and not (c in [newline,#13,'{',';']) then + begin + + firsttoken := FALSE; + if c = '@' then + begin + token := AS_LLABEL; { this is a local label } + { Let us point to the next character } + c := current_scanner^.asmgetchar; + end; + + + + while c in ['A'..'Z','a'..'z','0'..'9','_','@','.'] do + begin + { if there is an at_sign, then this must absolutely be a label } + if c = '@' then forcelabel:=TRUE; + actasmpattern := actasmpattern + c; + c := current_scanner^.asmgetchar; + end; + + uppervar(actasmpattern); + + if c = ':' then + begin + case token of + AS_NONE: token := AS_LABEL; + AS_LLABEL: ; { do nothing } + end; { end case } + { let us point to the next character } + c := current_scanner^.asmgetchar; + gettoken := token; + exit; + end; + + { Are we trying to create an identifier with } + { an at-sign...? } + if forcelabel then + Message(assem_e_none_label_contain_at); + + If is_asmopcode(actasmpattern) then + Begin + gettoken := AS_OPCODE; + exit; + end; + is_asmdirective(actasmpattern, token); + if (token <> AS_NONE) then + Begin + gettoken := token; + exit + end + else + begin + gettoken := AS_NONE; + Message1(assem_e_invalid_operand,actasmpattern); + end; + end + else { else firsttoken } + { Here we must handle all possible cases } + begin + case c of + + '@': { possiblities : - local label reference , such as in jmp @local1 } + { - @Result, @Code or @Data special variables. } + begin + actasmpattern := c; + c:= current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_','@','.'] do + begin + actasmpattern := actasmpattern + c; + c := current_scanner^.asmgetchar; + end; + uppervar(actasmpattern); + gettoken := AS_ID; + exit; + end; + { identifier, register, opcode, prefix or directive } + 'A'..'Z','a'..'z','_': begin + actasmpattern := c; + c:= current_scanner^.asmgetchar; + while c in ['A'..'Z','a'..'z','0'..'9','_','.'] do + begin + actasmpattern := actasmpattern + c; + c := current_scanner^.asmgetchar; + end; + uppervar(actasmpattern); + + If is_asmopcode(actasmpattern) then + Begin + gettoken := AS_OPCODE; + exit; + end; + is_register(actasmpattern, token); + {is_asmoperator(actasmpattern,token);} + is_asmdirective(actasmpattern,token); + { if found } + if (token <> AS_NONE) then + begin + gettoken := token; + exit; + end + { this is surely an identifier } + else + token := AS_ID; + gettoken := token; + exit; + end; + { override operator... not supported } + '&': begin + c:=current_scanner^.asmgetchar; + gettoken := AS_AND; + end; + { string or character } + '''' : + begin + actasmpattern:=''; + while true do + begin + if c = '''' then + begin + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + repeat + if c=''''then + begin + c:=current_scanner^.asmgetchar; + if c='''' then + begin + actasmpattern:=actasmpattern+''''; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break; + end; + end + else break; + end + else + begin + actasmpattern:=actasmpattern+c; + c:=current_scanner^.asmgetchar; + if c=newline then + begin + Message(scan_f_string_exceeds_line); + break + end; + end; + until false; { end repeat } + end + else break; { end if } + end; { end while } + token:=AS_STRING; + gettoken := token; + exit; + end; + '$' : begin + c:=current_scanner^.asmgetchar; + while c in ['0'..'9','A'..'F','a'..'f'] do + begin + actasmpattern := actasmpattern + c; + c := current_scanner^.asmgetchar; + end; + gettoken := AS_HEXNUM; + exit; + end; + ',' : begin + gettoken := AS_COMMA; + c:=current_scanner^.asmgetchar; + exit; + end; + '(' : begin + gettoken := AS_LPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + ')' : begin + gettoken := AS_RPAREN; + c:=current_scanner^.asmgetchar; + exit; + end; + ':' : begin + gettoken := AS_COLON; + c:=current_scanner^.asmgetchar; + exit; + end; +{ '.' : begin + gettoken := AS_DOT; + c:=current_scanner^.asmgetchar; + exit; + end; } + '+' : begin + gettoken := AS_PLUS; + c:=current_scanner^.asmgetchar; + exit; + end; + '-' : begin + gettoken := AS_MINUS; + c:=current_scanner^.asmgetchar; + exit; + end; + '*' : begin + gettoken := AS_STAR; + c:=current_scanner^.asmgetchar; + exit; + end; + '/' : begin + gettoken := AS_SLASH; + c:=current_scanner^.asmgetchar; + exit; + end; + '<' : begin + c := current_scanner^.asmgetchar; + { invalid characters } + if c <> '<' then + Message(assem_e_invalid_char_smaller); + { still assume << } + gettoken := AS_SHL; + c := current_scanner^.asmgetchar; + exit; + end; + '>' : begin + c := current_scanner^.asmgetchar; + { invalid characters } + if c <> '>' then + Message(assem_e_invalid_char_greater); + { still assume << } + gettoken := AS_SHR; + c := current_scanner^.asmgetchar; + exit; + end; + '|' : begin + gettoken := AS_OR; + c := current_scanner^.asmgetchar; + exit; + end; + '^' : begin + gettoken := AS_XOR; + c := current_scanner^.asmgetchar; + exit; + end; + '#' : begin + gettoken:=AS_APPT; + c:=current_scanner^.asmgetchar; + exit; + end; + '%' : begin + c:=current_scanner^.asmgetchar; + while c in ['0','1'] do + Begin + actasmpattern := actasmpattern + c; + c := current_scanner^.asmgetchar; + end; + gettoken := AS_BINNUM; + exit; + end; + { integer number } + '0'..'9': begin + actasmpattern := c; + c := current_scanner^.asmgetchar; + while c in ['0'..'9'] do + Begin + actasmpattern := actasmpattern + c; + c:= current_scanner^.asmgetchar; + end; + gettoken := AS_INTNUM; + exit; + end; + ';' : begin + repeat + c:=current_scanner^.asmgetchar; + until c=newline; + firsttoken := TRUE; + gettoken:=AS_SEPARATOR; + end; + + '{',#13,newline : begin + c:=current_scanner^.asmgetchar; + firsttoken := TRUE; + gettoken:=AS_SEPARATOR; + end; + else + Begin + Message(scan_f_illegal_char); + end; + + end; { end case } + end; { end else if } + end; + + + {---------------------------------------------------------------------} + { Routines for the parsing } + {---------------------------------------------------------------------} + + procedure consume(t : tmotorolatoken); + + begin + if t<>actasmtoken then + Message(assem_e_syntax_error); + actasmtoken:=gettoken; + { if the token must be ignored, then } + { get another token to parse. } + if actasmtoken = AS_NONE then + actasmtoken := gettoken; + end; + + + + + + function findregister(const s : string): tregister; + {*********************************************************************} + { FUNCTION findregister(s: string):tasmop; } + { Description: Determines if the s string is a valid register, } + { if so returns correct tregister token, or R_NO if not found. } + {*********************************************************************} + var + i: tregister; + begin + findregister := R_NO; + for i:=firstreg to lastreg do + if s = iasmregs[i] then + Begin + findregister := i; + exit; + end; + if s = 'A7' then + Begin + findregister := R_SP; + exit; + end; + end; + + + function findopcode(s: string): tasmop; + {*********************************************************************} + { FUNCTION findopcode(s: string): tasmop; } + { Description: Determines if the s string is a valid opcode } + { if so returns correct tasmop token. } + {*********************************************************************} + var + i: tasmop; + j: byte; + op_size: string; + Begin + findopcode := A_NONE; + j:=pos('.',s); + if j<>0 then + begin + op_size:=copy(s,j+1,1); + case op_size[1] of + { For the motorola only stropsize size is used to } + { determine the size of the operands. } + 'B': instr.stropsize := S_B; + 'W': instr.stropsize := S_W; + 'L': instr.stropsize := S_L; + 'S': instr.stropsize := S_FS; + 'D': instr.stropsize := S_FL; + 'X': instr.stropsize := S_FX; + else + Message1(assem_e_invalid_opcode,s); + end; + { delete everything starting from dot } + delete(s,j,length(s)); + end; + for i:=firstop to lastop do + if s = iasmops^[i] then + begin + findopcode:=i; + exit; + end; + end; + + Procedure InitAsmRef(var instr: TInstruction); + {*********************************************************************} + { Description: This routine first check if the instruction is of } + { type OPR_NONE, or OPR_REFERENCE , if not it gives out an error. } + { If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up } + { the operand type to OPR_REFERENCE, as well as setting up the ref } + { to point to the default segment. } + {*********************************************************************} + Begin + With instr do + Begin + case operands[operandnum].operandtype of + OPR_REFERENCE: exit; + OPR_NONE: ; + else + Message(assem_e_invalid_operand_type); + end; + operands[operandnum].ref.direction := dir_none; + operands[operandnum].operandtype := OPR_REFERENCE; + operands[operandnum].ref.segment := R_DEFAULT_SEG; + end; + end; + + + + + Function CalculateExpression(expression: string): longint; + var + expr: TExprParse; + Begin + expr.Init; + CalculateExpression := expr.Evaluate(expression); + expr.Done; + end; + + + Procedure ConcatOpCode(var instr: TInstruction); + var + fits : boolean; + i: longint; + opsize: topsize; + optyp1, optyp2, optyp3: longint; + instruc: tasmop; + op: tasmop; + Begin + fits := FALSE; + { setup specific instructions for first pass } + instruc := instr.getinstruction; + + { Setup special operands } + { Convert to general form as to conform to the m68k opcode table } + if (instruc = A_ADDA) or (instruc = A_ADDI) + then instruc := A_ADD + else + { CMPM excluded because of GAS v1.34 BUG } + if (instruc = A_CMPA) or + (instruc = A_CMPI) then + instruc := A_CMP + else + if instruc = A_EORI then + instruc := A_EOR + else + if instruc = A_MOVEA then + instruc := A_MOVE + else + if instruc = A_ORI then + instruc := A_OR + else + if (instruc = A_SUBA) or (instruc = A_SUBI) then + instruc := A_SUB; + + { Setup operand types } + +(* + in instruc <> A_MOVEM then + Begin + + while not(fits) do + begin + { set the instruction cache, if the instruction } + { occurs the first time } + if (it[i].i=instruc) and (ins_cache[instruc]=-1) then + ins_cache[instruc]:=i; + + if (it[i].i=instruc) and (instr.numops=it[i].ops) then + begin + { first fit } + case instr.numops of + 0 : begin + fits:=true; + break; + end; + 1 : + Begin + if (optyp1 and it[i].o1)<>0 then + Begin + fits:=true; + break; + end; + end; + 2 : if ((optyp1 and it[i].o1)<>0) and + ((optyp2 and it[i].o2)<>0) then + Begin + fits:=true; + break; + end + 3 : if ((optyp1 and it[i].o1)<>0) and + ((optyp2 and it[i].o2)<>0) and + ((optyp3 and it[i].o3)<>0) then + Begin + fits:=true; + break; + end; + end; { end case } + end; { endif } + if it[i].i=A_NONE then + begin + { NO MATCH! } + Message(assem_e_invalid_combination_opcode_and_operand); + exit; + end; + inc(i); + end; { end while } + *) + fits:=TRUE; + + { We add the opcode to the opcode linked list } + if fits then + Begin + case instr.numops of + + 0: + if instr.stropsize <> S_NO then + p^.concat(new(pai68k,op_none(instruc,instr.stropsize))) + else + p^.concat(new(pai68k,op_none(instruc,S_NO))); + 1: Begin + case instr.operands[1].operandtype of + OPR_SYMBOL: Begin + p^.concat(new(pai68k,op_ref(instruc, + instr.stropsize, newreference(instr.operands[1].ref)))); + end; + OPR_CONSTANT: Begin + p^.concat(new(pai68k,op_const(instruc, + instr.stropsize, instr.operands[1].val))); + end; + OPR_REGISTER: p^.concat(new(pai68k,op_reg(instruc, + instr.stropsize,instr.operands[1].reg))); + OPR_REFERENCE: + if instr.stropsize <> S_NO then + Begin + p^.concat(new(pai68k,op_ref(instruc, + instr.stropsize,newreference(instr.operands[1].ref)))); + end + else + Begin + { special jmp and call case with } + { symbolic references. } + if instruc in [A_BSR,A_JMP,A_JSR,A_BRA,A_PEA] then + Begin + p^.concat(new(pai68k,op_ref(instruc, + S_NO,newreference(instr.operands[1].ref)))); + end + else + Message(assem_e_invalid_opcode_and_operand); + end; + OPR_NONE: Begin + Message(assem_f_internal_error_in_concatopcode); + end; + else + Begin + Message(assem_f_internal_error_in_concatopcode); + end; + end; + end; + 2: + Begin + With instr do + Begin + { source } + case operands[1].operandtype of + { reg,reg } + { reg,ref } + OPR_REGISTER: + Begin + case operands[2].operandtype of + OPR_REGISTER: + Begin + p^.concat(new(pai68k,op_reg_reg(instruc, + stropsize,operands[1].reg,operands[2].reg))); + end; + OPR_REFERENCE: + p^.concat(new(pai68k,op_reg_ref(instruc, + stropsize,operands[1].reg,newreference(operands[2].ref)))); + else { else case } + Begin + Message(assem_f_internal_error_in_concatopcode); + end; + end; { end inner case } + end; + { reglist, ref } + OPR_REGLIST: + Begin + case operands[2].operandtype of + OPR_REFERENCE : + p^.concat(new(pai68k,op_reglist_ref(instruc, + stropsize,operands[1].list,newreference(operands[2].ref)))); + else + Begin + Message(assem_f_internal_error_in_concatopcode); + end; + end; { end case } + end; + + { const,reg } + { const,const } + { const,ref } + OPR_CONSTANT: + case instr.operands[2].operandtype of + { constant, constant does not have a specific size. } + OPR_CONSTANT: + p^.concat(new(pai68k,op_const_const(instruc, + S_NO,operands[1].val,operands[2].val))); + OPR_REFERENCE: + Begin + p^.concat(new(pai68k,op_const_ref(instruc, + stropsize,operands[1].val, + newreference(operands[2].ref)))) + end; + OPR_REGISTER: + Begin + p^.concat(new(pai68k,op_const_reg(instruc, + stropsize,operands[1].val, + operands[2].reg))) + end; + else + Begin + Message(assem_f_internal_error_in_concatopcode); + end; + end; { end case } + { ref,reg } + { ref,ref } + OPR_REFERENCE: + case instr.operands[2].operandtype of + OPR_REGISTER: + Begin + p^.concat(new(pai68k,op_ref_reg(instruc, + stropsize,newreference(operands[1].ref), + operands[2].reg))); + end; + OPR_REGLIST: + Begin + p^.concat(new(pai68k,op_ref_reglist(instruc, + stropsize,newreference(operands[1].ref), + operands[2].list))); + end; + OPR_REFERENCE: { special opcodes } + p^.concat(new(pai68k,op_ref_ref(instruc, + stropsize,newreference(operands[1].ref), + newreference(operands[2].ref)))); + else + Begin + Message(assem_f_internal_error_in_concatopcode); + end; + end; { end inner case } + end; { end case } + end; { end with } + end; + 3: Begin + if (instruc = A_DIVSL) or (instruc = A_DIVUL) or (instruc = A_MULU) + or (instruc = A_MULS) or (instruc = A_DIVS) or (instruc = A_DIVU) then + Begin + if (instr.operands[1].operandtype <> OPR_REGISTER) + or (instr.operands[2].operandtype <> OPR_REGISTER) + or (instr.operands[3].operandtype <> OPR_REGISTER) then + Begin + Message(assem_f_internal_error_in_concatopcode); + end + else + Begin + p^.concat(new(pai68k, op_reg_reg_reg(instruc,instr.stropsize, + instr.operands[1].reg,instr.operands[2].reg,instr.operands[3].reg))); + end; + end + else + Message(assem_e_unsupported_opcode); + end; + end; { end case } + end; + end; + + + Procedure ConcatLabeledInstr(var instr: TInstruction); + Begin + if ((instr.getinstruction >= A_BCC) and (instr.getinstruction <= A_BVS)) + or (instr.getinstruction = A_BRA) or (instr.getinstruction = A_BSR) + or (instr.getinstruction = A_JMP) or (instr.getinstruction = A_JSR) + or ((instr.getinstruction >= A_FBEQ) and (instr.getinstruction <= A_FBNGLE)) + then + Begin + if instr.numops > 2 then + Message(assem_e_invalid_opcode) + else if instr.operands[1].operandtype <> OPR_LABINSTR then + Message(assem_e_invalid_opcode) + else if (instr.operands[1].operandtype = OPR_LABINSTR) and + (instr.numops = 1) then + if assigned(instr.operands[1].hl) then + ConcatLabel(p,instr.getinstruction, instr.operands[1].hl) + else + Message(assem_f_internal_error_in_findtype); + end + else + if ((instr.getinstruction >= A_DBCC) and (instr.getinstruction <= A_DBF)) + or ((instr.getinstruction >= A_FDBEQ) and (instr.getinstruction <= A_FBDNGLE)) then + begin + p^.concat(new(pai_labeled,init_reg(instr.getinstruction,instr.operands[2].hl, + instr.operands[1].reg))); + end + else + Message(assem_e_invalid_operand); + end; + + + + + + Function BuildExpression: longint; + {*********************************************************************} + { FUNCTION BuildExpression: longint } + { Description: This routine calculates a constant expression to } + { a given value. The return value is the value calculated from } + { the expression. } + { The following tokens (not strings) are recognized: } + { (,),SHL,SHR,/,*,NOT,OR,XOR,AND,MOD,+/-,numbers,ID to constants. } + {*********************************************************************} + { ENTRY: On entry the token should be any valid expression token. } + { EXIT: On Exit the token points to either COMMA or SEPARATOR } + { ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming } + { invalid tokens. } + {*********************************************************************} + var expr: string; + tempstr: string; + l : longint; + errorflag: boolean; + Begin + errorflag := FALSE; + expr := ''; + tempstr := ''; + Repeat + Case actasmtoken of + AS_LPAREN: Begin + Consume(AS_LPAREN); + expr := expr + '('; + end; + AS_RPAREN: Begin + Consume(AS_RPAREN); + expr := expr + ')'; + end; + AS_SHL: Begin + Consume(AS_SHL); + expr := expr + '<'; + end; + AS_SHR: Begin + Consume(AS_SHR); + expr := expr + '>'; + end; + AS_SLASH: Begin + Consume(AS_SLASH); + expr := expr + '/'; + end; + AS_MOD: Begin + Consume(AS_MOD); + expr := expr + '%'; + end; + AS_STAR: Begin + Consume(AS_STAR); + expr := expr + '*'; + end; + AS_PLUS: Begin + Consume(AS_PLUS); + expr := expr + '+'; + end; + AS_MINUS: Begin + Consume(AS_MINUS); + expr := expr + '-'; + end; + AS_AND: Begin + Consume(AS_AND); + expr := expr + '&'; + end; + AS_NOT: Begin + Consume(AS_NOT); + expr := expr + '~'; + end; + AS_XOR: Begin + Consume(AS_XOR); + expr := expr + '^'; + end; + AS_OR: Begin + Consume(AS_OR); + expr := expr + '|'; + end; + AS_ID: Begin + if NOT SearchIConstant(actasmpattern,l) then + Begin + Message1(assem_e_invalid_const_symbol,actasmpattern); + l := 0; + end; + str(l, tempstr); + expr := expr + tempstr; + Consume(AS_ID); + end; + AS_INTNUM: Begin + expr := expr + actasmpattern; + Consume(AS_INTNUM); + end; + AS_BINNUM: Begin + tempstr := BinaryToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_bin); + expr:=expr+tempstr; + Consume(AS_BINNUM); + end; + + AS_HEXNUM: Begin + tempstr := HexToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_hex); + expr:=expr+tempstr; + Consume(AS_HEXNUM); + end; + AS_OCTALNUM: Begin + tempstr := OctalToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_octal); + expr:=expr+tempstr; + Consume(AS_OCTALNUM); + end; + { go to next term } + AS_COMMA: Begin + if not ErrorFlag then + BuildExpression := CalculateExpression(expr) + else + BuildExpression := 0; + Exit; + end; + { go to next symbol } + AS_SEPARATOR: Begin + if not ErrorFlag then + BuildExpression := CalculateExpression(expr) + else + BuildExpression := 0; + Exit; + end; + else + Begin + { only write error once. } + if not errorflag then + Message(assem_e_invalid_constant_expression); + { consume tokens until we find COMMA or SEPARATOR } + Consume(actasmtoken); + errorflag := TRUE; + End; + end; + Until false; + end; + + + Procedure BuildRealConstant(typ : tfloattype); + {*********************************************************************} + { PROCEDURE BuilRealConst } + { Description: This routine calculates a constant expression to } + { a given value. The return value is the value calculated from } + { the expression. } + { The following tokens (not strings) are recognized: } + { +/-,numbers and real numbers } + {*********************************************************************} + { ENTRY: On entry the token should be any valid expression token. } + { EXIT: On Exit the token points to either COMMA or SEPARATOR } + { ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming } + { invalid tokens. } + {*********************************************************************} + var expr: string; + tempstr: string; + r : extended; + code : word; + negativ : boolean; + errorflag: boolean; + Begin + errorflag := FALSE; + Repeat + negativ:=false; + expr := ''; + tempstr := ''; + if actasmtoken=AS_PLUS then Consume(AS_PLUS) + else if actasmtoken=AS_MINUS then + begin + negativ:=true; + consume(AS_MINUS); + end; + Case actasmtoken of + AS_INTNUM: Begin + expr := actasmpattern; + Consume(AS_INTNUM); + end; + AS_REALNUM: Begin + expr := actasmpattern; + { in ATT syntax you have 0d in front of the real } + { should this be forced ? yes i think so, as to } + { conform to gas as much as possible. } + if (expr[1]='0') and (upper(expr[2])='D') then + expr:=copy(expr,3,255); + Consume(AS_REALNUM); + end; + AS_BINNUM: Begin + { checking for real constants with this should use } + { real DECODING otherwise the compiler will crash! } + Message(assem_w_float_bin_ignored); + Consume(AS_BINNUM); + end; + + AS_HEXNUM: Begin + { checking for real constants with this should use } + { real DECODING otherwise the compiler will crash! } + Message(assem_w_float_hex_ignored); + Consume(AS_HEXNUM); + end; + AS_OCTALNUM: Begin + { checking for real constants with this should use } + { real DECODING otherwise the compiler will crash! } + { xxxToDec using reals could be a solution, but the } + { problem is that these will crash the m68k compiler } + { when compiling -- because of lack of good fpu } + { support. } + Message(assem_w_float_octal_ignored); + Consume(AS_OCTALNUM); + end; + else + Begin + { only write error once. } + if not errorflag then + Message(assem_e_invalid_real_const); + { consume tokens until we find COMMA or SEPARATOR } + Consume(actasmtoken); + errorflag := TRUE; + End; + + end; + { go to next term } + if (actasmtoken=AS_COMMA) or (actasmtoken=AS_SEPARATOR) then + Begin + if negativ then expr:='-'+expr; + val(expr,r,code); + if code<>0 then + Begin + r:=0; + Message(assem_e_invalid_real_const); + ConcatRealConstant(p,r,typ); + End + else + Begin + ConcatRealConstant(p,r,typ); + End; + end + else + Message(assem_e_invalid_real_const); + Until actasmtoken=AS_SEPARATOR; + end; + + + + Procedure BuildScaling(Var instr: TInstruction); + {*********************************************************************} + { Takes care of parsing expression starting from the scaling value } + { up to and including possible field specifiers. } + { EXIT CONDITION: On exit the routine should point to AS_SEPARATOR } + { or AS_COMMA. On entry should point to the AS_STAR token. } + {*********************************************************************} + var str:string; + l: longint; + code: integer; + Begin + Consume(AS_STAR); + if (instr.operands[operandnum].ref.scalefactor <> 0) + and (instr.operands[operandnum].ref.scalefactor <> 1) then + Message(assem_f_internal_error_in_buildscale); + case actasmtoken of + AS_INTNUM: str := actasmpattern; + AS_HEXNUM: str := HexToDec(actasmpattern); + AS_BINNUM: str := BinaryToDec(actasmpattern); + AS_OCTALNUM: str := OctalToDec(actasmpattern); + else + Message(assem_e_syntax_error); + end; + val(str, l, code); + if code <> 0 then + Message(assem_e_invalid_scaling_factor); + if ((l = 2) or (l = 4) or (l = 8) or (l = 1)) and (code = 0) then + begin + instr.operands[operandnum].ref.scalefactor := l; + end + else + Begin + Message(assem_e_invalid_scaling_value); + instr.operands[operandnum].ref.scalefactor := 0; + end; + if instr.operands[operandnum].ref.index = R_NO then + Begin + Message(assem_e_scaling_value_only_allowed_with_index); + instr.operands[operandnum].ref.scalefactor := 0; + end; + { Consume the scaling number } + Consume(actasmtoken); + if actasmtoken = AS_RPAREN then + Consume(AS_RPAREN) + else + Message(assem_e_invalid_scaling_value); + { // .Field.Field ... or separator/comma // } + if actasmtoken in [AS_COMMA,AS_SEPARATOR] then + Begin + end + else + Message(assem_e_syntax_error); + end; + + + Function BuildRefExpression: longint; + {*********************************************************************} + { FUNCTION BuildExpression: longint } + { Description: This routine calculates a constant expression to } + { a given value. The return value is the value calculated from } + { the expression. } + { The following tokens (not strings) are recognized: } + { SHL,SHR,/,*,NOT,OR,XOR,AND,MOD,+/-,numbers,ID to constants. } + {*********************************************************************} + { ENTRY: On entry the token should be any valid expression token. } + { EXIT: On Exit the token points to the LPAREN token. } + { ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming } + { invalid tokens. } + {*********************************************************************} + var tempstr: string; + expr: string; + l : longint; + errorflag : boolean; + Begin + errorflag := FALSE; + tempstr := ''; + expr := ''; + Repeat + Case actasmtoken of + AS_RPAREN: Begin + Message(assem_e_parenthesis_are_not_allowed); + Consume(AS_RPAREN); + end; + AS_SHL: Begin + Consume(AS_SHL); + expr := expr + '<'; + end; + AS_SHR: Begin + Consume(AS_SHR); + expr := expr + '>'; + end; + AS_SLASH: Begin + Consume(AS_SLASH); + expr := expr + '/'; + end; + AS_MOD: Begin + Consume(AS_MOD); + expr := expr + '%'; + end; + AS_STAR: Begin + Consume(AS_STAR); + expr := expr + '*'; + end; + AS_PLUS: Begin + Consume(AS_PLUS); + expr := expr + '+'; + end; + AS_MINUS: Begin + Consume(AS_MINUS); + expr := expr + '-'; + end; + AS_AND: Begin + Consume(AS_AND); + expr := expr + '&'; + end; + AS_NOT: Begin + Consume(AS_NOT); + expr := expr + '~'; + end; + AS_XOR: Begin + Consume(AS_XOR); + expr := expr + '^'; + end; + AS_OR: Begin + Consume(AS_OR); + expr := expr + '|'; + end; + { End of reference } + AS_LPAREN: Begin + if not ErrorFlag then + BuildRefExpression := CalculateExpression(expr) + else + BuildRefExpression := 0; + { no longer in an expression } + exit; + end; + AS_ID: + Begin + if NOT SearchIConstant(actasmpattern,l) then + Begin + Message1(assem_e_invalid_const_symbol,actasmpattern); + l := 0; + end; + str(l, tempstr); + expr := expr + tempstr; + Consume(AS_ID); + end; + AS_INTNUM: Begin + expr := expr + actasmpattern; + Consume(AS_INTNUM); + end; + AS_BINNUM: Begin + tempstr := BinaryToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_bin); + expr:=expr+tempstr; + Consume(AS_BINNUM); + end; + + AS_HEXNUM: Begin + tempstr := HexToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_hex); + expr:=expr+tempstr; + Consume(AS_HEXNUM); + end; + AS_OCTALNUM: Begin + tempstr := OctalToDec(actasmpattern); + if tempstr = '' then + Message(assem_f_error_converting_octal); + expr:=expr+tempstr; + Consume(AS_OCTALNUM); + end; + else + Begin + { write error only once. } + if not errorflag then + Message(assem_e_invalid_constant_expression); + BuildRefExpression := 0; + if actasmtoken in [AS_COMMA,AS_SEPARATOR] then exit; + { consume tokens until we find COMMA or SEPARATOR } + Consume(actasmtoken); + errorflag := TRUE; + end; + end; + Until false; + end; + + + Procedure BuildReference(var Instr: TInstruction); + {*********************************************************************} + { PROCEDURE BuildBracketExpression } + { Description: This routine builds up an expression after a LPAREN } + { token is encountered. } + { On entry actasmtoken should be equal to AS_LPAREN } + {*********************************************************************} + { EXIT CONDITION: On exit the routine should point to either the } + { AS_COMMA or AS_SEPARATOR token. } + {*********************************************************************} + var + l:longint; + code: integer; + str: string; + Begin + Consume(AS_LPAREN); + Case actasmtoken of + { // (reg ... // } + AS_REGISTER: Begin + instr.operands[operandnum].ref.base := + findregister(actasmpattern); + Consume(AS_REGISTER); + { can either be a register or a right parenthesis } + { // (reg) // } + { // (reg)+ // } + if actasmtoken=AS_RPAREN then + Begin + Consume(AS_RPAREN); + if actasmtoken = AS_PLUS then + Begin + if (instr.operands[operandnum].ref.direction <> dir_none) then + Message(assem_e_no_inc_and_dec_together) + else + instr.operands[operandnum].ref.direction := dir_inc; + Consume(AS_PLUS); + end; + if not (actasmtoken in [AS_COMMA,AS_SEPARATOR]) then + Begin + Message(assem_e_invalid_reference); + { error recovery ... } + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + exit; + end; + { // (reg,reg .. // } + Consume(AS_COMMA); + if actasmtoken = AS_REGISTER then + Begin + instr.operands[operandnum].ref.index := + findregister(actasmpattern); + Consume(AS_REGISTER); + { check for scaling ... } + case actasmtoken of + AS_RPAREN: + Begin + Consume(AS_RPAREN); + if not (actasmtoken in [AS_COMMA,AS_SEPARATOR]) then + Begin + { error recovery ... } + Message(assem_e_invalid_reference); + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + exit; + end; + AS_STAR: + Begin + BuildScaling(instr); + end; + else + Begin + Message(assem_e_invalid_reference_syntax); + while (actasmtoken <> AS_SEPARATOR) do + Consume(actasmtoken); + end; + end; { end case } + end + else + Begin + Message(assem_e_invalid_reference_syntax); + while (actasmtoken <> AS_SEPARATOR) do + Consume(actasmtoken); + end; + end; + AS_HEXNUM,AS_OCTALNUM, { direct address } + AS_BINNUM,AS_INTNUM: Begin + case actasmtoken of + AS_INTNUM: str := actasmpattern; + AS_HEXNUM: str := HexToDec(actasmpattern); + AS_BINNUM: str := BinaryToDec(actasmpattern); + AS_OCTALNUM: str := OctalToDec(actasmpattern); + else + Message(assem_e_syntax_error); + end; + Consume(actasmtoken); + val(str, l, code); + if code <> 0 then + Message(assem_e_invalid_reference_syntax) + else + instr.operands[operandnum].ref.offset := l; + Consume(AS_RPAREN); + if not (actasmtoken in [AS_COMMA,AS_SEPARATOR]) then + Begin + { error recovery ... } + Message(assem_e_invalid_reference); + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + exit; + end; + else + Begin + + Message(assem_e_invalid_reference_syntax); + while (actasmtoken <> AS_SEPARATOR) do + Consume(actasmtoken); + end; + end; { end case } + end; + + + Procedure BuildOperand(var instr: TInstruction); + {*********************************************************************} + { EXIT CONDITION: On exit the routine should point to either the } + { AS_COMMA or AS_SEPARATOR token. } + {*********************************************************************} + var + tempstr: string; + expr: string; + lab: Pasmlabel; + l : longint; + i: tregister; + hl: plabel; + reg_one, reg_two: tregister; + reglist: set of tregister; + Begin + reglist := []; + tempstr := ''; + expr := ''; + case actasmtoken of + { // Memory reference // } + AS_LPAREN: + Begin + initAsmRef(instr); + BuildReference(instr); + end; + { // Constant expression // } + AS_APPT: Begin + Consume(AS_APPT); + if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then + Message(assem_e_invalid_operand_type); + { identifiers are handled by BuildExpression } + instr.operands[operandnum].operandtype := OPR_CONSTANT; + instr.operands[operandnum].val :=BuildExpression; + end; + { // Constant memory offset . // } + { // This must absolutely be followed by ( // } + AS_HEXNUM,AS_INTNUM, + AS_BINNUM,AS_OCTALNUM,AS_PLUS: + Begin + InitAsmRef(instr); + instr.operands[operandnum].ref.offset:=BuildRefExpression; + BuildReference(instr); + end; + { // A constant expression, or a Variable ref. // } + AS_ID: Begin + if actasmpattern[1] = '@' then + { // Label or Special symbol reference // } + Begin + if actasmpattern = '@RESULT' then + Begin + InitAsmRef(instr); + SetUpResult(instr,operandnum); + end + else + if (actasmpattern = '@CODE') or (actasmpattern = '@DATA') then + Message(assem_w_CODE_and_DATA_not_supported) + else + Begin + delete(actasmpattern,1,1); + if actasmpattern = '' then + Message(assem_e_null_label_ref_not_allowed); + lab := labellist.search(actasmpattern); + { check if the label is already defined } + { if so, we then check if the plabel is } + { non-nil, if so we add it to instruction } + if assigned(lab) then + Begin + if assigned(lab^.lab) then + Begin + instr.operands[operandnum].operandtype := OPR_LABINSTR; + instr.operands[operandnum].hl := lab^.lab; + instr.labeled := TRUE; + end; + end + else + { the label does not exist, create it } + { emit the opcode, but set that the } + { label has not been emitted } + Begin + getlabel(hl); + labellist.insert(actasmpattern,hl,FALSE); + instr.operands[operandnum].operandtype := OPR_LABINSTR; + instr.operands[operandnum].hl := hl; + instr.labeled := TRUE; + end; + end; + Consume(AS_ID); + if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then + Message(assem_e_syntax_error); + end + { probably a variable or normal expression } + { or a procedure (such as in CALL ID) } + else + Begin + { is it a constant ? } + if SearchIConstant(actasmpattern,l) then + Begin + InitAsmRef(instr); + instr.operands[operandnum].ref.offset:=BuildRefExpression; + BuildReference(instr); + +{ if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then + Message(assem_e_invalid_operand_type); + instr.operands[operandnum].operandtype := OPR_CONSTANT; + instr.operands[operandnum].val :=BuildExpression;} + end + else { is it a label variable ? } + Begin + { // ID[ , ID.Field.Field or simple ID // } + { check if this is a label, if so then } + { emit it as a label. } + if SearchLabel(actasmpattern,hl) then + Begin + instr.operands[operandnum].operandtype := OPR_LABINSTR; + instr.operands[operandnum].hl := hl; + instr.labeled := TRUE; + Consume(AS_ID); + if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then + Message(assem_e_syntax_error); + end + else + { is it a normal variable ? } + Begin + initAsmRef(instr); + if not CreateVarInstr(instr,actasmpattern,operandnum) then + Begin + { not a variable.. } + { check special variables.. } + if actasmpattern = 'SELF' then + { special self variable } + Begin + if assigned(procinfo^._class) then + Begin + instr.operands[operandnum].ref.offset := procinfo^.selfpointer_offset; + instr.operands[operandnum].ref.base := procinfo^.framepointer; + end + else + Message(assem_e_cannot_use_SELF_outside_a_method); + end + else + if (cs_compilesystem in aktmoduleswitches) then + Begin + if not assigned(instr.operands[operandnum].ref.symbol) then + Begin + instr.operands[operandnum].ref.symbol:=newpasstr(actasmpattern); + Message1(assem_w_id_supposed_external,actasmpattern); + end; + end + else + Message1(assem_e_unknown_id,actasmpattern); + end; + expr := actasmpattern; + Consume(AS_ID); + case actasmtoken of + AS_LPAREN: { indexing } + BuildReference(instr); + AS_SEPARATOR,AS_COMMA: ; + else + Message(assem_e_syntax_error); + end; + end; + end; + end; + end; + { // Pre-decrement mode reference or constant mem offset. // } + AS_MINUS: Begin + Consume(AS_MINUS); + if actasmtoken = AS_LPAREN then + Begin + InitAsmRef(instr); + { indicate pre-decrement mode } + instr.operands[operandnum].ref.direction := dir_dec; + BuildReference(instr); + end + else + if actasmtoken in [AS_OCTALNUM,AS_HEXNUM,AS_BINNUM,AS_INTNUM] then + Begin + InitAsmRef(instr); + instr.operands[operandnum].ref.offset:=BuildRefExpression; + { negate because was preceded by a negative sign! } + instr.operands[operandnum].ref.offset:=-instr.operands[operandnum].ref.offset; + BuildReference(instr); + end + else + Begin + Message(assem_e_syntax_error); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end; + end; + { // Register, a variable reference or a constant reference // } + AS_REGISTER: Begin + { save the type of register used. } + tempstr := actasmpattern; + Consume(AS_REGISTER); + { // Simple register // } + if (actasmtoken = AS_SEPARATOR) or (actasmtoken = AS_COMMA) then + Begin + if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_REGISTER]) then + Message(assem_e_invalid_operand_type); + instr.operands[operandnum].operandtype := OPR_REGISTER; + instr.operands[operandnum].reg := findregister(tempstr); + end + else + { HERE WE MUST HANDLE THE SPECIAL CASE OF MOVEM AND FMOVEM } + { // Individual register listing // } + if (actasmtoken = AS_SLASH) then + Begin + reglist := [findregister(tempstr)]; + Consume(AS_SLASH); + if actasmtoken = AS_REGISTER then + Begin + While not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Begin + case actasmtoken of + AS_REGISTER: Begin + reglist := reglist + [findregister(actasmpattern)]; + Consume(AS_REGISTER); + end; + AS_SLASH: Consume(AS_SLASH); + AS_SEPARATOR,AS_COMMA: break; + else + Begin + Message(assem_e_invalid_reg_list_in_movem); + Consume(actasmtoken); + end; + end; { end case } + end; { end while } + instr.operands[operandnum].operandtype:= OPR_REGLIST; + instr.operands[operandnum].list := reglist; + end + else + { error recovery ... } + Begin + Message(assem_e_invalid_reg_list_in_movem); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end; + end + else + { // Range register listing // } + if (actasmtoken = AS_MINUS) then + Begin + Consume(AS_MINUS); + reg_one:=findregister(tempstr); + if actasmtoken <> AS_REGISTER then + Begin + Message(assem_e_invalid_reg_list_in_movem); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end + else + Begin + { determine the register range ... } + reg_two:=findregister(actasmpattern); + if reg_one > reg_two then + begin + for i:=reg_two to reg_one do + reglist := reglist + [i]; + end + else + Begin + for i:=reg_one to reg_two do + reglist := reglist + [i]; + end; + Consume(AS_REGISTER); + if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then + Begin + Message(assem_e_invalid_reg_list_in_movem); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end; + { set up instruction } + instr.operands[operandnum].operandtype:= OPR_REGLIST; + instr.operands[operandnum].list := reglist; + end; + end + else + { DIVSL/DIVS/MULS/MULU with long for MC68020 only } + if (actasmtoken = AS_COLON) then + Begin + if (aktoptprocessor = MC68020) or (cs_compilesystem in aktmoduleswitches) then + Begin + Consume(AS_COLON); + if (actasmtoken = AS_REGISTER) then + Begin + { set up old field, since register is valid } + instr.operands[operandnum].operandtype := OPR_REGISTER; + instr.operands[operandnum].reg := findregister(tempstr); + Inc(operandnum); + instr.operands[operandnum].operandtype := OPR_REGISTER; + instr.operands[operandnum].reg := findregister(actasmpattern); + Consume(AS_REGISTER); + if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then + Begin + Message(assem_e_invalid_reg_list_for_opcode); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end; + end; + end + else + Begin + Message(assem_e_68020_mode_required); + if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then + Begin + Message(assem_e_invalid_reg_list_for_opcode); + while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + end; + end; + end + else + Message1(assem_e_syn_register,tempstr); + end; + AS_SEPARATOR, AS_COMMA: ; + else + Begin + Message(assem_e_syn_opcode_operand); + Consume(actasmtoken); + end; + end; { end case } + end; + + + + Procedure BuildConstant(maxvalue: longint); + {*********************************************************************} + { PROCEDURE BuildConstant } + { Description: This routine takes care of parsing a DB,DD,or DW } + { line and adding those to the assembler node. Expressions, range- } + { checking are fullly taken care of. } + { maxvalue: $ff -> indicates that this is a DB node. } + { $ffff -> indicates that this is a DW node. } + { $ffffffff -> indicates that this is a DD node. } + {*********************************************************************} + { EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. } + {*********************************************************************} + var + strlength: byte; + expr: string; + tempstr: string; + value : longint; + Begin + Repeat + Case actasmtoken of + AS_STRING: Begin + if maxvalue = $ff then + strlength := 1 + else + Message(assem_e_string_not_allowed_as_const); + expr := actasmpattern; + if length(expr) > 1 then + Message(assem_e_string_not_allowed_as_const); + Consume(AS_STRING); + Case actasmtoken of + AS_COMMA: Consume(AS_COMMA); + AS_SEPARATOR: ; + else + Message(assem_e_invalid_string_expression); + end; { end case } + ConcatString(p,expr); + end; + AS_INTNUM,AS_BINNUM, + AS_OCTALNUM,AS_HEXNUM: + Begin + value:=BuildExpression; + ConcatConstant(p,value,maxvalue); + end; + AS_ID: + Begin + value:=BuildExpression; + if value > maxvalue then + Begin + Message(assem_e_constant_out_of_bounds); + { assuming a value of maxvalue } + value := maxvalue; + end; + ConcatConstant(p,value,maxvalue); + end; + { These terms can start an assembler expression } + AS_PLUS,AS_MINUS,AS_LPAREN,AS_NOT: Begin + value := BuildExpression; + ConcatConstant(p,value,maxvalue); + end; + AS_COMMA: BEGIN + Consume(AS_COMMA); + END; + AS_SEPARATOR: ; + + else + Begin + Message(assem_f_internal_error_in_buildconstant); + end; + end; { end case } + Until actasmtoken = AS_SEPARATOR; + end; + + + Procedure BuildStringConstant(asciiz: boolean); + {*********************************************************************} + { PROCEDURE BuildStringConstant } + { Description: Takes care of a ASCII, or ASCIIZ directive. } + { asciiz: boolean -> if true then string will be null terminated. } + {*********************************************************************} + { EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. } + { On ENTRY: Token should point to AS_STRING } + {*********************************************************************} + var + expr: string; + errorflag : boolean; + Begin + errorflag := FALSE; + Repeat + Case actasmtoken of + AS_STRING: Begin + expr:=actasmpattern; + if asciiz then + expr:=expr+#0; + ConcatPasString(p,expr); + Consume(AS_STRING); + end; + AS_COMMA: BEGIN + Consume(AS_COMMA); + END; + AS_SEPARATOR: ; + else + Begin + Consume(actasmtoken); + if not errorflag then + Message(assem_e_invalid_string_expression); + errorflag := TRUE; + end; + end; { end case } + Until actasmtoken = AS_SEPARATOR; + end; + + + + + Procedure BuildOpCode; + {*********************************************************************} + { PROCEDURE BuildOpcode; } + { Description: Parses the intel opcode and operands, and writes it } + { in the TInstruction object. } + {*********************************************************************} + { EXIT CONDITION: On exit the routine should point to AS_SEPARATOR. } + { On ENTRY: Token should point to AS_OPCODE } + {*********************************************************************} + var asmtok: tasmop; + op: tasmop; + expr: string; + segreg: tregister; + Begin + expr := ''; + asmtok := A_NONE; { assmume no prefix } + segreg := R_NO; { assume no segment override } + + { // opcode // } + { allow for newline as in gas styled syntax } + { under DOS you get two AS_SEPARATOR !! } + while actasmtoken=AS_SEPARATOR do + Consume(AS_SEPARATOR); + if (actasmtoken <> AS_OPCODE) then + Begin + Message(assem_e_invalid_or_missing_opcode); + { error recovery } + While not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do + Consume(actasmtoken); + exit; + end + else + Begin + op := findopcode(actasmpattern); + instr.addinstr(op); + Consume(AS_OPCODE); + { // Zero operand opcode ? // } + if actasmtoken = AS_SEPARATOR then + exit + else + operandnum := 1; + end; + + While actasmtoken <> AS_SEPARATOR do + Begin + case actasmtoken of + { // Operand delimiter // } + AS_COMMA: Begin + if operandnum > MaxOperands then + Message(assem_e_too_many_operands) + else + Inc(operandnum); + Consume(AS_COMMA); + end; + { // End of asm operands for this opcode // } + AS_SEPARATOR: ; + else + BuildOperand(instr); + end; { end case } + end; { end while } + end; + + + + + Function Assemble: Ptree; + {*********************************************************************} + { PROCEDURE Assemble; } + { Description: Parses the att assembler syntax, parsing is done } + { according to GAs rules. } + {*********************************************************************} + Var + hl: plabel; + labelptr,nextlabel : pasmlabel; + commname : string; + store_p : paasmoutput; + + Begin + Message(assem_d_start_motorola); + firsttoken := TRUE; + operandnum := 0; + { sets up all opcode and register tables in uppercase } + if not _asmsorted then + Begin + SetupTables; + _asmsorted := TRUE; + end; + p:=new(paasmoutput,init); + { save pointer code section } + store_p:=p; + { setup label linked list } + labellist.init; + c:=current_scanner^.asmgetchar; + actasmtoken:=gettoken; + while actasmtoken<>AS_END do + Begin + case actasmtoken of + AS_LLABEL: Begin + labelptr := labellist.search(actasmpattern); + if not assigned(labelptr) then + Begin + getlabel(hl); + labellist.insert(actasmpattern,hl,TRUE); + ConcatLabel(p,A_LABEL,hl); + end + else + { the label has already been inserted into the } + { label list, either as an instruction label (in} + { this case it has not been emitted), or as a } + { duplicate local symbol (in this case it has } + { already been emitted). } + Begin + if labelptr^.emitted then + Message1(assem_e_dup_local_sym,'@'+labelptr^.name^) + else + Begin + if assigned(labelptr^.lab) then + ConcatLabel(p,A_LABEL,labelptr^.lab); + labelptr^.emitted := TRUE; + end; + end; + Consume(AS_LLABEL); + end; + AS_LABEL: Begin + { when looking for Pascal labels, these must } + { be in uppercase. } + if SearchLabel(upper(actasmpattern),hl) then + ConcatLabel(p,A_LABEL, hl) + else + Begin + Message1(assem_e_unknown_label_identifer,actasmpattern); + end; + Consume(AS_LABEL); + end; + AS_DW: Begin + Consume(AS_DW); + BuildConstant($ffff); + end; + AS_DB: Begin + Consume(AS_DB); + BuildConstant($ff); + end; + AS_DD: Begin + Consume(AS_DD); + BuildConstant($ffffffff); + end; + AS_XDEF: + Begin + { normal units should not be able to declare } + { direct label names like this... anyhow } + { procedural calls in asm blocks are } + { supposedely replaced automatically } + if (cs_compilesystem in aktmoduleswitches) then + begin + Consume(AS_XDEF); + if actasmtoken <> AS_ID then + Message(assem_e_invalid_global_def) + else + ConcatPublic(p,actasmpattern); + Consume(actasmtoken); + if actasmtoken <> AS_SEPARATOR then + Begin + Message(assem_e_line_separator_expected); + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + end + else + begin + Message(assem_w_xdef_not_supported); + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + end; + AS_ALIGN: Begin + Message(assem_w_align_not_supported); + while actasmtoken <> AS_SEPARATOR do + Consume(actasmtoken); + end; + AS_OPCODE: Begin + instr.init; + BuildOpcode; + instr.numops := operandnum; + if instr.labeled then + ConcatLabeledInstr(instr) + else + ConcatOpCode(instr); + instr.done; + end; + AS_SEPARATOR:Begin + Consume(AS_SEPARATOR); + { let us go back to the first operand } + operandnum := 0; + end; + AS_END: ; { end assembly block } + else + Begin + Message(assem_e_assemble_node_syntax_error); + { error recovery } + Consume(actasmtoken); + end; + end; { end case } + end; { end while } + { check if there were undefined symbols. } + { if so, then list each of those undefined } + { labels. } + if assigned(labellist.First) then + Begin + labelptr := labellist.First; + While labelptr <> nil do + Begin + nextlabel:=labelptr^.next; + if not labelptr^.emitted then + Message1(assem_e_local_sym_not_found_in_asm_statement,'@'+labelptr^.name^); + labelptr:=nextlabel; + end; + end; + assemble := genasmnode(p); + labellist.done; + Message(assem_d_finish_motorola); +end; + + + procedure ra68kmot_exit;{$ifndef FPC}far;{$endif} + begin + if assigned(iasmops) then + dispose(iasmops); + exitproc:=old_exit; + end; + + +Begin + old_exit:=exitproc; + exitproc:=@ra68kmot_exit; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/02/09 13:23:02 peter + * log truncated + + Revision 1.12 2000/01/07 01:14:37 peter + * updated copyright to 2000 + + Revision 1.11 1999/11/10 00:06:08 pierre + * adapted to procinfo as pointer + + Revision 1.10 1999/11/09 23:06:46 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.9 1999/09/16 23:05:56 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} + diff --git a/befpc/compiler/rautils.pas b/befpc/compiler/rautils.pas new file mode 100644 index 0000000..3df0d8e --- /dev/null +++ b/befpc/compiler/rautils.pas @@ -0,0 +1,1638 @@ +{ + $Id: rautils.pas,v 1.1.1.1 2001-07-23 17:17:00 memson Exp $ + Copyright (c) 1998-2000 by Carl Eric Codere and Peter Vreman + + This unit implements some support routines for assembler parsing + independent of the processor + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **********************************************************************} +Unit RAUtils; +Interface + +Uses + strings, + cobjects, + globtype,types,systems,verbose,globals,files, + symconst,symtable,aasm,cpubase,cpuasm +{$ifdef NEWCG} + ,cgbase +{$else} + ,hcodegen +{$endif} + ; + +Const + RPNMax = 10; { I think you only need 4, but just to be safe } + OpMax = 25; + + maxoperands = 3; { Maximum operands for assembler instructions } + + +{--------------------------------------------------------------------- + Local Label Management +---------------------------------------------------------------------} + +Type + { Each local label has this structure associated with it } + PLocalLabel = ^TLocalLabel; + TLocalLabel = object(TNamedIndexObject) + Emitted : boolean; + constructor Init(const n:string); + function Getpasmlabel:pasmlabel; + private + lab : pasmlabel; + end; + + PLocalLabelList = ^TLocalLabelList; + TLocalLabelList = Object(TDictionary) + procedure CheckEmitted; + end; + +var + LocalLabelList : PLocalLabelList; + +function CreateLocalLabel(const s: string; var hl: pasmlabel; emit:boolean):boolean; +Function SearchLabel(const s: string; var hl: pasmlabel;emit:boolean): boolean; + + +{--------------------------------------------------------------------- + Instruction management +---------------------------------------------------------------------} + +type + TOprType=(OPR_NONE,OPR_CONSTANT,OPR_SYMBOL,OPR_REFERENCE,OPR_REGISTER); + + TOprRec = record + case typ:TOprType of + OPR_NONE : (); + OPR_CONSTANT : (val:longint); + OPR_SYMBOL : (symbol:PAsmSymbol;symofs:longint); + OPR_REFERENCE : (ref:treference); + OPR_REGISTER : (reg:tregister); + end; + + POperand = ^TOperand; + TOperand = object + size : topsize; + hastype, { if the operand has typecasted variable } + hasvar : boolean; { if the operand is loaded with a variable } + opr : TOprRec; + constructor init; + destructor done;virtual; + Procedure BuildOperand;virtual; + Procedure SetSize(_size:longint;force:boolean); + Procedure SetCorrectSize(opcode:tasmop);virtual; + Function SetupResult:boolean; + Function SetupSelf:boolean; + Function SetupOldEBP:boolean; + Function SetupVar(const hs:string;GetOffset : boolean): Boolean; + Function SetupDirectVar(const hs:string): Boolean; + Procedure InitRef; + end; + + PInstruction = ^TInstruction; + TInstruction = object + opcode : tasmop; + opsize : topsize; + condition : tasmcond; + ops : byte; + operands : array[1..maxoperands] of POperand; + constructor init; + destructor done;virtual; + Procedure InitOperands;virtual; + Procedure BuildOpcode;virtual; + procedure ConcatInstruction(p:PAasmoutput);virtual; + Procedure SwapOperands; + end; + + + {---------------------------------------------------------------------} + { Expression parser types } + {---------------------------------------------------------------------} + + TExprOperator = record + ch: char; { operator } + is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not } + end; + + String15 = String[15]; + {**********************************************************************} + { The following operators are supported: } + { '+' : addition } + { '-' : subtraction } + { '*' : multiplication } + { '/' : modulo division } + { '^' : exclusive or } + { '<' : shift left } + { '>' : shift right } + { '&' : bitwise and } + { '|' : bitwise or } + { '~' : bitwise complement } + { '%' : modulo division } + { nnn: longint numbers } + { ( and ) parenthesis } + {**********************************************************************} + + TExprParse = Object + public + Constructor Init; + Destructor Done; + Function Evaluate(Expr: String): longint; + Function Priority(_Operator: Char): Integer; virtual; + private + RPNStack : Array[1..RPNMax] of longint; { Stack For RPN calculator } + RPNTop : Integer; + OpStack : Array[1..OpMax] of TExprOperator; { Operator stack For conversion } + OpTop : Integer; + Procedure RPNPush(Num: Longint); + Function RPNPop: Longint; + Procedure RPNCalc(token: String15; prefix: boolean); + Procedure OpPush(_Operator: char; prefix: boolean); + { In reality returns TExprOperaotr } + Procedure OpPop(var _Operator:TExprOperator); + end; + + { Evaluate an expression string to a longint } + Function CalculateExpression(const expression: string): longint; + + {---------------------------------------------------------------------} + { String routines } + {---------------------------------------------------------------------} + +Function ValDecimal(const S:String):longint; +Function ValOctal(const S:String):longint; +Function ValBinary(const S:String):longint; +Function ValHexaDecimal(const S:String):longint; +Function PadZero(Var s: String; n: byte): Boolean; +Function EscapeToPascal(const s:string): string; + +{--------------------------------------------------------------------- + Symbol helper routines +---------------------------------------------------------------------} + +Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean; +Function SearchType(const hs:string): Boolean; +Function SearchRecordType(const s:string): boolean; +Function SearchIConstant(const s:string; var l:longint): boolean; + + +{--------------------------------------------------------------------- + Instruction generation routines +---------------------------------------------------------------------} + + Procedure ConcatPasString(p : paasmoutput;s:string); + Procedure ConcatDirect(p : paasmoutput;s:string); + Procedure ConcatLabel(p: paasmoutput;var l : pasmlabel); + Procedure ConcatConstant(p : paasmoutput;value: longint; maxvalue: longint); + Procedure ConcatConstSymbol(p : paasmoutput;const sym:string;l:longint); + Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype); + Procedure ConcatString(p : paasmoutput;s:string); + procedure ConcatAlign(p:paasmoutput;l:longint); + Procedure ConcatPublic(p:paasmoutput;const s : string); + Procedure ConcatLocal(p:paasmoutput;const s : string); + Procedure ConcatGlobalBss(const s : string;size : longint); + Procedure ConcatLocalBss(const s : string;size : longint); + + +Implementation + + +{************************************************************************* + TExprParse +*************************************************************************} + +Constructor TExprParse.Init; +Begin +end; + + +Procedure TExprParse.RPNPush(Num : longint); +{ Add an operand to the top of the RPN stack } +begin + if RPNTop < RPNMax then + begin + Inc(RPNTop); + RPNStack[RPNTop]:=Num; + end + else + Message(asmr_e_expr_illegal); +end; + + +Function TExprParse.RPNPop : longint; +{ Get the operand at the top of the RPN stack } +begin + if RPNTop > 0 then + begin + RPNPop:=RPNStack[RPNTop]; + Dec(RPNTop); + end + else + Message(asmr_e_expr_illegal); +end; + + +Procedure TExprParse.RPNCalc(Token : String15; prefix:boolean); { RPN Calculator } +Var + Temp : longint; + LocalError : Integer; +begin + { Handle operators } + if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then + Case Token[1] of + '+' : + Begin + if not prefix then + RPNPush(RPNPop + RPNPop); + end; + '-' : + Begin + if prefix then + RPNPush(-(RPNPop)) + else + RPNPush(RPNPop - RPNPop); + end; + '*' : RPNPush(RPNPop * RPNPop); + '&' : RPNPush(RPNPop AND RPNPop); + '|' : RPNPush(RPNPop OR RPNPop); + '~' : RPNPush(NOT RPNPop); + '<' : RPNPush(RPNPop SHL RPNPop); + '>' : RPNPush(RPNPop SHR RPNPop); + '%' : + begin + Temp:=RPNPop; + if Temp <> 0 then + RPNPush(RPNPop mod Temp) + else + begin + Message(asmr_e_expr_zero_divide); + { push 1 for error recovery } + RPNPush(1); + end; + end; + '^' : RPNPush(RPNPop XOR RPNPop); + '/' : + begin + Temp:=RPNPop; + if Temp <> 0 then + RPNPush(RPNPop div Temp) + else + begin + Message(asmr_e_expr_zero_divide); + { push 1 for error recovery } + RPNPush(1); + end; + end; + end + else + begin + { Convert String to number and add to stack } + if token='-2147483648' then + begin + temp:=$80000000; + localerror:=0; + end + else + Val(Token, Temp, LocalError); + if LocalError = 0 then + RPNPush(Temp) + else + begin + Message(asmr_e_expr_illegal); + { push 1 for error recovery } + RPNPush(1); + end; + end; +end; + + +Procedure TExprParse.OpPush(_Operator : char;prefix: boolean); +{ Add an operator onto top of the stack } +begin + if OpTop < OpMax then + begin + Inc(OpTop); + OpStack[OpTop].ch:=_Operator; + OpStack[OpTop].is_prefix:=prefix; + end + else + Message(asmr_e_expr_illegal); +end; + + +Procedure TExprParse.OpPop(var _Operator:TExprOperator); +{ Get operator at the top of the stack } +begin + if OpTop > 0 then + begin + _Operator:=OpStack[OpTop]; + Dec(OpTop); + end + else + Message(asmr_e_expr_illegal); +end; + + +Function TExprParse.Priority(_Operator : Char) : Integer; +{ Return priority of operator } +{ The greater the priority, the higher the precedence } +begin + Case _Operator OF + '(' : + Priority:=0; + '+', '-' : + Priority:=1; + '*', '/','%','<','>' : + Priority:=2; + '|','&','^','~' : + Priority:=0; + else + Message(asmr_e_expr_illegal); + end; +end; + + +Function TExprParse.Evaluate(Expr : String):longint; +Var + I : Integer; + Token : String15; + opr : TExprOperator; +begin + Evaluate:=0; + { Reset stacks } + OpTop :=0; + RPNTop:=0; + Token :=''; + { nothing to do ? } + if Expr='' then + exit; + For I:=1 to Length(Expr) DO + begin + if Expr[I] in ['0'..'9'] then + begin { Build multi-digit numbers } + Token:=Token + Expr[I]; + if I = Length(Expr) then { Send last one to calculator } + RPNCalc(Token,false); + end + else + if Expr[I] in ['+', '-', '*', '/', '(', ')','^','&','|','%','~','<','>'] then + begin + if Token <> '' then + begin { Send last built number to calc. } + RPNCalc(Token,false); + Token:=''; + end; + + Case Expr[I] OF + '(' : OpPush('(',false); + ')' : begin + While OpStack[OpTop].ch <> '(' DO + Begin + OpPop(opr); + RPNCalc(opr.ch,opr.is_prefix); + end; + OpPop(opr); { Pop off and ignore the '(' } + end; + '+','-','~' : Begin + { workaround for -2147483648 } + if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then + begin + token:='-'; + expr[i]:='+'; + end; + { if start of expression then surely a prefix } + { or if previous char was also an operator } + if (I = 1) or (not (Expr[I-1] in ['0'..'9','(',')'])) then + OpPush(Expr[I],true) + else + Begin + { Evaluate all higher priority operators } + While (OpTop > 0) AND (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO + Begin + OpPop(opr); + RPNCalc(opr.ch,opr.is_prefix); + end; + OpPush(Expr[I],false); + End; + end; + '*', '/', + '^','|','&', + '%','<','>' : begin + While (OpTop > 0) and (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO + Begin + OpPop(opr); + RPNCalc(opr.ch,opr.is_prefix); + end; + OpPush(Expr[I],false); + end; + end; { Case } + end + else + Message(asmr_e_expr_illegal); { Handle bad input error } + end; + +{ Pop off the remaining operators } + While OpTop > 0 do + Begin + OpPop(opr); + RPNCalc(opr.ch,opr.is_prefix); + end; + +{ The result is stored on the top of the stack } + Evaluate:=RPNPop; +end; + + +Destructor TExprParse.Done; +Begin +end; + + +Function CalculateExpression(const expression: string): longint; +var + expr: TExprParse; +Begin + expr.Init; + CalculateExpression:=expr.Evaluate(expression); + expr.Done; +end; + + +{*************************************************************************} +{ String conversions/utils } +{*************************************************************************} + +Function EscapeToPascal(const s:string): string; +{ converts a C styled string - which contains escape } +{ characters to a pascal style string. } +var + i,len : longint; + hs : string; + temp : string; + c : char; +Begin + hs:=''; + len:=0; + i:=0; + while (i n then + Begin + PadZero:=FALSE; + delete(s,n+1,length(s)); + exit; + end + else + PadZero:=TRUE; + { Fill it up with the specified character } + fillchar(s[length(s)+1],n-1,#0); + s[0]:=chr(n); +end; + + +{**************************************************************************** + TOperand +****************************************************************************} + +constructor TOperand.init; +begin + size:=S_NO; + hastype:=false; + hasvar:=false; + FillChar(Opr,sizeof(Opr),0); +end; + + +destructor TOperand.done; +begin +end; + + +Procedure TOperand.SetCorrectSize(opcode:tasmop); +begin +end; + +Procedure TOperand.SetSize(_size:longint;force:boolean); +begin + if force or + ((size = S_NO) and (_size<=extended_size)) then + Begin + case _size of + 1 : size:=S_B; + 2 : size:=S_W{ could be S_IS}; + 4 : size:=S_L{ could be S_IL or S_FS}; + 8 : size:=S_IQ{ could be S_D or S_FL}; + extended_size : size:=S_FX; + end; + end; +end; + + +Function TOperand.SetupResult:boolean; +Begin + SetupResult:=false; + { replace by correct offset. } + if assigned(procinfo^.returntype.def) and + (procinfo^.returntype.def<>pdef(voiddef)) then + begin + opr.ref.offset:=procinfo^.return_offset; + opr.ref.base:= procinfo^.framepointer; + { always assume that the result is valid. } + procinfo^.funcret_state:=vs_assigned; + SetupResult:=true; + end + else + Message(asmr_e_void_function); +end; + + +Function TOperand.SetupSelf:boolean; +Begin + SetupSelf:=false; + if assigned(procinfo^._class) then + Begin + opr.typ:=OPR_REFERENCE; + opr.ref.offset:=procinfo^.selfpointer_offset; + opr.ref.base:=procinfo^.framepointer; + opr.ref.options:=ref_selffixup; + SetupSelf:=true; + end + else + Message(asmr_e_cannot_use_SELF_outside_a_method); +end; + + +Function TOperand.SetupOldEBP:boolean; +Begin + SetupOldEBP:=false; + if lexlevel>normal_function_level then + Begin + opr.typ:=OPR_REFERENCE; + opr.ref.offset:=procinfo^.framepointer_offset; + opr.ref.base:=procinfo^.framepointer; + SetupOldEBP:=true; + end + else + Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure); +end; + + +Function TOperand.SetupVar(const hs:string;GetOffset : boolean): Boolean; +{ search and sets up the correct fields in the Instr record } +{ for the NON-constant identifier passed to the routine. } +{ if not found returns FALSE. } +var + sym : psym; + harrdef : parraydef; +Begin + SetupVar:=false; +{ are we in a routine ? } + getsym(hs,false); + sym:=srsym; + if sym=nil then + exit; + case sym^.typ of + varsym : + begin + { we always assume in asm statements that } + { that the variable is valid. } + pvarsym(sym)^.varstate:=vs_used; + inc(pvarsym(sym)^.refs); + case pvarsym(sym)^.owner^.symtabletype of + objectsymtable : + begin + { this is not allowed, because we don't know if the self + register is still free, and loading it first is also + not possible, because this could break code } + { Be TP/Delphi compatible in Delphi or TP modes } + if (m_tp in aktmodeswitches) then + begin + opr.typ:=OPR_CONSTANT; + opr.val:=pvarsym(sym)^.address; + end + { I do not agree here people using method vars should ensure + that %esi is valid there } + else + begin + opr.ref.base:=self_pointer; + opr.ref.offset:=pvarsym(sym)^.address; + end; + hasvar:=true; + SetupVar:=true; + Exit; + end; + unitsymtable, + globalsymtable, + staticsymtable : + opr.ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname); + parasymtable : + begin + { if we only want the offset we don't have to care + the base will be zeroed after ! } + if (lexlevel=pvarsym(sym)^.owner^.symtablelevel) or + { this below is wrong because there are two parast + for global functions one of interface the second of + implementation + if (pvarsym(sym)^.owner=procinfo^.def^.parast) or } + GetOffset then + begin + opr.ref.base:=procinfo^.framepointer; + end + else + begin + if (procinfo^.framepointer=R_ESP) and + assigned(procinfo^.parent) and + (lexlevel=pvarsym(sym)^.owner^.symtablelevel+1) and + { same problem as above !! + (procinfo^.parent^.sym^.definition^.parast=pvarsym(sym)^.owner) and } + (lexlevel>normal_function_level) then + opr.ref.base:=procinfo^.parent^.framepointer + else + message1(asmr_e_local_para_unreachable,hs); + end; + opr.ref.offset:=pvarsym(sym)^.address; + if (lexlevel=pvarsym(sym)^.owner^.symtablelevel) then + begin + opr.ref.offsetfixup:=aktprocsym^.definition^.parast^.address_fixup; + opr.ref.options:=ref_parafixup; + end + else + begin + opr.ref.offsetfixup:=0; + opr.ref.options:=ref_none; + end; + if (pvarsym(sym)^.varspez=vs_var) or + ((pvarsym(sym)^.varspez=vs_const) and + push_addr_param(pvarsym(sym)^.vartype.def)) then + SetSize(target_os.size_of_pointer,false); + end; + localsymtable : + begin + if (vo_is_external in pvarsym(sym)^.varoptions) then + opr.ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname) + else + begin + { if we only want the offset we don't have to care + the base will be zeroed after ! } + if (lexlevel=pvarsym(sym)^.owner^.symtablelevel) or + {if (pvarsym(sym)^.owner=procinfo^.def^.localst) or} + GetOffset then + opr.ref.base:=procinfo^.framepointer + else + begin + if (procinfo^.framepointer=R_ESP) and + assigned(procinfo^.parent) and + (lexlevel=pvarsym(sym)^.owner^.symtablelevel+1) and + {(procinfo^.parent^.sym^.definition^.localst=pvarsym(sym)^.owner) and} + (lexlevel>normal_function_level) then + opr.ref.base:=procinfo^.parent^.framepointer + else + message1(asmr_e_local_para_unreachable,hs); + end; + opr.ref.offset:=-(pvarsym(sym)^.address); + if (lexlevel=pvarsym(sym)^.owner^.symtablelevel) then + begin + opr.ref.offsetfixup:=aktprocsym^.definition^.localst^.address_fixup; + opr.ref.options:=ref_localfixup; + end + else + begin + opr.ref.offsetfixup:=0; + opr.ref.options:=ref_none; + end; + end; + end; + end; + case pvarsym(sym)^.vartype.def^.deftype of + orddef, + enumdef, + pointerdef, + floatdef : + SetSize(pvarsym(sym)^.getsize,false); + arraydef : + begin + { for arrays try to get the element size, take care of + multiple indexes } + harrdef:=Parraydef(PVarsym(sym)^.vartype.def); + while assigned(harrdef^.elementtype.def) and + (harrdef^.elementtype.def^.deftype=arraydef) do + harrdef:=parraydef(harrdef^.elementtype.def); + SetSize(harrdef^.elesize,false); + end; + end; + hasvar:=true; + SetupVar:=true; + Exit; + end; + typedconstsym : + begin + opr.ref.symbol:=newasmsymbol(ptypedconstsym(sym)^.mangledname); + case ptypedconstsym(sym)^.typedconsttype.def^.deftype of + orddef, + enumdef, + pointerdef, + floatdef : + SetSize(ptypedconstsym(sym)^.getsize,false); + arraydef : + begin + { for arrays try to get the element size, take care of + multiple indexes } + harrdef:=Parraydef(PTypedConstSym(sym)^.typedconsttype.def); + while assigned(harrdef^.elementtype.def) and + (harrdef^.elementtype.def^.deftype=arraydef) do + harrdef:=parraydef(harrdef^.elementtype.def); + SetSize(harrdef^.elesize,false); + end; + end; + hasvar:=true; + SetupVar:=true; + Exit; + end; + constsym : + begin + if pconstsym(sym)^.consttyp in [constint,constchar,constbool] then + begin + opr.typ:=OPR_CONSTANT; + opr.val:=pconstsym(sym)^.value; + SetupVar:=true; + Exit; + end; + end; + typesym : + begin + if ptypesym(sym)^.restype.def^.deftype in [recorddef,objectdef] then + begin + opr.typ:=OPR_CONSTANT; + opr.val:=0; + SetupVar:=TRUE; + Exit; + end; + end; + procsym : + begin + if assigned(pprocsym(sym)^.definition^.nextoverloaded) then + Message(asmr_w_calling_overload_func); + opr.typ:=OPR_SYMBOL; + opr.symbol:=newasmsymbol(pprocsym(sym)^.definition^.mangledname); + hasvar:=true; + SetupVar:=TRUE; + Exit; + end; + else + begin + Message(asmr_e_unsupported_symbol_type); + exit; + end; + end; +end; + + +{ looks for internal names of variables and routines } +Function TOperand.SetupDirectVar(const hs:string): Boolean; +{$ifndef OLDDIRECTVAR} +var + p : pasmsymbol; +begin + SetupDirectVar:=false; + p:=getasmsymbol(hs); + if assigned(p) then + begin + opr.ref.symbol:=p; + hasvar:=true; + SetupDirectVar:=true; + end; +end; +{$else} +var + p : pai_external; +Begin + SearchDirectVar:=false; + { search in the list of internals } + p:=search_assembler_symbol(internals,hs,EXT_ANY); + if p=nil then + p:=search_assembler_symbol(externals,hs,EXT_ANY); + if p<>nil then + begin + instr.operands[operandnum].opr.ref.symbol:=p^.sym; + case p^.exttyp of + EXT_BYTE : instr.operands[operandnum].size:=S_B; + EXT_WORD : instr.operands[operandnum].size:=S_W; + EXT_NEAR,EXT_FAR,EXT_PROC,EXT_DWORD,EXT_CODEPTR,EXT_DATAPTR: + instr.operands[operandnum].size:=S_L; + EXT_QWORD : instr.operands[operandnum].size:=S_FL; + EXT_TBYTE : instr.operands[operandnum].size:=S_FX; + else + { this is in the case where the instruction is LEA } + { or something like that, in that case size is not } + { important. } + instr.operands[operandnum].size:=S_NO; + end; + instr.operands[operandnum].hasvar:=true; + SearchDirectVar:=TRUE; + Exit; + end; +end; +{$endif} + +procedure TOperand.InitRef; +{*********************************************************************} +{ Description: This routine first check if the opcode is of } +{ type OPR_NONE, or OPR_REFERENCE , if not it gives out an error. } +{ If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up } +{ the operand type to OPR_REFERENCE, as well as setting up the ref } +{ to point to the default segment. } +{*********************************************************************} +Begin + case opr.typ of + OPR_REFERENCE: + exit; + OPR_NONE: ; + else + Message(asmr_e_invalid_operand_type); + end; + opr.typ := OPR_REFERENCE; + reset_reference(opr.ref); +end; + + +procedure TOperand.BuildOperand; +begin + abstract; +end; + + +{**************************************************************************** + TInstruction +****************************************************************************} + +constructor TInstruction.init; +Begin + Opcode:=A_NONE; + Opsize:=S_NO; + Condition:=C_NONE; + Ops:=0; + InitOperands; +end; + + +destructor TInstruction.done; +var + i : longint; +Begin + for i:=1 to 3 do + Dispose(Operands[i],Done); +end; + + +procedure TInstruction.InitOperands; +var + i : longint; +begin + for i:=1 to 3 do + New(Operands[i],init); +end; + + +Procedure TInstruction.SwapOperands; +Var + p : POperand; +Begin + case Ops of + 2 : + begin + p:=Operands[1]; + Operands[1]:=Operands[2]; + Operands[2]:=p; + end; + 3 : + begin + p:=Operands[1]; + Operands[1]:=Operands[3]; + Operands[3]:=p; + end; + end; +end; + + +procedure TInstruction.ConcatInstruction(p:PAasmOutput); +begin + abstract; +end; + + +procedure TInstruction.BuildOpcode; +begin + abstract; +end; + + +{*************************************************************************** + TLocalLabel +***************************************************************************} + +constructor TLocalLabel.Init(const n:string); +begin + inherited InitName(n); + lab:=nil; + emitted:=false; +end; + + +function TLocalLabel.Getpasmlabel:pasmlabel; +begin + if not assigned(lab) then + begin + getlabel(lab); + { this label is forced to be used so it's always written } + inc(lab^.refs); + end; + Getpasmlabel:=lab; +end; + + +{*************************************************************************** + TLocalLabelList +***************************************************************************} + +procedure LocalLabelEmitted(p:PNamedIndexObject);{$ifndef FPC}far;{$endif} +begin + if not PLocalLabel(p)^.emitted then + Message1(asmr_e_unknown_label_identifier,p^.name); +end; + +procedure TLocalLabelList.CheckEmitted; +begin + ForEach({$ifndef TP}@{$endif}LocalLabelEmitted) +end; + + +function CreateLocalLabel(const s: string; var hl: pasmlabel; emit:boolean):boolean; +var + lab : PLocalLabel; +Begin + CreateLocalLabel:=true; +{ Check if it already is defined } + lab:=PLocalLabel(LocalLabelList^.Search(s)); + if not assigned(lab) then + begin + new(lab,init(s)); + LocalLabelList^.Insert(lab); + end; +{ set emitted flag and check for dup syms } + if emit then + begin + if lab^.Emitted then + begin + Message1(asmr_e_dup_local_sym,lab^.Name); + CreateLocalLabel:=false; + end; + lab^.Emitted:=true; + end; + hl:=lab^.Getpasmlabel; +end; + + +{**************************************************************************** + Symbol table helper routines +****************************************************************************} + +Function SearchType(const hs:string): Boolean; +begin + getsym(hs,false); + SearchType:=assigned(srsym) and + (srsym^.typ=typesym); +end; + + + +Function SearchRecordType(const s:string): boolean; +Begin + SearchRecordType:=false; +{ Check the constants in symtable } + getsym(s,false); + if srsym <> nil then + Begin + case srsym^.typ of + typesym : + begin + if ptypesym(srsym)^.restype.def^.deftype in [recorddef,objectdef] then + begin + SearchRecordType:=true; + exit; + end; + end; + end; + end; +end; + + +Function SearchIConstant(const s:string; var l:longint): boolean; +{**********************************************************************} +{ Description: Searches for a CONSTANT of name s in either the local } +{ symbol list, then in the global symbol list, and returns the value } +{ of that constant in l. Returns TRUE if successfull, if not found, } +{ or if the constant is not of correct type, then returns FALSE } +{ Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 } +{ respectively. } +{**********************************************************************} +Begin + SearchIConstant:=false; +{ check for TRUE or FALSE reserved words first } + if s = 'TRUE' then + Begin + SearchIConstant:=TRUE; + l:=1; + exit; + end; + if s = 'FALSE' then + Begin + SearchIConstant:=TRUE; + l:=0; + exit; + end; +{ Check the constants in symtable } + getsym(s,false); + if srsym <> nil then + Begin + case srsym^.typ of + constsym : + begin + if (pconstsym(srsym)^.consttyp in [constord,constint,constchar,constbool]) then + Begin + l:=pconstsym(srsym)^.value; + SearchIConstant:=TRUE; + exit; + end; + end; + enumsym: + Begin + l:=penumsym(srsym)^.value; + SearchIConstant:=TRUE; + exit; + end; + end; + end; +end; + + +Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean; +{ search and returns the offset and size of records/objects of the base } +{ with field name setup in field. } +{ returns FALSE if not found. } +{ used when base is a variable or a typed constant name. } +var + st : psymtable; + harrdef : parraydef; + sym : psym; + i : longint; + base : string; +Begin + GetRecordOffsetSize:=FALSE; + Offset:=0; + Size:=0; + i:=pos('.',s); + if i=0 then + i:=255; + base:=Copy(s,1,i-1); + delete(s,1,i); + if base='SELF' then + st:=procinfo^._class^.symtable + else + begin + getsym(base,false); + sym:=srsym; + st:=nil; + { we can start with a var,type,typedconst } + case sym^.typ of + varsym : + begin + case pvarsym(sym)^.vartype.def^.deftype of + recorddef : + st:=precorddef(pvarsym(sym)^.vartype.def)^.symtable; + objectdef : + st:=pobjectdef(pvarsym(sym)^.vartype.def)^.symtable; + end; + end; + typesym : + begin + case ptypesym(sym)^.restype.def^.deftype of + recorddef : + st:=precorddef(ptypesym(sym)^.restype.def)^.symtable; + objectdef : + st:=pobjectdef(ptypesym(sym)^.restype.def)^.symtable; + end; + end; + typedconstsym : + begin + case ptypedconstsym(sym)^.typedconsttype.def^.deftype of + recorddef : + st:=precorddef(ptypedconstsym(sym)^.typedconsttype.def)^.symtable; + objectdef : + st:=pobjectdef(ptypedconstsym(sym)^.typedconsttype.def)^.symtable; + end; + end; + end; + end; + { now walk all recordsymtables } + while assigned(st) and (s<>'') do + begin + { load next field in base } + i:=pos('.',s); + if i=0 then + i:=255; + base:=Copy(s,1,i-1); + delete(s,1,i); + if st^.symtabletype=objectsymtable then + sym:=search_class_member(pobjectdef(st^.defowner),base) + else + sym:=st^.search(base); + if not assigned(sym) then + begin + GetRecordOffsetSize:=false; + exit; + end; + st:=nil; + case sym^.typ of + varsym : + begin + inc(Offset,pvarsym(sym)^.address); + Size:=PVarsym(sym)^.getsize; + case pvarsym(sym)^.vartype.def^.deftype of + arraydef : + begin + { for arrays try to get the element size, take care of + multiple indexes } + harrdef:=Parraydef(PVarsym(sym)^.vartype.def); + while assigned(harrdef^.elementtype.def) and + (harrdef^.elementtype.def^.deftype=arraydef) do + harrdef:=parraydef(harrdef^.elementtype.def); + size:=harrdef^.elesize; + end; + recorddef : + st:=precorddef(pvarsym(sym)^.vartype.def)^.symtable; + objectdef : + st:=pobjectdef(pvarsym(sym)^.vartype.def)^.symtable; + end; + end; + end; + end; + GetRecordOffsetSize:=(s=''); +end; + + +Function SearchLabel(const s: string; var hl: pasmlabel;emit:boolean): boolean; +var + sym : psym; + hs : string; +Begin + hl:=nil; + SearchLabel:=false; +{ Check for pascal labels, which are case insensetive } + hs:=upper(s); + getsym(hs,false); + sym:=srsym; + if sym=nil then + exit; + case sym^.typ of + labelsym : + begin + hl:=plabelsym(sym)^.lab; + if emit then + plabelsym(sym)^.defined:=true + else + plabelsym(sym)^.used:=true; + SearchLabel:=true; + exit; + end; + end; +end; + + + {*************************************************************************} + { Instruction Generation Utilities } + {*************************************************************************} + + + Procedure ConcatString(p : paasmoutput;s:string); + {*********************************************************************} + { PROCEDURE ConcatString(s:string); } + { Description: This routine adds the character chain pointed to in } + { s to the instruction linked list. } + {*********************************************************************} + Var + pc: PChar; + Begin + getmem(pc,length(s)+1); + p^.concat(new(pai_string,init_length_pchar(strpcopy(pc,s),length(s)))); + end; + + Procedure ConcatPasString(p : paasmoutput;s:string); + {*********************************************************************} + { PROCEDURE ConcatPasString(s:string); } + { Description: This routine adds the character chain pointed to in } + { s to the instruction linked list, contrary to ConcatString it } + { uses a pascal style string, so it conserves null characters. } + {*********************************************************************} + Begin + p^.concat(new(pai_string,init(s))); + end; + + Procedure ConcatDirect(p : paasmoutput;s:string); + {*********************************************************************} + { PROCEDURE ConcatDirect(s:string) } + { Description: This routine output the string directly to the asm } + { output, it is only sed when writing special labels in AT&T mode, } + { and should not be used without due consideration, since it may } + { cause problems. } + {*********************************************************************} + Var + pc: PChar; + Begin + getmem(pc,length(s)+1); + p^.concat(new(pai_direct,init(strpcopy(pc,s)))); + end; + + + + +Procedure ConcatConstant(p: paasmoutput; value: longint; maxvalue: longint); +{*********************************************************************} +{ PROCEDURE ConcatConstant(value: longint; maxvalue: longint); } +{ Description: This routine adds the value constant to the current } +{ instruction linked list. } +{ maxvalue -> indicates the size of the data to initialize: } +{ $ff -> create a byte node. } +{ $ffff -> create a word node. } +{ $ffffffff -> create a dword node. } +{*********************************************************************} +Begin + if (maxvalue <> longint($ffffffff)) and (value > maxvalue) then + Begin + Message(asmr_e_constant_out_of_bounds); + { assuming a value of maxvalue } + value:=maxvalue; + end; + if maxvalue = $ff then + p^.concat(new(pai_const,init_8bit(byte(value)))) + else + if maxvalue = $ffff then + p^.concat(new(pai_const,init_16bit(word(value)))) + else + if maxvalue = longint($ffffffff) then + p^.concat(new(pai_const,init_32bit(longint(value)))); +end; + + + Procedure ConcatConstSymbol(p : paasmoutput;const sym:string;l:longint); + begin + p^.concat(new(pai_const_symbol,initname_offset(sym,l))); + end; + + + Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype); + {***********************************************************************} + { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); } + { Description: This routine adds the value constant to the current } + { instruction linked list. } + { real_typ -> indicates the type of the real data to initialize: } + { s32real -> create a single node. } + { s64real -> create a double node. } + { s80real -> create an extended node. } + { s64bit -> create a comp node. } + { f32bit -> create a fixed node. (not used normally) } + {***********************************************************************} + Begin + case real_typ of + s32real : p^.concat(new(pai_real_32bit,init(value))); + s64real : p^.concat(new(pai_real_64bit,init(value))); + s80real : p^.concat(new(pai_real_80bit,init(value))); + s64comp : p^.concat(new(pai_comp_64bit,init(value))); + f32bit : p^.concat(new(pai_const,init_32bit(trunc(value*$10000)))); + end; + end; + + Procedure ConcatLabel(p: paasmoutput;var l : pasmlabel); + {*********************************************************************} + { PROCEDURE ConcatLabel } + { Description: This routine either emits a label or a labeled } + { instruction to the linked list of instructions. } + {*********************************************************************} + begin + p^.concat(new(pai_label,init(l))); + end; + + procedure ConcatAlign(p:paasmoutput;l:longint); + {*********************************************************************} + { PROCEDURE ConcatPublic } + { Description: This routine emits an global definition to the } + { linked list of instructions.(used by AT&T styled asm) } + {*********************************************************************} + begin + p^.concat(new(pai_align,init(l))); + end; + + procedure ConcatPublic(p:paasmoutput;const s : string); + {*********************************************************************} + { PROCEDURE ConcatPublic } + { Description: This routine emits an global definition to the } + { linked list of instructions.(used by AT&T styled asm) } + {*********************************************************************} + begin + p^.concat(new(pai_symbol,initname_global(s,0))); + end; + + procedure ConcatLocal(p:paasmoutput;const s : string); + {*********************************************************************} + { PROCEDURE ConcatLocal } + { Description: This routine emits an local definition to the } + { linked list of instructions. } + {*********************************************************************} + begin + p^.concat(new(pai_symbol,initname(s,0))); + end; + + Procedure ConcatGlobalBss(const s : string;size : longint); + {*********************************************************************} + { PROCEDURE ConcatGlobalBss } + { Description: This routine emits an global datablock to the } + { linked list of instructions. } + {*********************************************************************} + begin + bsssegment^.concat(new(pai_datablock,init_global(s,size))); + end; + + Procedure ConcatLocalBss(const s : string;size : longint); + {*********************************************************************} + { PROCEDURE ConcatLocalBss } + { Description: This routine emits a local datablcok to the } + { linked list of instructions. } + {*********************************************************************} + begin + bsssegment^.concat(new(pai_datablock,init(s,size))); + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.46 2000/05/26 18:23:11 peter + * fixed % parsing and added modulo support + * changed some evaulator errors to more generic illegal expresion + + Revision 1.45 2000/05/23 20:36:28 peter + + typecasting support for variables, but be carefull as word,byte can't + be used because they are reserved assembler keywords + + Revision 1.44 2000/05/22 12:47:52 pierre + fix wrong handling of var para for size bug 961 + + Revision 1.43 2000/05/18 17:05:16 peter + * fixed size of const parameters in asm readers + + Revision 1.42 2000/05/11 09:56:22 pierre + * fixed several compare problems between longints and + const > $80000000 that are treated as int64 constanst + by Delphi reported by Kovacs Attila Zoltan + + Revision 1.41 2000/05/08 13:23:05 peter + * fixed reference parsing + + Revision 1.40 2000/04/06 07:56:04 pierre + * bug in TOperand.SetSize corrected + + Revision 1.39 2000/04/04 13:48:45 pierre + + TOperand.SetCorrectSize virtual method added + to be able to change the suffix according to the instruction + (FIADD word ptr w need a s as ATT suffix + wheras FILD word ptr w need a w suffix :( ) + + Revision 1.38 2000/03/28 22:10:12 pierre + * Object fields are simple offsets in TP/Delphi mode + + Revision 1.37 2000/03/16 15:10:25 pierre + * correct the fixups for inlined assembler code + + Revision 1.36 2000/03/15 23:10:01 pierre + * fix for bug 848 (that still genrated wrong code) + + better testing for variables used in assembler + (gives an error if variable is not directly reachable !) + + Revision 1.35 2000/02/09 13:23:03 peter + * log truncated + + Revision 1.34 2000/01/07 01:14:37 peter + * updated copyright to 2000 + + Revision 1.33 1999/12/22 00:57:30 peter + * label are set to used so an error is given if used but not defined + + Revision 1.32 1999/12/17 10:43:34 florian + * 761 fixed + + Revision 1.31 1999/11/30 10:40:54 peter + + ttype, tsymlist + + Revision 1.30 1999/11/17 17:05:04 pierre + * Notes/hints changes + + Revision 1.29 1999/11/09 23:06:46 peter + * esi_offset -> selfpointer_offset to be newcg compatible + * hcogegen -> cgbase fixes for newcg + + Revision 1.28 1999/11/06 14:34:26 peter + * truncated log to 20 revs + + Revision 1.27 1999/09/27 23:44:58 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.26 1999/09/08 16:04:04 peter + * better support for object fields and more error checks for + field accesses which create buggy code + + Revision 1.25 1999/09/04 20:29:11 florian + * bug 577 fixed + + Revision 1.24 1999/08/27 14:37:50 peter + * fixed crash with typedconst array + + Revision 1.23 1999/08/13 21:28:38 peter + * more reference types support + * arraydef size returns elementsize, also for multiple indexing array + + Revision 1.22 1999/08/04 00:23:28 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.21 1999/08/03 22:03:12 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.20 1999/07/29 20:54:06 peter + * write .size also + +} \ No newline at end of file diff --git a/befpc/compiler/scandir.inc b/befpc/compiler/scandir.inc new file mode 100644 index 0000000..c09a2ae --- /dev/null +++ b/befpc/compiler/scandir.inc @@ -0,0 +1,1527 @@ +{ + $Id: scandir.inc,v 1.1.1.1 2001-07-23 17:17:01 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements directive parsing for the scanner + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +const + directivelen=15; +type + directivestr=string[directivelen]; + tdirectivetoken=( + _DIR_NONE, + _DIR_ALIGN,_DIR_APPTYPE,_DIR_ASMMODE,_DIR_ASSERTIONS, + _DIR_BOOLEVAL, + _DIR_D,_DIR_DEBUGINFO,_DIR_DEFINE,_DIR_DESCRIPTION, + _DIR_ELSE,_DIR_ENDIF,_DIR_ERROR,_DIR_EXTENDEDSYNTAX, + _DIR_FATAL, + _DIR_GOTO, + _DIR_HINT,_DIR_HINTS, + _DIR_I,_DIR_I386_ATT,_DIR_I386_DIRECT,_DIR_I386_INTEL,_DIR_IOCHECKS, + _DIR_IF,_DIR_IFDEF,_DIR_IFNDEF,_DIR_IFOPT,_DIR_INCLUDE,_DIR_INCLUDEPATH, + _DIR_INFO,_DIR_INLINE, + _DIR_L,_DIR_LIBRARYPATH,_DIR_LINK,_DIR_LINKLIB,_DIR_LOCALSYMBOLS, + _DIR_LONGSTRINGS, + _DIR_M,_DIR_MACRO,_DIR_MAXFPUREGISTERS,_DIR_MEMORY,_DIR_MESSAGE,_DIR_MINENUMSIZE,_DIR_MMX,_DIR_MODE, + _DIR_NOTE,_DIR_NOTES, + _DIR_OBJECTPATH,_DIR_OPENSTRINGS,_DIR_OUTPUT_FORMAT,_DIR_OVERFLOWCHECKS, + _DIR_PACKENUM,_DIR_PACKRECORDS, + {$IFDEF Testvarsets} + _DIR_PACKSET, + {$ENDIF} + _DIR_R,_DIR_RANGECHECKS,_DIR_REFERENCEINFO, + _DIR_SATURATION,_DIR_SMARTLINK,_DIR_STACKFRAMES,_DIR_STATIC,_DIR_STOP, + _DIR_TYPEDADDRESS,_DIR_TYPEINFO, + _DIR_UNDEF,_DIR_UNITPATH, + _DIR_VARSTRINGCHECKS,_DIR_VERSION, + _DIR_WAIT,_DIR_WARNING,_DIR_WARNINGS, + _DIR_Z1,_DIR_Z2,_DIR_Z4 + ); +const + firstdirective=_DIR_NONE; + lastdirective=_DIR_Z4; + directive:array[tdirectivetoken] of directivestr=( + {12345678901234567890 (To determine longest string.)} + '', + 'ALIGN', + 'APPTYPE', + 'ASMMODE', + 'ASSERTIONS', + 'BOOLEVAL', + 'D', + 'DEBUGINFO', + 'DEFINE', + 'DESCRIPTION', + 'ELSE', + 'ENDIF', + 'ERROR', + 'EXTENDEDSYNTAX', + 'FATAL', + 'GOTO', + 'HINT', + 'HINTS', + 'I', + {12345678901234567890 (To determine longest string.)} + 'I386_ATT', + 'I386_DIRECT', + 'I386_INTEL', + 'IOCHECKS', + 'IF', + 'IFDEF', + 'IFNDEF', + 'IFOPT', + 'INCLUDE', + 'INCLUDEPATH', + 'INFO', + 'INLINE', + 'L', + 'LIBRARYPATH', + 'LINK', + 'LINKLIB', + 'LOCALSYMBOLS', + 'LONGSTRINGS', + 'M', + {12345678901234567890 (To determine longest string.)} + 'MACRO', + 'MAXFPUREGISTERS', + 'MEMORY', + 'MESSAGE', + 'MINENUMSIZE', + 'MMX', + 'MODE', + 'NOTE', + 'NOTES', + 'OBJECTPATH', + 'OPENSTRINGS', + 'OUTPUT_FORMAT', + 'OVERFLOWCHECKS', + 'PACKENUM', + 'PACKRECORDS', + {$IFDEF testvarsets} + 'PACKSET', + {$ENDIF} + 'R', + 'RANGECHECKS', + 'REFERENCEINFO', + 'SATURATION', + 'SMARTLINK', + {12345678901234567890 (To determine longest string.)} + 'STACKFRAMES', + 'STATIC', + 'STOP', + 'TYPEDADDRESS', + 'TYPEINFO', + 'UNDEF', + 'UNITPATH', + 'VARSTRINGCHECKS', + 'VERSION', + 'WAIT', + 'WARNING', + 'WARNINGS', + 'Z1', + 'Z2', + 'Z4' + ); + + + + function Get_Directive(const hs:string):tdirectivetoken; + var + i : tdirectivetoken; + begin + for i:=firstdirective to lastdirective do + if directive[i]=hs then + begin + Get_Directive:=i; + exit; + end; + Get_Directive:=_DIR_NONE; + end; + + + {------------------------------------------- + IF Conditional Handling + -------------------------------------------} + + var + preprocpat : string; + preproc_token : ttoken; + + procedure preproc_consume(t : ttoken); + begin + if t<>preproc_token then + Message(scan_e_preproc_syntax_error); + preproc_token:=current_scanner^.readpreproc; + end; + + function read_expr : string;forward; + + function read_factor : string; + var + hs : string; + mac : pmacrosym; + len : byte; + begin + if preproc_token=_ID then + begin + if preprocpat='NOT' then + begin + preproc_consume(_ID); + hs:=read_expr; + if hs='0' then + read_factor:='1' + else + read_factor:='0'; + end + else + begin + mac:=pmacrosym(macros^.search(hs)); + hs:=preprocpat; + preproc_consume(_ID); + if assigned(mac) then + begin + if mac^.defined and assigned(mac^.buftext) then + begin + if mac^.buflen>255 then + begin + len:=255; + Message(scan_w_macro_cut_after_255_chars); + end + else + len:=mac^.buflen; + {$ifndef TP} + {$ifopt H+} + setlength(hs,len); + {$else} + hs[0]:=char(len); + {$endif} + {$else} + hs[0]:=char(len); + {$endif} + move(mac^.buftext^,hs[1],len); + end + else + read_factor:=''; + end + else + read_factor:=hs; + end + end + else if preproc_token=_LKLAMMER then + begin + preproc_consume(_LKLAMMER); + read_factor:=read_expr; + preproc_consume(_RKLAMMER); + end + else + Message(scan_e_error_in_preproc_expr); + end; + + + function read_term : string; + var + hs1,hs2 : string; + begin + hs1:=read_factor; + while true do + begin + if (preproc_token=_ID) then + begin + if preprocpat='AND' then + begin + preproc_consume(_ID); + hs2:=read_factor; + if (hs1<>'0') and (hs2<>'0') then + hs1:='1'; + end + else + break; + end + else + break; + end; + read_term:=hs1; + end; + + + function read_simple_expr : string; + var + hs1,hs2 : string; + begin + hs1:=read_term; + while true do + begin + if (preproc_token=_ID) then + begin + if preprocpat='OR' then + begin + preproc_consume(_ID); + hs2:=read_term; + if (hs1<>'0') or (hs2<>'0') then + hs1:='1'; + end + else + break; + end + else + break; + end; + read_simple_expr:=hs1; + end; + + + function read_expr : string; + var + hs1,hs2 : string; + b : boolean; + t : ttoken; + w : integer; + l1,l2 : longint; + begin + hs1:=read_simple_expr; + t:=preproc_token; + if not(t in [_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then + begin + read_expr:=hs1; + exit; + end; + preproc_consume(t); + hs2:=read_simple_expr; + if is_number(hs1) and is_number(hs2) then + begin + valint(hs1,l1,w); + valint(hs2,l2,w); + case t of + _EQUAL : b:=l1=l2; + _UNEQUAL : b:=l1<>l2; + _LT : b:=l1l2; + _GTE : b:=l1>=l2; + _LTE : b:=l1<=l2; + end; + end + else + begin + case t of + _EQUAL : b:=hs1=hs2; + _UNEQUAL : b:=hs1<>hs2; + _LT : b:=hs1hs2; + _GTE : b:=hs1>=hs2; + _LTE : b:=hs1<=hs2; + end; + end; + if b then + read_expr:='1' + else + read_expr:='0'; + end; + + {------------------------------------------- + Directives + -------------------------------------------} + + function is_conditional(t:tdirectivetoken):boolean; + begin + is_conditional:=(t in [_DIR_ENDIF,_DIR_IFDEF,_DIR_IFNDEF,_DIR_IFOPT,_DIR_IF,_DIR_ELSE]); + end; + + + procedure dir_conditional(t:tdirectivetoken); + var + hs : string; + mac : pmacrosym; + found : boolean; + state : char; + oldaktfilepos : tfileposinfo; + begin + oldaktfilepos:=aktfilepos; + while true do + begin + current_scanner^.gettokenpos; + case t of + _DIR_ENDIF : begin + current_scanner^.poppreprocstack; + end; + _DIR_ELSE : begin + current_scanner^.elsepreprocstack; + end; + _DIR_IFDEF : begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + mac:=pmacrosym(macros^.search(hs)); + if assigned(mac) then + mac^.is_used:=true; + current_scanner^.addpreprocstack(pp_ifdef,assigned(mac) and mac^.defined,hs,scan_c_ifdef_found); + end; + _DIR_IFOPT : begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + if (length(hs)>1) then + Message(scan_w_illegal_switch) + else + begin + state:=current_scanner^.ReadState; + if state in ['-','+'] then + found:=CheckSwitch(hs[1],state); + end; + current_scanner^.addpreprocstack(pp_ifopt,found,hs,scan_c_ifopt_found); + end; + _DIR_IF : begin + current_scanner^.skipspace; + { start preproc expression scanner } + preproc_token:=current_scanner^.readpreproc; + hs:=read_expr; + current_scanner^.addpreprocstack(pp_if,hs<>'0',hs,scan_c_if_found); + end; + _DIR_IFNDEF : begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + mac:=pmacrosym(macros^.search(hs)); + if assigned(mac) then + mac^.is_used:=true; + current_scanner^.addpreprocstack(pp_ifndef,not(assigned(mac) and mac^.defined),hs,scan_c_ifndef_found); + end; + end; + { accept the text ? } + if (current_scanner^.preprocstack=nil) or current_scanner^.preprocstack^.accept then + break + else + begin + current_scanner^.gettokenpos; + Message(scan_c_skipping_until); + repeat + current_scanner^.skipuntildirective; + t:=Get_Directive(current_scanner^.readid); + until is_conditional(t); + current_scanner^.gettokenpos; + Message1(scan_d_handling_switch,'$'+directive[t]); + end; + end; + aktfilepos:=oldaktfilepos; + end; + + + procedure dir_define(t:tdirectivetoken); + var + hs : string; + bracketcount : longint; + mac : pmacrosym; + macropos : longint; + macrobuffer : pmacrobuffer; + begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + mac:=pmacrosym(macros^.search(hs)); + if not assigned(mac) then + begin + mac:=new(pmacrosym,init(hs)); + mac^.defined:=true; + Message1(parser_m_macro_defined,mac^.name); + macros^.insert(mac); + end + else + begin + Message1(parser_m_macro_defined,mac^.name); + mac^.defined:=true; + { delete old definition } + if assigned(mac^.buftext) then + begin + freemem(mac^.buftext,mac^.buflen); + mac^.buftext:=nil; + end; + end; + mac^.is_used:=true; + if (cs_support_macro in aktmoduleswitches) then + begin + { key words are never substituted } + if is_keyword(hs) then + Message(scan_e_keyword_cant_be_a_macro); + { !!!!!! handle macro params, need we this? } + current_scanner^.skipspace; + { may be a macro? } + if c=':' then + begin + current_scanner^.readchar; + if c='=' then + begin + new(macrobuffer); + macropos:=0; + { parse macro, brackets are counted so it's possible + to have a $ifdef etc. in the macro } + bracketcount:=0; + repeat + current_scanner^.readchar; + case c of + '}' : + if (bracketcount=0) then + break + else + dec(bracketcount); + '{' : + inc(bracketcount); + #26 : + current_scanner^.end_of_file; + end; + macrobuffer^[macropos]:=c; + inc(macropos); + if macropos>maxmacrolen then + Message(scan_f_macro_buffer_overflow); + until false; + { free buffer of macro ?} + if assigned(mac^.buftext) then + freemem(mac^.buftext,mac^.buflen); + { get new mem } + getmem(mac^.buftext,macropos); + mac^.buflen:=macropos; + { copy the text } + move(macrobuffer^,mac^.buftext^,macropos); + dispose(macrobuffer); + end; + end; + end; + end; + + + procedure dir_undef(t:tdirectivetoken); + var + hs : string; + mac : pmacrosym; + begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + mac:=pmacrosym(macros^.search(hs)); + if not assigned(mac) then + begin + mac:=new(pmacrosym,init(hs)); + Message1(parser_m_macro_undefined,mac^.name); + mac^.defined:=false; + macros^.insert(mac); + end + else + begin + Message1(parser_m_macro_undefined,mac^.name); + mac^.defined:=false; + { delete old definition } + if assigned(mac^.buftext) then + begin + freemem(mac^.buftext,mac^.buflen); + mac^.buftext:=nil; + end; + end; + mac^.is_used:=true; + end; + + + procedure dir_message(t:tdirectivetoken); + var + w : longint; + begin + case t of + _DIR_STOP, + _DIR_FATAL : w:=scan_f_user_defined; + _DIR_ERROR : w:=scan_e_user_defined; + _DIR_WARNING : w:=scan_w_user_defined; + _DIR_HINT : w:=scan_h_user_defined; + _DIR_NOTE : w:=scan_n_user_defined; + _DIR_MESSAGE, + _DIR_INFO : w:=scan_i_user_defined; + end; + current_scanner^.skipspace; + Message1(w,current_scanner^.readcomment); + end; + + + procedure dir_moduleswitch(t:tdirectivetoken); + var + sw : tmoduleswitch; + state : char; + begin + sw:=cs_modulenone; + case t of + _DIR_GOTO : sw:=cs_support_goto; + _DIR_MACRO : sw:=cs_support_macro; + _DIR_INLINE : sw:=cs_support_inline; + _DIR_SMARTLINK : sw:=cs_create_smart; + _DIR_STATIC : sw:=cs_static_keyword; + end; + state:=current_scanner^.readstate; + if (sw<>cs_modulenone) and (state in ['-','+']) then + begin + if state='-' then + aktmoduleswitches:=aktmoduleswitches-[sw] + else + aktmoduleswitches:=aktmoduleswitches+[sw]; + end; + end; + + + procedure dir_localswitch(t:tdirectivetoken); + var + sw : tlocalswitch; + state : char; + begin + sw:=cs_localnone; +{$ifdef SUPPORT_MMX} + case t of + _DIR_MMX : sw:=cs_mmx; + _DIR_SATURATION : sw:=cs_mmx_saturation; + end; +{$endif} + state:=current_scanner^.readstate; + if (sw<>cs_localnone) and (state in ['-','+']) then + begin + if not localswitcheschanged then + nextaktlocalswitches:=aktlocalswitches; + if state='-' then + nextaktlocalswitches:=nextaktlocalswitches-[sw] + else + nextaktlocalswitches:=nextaktlocalswitches+[sw]; + localswitcheschanged:=true; + end; + end; + + + procedure dir_include(t:tdirectivetoken); + var + hs : string; + path : dirstr; + name : namestr; + ext : extstr; + hp : pinputfile; + i : longint; + found : boolean; + begin + current_scanner^.skipspace; + hs:=current_scanner^.readcomment; + i:=length(hs); + while (i>0) and (hs[i]=' ') do + dec(i); + Delete(hs,i+1,length(hs)-i); + if hs='' then + exit; + if (hs[1]='%') then + begin + { case insensitive } + hs:=upper(hs); + { remove %'s } + Delete(hs,1,1); + if hs[length(hs)]='%' then + Delete(hs,length(hs),1); + { save old } + path:=hs; + { first check for internal macros } + if hs='TIME' then + hs:=gettimestr + else + if hs='DATE' then + hs:=getdatestr + else + if hs='FILE' then + hs:=current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex) + else + if hs='LINE' then + hs:=tostr(aktfilepos.line) + else + if hs='FPCVERSION' then + hs:=version_string + else + if hs='FPCTARGET' then + hs:=target_cpu_string + else + hs:=getenv(hs); + if hs='' then + Message1(scan_w_include_env_not_found,path); + { make it a stringconst } + hs:=''''+hs+''''; + current_scanner^.insertmacro(path,@hs[1],length(hs)); + end + else + begin + hs:=FixFileName(hs); + fsplit(hs,path,name,ext); + { look for the include file + 1. specified path,path of current inputfile,current dir + 2. local includepath + 3. global includepath } + found:=false; + if path<>'' then + path:=path+';'; + path:=FindFile(name+ext,path+current_scanner^.inputfile^.path^+';.'+DirSep,found); + if (not found) then + path:=current_module^.localincludesearchpath.FindFile(name+ext,found); + if (not found) then + path:=includesearchpath.FindFile(name+ext,found); + { shutdown current file } + current_scanner^.tempcloseinputfile; + { load new file } + hp:=new(pinputfile,init(path+name+ext)); + current_scanner^.addfile(hp); + if not current_scanner^.openinputfile then + Message1(scan_f_cannot_open_includefile,hs); + Message1(scan_t_start_include_file,current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^); + current_scanner^.reload; + { process first read char } + case c of + #26 : current_scanner^.reload; + #10, + #13 : current_scanner^.linebreak; + end; + { register for refs } + current_module^.sourcefiles^.register_file(hp); + end; + end; + + + procedure dir_description(t:tdirectivetoken); + begin + if not (target_info.target in [target_i386_os2,target_i386_win32]) then + Message(scan_w_decription_not_support); + { change description global var in all cases } + { it not used but in win32 and os2 } + current_scanner^.skipspace; + description:=current_scanner^.readcomment; + end; + + + procedure dir_version(t:tdirectivetoken); + var + major, minor : longint; + error : integer; + begin + if not (target_info.target in [target_i386_os2,target_i386_win32]) then + begin + Message(scan_n_version_not_support); + exit; + end; + if (compile_level<>1) then + Message(scan_n_only_exe_version) + else + begin + { change description global var in all cases } + { it not used but in win32 and os2 } + current_scanner^.skipspace; + { we should only accept Major.Minor format } + current_scanner^.readnumber; + major:=0; + minor:=0; + valint(pattern,major,error); + if error<>0 then + begin + Message1(scan_w_wrong_version_ignored,pattern); + exit; + end; + if c='.' then + begin + current_scanner^.readchar; + current_scanner^.readnumber; + valint(pattern,minor,error); + if error<>0 then + begin + Message1(scan_w_wrong_version_ignored,tostr(major)+'.'+pattern); + exit; + end; + dllmajor:=major; + dllminor:=minor; + dllversion:=tostr(major)+'.'+tostr(minor); + end + else + dllversion:=tostr(major); + end; + end; + + + procedure dir_linkobject(t:tdirectivetoken); + var + s : string; + begin + current_scanner^.skipspace; + s:=AddExtension(FixFileName(current_scanner^.readcomment),target_info.objext); + {$IFDEF NEWST} + current_module^.linkotherofiles. + insert(new(Plinkitem,init(s,link_allways))); + {$ELSE} + current_module^.linkotherofiles. + insert(s,link_allways); + {$ENDIF NEWST} + end; + + + procedure dir_resource(t:tdirectivetoken); + var + s : string; + begin + current_scanner^.skipspace; + s:=current_scanner^.readcomment; + { replace * with current module name. + This should always be defined. } + if s[1]='*' then + if Assigned(Current_Module) then + begin + delete(S,1,1); + insert(lower(current_module^.modulename^),S,1); + end; + s:=AddExtension(FixFileName(s),target_info.resext); + if target_info.res<>res_none then + if (target_info.res = res_i386_emx) and + not (Current_Module^.ResourceFiles.Empty) then + Message(scan_w_only_one_resourcefile_supported) + else + current_module^.resourcefiles.insert(FixFileName(s)) + else + Message(scan_e_resourcefiles_not_supported); + end; + +{$ifndef PAVEL_LINKLIB} + procedure dir_linklib(t:tdirectivetoken); + var + s : string; + quote : char; + begin + current_scanner^.skipspace; + { This way spaces are also allowed in library names + if quoted PM } + if (c='''') or (c='"') then + begin + quote:=c; + current_scanner^.readchar; + s:=current_scanner^.readcomment; + if pos(quote,s)>0 then + s:=copy(s,1,pos(quote,s)-1); + end + else + begin + current_scanner^.readstring; + s:=orgpattern; + if c='.' then + begin + s:=s+'.'; + current_scanner^.readchar; + current_scanner^.readstring; + s:=s+orgpattern; + end; + end; + {$IFDEF NEWST} + current_module^.linkOtherSharedLibs. + insert(new(Plinkitem,init(s,link_allways))); + {$ELSE} + current_module^.linkOtherSharedLibs. + insert(s,link_allways); + {$ENDIF} + end; +{$else PAVEL_LINKLIB} + procedure dir_linklib(t:tdirectivetoken); + var + s:string; + libname,linkmodeStr:string; + p:longint; + type + tLinkMode=(lm_dynamic,lm_static); + var + linkMode:tLinkMode; + function ExtractLinkMode:tLinkMode; + var + p:longint; + begin + p:=pos(',',linkmodeStr); + if p>0 then + linkmodeStr:=copy(linkmodeStr,1,pred(p)); + for p:=1 to length(linkmodeStr)do + linkmodeStr[p]:=upcase(linkmodeStr[p]); + if linkmodeStr='STATIC' then + ExtractLinkMode:=lm_static + else + ExtractLinkMode:=lm_dynamic + end; + procedure MangleLibName(mode:tLinkMode); + begin + if (libname[1]='''')and(libname[length(libname)]='''')then + begin + delete(libname,1,1); + delete(libname,length(libname),1); + end + else + begin + libname:=target_os.libprefix+libname; + case mode of + lm_static: + libname:=AddExtension(FixFileName(libname),target_os.staticlibext); + lm_dynamic: + libname:=AddExtension(FixFileName(libname),target_os.sharedlibext); + end; + end; + end; + begin + current_scanner^.skipspace; + s:=current_scanner^.readcomment; + p:=pos(',',s); + if p=0 then + begin + libname:=s; + linkmodeStr:='' + end + else + begin + libname:=copy(s,1,pred(p)); + linkmodeStr:=copy(s,succ(p),255); + end; + if(libname='')or(libname='''''')then + exit; + linkMode:=ExtractLinkMode; + MangleLibName(linkMode); + if linkMode=lm_static then +{$IFDEF NEWST} + current_module^.linkOtherStaticLibs. + insert(new(Plinkitem,init(FixFileName(libname),link_allways))) +{$ELSE} + current_module^.linkOtherStaticLibs. + insert(FixFileName(libname),link_allways) +{$ENDIF} + else +{$IFDEF NEWST} + current_module^.linkOtherSharedLibs. + insert(new(Plinkitem,init(FixFileName(libname),link_allways))); +{$ELSE} + current_module^.linkOtherSharedLibs. + insert(FixFileName(libname),link_allways); +{$ENDIF} + end; + + +{$endif PAVEL_LINKLIB} + + + procedure dir_outputformat(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + if set_string_asm(current_scanner^.readid) then + aktoutputformat:=target_asm.id + else + Message(scan_w_illegal_switch); + end; + end; + + + procedure dir_unitpath(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + current_module^.localunitsearchpath.AddPath(current_scanner^.readcomment,false); + end; + end; + + + procedure dir_includepath(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + current_module^.localincludesearchpath.AddPath(current_scanner^.readcomment,false); + end; + end; + + + procedure dir_librarypath(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + current_module^.locallibrarysearchpath.AddPath(current_scanner^.readcomment,false); + end; + end; + + + procedure dir_objectpath(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + current_module^.localobjectsearchpath.AddPath(current_scanner^.readcomment,false); + end; + end; + + + procedure dir_mode(t:tdirectivetoken); + begin + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + current_scanner^.readstring; + if pattern='DEFAULT' then + aktmodeswitches:=initmodeswitches + else + if pattern='DELPHI' then + aktmodeswitches:=delphimodeswitches + else + if pattern='TP' then + aktmodeswitches:=tpmodeswitches + else + if pattern='FPC' then + aktmodeswitches:=fpcmodeswitches + else + if pattern='OBJFPC' then + aktmodeswitches:=objfpcmodeswitches + else + if pattern='GPC' then + aktmodeswitches:=gpcmodeswitches + else + Message(scan_w_illegal_switch); + end; + end; + + + procedure dir_packrecords(t:tdirectivetoken); + var + hs : string; + begin + current_scanner^.skipspace; + if not(c in ['0'..'9']) then + begin + hs:=current_scanner^.readid; + if (hs='C') then + aktpackrecords:=packrecord_C + else + if (hs='NORMAL') or (hs='DEFAULT') then + aktpackrecords:=packrecord_2 + else + Message(scan_w_only_pack_records); + end + else + begin + case current_scanner^.readval of + 1 : aktpackrecords:=packrecord_1; + 2 : aktpackrecords:=packrecord_2; + 4 : aktpackrecords:=packrecord_4; + 8 : aktpackrecords:=packrecord_8; + 16 : aktpackrecords:=packrecord_16; + 32 : aktpackrecords:=packrecord_32; + else + Message(scan_w_only_pack_records); + end; + end; + end; + + procedure dir_maxfpuregisters(t:tdirectivetoken); + + var + l : longint; + hs : string; + + begin + current_scanner^.skipspace; + if not(c in ['0'..'9']) then + begin + hs:=current_scanner^.readid; + if (hs='NORMAL') or (hs='DEFAULT') then + aktmaxfpuregisters:=-1 + else + Message(scan_e_invalid_maxfpureg_value); + end + else + begin + l:=current_scanner^.readval; + case l of + 0..8: + aktmaxfpuregisters:=l; + else + Message(scan_e_invalid_maxfpureg_value); + end; + end; + end; + + + procedure dir_packenum(t:tdirectivetoken); + var + hs : string; + begin + if t in [_DIR_Z1,_DIR_Z2,_DIR_Z4] then + begin + aktpackenum:=ord(pattern[2])-ord('0'); + exit; + end; + current_scanner^.skipspace; + if not(c in ['0'..'9']) then + begin + hs:=current_scanner^.readid; + if (hs='NORMAL') or (hs='DEFAULT') then + aktpackenum:=4 + else + Message(scan_w_only_pack_enum); + end + else + begin + case current_scanner^.readval of + 1 : aktpackenum:=1; + 2 : aktpackenum:=2; + 4 : aktpackenum:=4; + else + Message(scan_w_only_pack_enum); + end; + end; + end; + +{$ifdef testvarsets} + procedure dir_setalloc(t:tdirectivetoken); + var + hs : string; + begin + current_scanner^.skipspace; + if not(c in ['1','2','4']) then + begin + hs:=current_scanner^.readid; + if (hs='FIXED') or ((hs='DEFAULT') OR (hs='NORMAL')) then + aktsetalloc:=0 {Fixed mode, sets are 4 or 32 bytes} + else + Message(scan_w_only_packset); + end + else + begin + case current_scanner^.readval of + 1 : aktpackenum:=1; + 2 : aktpackenum:=2; + 4 : aktpackenum:=4; + else + Message(scan_w_only_packset); + end; + end; + end; +{$ENDIF} + procedure dir_apptype(t:tdirectivetoken); + + var + hs : string; + + begin + if target_info.target<>target_i386_win32 then + Message(scan_w_app_type_not_support); + if not current_module^.in_global then + Message(scan_w_switch_is_global) + else + begin + current_scanner^.skipspace; + hs:=current_scanner^.readid; + if hs='GUI' then + apptype:=at_gui + else if hs='CONSOLE' then + apptype:=at_cui + else + Message1(scan_w_unsupported_app_type,hs); + end; + end; + + procedure dir_wait(t:tdirectivetoken); + var had_info : boolean; + begin + had_info:=(status.verbosity and V_Info)<>0; + { this message should allways appear !! } + status.verbosity:=status.verbosity or V_Info; + Message(scan_i_press_enter); + readln; + If not(had_info) then + status.verbosity:=status.verbosity and (not V_Info); + end; + + + procedure dir_asmmode(t:tdirectivetoken); + var + s : string; + begin + current_scanner^.skipspace; + s:=current_scanner^.readid; + If Inside_asm_statement then + Message1(scan_w_no_asm_reader_switch_inside_asm,s); + if s='DEFAULT' then + aktasmmode:=initasmmode + else + if not set_string_asmmode(s,aktasmmode) then + Message1(scan_w_unsupported_asmmode_specifier,s); + end; + + + procedure dir_oldasmmode(t:tdirectivetoken); + begin + If Inside_asm_statement then + Message1(scan_w_no_asm_reader_switch_inside_asm,directive[t]); +{$ifdef i386} + case t of + _DIR_I386_ATT : aktasmmode:=asmmode_i386_att; + _DIR_I386_DIRECT : aktasmmode:=asmmode_i386_direct; + _DIR_I386_INTEL : aktasmmode:=asmmode_i386_intel; + end; +{$endif i386} + end; + + + procedure dir_delphiswitch(t:tdirectivetoken); + var + sw,state : char; + begin + case t of + _DIR_ALIGN : sw:='A'; + _DIR_ASSERTIONS : sw:='C'; + _DIR_BOOLEVAL : sw:='B'; + _DIR_DEBUGINFO : sw:='D'; + _DIR_IOCHECKS : sw:='I'; + _DIR_LOCALSYMBOLS : sw:='L'; + _DIR_LONGSTRINGS : sw:='H'; + _DIR_OPENSTRINGS : sw:='P'; + _DIR_OVERFLOWCHECKS : sw:='Q'; + _DIR_RANGECHECKS : sw:='R'; + _DIR_REFERENCEINFO : sw:='Y'; + _DIR_STACKFRAMES : sw:='W'; + _DIR_TYPEDADDRESS : sw:='T'; + _DIR_TYPEINFO : sw:='M'; + _DIR_VARSTRINGCHECKS : sw:='V'; + else + exit; + end; + { c contains the next char, a + or - would be fine } + state:=current_scanner^.readstate; + if state in ['-','+'] then + HandleSwitch(sw,state); + end; + + + procedure dir_memory(t:tdirectivetoken); + var + l : longint; + begin + current_scanner^.skipspace; + l:=current_scanner^.readval; + if l>1024 then + stacksize:=l; + current_scanner^.skipspace; + if c=',' then + begin + current_scanner^.readchar; + current_scanner^.skipspace; + l:=current_scanner^.readval; + if l>1024 then + heapsize:=l; + end; + if c=',' then + begin + current_scanner^.readchar; + current_scanner^.skipspace; + l:=current_scanner^.readval; + { Ignore this value, because the limit is set by the OS + info and shouldn't be changed by the user (PFV) } + end; + end; + + + procedure dir_setverbose(t:tdirectivetoken); + var + flag, + state : char; + begin + case t of + _DIR_HINTS : flag:='H'; + _DIR_WARNINGS : flag:='W'; + _DIR_NOTES : flag:='N'; + else + exit; + end; + { support ON/OFF } + state:=current_scanner^.ReadState; + SetVerbosity(flag+state); + end; + + + type + tdirectiveproc=procedure(t:tdirectivetoken); + const + directiveproc:array[tdirectivetoken] of tdirectiveproc=( + {_DIR_NONE} nil, + {_DIR_ALIGN} dir_delphiswitch, + {_DIR_APPTYPE} dir_apptype, + {_DIR_ASMMODE} dir_asmmode, + {_DIR_ASSERTION} dir_delphiswitch, + {_DIR_BOOLEVAL} dir_delphiswitch, + {_DIR_D} dir_description, + {_DIR_DEBUGINFO} dir_delphiswitch, + {_DIR_DEFINE} dir_define, + {_DIR_DESCRIPTION} dir_description, + {_DIR_ELSE} dir_conditional, + {_DIR_ENDIF} dir_conditional, + {_DIR_ERROR} dir_message, + {_DIR_EXTENDEDSYNTAX} dir_delphiswitch, + {_DIR_FATAL} dir_message, + {_DIR_GOTO} dir_moduleswitch, + {_DIR_HINT} dir_message, + {_DIR_HINTS} dir_setverbose, + {_DIR_I} dir_include, + {_DIR_I386_ATT} dir_oldasmmode, + {_DIR_I386_DIRECT} dir_oldasmmode, + {_DIR_I386_INTEL} dir_oldasmmode, + {_DIR_IOCHECKS} dir_delphiswitch, + {_DIR_IF} dir_conditional, + {_DIR_IFDEF} dir_conditional, + {_DIR_IFNDEF} dir_conditional, + {_DIR_IFOPT} dir_conditional, + {_DIR_INCLUDE} dir_include, + {_DIR_INCLUDEPATH} dir_includepath, + {_DIR_INFO} dir_message, + {_DIR_INLINE} dir_moduleswitch, + {_DIR_L} dir_linkobject, + {_DIR_LIBRARYPATH} dir_librarypath, + {_DIR_LINK} dir_linkobject, + {_DIR_LINKLIB} dir_linklib, + {_DIR_LOCALSYMBOLS} dir_delphiswitch, + {_DIR_LONGSTRINGS} dir_delphiswitch, + {_DIR_M} dir_memory, + {_DIR_MACRO} dir_moduleswitch, + {_DIR_MAXFPUREGISTERS} dir_maxfpuregisters, + {_DIR_MEMORY} dir_memory, + {_DIR_MESSAGE} dir_message, + {_DIR_MINENUMSIZE} dir_packenum, + {_DIR_MMX} dir_localswitch, + {_DIR_MODE} dir_mode, + {_DIR_NOTE} dir_message, + {_DIR_NOTES} dir_setverbose, + {_DIR_OBJECTPATH} dir_objectpath, + {_DIR_OPENSTRINGS} dir_delphiswitch, + {_DIR_OUTPUT_FORMAT} dir_outputformat, + {_DIR_OVERFLOWCHECKS} dir_delphiswitch, + {_DIR_PACKENUM} dir_packenum, + {_DIR_PACKRECORDS} dir_packrecords, + {$IFDEF TestVarsets} + {_DIR_PACKSET} dir_packset, + {$ENDIF} + {_DIR_R} dir_resource, + {_DIR_RANGECHECKS} dir_delphiswitch, + {_DIR_REFERENCEINFO} dir_delphiswitch, + {_DIR_SATURATION} dir_localswitch, + {_DIR_SMARTLINK} dir_moduleswitch, + {_DIR_STACKFRAMES} dir_delphiswitch, + {_DIR_STATIC} dir_moduleswitch, + {_DIR_STOP} dir_message, + {_DIR_TYPEDADDRESS} dir_delphiswitch, + {_DIR_TYPEINFO} dir_delphiswitch, + {_DIR_UNDEF} dir_undef, + {_DIR_UNITPATH} dir_unitpath, + {_DIR_VARSTRINGCHECKS} dir_delphiswitch, + {_DIR_VERSION} dir_version, + {_DIR_WAIT} dir_wait, + {_DIR_WARNING} dir_message, + {_DIR_WARNINGS} dir_setverbose, + {_DIR_Z1} dir_packenum, + {_DIR_Z2} dir_packenum, + {_DIR_Z4} dir_packenum + ); + + {------------------------------------------- + Main switches handling + -------------------------------------------} + + procedure handledirectives; + var + t : tdirectivetoken; + p : tdirectiveproc; + hs : string; + begin + current_scanner^.gettokenpos; + current_scanner^.readchar; {Remove the $} + hs:=current_scanner^.readid; + if parapreprocess then + begin + t:=Get_Directive(hs); + if not(is_conditional(t) or (t=_DIR_DEFINE) or (t=_DIR_UNDEF)) then + begin + preprocfile^.AddSpace; + preprocfile^.Add('{$'+hs+current_scanner^.readcomment+'}'); + exit; + end; + end; + Message1(scan_d_handling_switch,'$'+hs); + if hs='' then + Message1(scan_w_illegal_switch,'$'+hs); + { Check for compiler switches } + while (length(hs)=1) and (c in ['-','+']) do + begin + HandleSwitch(hs[1],c); + current_scanner^.readchar; {Remove + or -} + if c=',' then + begin + current_scanner^.readchar; {Remove , } + { read next switch, support $v+,$+} + hs:=current_scanner^.readid; + if (hs='') then + begin + if (c='$') and (m_fpc in aktmodeswitches) then + begin + current_scanner^.readchar; { skip $ } + hs:=current_scanner^.readid; + end; + if (hs='') then + Message1(scan_w_illegal_directive,'$'+c); + end + else + Message1(scan_d_handling_switch,'$'+hs); + end + else + hs:=''; + end; + { directives may follow switches after a , } + if hs<>'' then + begin + t:=Get_Directive(hs); + if t<>_DIR_NONE then + begin + p:=directiveproc[t]; + {$ifndef TP} + if assigned(p) then + {$else} + if @p<>nil then + {$endif} + p(t); + end + else + Message1(scan_w_illegal_directive,'$'+hs); + { conditionals already read the comment } + if (current_scanner^.comment_level>0) then + current_scanner^.readcomment; + { we've read the whole comment } + aktcommentstyle:=comment_none; + end; + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.83 2000/06/30 20:23:38 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.82 2000/06/25 19:08:27 hajny + + $R support for OS/2 (EMX) added + + Revision 1.81 2000/05/23 20:18:25 pierre + + pavel's code integrated, but onyl inside + ifdef pavel_linklib ! + + Revision 1.80 2000/05/09 21:31:50 pierre + * fix problem when modifying several local switches in a row + + Revision 1.79 2000/05/03 14:36:58 pierre + * fix for tests/test/testrang.pp bug + + Revision 1.78 2000/04/14 11:16:10 pierre + * partial linklib change + I could not use Pavel's code because it broke the current way + linklib is used, which is messy :( + + add postw32 call if external linking on win32 + + Revision 1.77 2000/04/08 20:18:53 michael + * Fixed bug in readcomment that was dropping * characters + + Revision 1.76 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.75 2000/02/14 20:58:43 marco + * Basic structures for new sethandling implemented. + + Revision 1.74 2000/02/09 13:23:03 peter + * log truncated + + Revision 1.73 2000/01/14 14:28:40 pierre + * avoid searching of include file in start dir first + + Revision 1.72 2000/01/07 01:14:37 peter + * updated copyright to 2000 + + Revision 1.71 2000/01/04 15:15:53 florian + + added compiler switch $maxfpuregisters + + fixed a small problem in secondvecn + + Revision 1.70 1999/12/20 23:23:30 pierre + + $description $version + + Revision 1.69 1999/12/02 17:34:34 peter + * preprocessor support. But it fails on the caret in type blocks + + Revision 1.68 1999/11/24 11:39:53 pierre + * asmmode message was placed too early + + Revision 1.67 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.66 1999/11/06 14:34:26 peter + * truncated log to 20 revs + + Revision 1.65 1999/10/30 12:32:30 peter + * fixed line counter when the first line had #10 only. This was buggy + for both the main file as for include files + + Revision 1.64 1999/09/27 23:38:17 peter + * bracket support for macro define + + Revision 1.63 1999/09/20 16:39:02 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + + Revision 1.62 1999/09/03 10:00:49 peter + * included the 1.60 version of Pierre which was lost ! + + Revision 1.61 1999/09/02 18:47:46 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.60 1999/08/31 15:55:45 pierre + + tmacrosym.is_used set + + Revision 1.59 1999/08/05 16:53:10 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.58 1999/08/04 13:03:03 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.57 1999/07/26 14:55:36 florian + * $mode gives now a warning if an unknown mode keyword follows + + Revision 1.56 1999/07/23 16:05:27 peter + * alignment is now saved in the symtable + * C alignment added for records + * PPU version increased to solve .12 <-> .13 probs + +} \ No newline at end of file diff --git a/befpc/compiler/scanner.pas b/befpc/compiler/scanner.pas new file mode 100644 index 0000000..1743355 --- /dev/null +++ b/befpc/compiler/scanner.pas @@ -0,0 +1,1945 @@ +{ + $Id: scanner.pas,v 1.1.1.1 2001-07-23 17:17:02 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This unit implements the scanner part and handling of the switches + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef tp} + {$F+,N+,E+,R-} +{$endif} +unit scanner; +{$ifdef FPC} + {$goto on} +{$endif FPC} + + interface + + uses +{$ifdef Delphi} + dmisc, +{$endif Delphi} + globtype,version,tokens, + cobjects,globals,verbose,comphook,files; + + const +{$ifdef TP} + maxmacrolen=1024; + preprocbufsize=1024; +{$else} + maxmacrolen=16*1024; + preprocbufsize=32*1024; +{$endif} + Newline = #10; + + + type + tcommentstyle = (comment_none,comment_tp,comment_oldtp,comment_delphi,comment_c); + + pmacrobuffer = ^tmacrobuffer; + tmacrobuffer = array[0..maxmacrolen-1] of char; + + preproctyp = (pp_ifdef,pp_ifndef,pp_if,pp_ifopt,pp_else); + ppreprocstack = ^tpreprocstack; + tpreprocstack = object + typ : preproctyp; + accept : boolean; + next : ppreprocstack; + name : stringid; + line_nb : longint; + constructor init(atyp:preproctyp;a:boolean;n:ppreprocstack); + destructor done; + end; + + pscannerfile = ^tscannerfile; + tscannerfile = object + inputfile : pinputfile; { current inputfile list } + + inputbuffer, { input buffer } + inputpointer : pchar; + inputstart : longint; + + line_no, { line } + lastlinepos : longint; + + lasttokenpos : longint; { token } + lasttoken, + nexttoken : ttoken; + + comment_level, + yylexcount : longint; + lastasmgetchar : char; + preprocstack : ppreprocstack; + invalid : boolean; { flag if sourcefiles have been destroyed ! } + + constructor init(const fn:string); + destructor done; + { File buffer things } + function openinputfile:boolean; + procedure closeinputfile; + function tempopeninputfile:boolean; + procedure tempcloseinputfile; + procedure saveinputfile; + procedure restoreinputfile; + procedure nextfile; + procedure addfile(hp:pinputfile); + procedure reload; + procedure insertmacro(const macname:string;p:pchar;len:longint); + { Scanner things } + procedure gettokenpos; + procedure inc_comment_level; + procedure dec_comment_level; + procedure illegal_char(c:char); + procedure end_of_file; + procedure checkpreprocstack; + procedure poppreprocstack; + procedure addpreprocstack(atyp : preproctyp;a:boolean;const s:string;w:longint); + procedure elsepreprocstack; + procedure linebreak; + procedure readchar; + procedure readstring; + procedure readnumber; + function readid:string; + function readval:longint; + function readcomment:string; + function readstate:char; + procedure skipspace; + procedure skipuntildirective; + procedure skipcomment; + procedure skipdelphicomment; + procedure skipoldtpcomment; + procedure readtoken; + function readpreproc:ttoken; + function asmgetchar:char; + end; + + ppreprocfile=^tpreprocfile; + tpreprocfile=object + f : text; + buf : pointer; + spacefound, + eolfound : boolean; + constructor init(const fn:string); + destructor done; + procedure Add(const s:string); + procedure AddSpace; + end; + + + var + c : char; + orgpattern, + pattern : string; + current_scanner : pscannerfile; + aktcommentstyle : tcommentstyle; { needed to use read_comment from directives } + + preprocfile : ppreprocfile; { used with only preprocessing } + + +implementation + + uses +{$ifndef delphi} + dos, +{$endif delphi} + systems,symtable,switches +{$IFDEF NEWST} + ,symbols +{$ENDIF NEWST}; + +{***************************************************************************** + Helper routines +*****************************************************************************} + + const + { use any special name that is an invalid file name to avoid problems } + preprocstring : array [preproctyp] of string[7] + = ('$IFDEF','$IFNDEF','$IF','$IFOPT','$ELSE'); + + + function is_keyword(const s:string):boolean; + var + low,high,mid : longint; + begin + if not (length(s) in [2..tokenidlen]) then + begin + is_keyword:=false; + exit; + end; + low:=ord(tokenidx^[length(s),s[1]].first); + high:=ord(tokenidx^[length(s),s[1]].last); + while low0 then + Comment(V_Fatal,'can''t create file '+fn); + getmem(buf,preprocbufsize); + settextbuf(f,buf^,preprocbufsize); + { reset } + eolfound:=false; + spacefound:=false; + end; + + + destructor tpreprocfile.done; + begin + close(f); + freemem(buf,preprocbufsize); + end; + + + procedure tpreprocfile.add(const s:string); + begin + write(f,s); + end; + + procedure tpreprocfile.addspace; + begin + if eolfound then + begin + writeln(f,''); + eolfound:=false; + spacefound:=false; + end + else + if spacefound then + begin + write(f,' '); + spacefound:=false; + end; + end; + + +{***************************************************************************** + TPreProcStack +*****************************************************************************} + + constructor tpreprocstack.init(atyp : preproctyp;a:boolean;n:ppreprocstack); + begin + accept:=a; + typ:=atyp; + next:=n; + end; + + + destructor tpreprocstack.done; + begin + end; + + +{**************************************************************************** + TSCANNERFILE + ****************************************************************************} + + constructor tscannerfile.init(const fn:string); + begin + inputfile:=new(pinputfile,init(fn)); + if assigned(current_module) then + current_module^.sourcefiles^.register_file(inputfile); + { reset localinput } + inputbuffer:=nil; + inputpointer:=nil; + inputstart:=0; + { reset scanner } + preprocstack:=nil; + comment_level:=0; + yylexcount:=0; + block_type:=bt_general; + line_no:=0; + lastlinepos:=0; + lasttokenpos:=0; + lasttoken:=NOTOKEN; + nexttoken:=NOTOKEN; + lastasmgetchar:=#0; + invalid:=false; + { load block } + if not openinputfile then + Message1(scan_f_cannot_open_input,fn); + reload; + { process first read char } + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + end; + + + destructor tscannerfile.done; + begin + if not invalid then + begin + if status.errorcount=0 then + checkpreprocstack; + { close file, but only if we are the first compile } + { probably not necessary anymore with invalid flag PM } + if not current_module^.in_second_compile then + begin + if not inputfile^.closed then + closeinputfile; + end; + end; + end; + + + function tscannerfile.openinputfile:boolean; + begin + openinputfile:=inputfile^.open; + { load buffer } + inputbuffer:=inputfile^.buf; + inputpointer:=inputfile^.buf; + inputstart:=inputfile^.bufstart; + { line } + line_no:=0; + lastlinepos:=0; + lasttokenpos:=0; + end; + + + procedure tscannerfile.closeinputfile; + begin + inputfile^.close; + { reset buffer } + inputbuffer:=nil; + inputpointer:=nil; + inputstart:=0; + { reset line } + line_no:=0; + lastlinepos:=0; + lasttokenpos:=0; + end; + + + function tscannerfile.tempopeninputfile:boolean; + begin + tempopeninputfile:=inputfile^.tempopen; + { reload buffer } + inputbuffer:=inputfile^.buf; + inputpointer:=inputfile^.buf; + inputstart:=inputfile^.bufstart; + end; + + + procedure tscannerfile.tempcloseinputfile; + begin + inputfile^.setpos(inputstart+(inputpointer-inputbuffer)); + inputfile^.tempclose; + { reset buffer } + inputbuffer:=nil; + inputpointer:=nil; + inputstart:=0; + end; + + + procedure tscannerfile.saveinputfile; + begin + inputfile^.saveinputpointer:=inputpointer; + inputfile^.savelastlinepos:=lastlinepos; + inputfile^.saveline_no:=line_no; + end; + + + procedure tscannerfile.restoreinputfile; + begin + inputpointer:=inputfile^.saveinputpointer; + lastlinepos:=inputfile^.savelastlinepos; + line_no:=inputfile^.saveline_no; + if not inputfile^.is_macro then + parser_current_file:=inputfile^.name^; + end; + + + procedure tscannerfile.nextfile; + var + to_dispose : pinputfile; + begin + if assigned(inputfile^.next) then + begin + if inputfile^.is_macro then + to_dispose:=inputfile + else + to_dispose:=nil; + { we can allways close the file, no ? } + inputfile^.close; + inputfile:=inputfile^.next; + if assigned(to_dispose) then + dispose(to_dispose,done); + restoreinputfile; + end; + end; + + + procedure tscannerfile.addfile(hp:pinputfile); + begin + saveinputfile; + { add to list } + hp^.next:=inputfile; + inputfile:=hp; + { load new inputfile } + restoreinputfile; + end; + + + procedure tscannerfile.reload; + begin + with inputfile^ do + begin + { when nothing more to read then leave immediatly, so we + don't change the aktfilepos and leave it point to the last + char } + if (c=#26) and (not assigned(next)) then + exit; + repeat + { still more to read?, then change the #0 to a space so its seen + as a seperator, this can't be used for macro's which can change + the place of the #0 in the buffer with tempopen } + if (c=#0) and (bufsize>0) and + not(inputfile^.is_macro) and + (inputpointer-inputbuffer#26) and (not endoffile) then + begin + readbuf; + inputpointer:=buf; + inputbuffer:=buf; + inputstart:=bufstart; + { first line? } + if line_no=0 then + begin + line_no:=1; + if cs_asm_source in aktglobalswitches then + inputfile^.setline(line_no,bufstart); + end; + end + else + begin + { load eof position in tokenpos/aktfilepos } + gettokenpos; + { close file } + closeinputfile; + { no next module, than EOF } + if not assigned(inputfile^.next) then + begin + c:=#26; + exit; + end; + { load next file and reopen it } + nextfile; + tempopeninputfile; + { status } + Message1(scan_t_back_in,inputfile^.name^); + end; + { load next char } + c:=inputpointer^; + inc(longint(inputpointer)); + until c<>#0; { if also end, then reload again } + end; + end; + + + procedure tscannerfile.insertmacro(const macname:string;p:pchar;len:longint); + var + hp : pinputfile; + begin + { save old postion and decrease linebreak } + if c=newline then + dec(line_no); + dec(longint(inputpointer)); + tempcloseinputfile; + { create macro 'file' } + { use special name to dispose after !! } + hp:=new(pinputfile,init('_Macro_.'+macname)); + addfile(hp); + with inputfile^ do + begin + setmacro(p,len); + { local buffer } + inputbuffer:=buf; + inputpointer:=buf; + inputstart:=bufstart; + end; + { reset line } + line_no:=0; + lastlinepos:=0; + lasttokenpos:=0; + { load new c } + c:=inputpointer^; + inc(longint(inputpointer)); + end; + + + procedure tscannerfile.gettokenpos; + { load the values of tokenpos and lasttokenpos } + begin + lasttokenpos:=inputstart+(inputpointer-inputbuffer); + tokenpos.line:=line_no; + tokenpos.column:=lasttokenpos-lastlinepos; + tokenpos.fileindex:=inputfile^.ref_index; + aktfilepos:=tokenpos; + end; + + + procedure tscannerfile.inc_comment_level; + var + oldaktfilepos : tfileposinfo; + begin + if (m_nested_comment in aktmodeswitches) then + inc(comment_level) + else + comment_level:=1; + if (comment_level>1) then + begin + oldaktfilepos:=aktfilepos; + gettokenpos; { update for warning } + Message1(scan_w_comment_level,tostr(comment_level)); + aktfilepos:=oldaktfilepos; + end; + end; + + + procedure tscannerfile.dec_comment_level; + begin + if (m_nested_comment in aktmodeswitches) then + dec(comment_level) + else + comment_level:=0; + end; + + + procedure tscannerfile.linebreak; + var + cur : char; + oldtokenpos, + oldaktfilepos : tfileposinfo; + begin + with inputfile^ do + begin + if (byte(inputpointer^)=0) and not(endoffile) then + begin + cur:=c; + reload; + if byte(cur)+byte(c)<>23 then + dec(longint(inputpointer)); + end + else + begin + { Fix linebreak to be only newline (=#10) for all types of linebreaks } + if (byte(inputpointer^)+byte(c)=23) then + inc(longint(inputpointer)); + end; + c:=newline; + { increase line counters } + lastlinepos:=bufstart+(inputpointer-inputbuffer); + inc(line_no); + { update linebuffer } + if cs_asm_source in aktglobalswitches then + inputfile^.setline(line_no,lastlinepos); + { update for status and call the show status routine, + but don't touch aktfilepos ! } + oldaktfilepos:=aktfilepos; + oldtokenpos:=tokenpos; + gettokenpos; { update for v_status } + inc(status.compiledlines); + ShowStatus; + aktfilepos:=oldaktfilepos; + tokenpos:=oldtokenpos; + end; + end; + + + procedure tscannerfile.illegal_char(c:char); + var + s : string; + begin + if c in [#32..#255] then + s:=''''+c+'''' + else + s:='#'+tostr(ord(c)); + Message2(scan_f_illegal_char,s,'$'+hexstr(ord(c),2)); + end; + + + procedure tscannerfile.end_of_file; + begin + checkpreprocstack; + Message(scan_f_end_of_file); + end; + + + procedure tscannerfile.checkpreprocstack; + begin + { check for missing ifdefs } + while assigned(preprocstack) do + begin + Message3(scan_e_endif_expected,preprocstring[preprocstack^.typ],preprocstack^.name,tostr(preprocstack^.line_nb)); + poppreprocstack; + end; + end; + + + procedure tscannerfile.poppreprocstack; + var + hp : ppreprocstack; + begin + if assigned(preprocstack) then + begin + Message1(scan_c_endif_found,preprocstack^.name); + hp:=preprocstack^.next; + dispose(preprocstack,done); + preprocstack:=hp; + end + else + Message(scan_e_endif_without_if); + end; + + + procedure tscannerfile.addpreprocstack(atyp : preproctyp;a:boolean;const s:string;w:longint); + begin + preprocstack:=new(ppreprocstack,init(atyp,((preprocstack=nil) or preprocstack^.accept) and a,preprocstack)); + preprocstack^.name:=s; + preprocstack^.line_nb:=line_no; + if preprocstack^.accept then + Message2(w,preprocstack^.name,'accepted') + else + Message2(w,preprocstack^.name,'rejected'); + end; + + + procedure tscannerfile.elsepreprocstack; + begin + if assigned(preprocstack) then + begin + preprocstack^.typ:=pp_else; + preprocstack^.line_nb:=line_no; + if not(assigned(preprocstack^.next)) or (preprocstack^.next^.accept) then + preprocstack^.accept:=not preprocstack^.accept; + if preprocstack^.accept then + Message2(scan_c_else_found,preprocstack^.name,'accepted') + else + Message2(scan_c_else_found,preprocstack^.name,'rejected'); + end + else + Message(scan_e_endif_without_if); + end; + + + procedure tscannerfile.readchar; + begin + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + end; + + + procedure tscannerfile.readstring; + var + i : longint; + begin + i:=0; + repeat + case c of + '_', + '0'..'9', + 'A'..'Z' : begin + if i<255 then + begin + inc(i); + orgpattern[i]:=c; + pattern[i]:=c; + end; + c:=inputpointer^; + inc(longint(inputpointer)); + end; + 'a'..'z' : begin + if i<255 then + begin + inc(i); + orgpattern[i]:=c; + pattern[i]:=chr(ord(c)-32) + end; + c:=inputpointer^; + inc(longint(inputpointer)); + end; + #0 : reload; + #26 : begin + reload; + if c=#26 then + break; + end; + #13,#10 : begin + linebreak; + break; + end; + else + break; + end; + until false; + {$ifndef TP} + {$ifopt H+} + setlength(orgpattern,i); + setlength(pattern,i); + {$else} + orgpattern[0]:=chr(i); + pattern[0]:=chr(i); + {$endif} + {$else} + orgpattern[0]:=chr(i); + pattern[0]:=chr(i); + {$endif} + end; + + + procedure tscannerfile.readnumber; + var + base, + i : longint; + begin + case c of + '%' : begin + readchar; + base:=2; + pattern[1]:='%'; + i:=1; + end; + '$' : begin + readchar; + base:=16; + pattern[1]:='$'; + i:=1; + end; + else + begin + base:=10; + i:=0; + end; + end; + while ((base>=10) and (c in ['0'..'9'])) or + ((base=16) and (c in ['A'..'F','a'..'f'])) or + ((base=2) and (c in ['0'..'1'])) do + begin + if i<255 then + begin + inc(i); + pattern[i]:=c; + end; + { get next char } + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + end; + { was the next char a linebreak ? } + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + {$ifndef TP} + {$ifopt H+} + setlength(pattern,i); + {$else} + pattern[0]:=chr(i); + {$endif} + {$else} + pattern[0]:=chr(i); + {$endif} + end; + + + function tscannerfile.readid:string; + begin + readstring; + readid:=pattern; + end; + + + function tscannerfile.readval:longint; + var + l : longint; + w : integer; + begin + readnumber; + valint(pattern,l,w); + readval:=l; + end; + + + function tscannerfile.readcomment:string; + var + i : longint; + begin + i:=0; + repeat + case c of + '{' : + if aktcommentstyle=comment_tp then + inc_comment_level; + '}' : + if aktcommentstyle=comment_tp then + begin + readchar; + dec_comment_level; + if comment_level=0 then + break + else + continue; + end; + '*' : + if aktcommentstyle=comment_oldtp then + begin + readchar; + if c=')' then + begin + readchar; + dec_comment_level; + break; + end + else + { Add both characters !!} + if (i<255) then + begin + inc(i); + readcomment[i]:='*'; + if (i<255) then + begin + inc(i); + readcomment[i]:='*'; + end; + end; + end + else + { Not old TP comment, so add...} + begin + if (i<255) then + begin + inc(i); + readcomment[i]:='*'; + end; + end; + #26 : + end_of_file; + else + begin + if (i<255) then + begin + inc(i); + readcomment[i]:=c; + end; + end; + end; + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + if c in [#10,#13] then + linebreak; + until false; + {$ifndef TP} + {$ifopt H+} + setlength(readcomment,i); + {$else} + readcomment[0]:=chr(i); + {$endif} + {$else} + readcomment[0]:=chr(i); + {$endif} + end; + + + function tscannerfile.readstate:char; + var + state : char; + begin + state:=' '; + if c=' ' then + begin + current_scanner^.skipspace; + current_scanner^.readid; + if pattern='ON' then + state:='+' + else + if pattern='OFF' then + state:='-'; + end + else + state:=c; + if not (state in ['+','-']) then + Message(scan_e_wrong_switch_toggle); + readstate:=state; + end; + + + procedure tscannerfile.skipspace; + begin + while c in [' ',#9..#13] do + begin + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + case c of + #26 : + reload; + #10, + #13 : + linebreak; + end; + end; + end; + + + procedure tscannerfile.skipuntildirective; + var + found : longint; + next_char_loaded : boolean; + oldcommentstyle : tcommentstyle; + begin + found:=0; + next_char_loaded:=false; + oldcommentstyle:=aktcommentstyle; + repeat + case c of + #26 : + end_of_file; + '{' : + begin + if not(m_nested_comment in aktmodeswitches) or + (comment_level=0) then + begin + found:=1; + aktcommentstyle:=comment_tp; + end; + inc_comment_level; + end; + '}' : + begin + dec_comment_level; + found:=0; + end; + '$' : + begin + if found=1 then + found:=2; + end; + '''' : + if not(m_nested_comment in aktmodeswitches) then + begin + repeat + readchar; + case c of + #26 : + end_of_file; + newline : + break; + '''' : + begin + readchar; + if c<>'''' then + break; + end; + end; + until false; + end; + '(' : + begin + readchar; + if c='*' then + begin + readchar; + if c='$' then + begin + found:=2; + inc_comment_level; + aktcommentstyle:=comment_oldtp; + end + else + begin + skipoldtpcomment; + aktcommentstyle:=oldcommentstyle; + end; + end + else + next_char_loaded:=true; + end; + else + found:=0; + end; + if next_char_loaded then + next_char_loaded:=false + else + begin + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + end; + until (found=2); + end; + + +{**************************************************************************** + Include directive scanning/parsing +****************************************************************************} + +{$i scandir.inc} + + +{**************************************************************************** + Comment Handling +****************************************************************************} + + procedure tscannerfile.skipcomment; + begin + aktcommentstyle:=comment_tp; + readchar; + inc_comment_level; + { handle compiler switches } + if (c='$') then + handledirectives; + { handle_switches can dec comment_level, } + while (comment_level>0) do + begin + case c of + '{' : inc_comment_level; + '}' : dec_comment_level; + #26 : end_of_file; + end; + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + end; + aktcommentstyle:=comment_none; + end; + + + procedure tscannerfile.skipdelphicomment; + begin + aktcommentstyle:=comment_delphi; + inc_comment_level; + readchar; + { this is currently not supported } + if c='$' then + Message(scan_e_wrong_styled_switch); + { skip comment } + while c<>newline do + begin + if c=#26 then + end_of_file; + readchar; + end; + dec_comment_level; + aktcommentstyle:=comment_none; + end; + + + procedure tscannerfile.skipoldtpcomment; + var + found : longint; + begin + aktcommentstyle:=comment_oldtp; + inc_comment_level; + readchar; + { this is currently not supported } + if (c='$') then + handledirectives; + { skip comment } + while (comment_level>0) do + begin + found:=0; + repeat + case c of + #26 : + end_of_file; + '*' : + begin + if found=3 then + found:=4 + else + found:=1; + end; + ')' : + begin + if found in [1,4] then + begin + dec_comment_level; + if comment_level=0 then + found:=2 + else + found:=0; + end; + end; + '(' : + begin + if found=4 then + inc_comment_level; + found:=3; + end; + else + begin + if found=4 then + inc_comment_level; + found:=0; + end; + end; + c:=inputpointer^; + if c=#0 then + reload + else + inc(longint(inputpointer)); + case c of + #26 : reload; + #10, + #13 : linebreak; + end; + until (found=2); + end; + aktcommentstyle:=comment_none; + end; + + + +{**************************************************************************** + Token Scanner +****************************************************************************} + + procedure tscannerfile.readtoken; + var + code : integer; + low,high,mid : longint; + m : longint; + mac : pmacrosym; + asciinr : string[6]; + label + exit_label; + begin + if localswitcheschanged then + begin + aktlocalswitches:=nextaktlocalswitches; + localswitcheschanged:=false; + end; + { was there already a token read, then return that token } + if nexttoken<>NOTOKEN then + begin + token:=nexttoken; + nexttoken:=NOTOKEN; + goto exit_label; + end; + + { Skip all spaces and comments } + repeat + case c of + '{' : + skipcomment; + ' ',#9..#13 : + begin + if parapreprocess then + begin + if c=#10 then + preprocfile^.eolfound:=true + else + preprocfile^.spacefound:=true; + end; + skipspace; + end + else + break; + end; + until false; + + { Save current token position, for EOF its already loaded } + if c<>#26 then + gettokenpos; + + { Check first for a identifier/keyword, this is 20+% faster (PFV) } + if c in ['A'..'Z','a'..'z','_'] then + begin + readstring; + token:=_ID; + idtoken:=_ID; + { keyword or any other known token, + pattern is always uppercased } + if (pattern[1]<>'_') and (length(pattern) in [2..tokenidlen]) then + begin + low:=ord(tokenidx^[length(pattern),pattern[1]].first); + high:=ord(tokenidx^[length(pattern),pattern[1]].last); + while low16 then + Message(scan_w_macro_deep_ten); + readtoken; + { that's all folks } + dec(yylexcount); + exit; + end; + end; + end; + { return token } + goto exit_label; + end + else + begin + idtoken:=_NOID; + case c of + + '$' : + begin + readnumber; + token:=_INTCONST; + goto exit_label; + end; + + '%' : + begin + if (m_tp in aktmodeswitches) then + Illegal_Char(c) + else + begin + readnumber; + token:=_INTCONST; + goto exit_label; + end; + end; + + '0'..'9' : + begin + readnumber; + if (c in ['.','e','E']) then + begin + { first check for a . } + if c='.' then + begin + readchar; + { is it a .. from a range? } + case c of + '.' : + begin + readchar; + token:=_INTCONST; + nexttoken:=_POINTPOINT; + goto exit_label; + end; + ')' : + begin + readchar; + token:=_INTCONST; + nexttoken:=_RECKKLAMMER; + goto exit_label; + end; + end; + { insert the number after the . } + pattern:=pattern+'.'; + while c in ['0'..'9'] do + begin + pattern:=pattern+c; + readchar; + end; + end; + { E can also follow after a point is scanned } + if c in ['e','E'] then + begin + pattern:=pattern+'E'; + readchar; + if c in ['-','+'] then + begin + pattern:=pattern+c; + readchar; + end; + if not(c in ['0'..'9']) then + Illegal_Char(c); + while c in ['0'..'9'] do + begin + pattern:=pattern+c; + readchar; + end; + end; + token:=_REALNUMBER; + goto exit_label; + end; + token:=_INTCONST; + goto exit_label; + end; + + ';' : + begin + readchar; + token:=_SEMICOLON; + goto exit_label; + end; + + '[' : + begin + readchar; + token:=_LECKKLAMMER; + goto exit_label; + end; + + ']' : + begin + readchar; + token:=_RECKKLAMMER; + goto exit_label; + end; + + '(' : + begin + readchar; + case c of + '*' : + begin + skipoldtpcomment; + readtoken; + exit; + end; + '.' : + begin + readchar; + token:=_LECKKLAMMER; + goto exit_label; + end; + end; + token:=_LKLAMMER; + goto exit_label; + end; + + ')' : + begin + readchar; + token:=_RKLAMMER; + goto exit_label; + end; + + '+' : + begin + readchar; + if (c='=') and (cs_support_c_operators in aktmoduleswitches) then + begin + readchar; + token:=_PLUSASN; + goto exit_label; + end; + token:=_PLUS; + goto exit_label; + end; + + '-' : + begin + readchar; + if (c='=') and (cs_support_c_operators in aktmoduleswitches) then + begin + readchar; + token:=_MINUSASN; + goto exit_label; + end; + token:=_MINUS; + goto exit_label; + end; + + ':' : + begin + readchar; + if c='=' then + begin + readchar; + token:=_ASSIGNMENT; + goto exit_label; + end; + token:=_COLON; + goto exit_label; + end; + + '*' : + begin + readchar; + if (c='=') and (cs_support_c_operators in aktmoduleswitches) then + begin + readchar; + token:=_STARASN; + end + else + if c='*' then + begin + readchar; + token:=_STARSTAR; + end + else + token:=_STAR; + goto exit_label; + end; + + '/' : + begin + readchar; + case c of + '=' : + begin + if (cs_support_c_operators in aktmoduleswitches) then + begin + readchar; + token:=_SLASHASN; + goto exit_label; + end; + end; + '/' : + begin + skipdelphicomment; + readtoken; + exit; + end; + end; + token:=_SLASH; + goto exit_label; + end; + + '=' : + begin + readchar; + token:=_EQUAL; + goto exit_label; + end; + + '.' : + begin + readchar; + case c of + '.' : + begin + readchar; + token:=_POINTPOINT; + goto exit_label; + end; + ')' : + begin + readchar; + token:=_RECKKLAMMER; + goto exit_label; + end; + end; + token:=_POINT; + goto exit_label; + end; + + '@' : + begin + readchar; + if c='@' then + begin + readchar; + token:=_DOUBLEADDR; + end + else + token:=_KLAMMERAFFE; + goto exit_label; + end; + + ',' : + begin + readchar; + token:=_COMMA; + goto exit_label; + end; + + '''','#','^' : + begin + if c='^' then + begin + readchar; + c:=upcase(c); + if (block_type=bt_type) or + (lasttoken=_ID) or + (lasttoken=_RKLAMMER) or (lasttoken=_RECKKLAMMER) or (lasttoken=_CARET) then + begin + token:=_CARET; + goto exit_label; + end + else + begin + if c<#64 then + pattern:=chr(ord(c)+64) + else + pattern:=chr(ord(c)-64); + readchar; + end; + end + else + pattern:=''; + repeat + case c of + '#' : + begin + readchar; { read # } + if c='$' then + begin + readchar; { read leading $ } + asciinr:='$'; + while (upcase(c) in ['A'..'F','0'..'9']) and (length(asciinr)<6) do + begin + asciinr:=asciinr+c; + readchar; + end; + end + else + begin + asciinr:=''; + while (c in ['0'..'9']) and (length(asciinr)<6) do + begin + asciinr:=asciinr+c; + readchar; + end; + end; + valint(asciinr,m,code); + if (asciinr='') or (code<>0) or + (m<0) or (m>255) then + Message(scan_e_illegal_char_const); + pattern:=pattern+chr(m); + end; + '''' : + begin + repeat + readchar; + case c of + #26 : + end_of_file; + newline : + Message(scan_f_string_exceeds_line); + '''' : + begin + readchar; + if c<>'''' then + break; + end; + end; + pattern:=pattern+c; + until false; + end; + '^' : + begin + readchar; + c:=upcase(c); + if c<#64 then + c:=chr(ord(c)+64) + else + c:=chr(ord(c)-64); + pattern:=pattern+c; + readchar; + end; + else + break; + end; + until false; + { strings with length 1 become const chars } + if length(pattern)=1 then + token:=_CCHAR + else + token:=_CSTRING; + goto exit_label; + end; + + '>' : + begin + readchar; + case c of + '=' : + begin + readchar; + token:=_GTE; + goto exit_label; + end; + '>' : + begin + readchar; + token:=_OP_SHR; + goto exit_label; + end; + '<' : + begin { >< is for a symetric diff for sets } + readchar; + token:=_SYMDIF; + goto exit_label; + end; + end; + token:=_GT; + goto exit_label; + end; + + '<' : + begin + readchar; + case c of + '>' : + begin + readchar; + token:=_UNEQUAL; + goto exit_label; + end; + '=' : + begin + readchar; + token:=_LTE; + goto exit_label; + end; + '<' : + begin + readchar; + token:=_OP_SHL; + goto exit_label; + end; + end; + token:=_LT; + goto exit_label; + end; + + #26 : + begin + token:=_EOF; + checkpreprocstack; + goto exit_label; + end; + else + Illegal_Char(c); + end; + end; +exit_label: + lasttoken:=token; + end; + + + function tscannerfile.readpreproc:ttoken; + begin + skipspace; + case c of + 'A'..'Z', + 'a'..'z', + '_','0'..'9' : begin + preprocpat:=readid; + readpreproc:=_ID; + end; + '}' : begin + readpreproc:=_END; + end; + '(' : begin + readchar; + readpreproc:=_LKLAMMER; + end; + ')' : begin + readchar; + readpreproc:=_RKLAMMER; + end; + '+' : begin + readchar; + readpreproc:=_PLUS; + end; + '-' : begin + readchar; + readpreproc:=_MINUS; + end; + '*' : begin + readchar; + readpreproc:=_STAR; + end; + '/' : begin + readchar; + readpreproc:=_SLASH; + end; + '=' : begin + readchar; + readpreproc:=_EQUAL; + end; + '>' : begin + readchar; + if c='=' then + begin + readchar; + readpreproc:=_GTE; + end + else + readpreproc:=_GT; + end; + '<' : begin + readchar; + case c of + '>' : begin + readchar; + readpreproc:=_UNEQUAL; + end; + '=' : begin + readchar; + readpreproc:=_LTE; + end; + else readpreproc:=_LT; + end; + end; + #26 : + end_of_file; + else + begin + readpreproc:=_EOF; + checkpreprocstack; + end; + end; + end; + + + function tscannerfile.asmgetchar : char; + begin + if lastasmgetchar<>#0 then + begin + c:=lastasmgetchar; + lastasmgetchar:=#0; + end + else + readchar; + case c of + '{' : begin + skipcomment; + asmgetchar:=c; + exit; + end; + '/' : begin + readchar; + if c='/' then + begin + skipdelphicomment; + asmgetchar:=c; + end + else + begin + asmgetchar:='/'; + lastasmgetchar:=c; + end; + exit; + end; + '(' : begin + readchar; + if c='*' then + begin + skipoldtpcomment; + asmgetchar:=c; + end + else + begin + asmgetchar:='('; + lastasmgetchar:=c; + end; + exit; + end; + else + begin + asmgetchar:=c; + end; + end; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.116 2000/07/08 18:03:11 peter + * undid my previous commit, because it breaks some code + + Revision 1.115 2000/07/08 16:22:30 peter + * also support string parsing in skipuntildirective for fpc modes + + Revision 1.114 2000/06/30 20:23:38 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.113 2000/06/18 18:05:54 peter + * no binary value reading with % if not fpc mode + * extended illegal char message with the char itself (Delphi like) + + Revision 1.112 2000/06/09 21:35:37 peter + * fixed parsing of $if preproc function + + Revision 1.111 2000/05/03 14:36:58 pierre + * fix for tests/test/testrang.pp bug + + Revision 1.110 2000/04/08 20:18:53 michael + * Fixed bug in readcomment that was dropping * characters + + Revision 1.109 2000/03/13 21:21:57 peter + * ^m support also after a string + + Revision 1.108 2000/03/12 17:53:16 florian + * very small change to scanner ... + + Revision 1.107 2000/02/29 23:59:47 pierre + Use $GOTO ON + + Revision 1.106 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.105 2000/02/09 13:23:03 peter + * log truncated + + Revision 1.104 2000/01/30 19:28:25 peter + * fixed filepos when eof is read, it'll now stay on the eof position + + Revision 1.103 2000/01/07 01:14:38 peter + * updated copyright to 2000 + + Revision 1.102 1999/12/02 17:34:34 peter + * preprocessor support. But it fails on the caret in type blocks + + Revision 1.101 1999/11/15 17:52:59 pierre + + one field added for ttoken record for operator + linking the id to the corresponding operator token that + can now now all be overloaded + * overloaded operators are resetted to nil in InitSymtable + (bug when trying to compile a uint that overloads operators twice) + + Revision 1.100 1999/11/06 14:34:26 peter + * truncated log to 20 revs + + Revision 1.99 1999/11/03 23:44:28 peter + * fixed comment level counting after directive + + Revision 1.98 1999/11/02 15:05:08 peter + * fixed oldtp comment parsing + + Revision 1.97 1999/10/30 12:32:30 peter + * fixed line counter when the first line had #10 only. This was buggy + for both the main file as for include files + + Revision 1.96 1999/09/27 23:40:10 peter + * fixed macro within macro endless-loop + + Revision 1.95 1999/09/03 10:02:48 peter + * $IFNDEF is 7 chars and not 6 chars + + Revision 1.94 1999/09/02 18:47:47 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.93 1999/08/30 10:17:58 peter + * fixed crash in psub + * ansistringcompare fixed + * support for #$0b8 + + Revision 1.92 1999/08/06 13:11:44 michael + * Removed C style comments. + + Revision 1.91 1999/08/05 16:53:11 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.90 1999/08/04 13:03:05 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.89 1999/07/29 11:43:22 peter + * always output preprocstack when unexpected eof is found + * fixed tp7/delphi skipuntildirective parsing + + Revision 1.88 1999/07/24 11:20:59 peter + * directives are allowed in (* *) + * fixed parsing of (* between conditional code + +} diff --git a/befpc/compiler/script.pas b/befpc/compiler/script.pas new file mode 100644 index 0000000..b385af2 --- /dev/null +++ b/befpc/compiler/script.pas @@ -0,0 +1,258 @@ +{ + $Id: script.pas,v 1.1.1.1 2001-07-23 17:17:02 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit handles the writing of script files + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit Script; +interface + +uses + CObjects; + +type + PScript=^TScript; + TScript=object + fn : string[80]; + data : TStringQueue; + executable : boolean; + constructor Init(const s:string); + constructor InitExec(const s:string); + destructor Done; + procedure AddStart(const s:string); + procedure Add(const s:string); + Function Empty:boolean; + procedure WriteToDisk;virtual; + end; + + PAsmScript = ^TAsmScript; + TAsmScript = Object (TScript) + Constructor Init (Const ScriptName : String); + Procedure AddAsmCommand (Const Command, Options,FileName : String); + Procedure AddLinkCommand (Const Command, Options, FileName : String); + Procedure AddDeleteCommand (Const FileName : String); + Procedure WriteToDisk;virtual; + end; + + PLinkRes = ^TLinkRes; + TLinkRes = Object (TScript) + procedure Add(const s:string); + procedure AddFileName(const s:string); + end; + +var + AsmRes : TAsmScript; + LinkRes : TLinkRes; + + +implementation + +uses +{$ifdef linux} + linux, +{$endif} + + globals,systems; + + +{$ifdef beos} + {$define linux} +{$endif} + + +{**************************************************************************** + TScript +****************************************************************************} + +constructor TScript.Init(const s:string); +begin + fn:=FixFileName(s); + executable:=false; + data.Init; +end; + + +constructor TScript.InitExec(const s:string); +begin + fn:=FixFileName(s)+source_os.scriptext; + executable:=true; + data.Init; +end; + + +destructor TScript.Done; +begin + data.done; +end; + + +procedure TScript.AddStart(const s:string); +begin + data.Insert(s); +end; + + +procedure TScript.Add(const s:string); +begin + data.Concat(s); +end; + + +Function TScript.Empty:boolean; +begin + Empty:=Data.Empty; +end; + + +procedure TScript.WriteToDisk; +var + t : Text; +begin + Assign(t,fn); + Rewrite(t); + while not data.Empty do + Writeln(t,data.Get); + Close(t); +{$ifdef linux} + {$ifndef beos} + if executable then + ChMod(fn,493); + {$endif} +{$endif} +end; + + +{**************************************************************************** + Asm Response +****************************************************************************} + +Constructor TAsmScript.Init (Const ScriptName : String); +begin + Inherited InitExec(ScriptName); +end; + + +Procedure TAsmScript.AddAsmCommand (Const Command, Options,FileName : String); +begin + {$ifdef linux} + if FileName<>'' then + Add('echo Assembling '+FileName); + Add (Command+' '+Options); + Add('if [ $? != 0 ]; then DoExitAsm '+FileName+'; fi'); + {$else} + if FileName<>'' then + begin + Add('SET THEFILE='+FileName); + Add('echo Assembling %THEFILE%'); + end; + Add(command+' '+Options); + Add('if errorlevel 1 goto asmend'); + {$endif} +end; + + +Procedure TasmScript.AddLinkCommand (Const Command, Options, FileName : String); +begin + {$ifdef linux} + if FileName<>'' then + Add('echo Linking '+FileName); + Add (Command+' '+Options); + Add('if [ $? != 0 ]; then DoExitLink '+FileName+'; fi'); + {$else} + if FileName<>'' then + begin + Add('SET THEFILE='+FileName); + Add('echo Linking %THEFILE%'); + end; + Add (Command+' '+Options); + Add('if errorlevel 1 goto linkend'); + {$endif} +end; + + +Procedure TAsmScript.AddDeleteCommand (Const FileName : String); +begin + {$ifdef linux} + Add('rm '+FileName); + {$else} + Add('Del '+FileName); + {$endif} +end; + + +Procedure TAsmScript.WriteToDisk; +Begin +{$ifdef linux} + AddStart('{ echo "An error occurred while linking $1"; exit 1; }'); + AddStart('DoExitLink ()'); + AddStart('{ echo "An error occurred while assembling $1"; exit 1; }'); + AddStart('DoExitAsm ()'); + AddStart('#!/bin/sh'); +{$else} + AddStart('@echo off'); + Add('goto end'); + Add(':asmend'); + Add('echo An error occured while assembling %THEFILE%'); + Add('goto end'); + Add(':linkend'); + Add('echo An error occured while linking %THEFILE%'); + Add(':end'); +{$endif} + inherited WriteToDisk; +end; + + +{**************************************************************************** + Link Response +****************************************************************************} + +procedure TLinkRes.Add(const s:string); +begin + if s<>'' then + inherited Add(s); +end; + +procedure TLinkRes.AddFileName(const s:string); +begin + if s<>'' then + begin + if not(s[1] in ['a'..'z','A'..'Z','/','\','.']) then + inherited Add('.'+DirSep+s) + else + inherited Add(s); + end; +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.6 2000/02/09 13:23:04 peter + * log truncated + + Revision 1.5 2000/02/07 11:52:26 michael + + Changed bash to sh + + Revision 1.4 2000/01/07 01:14:39 peter + * updated copyright to 2000 + + Revision 1.3 1999/10/21 14:29:37 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/switches.pas b/befpc/compiler/switches.pas new file mode 100644 index 0000000..6d4ce13 --- /dev/null +++ b/befpc/compiler/switches.pas @@ -0,0 +1,198 @@ +{ + $Id: switches.pas,v 1.1.1.1 2001-07-23 17:17:02 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements the parsing of the switches like $I- + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit switches; +interface + +procedure HandleSwitch(switch,state:char); +function CheckSwitch(switch,state:char):boolean; + + +implementation +uses + globtype,systems, + globals,verbose,files; + +{**************************************************************************** + Main Switches Parsing +****************************************************************************} + +type + TSwitchType=(ignoredsw,localsw,modulesw,globalsw,illegalsw,unsupportedsw); + SwitchRec=record + typesw : TSwitchType; + setsw : byte; + end; +const + SwitchTable:array['A'..'Z'] of SwitchRec=( + {A} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {B} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {C} (typesw:localsw; setsw:ord(cs_do_assertion)), + {D} (typesw:modulesw; setsw:ord(cs_debuginfo)), + {E} (typesw:globalsw; setsw:ord(cs_fp_emulation)), + {F} (typesw:ignoredsw; setsw:ord(cs_localnone)), + {G} (typesw:ignoredsw; setsw:ord(cs_localnone)), + {H} (typesw:localsw; setsw:ord(cs_ansistrings)), + {I} (typesw:localsw; setsw:ord(cs_check_io)), + {J} (typesw:unsupportedsw; setsw:ord(cs_typed_const_not_changeable)), + {K} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {L} (typesw:modulesw; setsw:ord(cs_local_browser)), + {M} (typesw:localsw; setsw:ord(cs_generate_rtti)), + {N} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {O} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {P} (typesw:modulesw; setsw:ord(cs_openstring)), + {Q} (typesw:localsw; setsw:ord(cs_check_overflow)), + {R} (typesw:localsw; setsw:ord(cs_check_range)), + {S} (typesw:localsw; setsw:ord(cs_check_stack)), + {T} (typesw:localsw; setsw:ord(cs_typed_addresses)), + {U} (typesw:illegalsw; setsw:ord(cs_localnone)), + {V} (typesw:localsw; setsw:ord(cs_strict_var_strings)), + {W} (typesw:unsupportedsw; setsw:ord(cs_localnone)), + {X} (typesw:modulesw; setsw:ord(cs_extsyntax)), + {Y} (typesw:modulesw; setsw:ord(cs_browser)), + {Z} (typesw:illegalsw; setsw:ord(cs_localnone)) + ); + +procedure HandleSwitch(switch,state:char); +begin + switch:=upcase(switch); +{ Is the Switch in the letters ? } + if not ((switch in ['A'..'Z']) and (state in ['-','+'])) then + begin + Message(scan_w_illegal_switch); + exit; + end; +{ Handle the switch } + with SwitchTable[switch] do + begin + case typesw of + ignoredsw : Message1(scan_n_ignored_switch,'$'+switch); + illegalsw : Message1(scan_w_illegal_switch,'$'+switch); + unsupportedsw : Message1(scan_w_unsupported_switch,'$'+switch); + localsw : begin + if not localswitcheschanged then + nextaktlocalswitches:=aktlocalswitches; + if state='+' then + nextaktlocalswitches:=nextaktlocalswitches+[tlocalswitch(setsw)] + else + nextaktlocalswitches:=nextaktlocalswitches-[tlocalswitch(setsw)]; + localswitcheschanged:=true; + { Message for linux which has global checking only } + if (switch='S') and ( +{$ifdef i386} + (target_info.target = target_i386_linux) +{$else} +{$ifdef m68k} + (target_info.target = target_m68k_linux) +{$else} + True +{$endif m68k} +{$endif i386} + ) then + Message(scan_n_stack_check_global_under_linux); + end; + modulesw : begin + if current_module^.in_global then + begin + if state='+' then + aktmoduleswitches:=aktmoduleswitches+[tmoduleswitch(setsw)] + else + aktmoduleswitches:=aktmoduleswitches-[tmoduleswitch(setsw)]; + { can't have local browser when no global browser + moved to end of global section + if (cs_local_browser in aktmoduleswitches) and + not(cs_browser in aktmoduleswitches) then + aktmoduleswitches:=aktmoduleswitches-[cs_local_browser];} + end + else + Message(scan_w_switch_is_global); + end; + globalsw : begin + if current_module^.in_global and (current_module=main_module) then + begin + if state='+' then + aktglobalswitches:=aktglobalswitches+[tglobalswitch(setsw)] + else + aktglobalswitches:=aktglobalswitches-[tglobalswitch(setsw)]; + end + else + Message(scan_w_switch_is_global); + end; + end; + end; +end; + + +function CheckSwitch(switch,state:char):boolean; +var + found : boolean; +begin + switch:=upcase(switch); +{ Is the Switch in the letters ? } + if not ((switch in ['A'..'Z']) and (state in ['-','+'])) then + begin + Message(scan_w_illegal_switch); + CheckSwitch:=false; + exit; + end; +{ Check the switch } + with SwitchTable[switch] do + begin + case typesw of + localsw : found:=(tlocalswitch(setsw) in aktlocalswitches); + modulesw : found:=(tmoduleswitch(setsw) in aktmoduleswitches); + globalsw : found:=(tglobalswitch(setsw) in aktglobalswitches); + else + found:=false; + end; + if state='-' then + found:=not found; + CheckSwitch:=found; + end; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.28 2000/05/09 21:31:50 pierre + * fix problem when modifying several local switches in a row + + Revision 1.27 2000/05/03 14:36:58 pierre + * fix for tests/test/testrang.pp bug + + Revision 1.26 2000/02/09 13:23:04 peter + * log truncated + + Revision 1.25 2000/01/07 01:14:39 peter + * updated copyright to 2000 + + Revision 1.24 1999/11/06 14:34:26 peter + * truncated log to 20 revs + + Revision 1.23 1999/09/16 11:34:58 pierre + * typo correction + + Revision 1.22 1999/08/01 23:35:06 michael + * Alpha changes + +} \ No newline at end of file diff --git a/befpc/compiler/symconst.pas b/befpc/compiler/symconst.pas new file mode 100644 index 0000000..4934dba --- /dev/null +++ b/befpc/compiler/symconst.pas @@ -0,0 +1,270 @@ +{ + $Id: symconst.pas,v 1.1.1.1 2001-07-23 17:17:02 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Symbol table constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} +unit symconst; +interface + +const + def_alignment = 4; + +type + { symbol options } + tsymoption=(sp_none, + sp_public, + sp_private, + sp_published, + sp_protected, + sp_static, + sp_primary_typesym { this is for typesym, to know who is the primary symbol of a def } + ); + tsymoptions=set of tsymoption; + + { flags for a definition } + tdefoption=(df_none, + df_need_rtti, { the definitions needs rtti } + df_has_rtti { the rtti is generated } + ); + tdefoptions=set of tdefoption; + + { base types for orddef } + tbasetype = ( + uauto,uvoid,uchar, + u8bit,u16bit,u32bit, + s8bit,s16bit,s32bit, + bool8bit,bool16bit,bool32bit, + u64bit,s64bit,uwidechar + ); + + { float types } + tfloattype = ( + s32real,s64real,s80real, + s64comp, + f16bit,f32bit + ); + + { string types } + tstringtype = (st_default, + st_shortstring, st_longstring, st_ansistring, st_widestring + ); + + { set types } + tsettype = ( + normset,smallset,varset + ); + + { calling convention for tprocdef and tprocvardef } + tproccalloption=(pocall_none, + pocall_clearstack, { Use IBM flat calling convention. (Used by GCC.) } + pocall_leftright, { Push parameters from left to right } + pocall_cdecl, { procedure uses C styled calling } + pocall_register, { procedure uses register (fastcall) calling } + pocall_stdcall, { procedure uses stdcall call } + pocall_safecall, { safe call calling conventions } + pocall_palmossyscall, { procedure is a PalmOS system call } + pocall_system, + pocall_inline, { Procedure is an assembler macro } + pocall_internproc, { Procedure has compiler magic} + pocall_internconst { procedure has constant evaluator intern } + ); + tproccalloptions=set of tproccalloption; + + { basic type for tprocdef and tprocvardef } + tproctypeoption=(potype_none, + potype_proginit, { Program initialization } + potype_unitinit, { unit initialization } + potype_unitfinalize, { unit finalization } + potype_constructor, { Procedure is a constructor } + potype_destructor, { Procedure is a destructor } + potype_operator { Procedure defines an operator } + ); + tproctypeoptions=set of tproctypeoption; + + { other options for tprocdef and tprocvardef } + tprocoption=(po_none, + po_classmethod, { class method } + po_virtualmethod, { Procedure is a virtual method } + po_abstractmethod, { Procedure is an abstract method } + po_staticmethod, { static method } + po_overridingmethod, { method with override directive } + po_methodpointer, { method pointer, only in procvardef, also used for 'with object do' } + po_containsself, { self is passed explicit to the compiler } + po_interrupt, { Procedure is an interrupt handler } + po_iocheck, { IO checking should be done after a call to the procedure } + po_assembler, { Procedure is written in assembler } + po_msgstr, { method for string message handling } + po_msgint, { method for int message handling } + po_exports, { Procedure has export directive (needed for OS/2) } + po_external, { Procedure is external (in other object or lib)} + po_savestdregs, { save std regs cdecl and stdcall need that ! } + po_saveregisters, { save all registers } + po_overload { procedure is declared with overload directive } + ); + tprocoptions=set of tprocoption; + + { options for objects and classes } + tobjectoption=(oo_none, + oo_is_class, + oo_is_forward, { the class is only a forward declared yet } + oo_has_virtual, { the object/class has virtual methods } + oo_has_private, + oo_has_protected, + oo_has_constructor, { the object/class has a constructor } + oo_has_destructor, { the object/class has a destructor } + oo_has_vmt, { the object/class has a vmt } + oo_has_msgstr, + oo_has_msgint, + oo_has_abstract, { the object/class has an abstract method => no instances can be created } + oo_can_have_published, { the class has rtti, i.e. you can publish properties } + oo_cpp_class, { the object/class uses an C++ compatible } + { class layout } + oo_interface { delphi styled interface } + ); + + tobjectoptions=set of tobjectoption; + + { options for properties } + tpropertyoption=(ppo_none, + ppo_indexed, + ppo_defaultproperty, + ppo_stored, + ppo_hasparameters, + ppo_is_override + ); + tpropertyoptions=set of tpropertyoption; + + { options for variables } + tvaroption=(vo_none, + vo_regable, + vo_is_C_var, + vo_is_external, + vo_is_dll_var, + vo_is_thread_var, + vo_fpuregable, + vo_is_local_copy, + vo_is_const, { variable is declared as const (parameter) and can't be written to } + vo_is_exported + ); + tvaroptions=set of tvaroption; + + { definition contains the informations about a type } + tdeftype = (abstractdef,arraydef,recorddef,pointerdef,orddef, + stringdef,enumdef,procdef,objectdef,errordef, + filedef,formaldef,setdef,procvardef,floatdef, + classrefdef,forwarddef); + + { possible types for symtable entries } + tsymtyp = (abstractsym,varsym,typesym,procsym,unitsym,programsym, + constsym,enumsym,typedconstsym,errorsym,syssym, + labelsym,absolutesym,propertysym,funcretsym, + macrosym); + + { State of the variable, if it's declared, assigned or used } + tvarstate=(vs_none, + vs_declared,vs_declared_and_first_found, + vs_set_but_first_not_passed,vs_assigned,vs_used + ); + + absolutetyp = (tovar,toasm,toaddr); + + tconsttyp = (constnone, + constord,conststring,constreal,constbool, + constint,constchar,constset,constpointer,constnil, + constresourcestring + ); + + +const + { relevant options for assigning a proc or a procvar to a procvar } + po_compatibility_options = [ + po_classmethod, + po_staticmethod, + po_methodpointer, + po_containsself, + po_interrupt, + po_iocheck, + po_exports + ]; + +const + SymTypeName : array[tsymtyp] of string[12] = + ('abstractsym','variable','type','proc','unit','program', + 'const','enum','typed const','errorsym','system sym', + 'label','absolute','property','funcret', + 'macrosym'); + +implementation + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.12 2000/06/02 21:15:49 pierre + + vo_is_exported for bug0317 fix + + Revision 1.11 2000/03/19 14:56:38 florian + * bug 873 fixed + * some cleanup in objectdec + + Revision 1.10 2000/01/09 23:16:06 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.9 2000/01/07 01:14:39 peter + * updated copyright to 2000 + + Revision 1.8 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.7 1999/11/30 10:40:54 peter + + ttype, tsymlist + + Revision 1.6 1999/11/17 17:05:04 pierre + * Notes/hints changes + + Revision 1.5 1999/11/07 23:16:49 florian + * finally bug 517 solved ... + + Revision 1.4 1999/10/26 12:30:45 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.3 1999/10/01 08:02:48 peter + * forward type declaration rewritten + + Revision 1.2 1999/08/04 13:45:29 florian + + floating point register variables !! + * pairegalloc is now generated for register variables + + Revision 1.1 1999/08/03 22:03:14 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/symdef.inc b/befpc/compiler/symdef.inc new file mode 100644 index 0000000..cc04891 --- /dev/null +++ b/befpc/compiler/symdef.inc @@ -0,0 +1,4242 @@ +{ + $Id: symdef.inc,v 1.1.1.1 2001-07-23 17:17:04 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Symbol table implementation for the definitions + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} + +{**************************************************************************** + TDEF (base class for definitions) +****************************************************************************} + + const + { if you change one of the following contants, } + { you have also to change the typinfo unit } + { and the rtl/i386,template/rttip.inc files } + tkUnknown = 0; + tkInteger = 1; + tkChar = 2; + tkEnumeration = 3; + tkFloat = 4; + tkSet = 5; + tkMethod = 6; + tkSString = 7; + tkString = tkSString; + tkLString = 8; + tkAString = 9; + tkWString = 10; + tkVariant = 11; + tkArray = 12; + tkRecord = 13; + tkInterface = 14; + tkClass = 15; + tkObject = 16; + tkWChar = 17; + tkBool = 18; + tkInt64 = 19; + tkQWord = 20; + + otSByte = 0; + otUByte = 1; + otSWord = 2; + otUWord = 3; + otSLong = 4; + otULong = 5; + + ftSingle = 0; + ftDouble = 1; + ftExtended = 2; + ftComp = 3; + ftCurr = 4; + ftFixed16 = 5; + ftFixed32 = 6; + + mkProcedure = 0; + mkFunction = 1; + mkConstructor = 2; + mkDestructor = 3; + mkClassProcedure= 4; + mkClassFunction = 5; + + pfvar = 1; + pfConst = 2; + pfArray = 4; + pfAddress = 8; + pfReference = 16; + pfOut = 32; + + + constructor tdef.init; + begin + inherited init; + deftype:=abstractdef; + owner := nil; + typesym := nil; + savesize := 0; + if registerdef then + symtablestack^.registerdef(@self); + has_rtti:=false; + has_inittable:=false; +{$ifdef GDB} + is_def_stab_written := false; + globalnb := 0; +{$endif GDB} + if assigned(lastglobaldef) then + begin + lastglobaldef^.nextglobal := @self; + previousglobal:=lastglobaldef; + end + else + begin + firstglobaldef := @self; + previousglobal := nil; + end; + lastglobaldef := @self; + nextglobal := nil; + end; + + + constructor tdef.load; + begin + deftype:=abstractdef; + next := nil; + owner := nil; + has_rtti:=false; + has_inittable:=false; +{$ifdef GDB} + is_def_stab_written := false; + globalnb := 0; +{$endif GDB} + if assigned(lastglobaldef) then + begin + lastglobaldef^.nextglobal := @self; + previousglobal:=lastglobaldef; + end + else + begin + firstglobaldef := @self; + previousglobal:=nil; + end; + lastglobaldef := @self; + nextglobal := nil; + { load } + indexnr:=readword; + typesym:=ptypesym(readsymref); + end; + + + destructor tdef.done; + begin + { first element ? } + if not(assigned(previousglobal)) then + begin + firstglobaldef := nextglobal; + if assigned(firstglobaldef) then + firstglobaldef^.previousglobal:=nil; + end + else + begin + { remove reference in the element before } + previousglobal^.nextglobal:=nextglobal; + end; + { last element ? } + if not(assigned(nextglobal)) then + begin + lastglobaldef := previousglobal; + if assigned(lastglobaldef) then + lastglobaldef^.nextglobal:=nil; + end + else + nextglobal^.previousglobal:=previousglobal; + previousglobal:=nil; + nextglobal:=nil; +{$ifdef SYNONYM} + while assigned(typesym) do + begin + typesym^.restype.setdef(nil); + typesym:=typesym^.synonym; + end; +{$endif} + end; + + { used for enumdef because the symbols are + inserted in the owner symtable } + procedure tdef.correct_owner_symtable; + var + st : psymtable; + begin + if assigned(owner) and + (owner^.symtabletype in [recordsymtable,objectsymtable]) then + begin + owner^.defindex^.deleteindex(@self); + st:=owner; + while (st^.symtabletype in [recordsymtable,objectsymtable]) do + st:=st^.next; + st^.registerdef(@self); + end; + end; + + + function tdef.typename:string; + begin + if assigned(typesym) then + typename:=Upper(typesym^.name) + else + typename:=gettypename; + end; + + function tdef.gettypename : string; + + begin + gettypename:='' + end; + + function tdef.is_in_current : boolean; + var + p : psymtable; + begin + p:=owner; + is_in_current:=false; + while assigned(p) do + begin + if (p=current_module^.globalsymtable) or (p=current_module^.localsymtable) + or (p^.symtabletype in [globalsymtable,staticsymtable]) then + begin + is_in_current:=true; + exit; + end + else if p^.symtabletype in [localsymtable,parasymtable,objectsymtable] then + begin + if assigned(p^.defowner) then + p:=pobjectdef(p^.defowner)^.owner + else + exit; + end + else + exit; + end; + + end; + + procedure tdef.write; + begin + writeword(indexnr); + writesymref(typesym); +{$ifdef GDB} + if globalnb = 0 then + begin + if assigned(owner) then + globalnb := owner^.getnewtypecount + else + begin + globalnb := PGlobalTypeCount^; + Inc(PGlobalTypeCount^); + end; + end; +{$endif GDB} + end; + + + function tdef.size : longint; + begin + size:=savesize; + end; + + + function tdef.alignment : longint; + begin + { normal alignment by default } + alignment:=0; + end; + + +{$ifdef GDB} + procedure tdef.set_globalnb; + begin + globalnb :=PGlobalTypeCount^; + inc(PglobalTypeCount^); + end; + + + function tdef.stabstring : pchar; + begin + stabstring := strpnew('t'+numberstring+';'); + end; + + + function tdef.numberstring : string; + var table : psymtable; + begin + {formal def have no type !} + if deftype = formaldef then + begin + numberstring := voiddef^.numberstring; + exit; + end; + if (not assigned(typesym)) or (not typesym^.isusedinstab) then + begin + {set even if debuglist is not defined} + if assigned(typesym) then + typesym^.isusedinstab := true; + if assigned(debuglist) and not is_def_stab_written then + concatstabto(debuglist); + end; + if not (cs_gdb_dbx in aktglobalswitches) then + begin + if globalnb = 0 then + set_globalnb; + numberstring := tostr(globalnb); + end + else + begin + if globalnb = 0 then + begin + if assigned(owner) then + globalnb := owner^.getnewtypecount + else + begin + globalnb := PGlobalTypeCount^; + Inc(PGlobalTypeCount^); + end; + end; + if assigned(typesym) then + begin + table := typesym^.owner; + if table^.unitid > 0 then + numberstring := '('+tostr(table^.unitid)+','+tostr(typesym^.restype.def^.globalnb)+')' + else + numberstring := tostr(globalnb); + exit; + end; + numberstring := tostr(globalnb); + end; + end; + + + function tdef.allstabstring : pchar; + var stabchar : string[2]; + ss,st : pchar; + sname : string; + sym_line_no : longint; + begin + ss := stabstring; + getmem(st,strlen(ss)+512); + stabchar := 't'; + if deftype in tagtypes then + stabchar := 'Tt'; + if assigned(typesym) then + begin + sname := typesym^.name; + sym_line_no:=typesym^.fileinfo.line; + end + else + begin + sname := ' '; + sym_line_no:=0; + end; + strpcopy(st,'"'+sname+':'+stabchar+numberstring+'='); + strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0'); + allstabstring := strnew(st); + freemem(st,strlen(ss)+512); + strdispose(ss); + end; + + + procedure tdef.concatstabto(asmlist : paasmoutput); + var stab_str : pchar; + begin + if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) + and not is_def_stab_written then + begin + If cs_gdb_dbx in aktglobalswitches then + begin + { otherwise you get two of each def } + If assigned(typesym) then + begin + if typesym^.typ=symconst.typesym then + typesym^.isusedinstab:=true; + if (typesym^.owner = nil) or + ((typesym^.owner^.symtabletype = unitsymtable) and + punitsymtable(typesym^.owner)^.dbx_count_ok) then + begin + {with DBX we get the definition from the other objects } + is_def_stab_written := true; + exit; + end; + end; + end; + { to avoid infinite loops } + is_def_stab_written := true; + stab_str := allstabstring; + asmlist^.concat(new(pai_stabs,init(stab_str))); + end; + end; +{$endif GDB} + + + procedure tdef.deref; + begin + resolvesym(psym(typesym)); + end; + + + { rtti generation } + procedure tdef.generate_rtti; + begin + if not has_rtti then + begin + has_rtti:=true; + getdatalabel(rtti_label); + write_child_rtti_data; + rttilist^.concat(new(pai_symbol,init(rtti_label,0))); + write_rtti_data; + rttilist^.concat(new(pai_symbol_end,init(rtti_label))); + end; + end; + + + function tdef.get_rtti_label : string; + begin + generate_rtti; + get_rtti_label:=rtti_label^.name; + end; + + + { init table handling } + function tdef.needs_inittable : boolean; + begin + needs_inittable:=false; + end; + + + procedure tdef.generate_inittable; + begin + has_inittable:=true; + getdatalabel(inittable_label); + write_child_init_data; + rttilist^.concat(new(pai_label,init(inittable_label))); + write_init_data; + end; + + + procedure tdef.write_init_data; + begin + write_rtti_data; + end; + + + procedure tdef.write_child_init_data; + begin + write_child_rtti_data; + end; + + + function tdef.get_inittable_label : pasmlabel; + begin + if not(has_inittable) then + generate_inittable; + get_inittable_label:=inittable_label; + end; + + + procedure tdef.write_rtti_name; + var + str : string; + begin + { name } + if assigned(typesym) then + begin + str:=typesym^.name; + rttilist^.concat(new(pai_string,init(chr(length(str))+str))); + end + else + rttilist^.concat(new(pai_string,init(#0))) + end; + + + { returns true, if the definition can be published } + function tdef.is_publishable : boolean; + begin + is_publishable:=false; + end; + + + procedure tdef.write_rtti_data; + begin + end; + + + procedure tdef.write_child_rtti_data; + begin + end; + + + function tdef.is_intregable : boolean; + + begin + is_intregable:=false; + case deftype of + pointerdef, + enumdef, + procvardef : + is_intregable:=true; + orddef : + case porddef(@self)^.typ of + bool8bit,bool16bit,bool32bit, + u8bit,u16bit,u32bit, + s8bit,s16bit,s32bit: + is_intregable:=true; + end; + setdef: + is_intregable:=is_smallset(@self); + end; + end; + + function tdef.is_fpuregable : boolean; + + begin + is_fpuregable:=(deftype=floatdef) and not(pfloatdef(@self)^.typ in [f32bit,f16bit]); + end; + +{**************************************************************************** + TSTRINGDEF +****************************************************************************} + + constructor tstringdef.shortinit(l : byte); + begin + tdef.init; + string_typ:=st_shortstring; + deftype:=stringdef; + len:=l; + savesize:=len+1; + end; + + + constructor tstringdef.shortload; + begin + tdef.load; + string_typ:=st_shortstring; + deftype:=stringdef; + len:=readbyte; + savesize:=len+1; + end; + + + constructor tstringdef.longinit(l : longint); + begin + tdef.init; + string_typ:=st_longstring; + deftype:=stringdef; + len:=l; + savesize:=target_os.size_of_pointer; + end; + + + constructor tstringdef.longload; + begin + tdef.load; + deftype:=stringdef; + string_typ:=st_longstring; + len:=readlong; + savesize:=target_os.size_of_pointer; + end; + + + constructor tstringdef.ansiinit(l : longint); + begin + tdef.init; + string_typ:=st_ansistring; + deftype:=stringdef; + len:=l; + savesize:=target_os.size_of_pointer; + end; + + + constructor tstringdef.ansiload; + begin + tdef.load; + deftype:=stringdef; + string_typ:=st_ansistring; + len:=readlong; + savesize:=target_os.size_of_pointer; + end; + + + constructor tstringdef.wideinit(l : longint); + begin + tdef.init; + string_typ:=st_widestring; + deftype:=stringdef; + len:=l; + savesize:=target_os.size_of_pointer; + end; + + + constructor tstringdef.wideload; + begin + tdef.load; + deftype:=stringdef; + string_typ:=st_widestring; + len:=readlong; + savesize:=target_os.size_of_pointer; + end; + + + function tstringdef.stringtypname:string; + const + typname:array[tstringtype] of string[8]=('', + 'SHORTSTR','LONGSTR','ANSISTR','WIDESTR' + ); + begin + stringtypname:=typname[string_typ]; + end; + + + function tstringdef.size : longint; + begin + size:=savesize; + end; + + + procedure tstringdef.write; + begin + tdef.write; + if string_typ=st_shortstring then + writebyte(len) + else + writelong(len); + case string_typ of + st_shortstring : current_ppu^.writeentry(ibshortstringdef); + st_longstring : current_ppu^.writeentry(iblongstringdef); + st_ansistring : current_ppu^.writeentry(ibansistringdef); + st_widestring : current_ppu^.writeentry(ibwidestringdef); + end; + end; + + +{$ifdef GDB} + function tstringdef.stabstring : pchar; + var + bytest,charst,longst : string; + begin + case string_typ of + st_shortstring: + begin + charst := typeglobalnumber('char'); + { this is what I found in stabs.texinfo but + gdb 4.12 for go32 doesn't understand that !! } + {$IfDef GDBknowsstrings} + stabstring := strpnew('n'+charst+';'+tostr(len)); + {$else} + bytest := typeglobalnumber('byte'); + stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest + +',0,8;st:ar'+bytest + +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;'); + {$EndIf} + end; + st_longstring: + begin + charst := typeglobalnumber('char'); + { this is what I found in stabs.texinfo but + gdb 4.12 for go32 doesn't understand that !! } + {$IfDef GDBknowsstrings} + stabstring := strpnew('n'+charst+';'+tostr(len)); + {$else} + bytest := typeglobalnumber('byte'); + longst := typeglobalnumber('longint'); + stabstring := strpnew('s'+tostr(len+5)+'length:'+longst + +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest + +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;'); + {$EndIf} + end; + st_ansistring: + begin + { an ansi string looks like a pchar easy !! } + stabstring:=strpnew('*'+typeglobalnumber('char')); + end; + st_widestring: + begin + { an ansi string looks like a pchar easy !! } + stabstring:=strpnew('*'+typeglobalnumber('char')); + end; + end; + end; + + + procedure tstringdef.concatstabto(asmlist : paasmoutput); + begin + inherited concatstabto(asmlist); + end; +{$endif GDB} + + + function tstringdef.needs_inittable : boolean; + begin + needs_inittable:=string_typ in [st_ansistring,st_widestring]; + end; + + function tstringdef.gettypename : string; + + const + names : array[tstringtype] of string[20] = ('', + 'ShortString','LongString','AnsiString','WideString'); + + begin + gettypename:=names[string_typ]; + end; + + procedure tstringdef.write_rtti_data; + begin + case string_typ of + st_ansistring: + begin + rttilist^.concat(new(pai_const,init_8bit(tkAString))); + write_rtti_name; + end; + st_widestring: + begin + rttilist^.concat(new(pai_const,init_8bit(tkWString))); + write_rtti_name; + end; + st_longstring: + begin + rttilist^.concat(new(pai_const,init_8bit(tkLString))); + write_rtti_name; + end; + st_shortstring: + begin + rttilist^.concat(new(pai_const,init_8bit(tkSString))); + write_rtti_name; + rttilist^.concat(new(pai_const,init_8bit(len))); + end; + end; + end; + + + function tstringdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + +{**************************************************************************** + TENUMDEF +****************************************************************************} + + constructor tenumdef.init; + begin + tdef.init; + deftype:=enumdef; + minval:=0; + maxval:=0; + calcsavesize; + has_jumps:=false; + basedef:=nil; + rangenr:=0; + firstenum:=nil; + correct_owner_symtable; + end; + + constructor tenumdef.init_subrange(_basedef:penumdef;_min,_max:longint); + begin + tdef.init; + deftype:=enumdef; + minval:=_min; + maxval:=_max; + basedef:=_basedef; + calcsavesize; + has_jumps:=false; + rangenr:=0; + firstenum:=basedef^.firstenum; + while assigned(firstenum) and (penumsym(firstenum)^.value<>minval) do + firstenum:=firstenum^.nextenum; + correct_owner_symtable; + end; + + + constructor tenumdef.load; + begin + tdef.load; + deftype:=enumdef; + basedef:=penumdef(readdefref); + minval:=readlong; + maxval:=readlong; + savesize:=readlong; + has_jumps:=false; + firstenum:=Nil; + end; + + + procedure tenumdef.calcsavesize; + begin + if (aktpackenum=4) or (min<0) or (max>65535) then + savesize:=4 + else + if (aktpackenum=2) or (min<0) or (max>255) then + savesize:=2 + else + savesize:=1; + end; + + + procedure tenumdef.setmax(_max:longint); + begin + maxval:=_max; + calcsavesize; + end; + + + procedure tenumdef.setmin(_min:longint); + begin + minval:=_min; + calcsavesize; + end; + + + function tenumdef.min:longint; + begin + min:=minval; + end; + + + function tenumdef.max:longint; + begin + max:=maxval; + end; + + + procedure tenumdef.deref; + begin + inherited deref; + resolvedef(pdef(basedef)); + end; + + + destructor tenumdef.done; + begin + inherited done; + end; + + + procedure tenumdef.write; + begin + tdef.write; + writedefref(basedef); + writelong(min); + writelong(max); + writelong(savesize); + current_ppu^.writeentry(ibenumdef); + end; + + + function tenumdef.getrangecheckstring : string; + begin + if (cs_create_smart in aktmoduleswitches) then + getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr) + else + getrangecheckstring:='R_'+tostr(rangenr); + end; + + + procedure tenumdef.genrangecheck; + begin + if rangenr=0 then + begin + { generate two constant for bounds } + getlabelnr(rangenr); + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8))) + else + datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8))); + datasegment^.concat(new(pai_const,init_32bit(min))); + datasegment^.concat(new(pai_const,init_32bit(max))); + end; + end; + + +{$ifdef GDB} + function tenumdef.stabstring : pchar; + var st,st2 : pchar; + p : penumsym; + s : string; + memsize : word; + begin + memsize := memsizeinc; + getmem(st,memsize); + strpcopy(st,'e'); + p := firstenum; + while assigned(p) do + begin + s :=p^.name+':'+tostr(p^.value)+','; + { place for the ending ';' also } + if (strlen(st)+length(s)+1=0 } + if (low>=0) and (high<0) then + begin + savesize:=4; + typ:=u32bit; + end + else if (low>=0) and (high<=255) then + begin + savesize:=1; + typ:=u8bit; + end + else if (low>=-128) and (high<=127) then + begin + savesize:=1; + typ:=s8bit; + end + else if (low>=0) and (high<=65536) then + begin + savesize:=2; + typ:=u16bit; + end + else if (low>=-32768) and (high<=32767) then + begin + savesize:=2; + typ:=s16bit; + end + else + begin + savesize:=4; + typ:=s32bit; + end; + end + else + begin + case typ of + u8bit,s8bit, + uchar,bool8bit: + savesize:=1; + + u16bit,s16bit, + bool16bit,uwidechar: + savesize:=2; + + s32bit,u32bit, + bool32bit: + savesize:=4; + + u64bit,s64bit: + savesize:=8; + else + savesize:=0; + end; + end; + { there are no entrys for range checking } + rangenr:=0; + end; + + function torddef.getrangecheckstring : string; + + begin + if (cs_create_smart in aktmoduleswitches) then + getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr) + else + getrangecheckstring:='R_'+tostr(rangenr); + end; + + procedure torddef.genrangecheck; + var + rangechecksize : longint; + begin + if rangenr=0 then + begin + if low<=high then + rangechecksize:=8 + else + rangechecksize:=16; + { generate two constant for bounds } + getlabelnr(rangenr); + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,rangechecksize))) + else + datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,rangechecksize))); + if low<=high then + begin + datasegment^.concat(new(pai_const,init_32bit(low))); + datasegment^.concat(new(pai_const,init_32bit(high))); + end + { for u32bit we need two bounds } + else + begin + datasegment^.concat(new(pai_const,init_32bit(low))); + datasegment^.concat(new(pai_const,init_32bit($7fffffff))); + datasegment^.concat(new(pai_const,init_32bit($80000000))); + datasegment^.concat(new(pai_const,init_32bit(high))); + end; + end; + end; + + + procedure torddef.write; + begin + tdef.write; + writebyte(byte(typ)); + writelong(low); + writelong(high); + current_ppu^.writeentry(iborddef); + end; + + +{$ifdef GDB} + function torddef.stabstring : pchar; + begin + case typ of + uvoid : stabstring := strpnew(numberstring+';'); + {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!} +{$ifdef Use_integer_types_for_boolean} + bool8bit, + bool16bit, + bool32bit : stabstring := strpnew('r'+numberstring+';0;255;'); +{$else : not Use_integer_types_for_boolean} + bool8bit : stabstring := strpnew('-21;'); + bool16bit : stabstring := strpnew('-22;'); + bool32bit : stabstring := strpnew('-23;'); + u64bit : stabstring := strpnew('-32;'); + s64bit : stabstring := strpnew('-31;'); +{$endif not Use_integer_types_for_boolean} + { u32bit : stabstring := strpnew('r'+ + s32bitdef^.numberstring+';0;-1;'); } + else + stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';'); + end; + end; +{$endif GDB} + + + procedure torddef.write_rtti_data; + + procedure dointeger; + const + trans : array[uchar..bool8bit] of byte = + (otUByte,otUByte,otUWord,otULong,otSByte,otSWord,otSLong,otUByte); + begin + write_rtti_name; + rttilist^.concat(new(pai_const,init_8bit(byte(trans[typ])))); + rttilist^.concat(new(pai_const,init_32bit(low))); + rttilist^.concat(new(pai_const,init_32bit(high))); + end; + + begin + case typ of + s64bit : + begin + rttilist^.concat(new(pai_const,init_8bit(tkInt64))); + write_rtti_name; + { low } + rttilist^.concat(new(pai_const,init_32bit($0))); + rttilist^.concat(new(pai_const,init_32bit($8000))); + { high } + rttilist^.concat(new(pai_const,init_32bit($ffff))); + rttilist^.concat(new(pai_const,init_32bit($7fff))); + end; + u64bit : + begin + rttilist^.concat(new(pai_const,init_8bit(tkQWord))); + write_rtti_name; + { low } + rttilist^.concat(new(pai_const,init_32bit($0))); + rttilist^.concat(new(pai_const,init_32bit($0))); + { high } + rttilist^.concat(new(pai_const,init_32bit($0))); + rttilist^.concat(new(pai_const,init_32bit($8000))); + end; + bool8bit: + begin + rttilist^.concat(new(pai_const,init_8bit(tkBool))); + dointeger; + end; + uchar: + begin + rttilist^.concat(new(pai_const,init_8bit(tkWChar))); + dointeger; + end; + uwidechar: + begin + rttilist^.concat(new(pai_const,init_8bit(tkChar))); + dointeger; + end; + else + begin + rttilist^.concat(new(pai_const,init_8bit(tkInteger))); + dointeger; + end; + end; + end; + + + function torddef.is_publishable : boolean; + begin + is_publishable:=typ in [uchar..bool8bit]; + end; + + function torddef.gettypename : string; + + const + names : array[tbasetype] of string[20] = ('', + 'untyped','Char','Byte','Word','DWord','ShortInt', + 'SmallInt','LongInt','Boolean','WordBool', + 'LongBool','QWord','Int64','WideChar'); + + begin + gettypename:=names[typ]; + end; + +{**************************************************************************** + TFLOATDEF +****************************************************************************} + + constructor tfloatdef.init(t : tfloattype); + begin + inherited init; + deftype:=floatdef; + typ:=t; + setsize; + end; + + + constructor tfloatdef.load; + begin + inherited load; + deftype:=floatdef; + typ:=tfloattype(readbyte); + setsize; + end; + + + procedure tfloatdef.setsize; + begin + case typ of + f16bit : savesize:=2; + f32bit, + s32real : savesize:=4; + s64real : savesize:=8; + s80real : savesize:=extended_size; + s64comp : savesize:=8; + else + savesize:=0; + end; + end; + + + procedure tfloatdef.write; + begin + inherited write; + writebyte(byte(typ)); + current_ppu^.writeentry(ibfloatdef); + end; + + +{$ifdef GDB} + function tfloatdef.stabstring : pchar; + begin + case typ of + s32real, + s64real : stabstring := strpnew('r'+ + s32bitdef^.numberstring+';'+tostr(savesize)+';0;'); + { for fixed real use longint instead to be able to } + { debug something at least } + f32bit: + stabstring := s32bitdef^.stabstring; + f16bit: + stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+ + tostr($ffff)+';'); + { found this solution in stabsread.c from GDB v4.16 } + s64comp : stabstring := strpnew('r'+ + s32bitdef^.numberstring+';-'+tostr(savesize)+';0;'); +{$ifdef i386} + { under dos at least you must give a size of twelve instead of 10 !! } + { this is probably do to the fact that in gcc all is pushed in 4 bytes size } + s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;'); +{$endif i386} + else + internalerror(10005); + end; + end; +{$endif GDB} + + + procedure tfloatdef.write_rtti_data; + const + {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);} + translate : array[tfloattype] of byte = + (ftSingle,ftDouble,ftExtended,ftComp,ftFixed16,ftFixed32); + begin + rttilist^.concat(new(pai_const,init_8bit(tkFloat))); + write_rtti_name; + rttilist^.concat(new(pai_const,init_8bit(translate[typ]))); + end; + + + function tfloatdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + function tfloatdef.gettypename : string; + + const + names : array[tfloattype] of string[20] = ( + 'Single','Double','Extended','Comp','Fixed','Fixed16'); + + begin + gettypename:=names[typ]; + end; + +{**************************************************************************** + TFILEDEF +****************************************************************************} + + constructor tfiledef.inittext; + begin + inherited init; + deftype:=filedef; + filetyp:=ft_text; + typedfiletype.reset; + setsize; + end; + + + constructor tfiledef.inituntyped; + begin + inherited init; + deftype:=filedef; + filetyp:=ft_untyped; + typedfiletype.reset; + setsize; + end; + + + constructor tfiledef.inittyped(const tt : ttype); + begin + inherited init; + deftype:=filedef; + filetyp:=ft_typed; + typedfiletype:=tt; + setsize; + end; + + + constructor tfiledef.inittypeddef(p : pdef); + begin + inherited init; + deftype:=filedef; + filetyp:=ft_typed; + typedfiletype.setdef(p); + setsize; + end; + + + constructor tfiledef.load; + begin + inherited load; + deftype:=filedef; + filetyp:=tfiletyp(readbyte); + if filetyp=ft_typed then + typedfiletype.load + else + typedfiletype.reset; + setsize; + end; + + + procedure tfiledef.deref; + begin + inherited deref; + if filetyp=ft_typed then + typedfiletype.resolve; + end; + + + procedure tfiledef.setsize; + begin + case filetyp of + ft_text : + savesize:=572; + ft_typed, + ft_untyped : + savesize:=316; + end; + end; + + + procedure tfiledef.write; + begin + inherited write; + writebyte(byte(filetyp)); + if filetyp=ft_typed then + typedfiletype.write; + current_ppu^.writeentry(ibfiledef); + end; + + +{$ifdef GDB} + function tfiledef.stabstring : pchar; + begin + {$IfDef GDBknowsfiles} + case filetyp of + ft_typed : + stabstring := strpnew('d'+typedfiletype.def^.numberstring{+';'}); + ft_untyped : + stabstring := strpnew('d'+voiddef^.numberstring{+';'}); + ft_text : + stabstring := strpnew('d'+cchardef^.numberstring{+';'}); + end; + {$Else} + {based on + FileRec = Packed Record + Handle, + Mode, + RecSize : longint; + _private : array[1..32] of byte; + UserData : array[1..16] of byte; + name : array[0..255] of char; + End; } + { the buffer part is still missing !! (PM) } + { but the string could become too long !! } + stabstring := strpnew('s'+tostr(savesize)+ + 'HANDLE:'+typeglobalnumber('longint')+',0,32;'+ + 'MODE:'+typeglobalnumber('longint')+',32,32;'+ + 'RECSIZE:'+typeglobalnumber('longint')+',64,32;'+ + '_PRIVATE:ar'+typeglobalnumber('word')+';1;32;'+typeglobalnumber('byte') + +',96,256;'+ + 'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte') + +',352,128;'+ + 'NAME:ar'+typeglobalnumber('word')+';0;255;'+typeglobalnumber('char') + +',480,2048;;'); + {$EndIf} + end; + + + procedure tfiledef.concatstabto(asmlist : paasmoutput); + begin + { most file defs are unnamed !!! } + if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and + not is_def_stab_written then + begin + if assigned(typedfiletype.def) then forcestabto(asmlist,typedfiletype.def); + inherited concatstabto(asmlist); + end; + end; +{$endif GDB} + + function tfiledef.gettypename : string; + + begin + case filetyp of + ft_untyped: + gettypename:='File'; + ft_typed: + gettypename:='File Of '+typedfiletype.def^.typename; + ft_text: + gettypename:='Text' + end; + end; + + + +{**************************************************************************** + TPOINTERDEF +****************************************************************************} + + constructor tpointerdef.init(const tt : ttype); + begin + tdef.init; + deftype:=pointerdef; + pointertype:=tt; + is_far:=false; + savesize:=target_os.size_of_pointer; + end; + + + constructor tpointerdef.initfar(const tt : ttype); + begin + tdef.init; + deftype:=pointerdef; + pointertype:=tt; + is_far:=true; + savesize:=target_os.size_of_pointer; + end; + + + constructor tpointerdef.initdef(p : pdef); + var + t : ttype; + begin + t.setdef(p); + tpointerdef.init(t); + end; + + + constructor tpointerdef.initfardef(p : pdef); + var + t : ttype; + begin + t.setdef(p); + tpointerdef.initfar(t); + end; + + + + constructor tpointerdef.load; + begin + tdef.load; + deftype:=pointerdef; + pointertype.load; + is_far:=(readbyte<>0); + savesize:=target_os.size_of_pointer; + end; + + + destructor tpointerdef.done; + begin + if assigned(pointertype.def) and + (pointertype.def^.deftype=forwarddef) then + begin + dispose(pointertype.def,done); + pointertype.reset; + end; + inherited done; + end; + + + procedure tpointerdef.deref; + begin + inherited deref; + pointertype.resolve; + end; + + + procedure tpointerdef.write; + begin + inherited write; + pointertype.write; + writebyte(byte(is_far)); + current_ppu^.writeentry(ibpointerdef); + end; + + +{$ifdef GDB} + function tpointerdef.stabstring : pchar; + begin + stabstring := strpnew('*'+pointertype.def^.numberstring); + end; + + + procedure tpointerdef.concatstabto(asmlist : paasmoutput); + var st,nb : string; + sym_line_no : longint; + begin + if assigned(pointertype.def) and + (pointertype.def^.deftype=forwarddef) then + exit; + + if ( (typesym=nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and + not is_def_stab_written then + begin + if assigned(pointertype.def) then + if pointertype.def^.deftype in [recorddef,objectdef] then + begin + is_def_stab_written := true; + nb:=pointertype.def^.numberstring; + {to avoid infinite recursion in record with next-like fields } + is_def_stab_written := false; + if not pointertype.def^.is_def_stab_written then + begin + if assigned(pointertype.def^.typesym) then + begin + if assigned(typesym) then + begin + st := typesym^.name; + sym_line_no:=typesym^.fileinfo.line; + end + else + begin + st := ' '; + sym_line_no:=0; + end; + st := '"'+st+':t'+numberstring+'=*'+nb + +'=xs'+pointertype.def^.typesym^.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0'; + asmlist^.concat(new(pai_stabs,init(strpnew(st)))); + end; + end else inherited concatstabto(asmlist); + is_def_stab_written := true; + end else + begin + { p =^p1; p1=^p problem } + is_def_stab_written := true; + forcestabto(asmlist,pointertype.def); + is_def_stab_written := false; + inherited concatstabto(asmlist); + end; + end; + end; +{$endif GDB} + + function tpointerdef.gettypename : string; + + begin + gettypename:='^'+pointertype.def^.typename; + end; + +{**************************************************************************** + TCLASSREFDEF +****************************************************************************} + + constructor tclassrefdef.init(def : pdef); + begin + inherited initdef(def); + deftype:=classrefdef; + end; + + + constructor tclassrefdef.load; + begin + { be careful, tclassdefref inherits from tpointerdef } + tdef.load; + deftype:=classrefdef; + pointertype.load; + is_far:=false; + savesize:=target_os.size_of_pointer; + end; + + + procedure tclassrefdef.write; + begin + { be careful, tclassdefref inherits from tpointerdef } + tdef.write; + pointertype.write; + current_ppu^.writeentry(ibclassrefdef); + end; + + +{$ifdef GDB} + function tclassrefdef.stabstring : pchar; + begin + stabstring:=strpnew(pvmtdef^.numberstring+';'); + end; + + + procedure tclassrefdef.concatstabto(asmlist : paasmoutput); + begin + inherited concatstabto(asmlist); + end; +{$endif GDB} + + function tclassrefdef.gettypename : string; + + begin + gettypename:='Class Of '+pointertype.def^.typename; + end; + + +{*************************************************************************** + TSETDEF +***************************************************************************} + +{ For i386 smallsets work, + for m68k there are problems + can be test by compiling with -dusesmallset PM } +{$ifdef i386} +{$define usesmallset} +{$endif i386} + + constructor tsetdef.init(s : pdef;high : longint); + begin + inherited init; + deftype:=setdef; + elementtype.setdef(s); +{$ifdef usesmallset} + { small sets only working for i386 PM } + if high<32 then + begin + settype:=smallset; + {$ifdef testvarsets} + if aktsetalloc=0 THEN { $PACKSET Fixed?} + {$endif} + savesize:=Sizeof(longint) + {$ifdef testvarsets} + else {No, use $PACKSET VALUE for rounding} + savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8)) + {$endif} + ; + end + else +{$endif usesmallset} + if high<256 then + begin + settype:=normset; + savesize:=32; + end + else +{$ifdef testvarsets} + if high<$10000 then + begin + settype:=varset; + savesize:=4*((high+31) div 32); + end + else +{$endif testvarsets} + Message(sym_e_ill_type_decl_set); + end; + + + constructor tsetdef.load; + begin + inherited load; + deftype:=setdef; + elementtype.load; + settype:=tsettype(readbyte); + case settype of + normset : savesize:=32; + varset : savesize:=readlong; + smallset : savesize:=Sizeof(longint); + end; + end; + + + destructor tsetdef.done; + begin + inherited done; + end; + + + procedure tsetdef.write; + begin + inherited write; + elementtype.write; + writebyte(byte(settype)); + if settype=varset then + writelong(savesize); + current_ppu^.writeentry(ibsetdef); + end; + + +{$ifdef GDB} + function tsetdef.stabstring : pchar; + begin + { For small sets write a longint, which can at least be seen + in the current GDB's (PFV) + this is obsolete with GDBPAS !! + and anyhow creates problems with version 4.18!! PM + if settype=smallset then + stabstring := strpnew('r'+s32bitdef^.numberstring+';0;0xffffffff;') + else } + stabstring := strpnew('S'+elementtype.def^.numberstring); + end; + + + procedure tsetdef.concatstabto(asmlist : paasmoutput); + begin + if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and + not is_def_stab_written then + begin + if assigned(elementtype.def) then + forcestabto(asmlist,elementtype.def); + inherited concatstabto(asmlist); + end; + end; +{$endif GDB} + + + procedure tsetdef.deref; + begin + inherited deref; + elementtype.resolve; + end; + + + procedure tsetdef.write_rtti_data; + begin + rttilist^.concat(new(pai_const,init_8bit(tkSet))); + write_rtti_name; + rttilist^.concat(new(pai_const,init_8bit(otULong))); + rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label))); + end; + + + procedure tsetdef.write_child_rtti_data; + begin + elementtype.def^.get_rtti_label; + end; + + + function tsetdef.is_publishable : boolean; + begin + is_publishable:=settype=smallset; + end; + + function tsetdef.gettypename : string; + + begin + if assigned(elementtype.def) then + gettypename:='Set Of '+elementtype.def^.typename + else + gettypename:='Empty Set'; + end; + + +{*************************************************************************** + TFORMALDEF +***************************************************************************} + + constructor tformaldef.init; + var + stregdef : boolean; + begin + stregdef:=registerdef; + registerdef:=false; + inherited init; + deftype:=formaldef; + registerdef:=stregdef; + { formaldef must be registered at unit level !! } + if registerdef and assigned(current_module) then + if assigned(current_module^.localsymtable) then + psymtable(current_module^.localsymtable)^.registerdef(@self) + else if assigned(current_module^.globalsymtable) then + psymtable(current_module^.globalsymtable)^.registerdef(@self); + savesize:=target_os.size_of_pointer; + end; + + + constructor tformaldef.load; + begin + inherited load; + deftype:=formaldef; + savesize:=target_os.size_of_pointer; + end; + + + procedure tformaldef.write; + begin + inherited write; + current_ppu^.writeentry(ibformaldef); + end; + + +{$ifdef GDB} + function tformaldef.stabstring : pchar; + begin + stabstring := strpnew('formal'+numberstring+';'); + end; + + + procedure tformaldef.concatstabto(asmlist : paasmoutput); + begin + { formaldef can't be stab'ed !} + end; +{$endif GDB} + + function tformaldef.gettypename : string; + + begin + gettypename:='Var'; + end; + +{*************************************************************************** + TARRAYDEF +***************************************************************************} + + constructor tarraydef.init(l,h : longint;rd : pdef); + begin + inherited init; + deftype:=arraydef; + lowrange:=l; + highrange:=h; + rangetype.setdef(rd); + elementtype.reset; + IsVariant:=false; + IsConstructor:=false; + IsArrayOfConst:=false; + rangenr:=0; + end; + + + constructor tarraydef.load; + begin + inherited load; + deftype:=arraydef; + { the addresses are calculated later } + elementtype.load; + rangetype.load; + lowrange:=readlong; + highrange:=readlong; + IsArrayOfConst:=boolean(readbyte); + IsVariant:=false; + IsConstructor:=false; + rangenr:=0; + end; + + + function tarraydef.getrangecheckstring : string; + begin + if (cs_create_smart in aktmoduleswitches) then + getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr) + else + getrangecheckstring:='R_'+tostr(rangenr); + end; + + + procedure tarraydef.genrangecheck; + begin + if rangenr=0 then + begin + { generates the data for range checking } + getlabelnr(rangenr); + if (cs_create_smart in aktmoduleswitches) then + datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8))) + else + datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8))); + if lowrange<=highrange then + begin + datasegment^.concat(new(pai_const,init_32bit(lowrange))); + datasegment^.concat(new(pai_const,init_32bit(highrange))); + end + { for big arrays we need two bounds } + else + begin + datasegment^.concat(new(pai_const,init_32bit(lowrange))); + datasegment^.concat(new(pai_const,init_32bit($7fffffff))); + datasegment^.concat(new(pai_const,init_32bit($80000000))); + datasegment^.concat(new(pai_const,init_32bit(highrange))); + end; + end; + end; + + + procedure tarraydef.deref; + begin + inherited deref; + elementtype.resolve; + rangetype.resolve; + end; + + + procedure tarraydef.write; + begin + inherited write; + elementtype.write; + rangetype.write; + writelong(lowrange); + writelong(highrange); + writebyte(byte(IsArrayOfConst)); + current_ppu^.writeentry(ibarraydef); + end; + + +{$ifdef GDB} + function tarraydef.stabstring : pchar; + begin + stabstring := strpnew('ar'+rangetype.def^.numberstring+';' + +tostr(lowrange)+';'+tostr(highrange)+';'+elementtype.def^.numberstring); + end; + + + procedure tarraydef.concatstabto(asmlist : paasmoutput); + begin + if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) + and not is_def_stab_written then + begin + {when array are inserted they have no definition yet !!} + if assigned(elementtype.def) then + inherited concatstabto(asmlist); + end; + end; +{$endif GDB} + + + function tarraydef.elesize : longint; + begin + if isconstructor or is_open_array(@self) then + begin + { strings are stored by address only } + case elementtype.def^.deftype of + stringdef : + elesize:=4; + else + elesize:=elementtype.def^.size; + end; + end + else + elesize:=elementtype.def^.size; + end; + + + function tarraydef.size : longint; + begin + {Tarraydef.size may never be called for an open array!} + if highrange0) and + ( + (highrange-lowrange = $7fffffff) or + { () are needed around elesize-1 to avoid a possible + integer overflow for elesize=1 !! PM } + (($7fffffff div elesize + (elesize -1)) < (highrange - lowrange)) + ) Then + Begin + Message(sym_e_segment_too_large); + size := 4 + End + Else size:=(highrange-lowrange+1)*elesize; + end; + + + function tarraydef.alignment : longint; + begin + { alignment is the size of the elements } + alignment:=elesize; + end; + + + function tarraydef.needs_inittable : boolean; + begin + needs_inittable:=elementtype.def^.needs_inittable; + end; + + + procedure tarraydef.write_child_rtti_data; + begin + elementtype.def^.get_rtti_label; + end; + + + procedure tarraydef.write_rtti_data; + begin + rttilist^.concat(new(pai_const,init_8bit(tkarray))); + write_rtti_name; + { size of elements } + rttilist^.concat(new(pai_const,init_32bit(elesize))); + { count of elements } + rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1))); + { element type } + rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label))); + end; + + function tarraydef.gettypename : string; + + begin + if isarrayofconst or isConstructor then + begin + if isvariant then + gettypename:='Array Of Const' + else + gettypename:='Array Of '+elementtype.def^.typename; + end + else if is_open_array(@self) then + gettypename:='Array Of '+elementtype.def^.typename + else + begin + if rangetype.def^.deftype=enumdef then + gettypename:='Array['+rangetype.def^.typename+'] Of '+elementtype.def^.typename + else + gettypename:='Array['+tostr(lowrange)+'..'+ + tostr(highrange)+'] Of '+elementtype.def^.typename + end; + end; + +{*************************************************************************** + trecorddef +***************************************************************************} + + constructor trecorddef.init(p : psymtable); + begin + inherited init; + deftype:=recorddef; + symtable:=p; + symtable^.defowner := @self; + symtable^.dataalignment:=packrecordalignment[aktpackrecords]; + end; + + + constructor trecorddef.load; + var + oldread_member : boolean; + begin + inherited load; + deftype:=recorddef; + savesize:=readlong; + oldread_member:=read_member; + read_member:=true; + symtable:=new(psymtable,loadas(recordsymtable)); + read_member:=oldread_member; + symtable^.defowner := @self; + end; + + + destructor trecorddef.done; + begin + if assigned(symtable) then + dispose(symtable,done); + inherited done; + end; + + + var + binittable : boolean; + + procedure check_rec_inittable(s : pnamedindexobject); + + begin + if (not binittable) and + (psym(s)^.typ=varsym) and + assigned(pvarsym(s)^.vartype.def) then + begin + if ((pvarsym(s)^.vartype.def^.deftype<>objectdef) or + not(pobjectdef(pvarsym(s)^.vartype.def)^.is_class)) then + binittable:=pvarsym(s)^.vartype.def^.needs_inittable; + end; + end; + + + function trecorddef.needs_inittable : boolean; + var + oldb : boolean; + begin + { there are recursive calls to needs_rtti possible, } + { so we have to change to old value how else should } + { we do that ? check_rec_rtti can't be a nested } + { procedure of needs_rtti ! } + oldb:=binittable; + binittable:=false; + symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable); + needs_inittable:=binittable; + binittable:=oldb; + end; + + + procedure trecorddef.deref; + var + oldrecsyms : psymtable; + begin + inherited deref; + oldrecsyms:=aktrecordsymtable; + aktrecordsymtable:=symtable; + { now dereference the definitions } + symtable^.deref; + aktrecordsymtable:=oldrecsyms; + end; + + + procedure trecorddef.write; + var + oldread_member : boolean; + begin + oldread_member:=read_member; + read_member:=true; + inherited write; + writelong(savesize); + current_ppu^.writeentry(ibrecorddef); + self.symtable^.writeas; + read_member:=oldread_member; + end; + + function trecorddef.size:longint; + begin + size:=symtable^.datasize; + end; + + + function trecorddef.alignment:longint; + var + l : longint; + hp : pvarsym; + begin + { also check the first symbol for it's size, because a + packed record has dataalignment of 1, but the first + sym could be a longint which should be aligned on 4 bytes, + this is compatible with C record packing (PFV) } + hp:=pvarsym(symtable^.symindex^.first); + if assigned(hp) then + begin + l:=hp^.vartype.def^.size; + if l>symtable^.dataalignment then + begin + if l>=4 then + alignment:=4 + else + if l>=2 then + alignment:=2 + else + alignment:=1; + end + else + alignment:=symtable^.dataalignment; + end + else + alignment:=symtable^.dataalignment; + end; + +{$ifdef GDB} + Const StabRecString : pchar = Nil; + StabRecSize : longint = 0; + RecOffset : Longint = 0; + + procedure addname(p : pnamedindexobject); + var + news, newrec : pchar; + spec : string[3]; + size : longint; + begin + { static variables from objects are like global objects } + if (sp_static in psym(p)^.symoptions) then + exit; + If psym(p)^.typ = varsym then + begin + if (sp_protected in psym(p)^.symoptions) then + spec:='/1' + else if (sp_private in psym(p)^.symoptions) then + spec:='/0' + else + spec:=''; + { class fields are pointers PM } + if not assigned(pvarsym(p)^.vartype.def) then + writeln(pvarsym(p)^.name); + if (pvarsym(p)^.vartype.def^.deftype=objectdef) and + pobjectdef(pvarsym(p)^.vartype.def)^.is_class then + spec:=spec+'*'; + size:=pvarsym(p)^.vartype.def^.size; + { open arrays made overflows !! } + if size>$fffffff then + size:=$fffffff; + newrec := strpnew(p^.name+':'+spec+pvarsym(p)^.vartype.def^.numberstring + +','+tostr(pvarsym(p)^.address*8)+',' + +tostr(size*8)+';'); + if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then + begin + getmem(news,stabrecsize+memsizeinc); + strcopy(news,stabrecstring); + freemem(stabrecstring,stabrecsize); + stabrecsize:=stabrecsize+memsizeinc; + stabrecstring:=news; + end; + strcat(StabRecstring,newrec); + strdispose(newrec); + {This should be used for case !!} + RecOffset := RecOffset + pvarsym(p)^.vartype.def^.size; + end; + end; + + + function trecorddef.stabstring : pchar; + Var oldrec : pchar; + oldsize : longint; + begin + oldrec := stabrecstring; + oldsize:=stabrecsize; + GetMem(stabrecstring,memsizeinc); + stabrecsize:=memsizeinc; + strpcopy(stabRecString,'s'+tostr(size)); + RecOffset := 0; + symtable^.foreach({$ifndef TP}@{$endif}addname); + { FPC doesn't want to convert a char to a pchar} + { is this a bug ? } + strpcopy(strend(StabRecString),';'); + stabstring := strnew(StabRecString); + Freemem(stabrecstring,stabrecsize); + stabrecstring := oldrec; + stabrecsize:=oldsize; + end; + + + procedure trecorddef.concatstabto(asmlist : paasmoutput); + begin + if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and + (not is_def_stab_written) then + inherited concatstabto(asmlist); + end; + +{$endif GDB} + + var + count : longint; + + procedure count_inittable_fields(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + if ((psym(sym)^.typ=varsym) and + pvarsym(sym)^.vartype.def^.needs_inittable) + and ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or + (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then + inc(count); + end; + + + procedure count_fields(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + inc(count); + end; + + + procedure write_field_inittable(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + if ((psym(sym)^.typ=varsym) and + pvarsym(sym)^.vartype.def^.needs_inittable) and + ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or + (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then + begin + rttilist^.concat(new(pai_const_symbol,init(pvarsym(sym)^.vartype.def^.get_inittable_label))); + rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address))); + end; + end; + + + procedure write_field_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label))); + rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address))); + end; + + + procedure generate_child_inittable(sym:pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + if (psym(sym)^.typ=varsym) and + pvarsym(sym)^.vartype.def^.needs_inittable then + { force inittable generation } + pvarsym(sym)^.vartype.def^.get_inittable_label; + end; + + + procedure generate_child_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + pvarsym(sym)^.vartype.def^.get_rtti_label; + end; + + + procedure trecorddef.write_child_rtti_data; + begin + symtable^.foreach({$ifndef TP}@{$endif}generate_child_rtti); + end; + + + procedure trecorddef.write_child_init_data; + begin + symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable); + end; + + + procedure trecorddef.write_rtti_data; + begin + rttilist^.concat(new(pai_const,init_8bit(tkrecord))); + write_rtti_name; + rttilist^.concat(new(pai_const,init_32bit(size))); + count:=0; + symtable^.foreach({$ifndef TP}@{$endif}count_fields); + rttilist^.concat(new(pai_const,init_32bit(count))); + symtable^.foreach({$ifndef TP}@{$endif}write_field_rtti); + end; + + + procedure trecorddef.write_init_data; + begin + rttilist^.concat(new(pai_const,init_8bit(tkrecord))); + write_rtti_name; + rttilist^.concat(new(pai_const,init_32bit(size))); + count:=0; + symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields); + rttilist^.concat(new(pai_const,init_32bit(count))); + symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable); + end; + + function trecorddef.gettypename : string; + + begin + gettypename:='' + end; + + +{*************************************************************************** + TABSTRACTPROCDEF +***************************************************************************} + + constructor tabstractprocdef.init; + begin + inherited init; + new(para,init); + fpu_used:=0; + proctypeoption:=potype_none; + proccalloptions:=[]; + procoptions:=[]; + rettype.setdef(voiddef); + symtablelevel:=0; + savesize:=target_os.size_of_pointer; + end; + + + destructor tabstractprocdef.done; + begin + dispose(para,done); + inherited done; + end; + + + procedure tabstractprocdef.concatpara(tt:ttype;vsp : tvarspez); + var + hp : pparaitem; + begin + new(hp,init); + hp^.paratyp:=vsp; + hp^.paratype:=tt; + hp^.register:=R_NO; + para^.insert(hp); + end; + + + { all functions returning in FPU are + assume to use 2 FPU registers + until the function implementation + is processed PM } + procedure tabstractprocdef.test_if_fpu_result; + begin + if assigned(rettype.def) and is_fpu(rettype.def) then + fpu_used:=2; + end; + + + procedure tabstractprocdef.deref; + var + hp : pparaitem; + begin + inherited deref; + rettype.resolve; + hp:=pparaitem(para^.first); + while assigned(hp) do + begin + hp^.paratype.resolve; + hp:=pparaitem(hp^.next); + end; + end; + + + constructor tabstractprocdef.load; + var + hp : pparaitem; + count,i : word; + begin + inherited load; + new(para,init); + rettype.load; + fpu_used:=readbyte; + proctypeoption:=tproctypeoption(readlong); + readsmallset(proccalloptions); + readsmallset(procoptions); + count:=readword; + savesize:=target_os.size_of_pointer; + for i:=1 to count do + begin + new(hp,init); + hp^.paratyp:=tvarspez(readbyte); + { hp^.register:=tregister(readbyte); } + hp^.register:=R_NO; + hp^.paratype.load; + para^.concat(hp); + end; + end; + + + procedure tabstractprocdef.write; + var + hp : pparaitem; + begin + inherited write; + rettype.write; + current_ppu^.do_interface_crc:=false; + writebyte(fpu_used); + writelong(ord(proctypeoption)); + writesmallset(proccalloptions); + writesmallset(procoptions); + writeword(para^.count); + hp:=pparaitem(para^.first); + while assigned(hp) do + begin + writebyte(byte(hp^.paratyp)); + { writebyte(byte(hp^.register)); } + hp^.paratype.write; + hp:=pparaitem(hp^.next); + end; + end; + + + function tabstractprocdef.para_size(alignsize:longint) : longint; + var + pdc : pparaitem; + l : longint; + begin + l:=0; + pdc:=pparaitem(para^.first); + while assigned(pdc) do + begin + case pdc^.paratyp of + vs_var : inc(l,target_os.size_of_pointer); + vs_value, + vs_const : if push_addr_param(pdc^.paratype.def) then + inc(l,target_os.size_of_pointer) + else + inc(l,pdc^.paratype.def^.size); + end; + l:=align(l,alignsize); + pdc:=pparaitem(pdc^.next); + end; + para_size:=l; + end; + + + function tabstractprocdef.demangled_paras : string; + var + s : string; + hp : pparaitem; + begin + s:='('; + hp:=pparaitem(para^.last); + while assigned(hp) do + begin + if assigned(hp^.paratype.def^.typesym) then + s:=s+hp^.paratype.def^.typesym^.name + else if hp^.paratyp=vs_var then + s:=s+'var' + else if hp^.paratyp=vs_const then + s:=s+'const'; + hp:=pparaitem(hp^.previous); + if assigned(hp) then + s:=s+','; + end; + s:=s+')'; + demangled_paras:=s; + end; + + + function tabstractprocdef.proccalloption2str : string; + type + tproccallopt=record + mask : tproccalloption; + str : string[30]; + end; + const + proccallopts=12; + proccallopt : array[1..proccallopts] of tproccallopt=( + (mask:pocall_none; str:''), + (mask:pocall_clearstack; str:'ClearStack'), + (mask:pocall_leftright; str:'LeftRight'), + (mask:pocall_cdecl; str:'Cdecl'), + (mask:pocall_register; str:'Register'), + (mask:pocall_stdcall; str:'StdCall'), + (mask:pocall_safecall; str:'SafeCall'), + (mask:pocall_palmossyscall;str:'PalmOSSysCall'), + (mask:pocall_system; str:'System'), + (mask:pocall_inline; str:'Inline'), + (mask:pocall_internproc; str:'InternProc'), + (mask:pocall_internconst; str:'InternConst') + ); + var + s : string; + i : longint; + first : boolean; + begin + s:=''; + first:=true; + for i:=1to proccallopts do + if (proccallopt[i].mask in proccalloptions) then + begin + if first then + first:=false + else + s:=s+';'; + s:=s+proccallopt[i].str; + end; + proccalloption2str:=s; + end; + + +{$ifdef GDB} + function tabstractprocdef.stabstring : pchar; + begin + stabstring := strpnew('abstractproc'+numberstring+';'); + end; + + + procedure tabstractprocdef.concatstabto(asmlist : paasmoutput); + begin + if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) + and not is_def_stab_written then + begin + if assigned(rettype.def) then forcestabto(asmlist,rettype.def); + inherited concatstabto(asmlist); + end; + end; +{$endif GDB} + + +{*************************************************************************** + TPROCDEF +***************************************************************************} + + constructor tprocdef.init; + begin + inherited init; + deftype:=procdef; + _mangledname:=nil; + nextoverloaded:=nil; + fileinfo:=aktfilepos; + extnumber:=-1; + localst:=new(psymtable,init(localsymtable)); + parast:=new(psymtable,init(parasymtable)); + localst^.defowner:=@self; + parast^.defowner:=@self; + { this is used by insert + to check same names in parast and localst } + localst^.next:=parast; + defref:=nil; + crossref:=nil; + lastwritten:=nil; + refcount:=0; + if (cs_browser in aktmoduleswitches) and make_ref then + begin + defref:=new(pref,init(defref,@tokenpos)); + inc(refcount); + end; + lastref:=defref; + { first, we assume that all registers are used } +{$ifdef newcg} + usedregisters:=[firstreg..lastreg]; +{$else newcg} +{$ifdef i386} + usedregisters:=$ff; +{$endif i386} +{$ifdef m68k} + usedregisters:=$FFFF; +{$endif} +{$endif newcg} + forwarddef:=true; + interfacedef:=false; + _class := nil; + code:=nil; + count:=false; + is_used:=false; + end; + + + constructor tprocdef.load; + var + s : string; + begin + inherited load; + deftype:=procdef; + +{$ifdef newcg} + readnormalset(usedregisters); +{$else newcg} +{$ifdef i386} + usedregisters:=readbyte; +{$endif i386} +{$ifdef m68k} + usedregisters:=readword; +{$endif} +{$endif newcg} + s:=readstring; + setstring(_mangledname,s); + + extnumber:=readlong; + nextoverloaded:=pprocdef(readdefref); + _class := pobjectdef(readdefref); + readposinfo(fileinfo); + + if (cs_link_deffile in aktglobalswitches) and + (tf_need_export in target_info.flags) and + (po_exports in procoptions) then + deffile.AddExport(mangledname); + + parast:=nil; + localst:=nil; + forwarddef:=false; + interfacedef:=false; + lastref:=nil; + lastwritten:=nil; + defref:=nil; + refcount:=0; + count:=true; + is_used:=false; + end; + + +Const local_symtable_index : longint = $8001; + + procedure tprocdef.load_references; + var + pos : tfileposinfo; +{$ifndef NOLOCALBROWSER} + oldsymtablestack, + st : psymtable; +{$endif ndef NOLOCALBROWSER} + move_last : boolean; + begin + move_last:=lastwritten=lastref; + while (not current_ppu^.endofentry) do + begin + readposinfo(pos); + inc(refcount); + lastref:=new(pref,init(lastref,@pos)); + lastref^.is_written:=true; + if refcount=1 then + defref:=lastref; + end; + if move_last then + lastwritten:=lastref; + if ((current_module^.flags and uf_local_browser)<>0) + and is_in_current then + begin +{$ifndef NOLOCALBROWSER} + oldsymtablestack:=symtablestack; + st:=aktlocalsymtable; + new(parast,loadas(parasymtable)); + parast^.defowner:=@self; + aktlocalsymtable:=parast; + parast^.deref; + parast^.next:=owner; + parast^.load_browser; + aktlocalsymtable:=st; + new(localst,loadas(localsymtable)); + localst^.defowner:=@self; + aktlocalsymtable:=localst; + symtablestack:=parast; + localst^.deref; + localst^.next:=parast; + localst^.load_browser; + aktlocalsymtable:=st; + symtablestack:=oldsymtablestack; +{$endif ndef NOLOCALBROWSER} + end; + end; + + + function tprocdef.write_references : boolean; + var + ref : pref; +{$ifndef NOLOCALBROWSER} + st : psymtable; + pdo : pobjectdef; +{$endif ndef NOLOCALBROWSER} + move_last : boolean; + begin + move_last:=lastwritten=lastref; + if move_last and (((current_module^.flags and uf_local_browser)=0) + or not is_in_current) then + exit; + { write address of this symbol } + writedefref(@self); + { write refs } + if assigned(lastwritten) then + ref:=lastwritten + else + ref:=defref; + while assigned(ref) do + begin + if ref^.moduleindex=current_module^.unit_index then + begin + writeposinfo(ref^.posinfo); + ref^.is_written:=true; + if move_last then + lastwritten:=ref; + end + else if not ref^.is_written then + move_last:=false + else if move_last then + lastwritten:=ref; + ref:=ref^.nextref; + end; + current_ppu^.writeentry(ibdefref); + write_references:=true; + if ((current_module^.flags and uf_local_browser)<>0) + and is_in_current then + begin +{$ifndef NOLOCALBROWSER} + pdo:=_class; + if (owner^.symtabletype<>localsymtable) then + while assigned(pdo) do + begin + if pdo^.symtable<>aktrecordsymtable then + begin + pdo^.symtable^.unitid:=local_symtable_index; + inc(local_symtable_index); + end; + pdo:=pdo^.childof; + end; + + { we need TESTLOCALBROWSER para and local symtables + PPU files are then easier to read PM } + if not assigned(parast) then + parast:=new(psymtable,init(parasymtable)); + parast^.defowner:=@self; + st:=aktlocalsymtable; + aktlocalsymtable:=parast; + parast^.writeas; + parast^.unitid:=local_symtable_index; + inc(local_symtable_index); + parast^.write_browser; + if not assigned(localst) then + localst:=new(psymtable,init(localsymtable)); + localst^.defowner:=@self; + aktlocalsymtable:=localst; + localst^.writeas; + localst^.unitid:=local_symtable_index; + inc(local_symtable_index); + localst^.write_browser; + aktlocalsymtable:=st; + { decrement for } + local_symtable_index:=local_symtable_index-2; + pdo:=_class; + if (owner^.symtabletype<>localsymtable) then + while assigned(pdo) do + begin + if pdo^.symtable<>aktrecordsymtable then + dec(local_symtable_index); + pdo:=pdo^.childof; + end; +{$endif ndef NOLOCALBROWSER} + end; + end; + + +{$ifdef BrowserLog} + procedure tprocdef.add_to_browserlog; + begin + if assigned(defref) then + begin + browserlog.AddLog('***'+mangledname); + browserlog.AddLogRefs(defref); + if (current_module^.flags and uf_local_browser)<>0 then + begin + if assigned(parast) then + parast^.writebrowserlog; + if assigned(localst) then + localst^.writebrowserlog; + end; + end; + end; +{$endif BrowserLog} + + + destructor tprocdef.done; + begin + if assigned(defref) then + begin + defref^.freechain; + dispose(defref,done); + end; + if assigned(parast) then + dispose(parast,done); + if assigned(localst) and (localst^.symtabletype<>staticsymtable) then + dispose(localst,done); + if (pocall_inline in proccalloptions) and assigned(code) then + disposetree(ptree(code)); + if (po_msgstr in procoptions) then + strdispose(messageinf.str); + if +{$ifdef tp} + not(use_big) and +{$endif} + assigned(_mangledname) then + strdispose(_mangledname); + inherited done; + end; + + + procedure tprocdef.write; + begin + inherited write; + current_ppu^.do_interface_crc:=false; + { set all registers to used for simplified compilation PM } + if simplify_ppu then + begin +{$ifdef newcg} + usedregisters:=[firstreg..lastreg]; +{$else newcg} +{$ifdef i386} + usedregisters:=$ff; +{$endif i386} +{$ifdef m68k} + usedregisters:=$ffff; +{$endif} +{$endif newcg} + end; + +{$ifdef newcg} + writenormalset(usedregisters); +{$else newcg} +{$ifdef i386} + writebyte(usedregisters); +{$endif i386} +{$ifdef m68k} + writeword(usedregisters); +{$endif} +{$endif newcg} + current_ppu^.do_interface_crc:=true; + writestring(mangledname); + writelong(extnumber); + if (proctypeoption<>potype_operator) then + writedefref(nextoverloaded) + else + begin + { only write the overloads from the same unit } + if assigned(nextoverloaded) and + (nextoverloaded^.owner=owner) then + writedefref(nextoverloaded) + else + writedefref(nil); + end; + writedefref(_class); + writeposinfo(fileinfo); + if (pocall_inline in proccalloptions) then + begin + { we need to save + - the para and the local symtable + - the code ptree !! PM + writesymtable(parast); + writesymtable(localst); + writeptree(ptree(code)); + } + end; + current_ppu^.writeentry(ibprocdef); + end; + + + function tprocdef.haspara:boolean; + begin + haspara:=assigned(aktprocsym^.definition^.parast^.symindex^.first); + end; + + +{$ifdef GDB} + procedure addparaname(p : psym); + var vs : char; + begin + if pvarsym(p)^.varspez = vs_value then vs := '1' + else vs := '0'; + strpcopy(strend(StabRecString),p^.name+':'+pvarsym(p)^.vartype.def^.numberstring+','+vs+';'); + end; + + + function tprocdef.stabstring : pchar; + var + i : longint; + oldrec : pchar; + begin + oldrec := stabrecstring; + getmem(StabRecString,1024); + strpcopy(StabRecString,'f'+rettype.def^.numberstring); + i:=para^.count; + if i>0 then + begin + strpcopy(strend(StabRecString),','+tostr(i)+';'); + (* confuse gdb !! PM + if assigned(parast) then + parast^.foreach({$ifndef TP}@{$endif}addparaname) + else + begin + param := para1; + i := 0; + while assigned(param) do + begin + inc(i); + if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0'; + {Here we have lost the parameter names !!} + {using lower case parameters } + strpcopy(strend(stabrecstring),'p'+tostr(i) + +':'+param^.paratype.def^.numberstring+','+vartyp+';'); + param := param^.next; + end; + end; *) + {strpcopy(strend(StabRecString),';');} + end; + stabstring := strnew(stabrecstring); + freemem(stabrecstring,1024); + stabrecstring := oldrec; + end; + + + procedure tprocdef.concatstabto(asmlist : paasmoutput); + begin + end; +{$endif GDB} + + + procedure tprocdef.deref; + begin + inherited deref; + resolvedef(pdef(nextoverloaded)); + resolvedef(pdef(_class)); + end; + + + function tprocdef.mangledname : string; +{$ifdef tp} + var + oldpos : longint; + s : string; + b : byte; +{$endif tp} + begin +{$ifndef Delphi} +{$ifdef tp} + if use_big then + begin + symbolstream.seek(longint(_mangledname)); + symbolstream.read(b,1); + symbolstream.read(s[1],b); + s[0]:=chr(b); + mangledname:=s; + end + else +{$endif} +{$endif Delphi} + mangledname:=strpas(_mangledname); + if count then + is_used:=true; + end; + + + function tprocdef.procname: string; + var + s : string; + l : longint; + begin + s:=mangledname; + { delete leading $$'s } + l:=pos('$$',s); + while l<>0 do + begin + delete(s,1,l+1); + l:=pos('$$',s); + end; + { delete leading _$'s } + l:=pos('_$',s); + while l<>0 do + begin + delete(s,1,l+1); + l:=pos('_$',s); + end; + l:=pos('$',s); + if l=0 then + procname:=s + else + procname:=Copy(s,1,l-1); + end; + +{$IfDef GDB} + function tprocdef.cplusplusmangledname : string; + var + s,s2 : string; + param : pparaitem; + begin + s := typesym^.name; + if _class <> nil then + begin + s2 := _class^.objname^; + s := s+'__'+tostr(length(s2))+s2; + end else s := s + '_'; + param := pparaitem(para^.first); + while assigned(param) do + begin + s2 := param^.paratype.def^.typesym^.name; + s := s+tostr(length(s2))+s2; + param := pparaitem(param^.next); + end; + cplusplusmangledname:=s; + end; +{$EndIf GDB} + + + procedure tprocdef.setmangledname(const s : string); + begin + if {$ifdef tp}not(use_big) and{$endif} (assigned(_mangledname)) then + strdispose(_mangledname); + setstring(_mangledname,s); + if assigned(parast) then + begin + stringdispose(parast^.name); + parast^.name:=stringdup('args of '+s); + end; + if assigned(localst) then + begin + stringdispose(localst^.name); + localst^.name:=stringdup('locals of '+s); + end; + end; + + +{*************************************************************************** + TPROCVARDEF +***************************************************************************} + + constructor tprocvardef.init; + begin + inherited init; + deftype:=procvardef; + end; + + + constructor tprocvardef.load; + begin + inherited load; + deftype:=procvardef; + end; + + + procedure tprocvardef.write; + begin + { here we cannot get a real good value so just give something } + { plausible (PM) } + { a more secure way would be + to allways store in a temp } + if is_fpu(rettype.def) then + fpu_used:=2 + else + fpu_used:=0; + inherited write; + current_ppu^.writeentry(ibprocvardef); + end; + + + function tprocvardef.size : longint; + begin + if (po_methodpointer in procoptions) then + size:=2*target_os.size_of_pointer + else + size:=target_os.size_of_pointer; + end; + + +{$ifdef GDB} + function tprocvardef.stabstring : pchar; + var + nss : pchar; + { i : longint; } + begin + { i := para^.count; } + getmem(nss,1024); + { it is not a function but a function pointer !! (PM) } + + strpcopy(nss,'*f'+rettype.def^.numberstring{+','+tostr(i)}+';'); + { this confuses gdb !! + we should use 'F' instead of 'f' but + as we use c++ language mode + it does not like that either + Please do not remove this part + might be used once + gdb for pascal is ready PM } + (* + param := para1; + i := 0; + while assigned(param) do + begin + inc(i); + if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0'; + {Here we have lost the parameter names !!} + pst := strpnew('p'+tostr(i)+':'+param^.paratype.def^.numberstring+','+vartyp+';'); + strcat(nss,pst); + strdispose(pst); + param := param^.next; + end; *) + {strpcopy(strend(nss),';');} + stabstring := strnew(nss); + freemem(nss,1024); + end; + + + procedure tprocvardef.concatstabto(asmlist : paasmoutput); + begin + if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) + and not is_def_stab_written then + inherited concatstabto(asmlist); + is_def_stab_written:=true; + end; +{$endif GDB} + + + procedure tprocvardef.write_rtti_data; + var + pdc : pparaitem; + methodkind, paraspec : byte; + begin + if po_methodpointer in procoptions then + begin + { write method id and name } + rttilist^.concat(new(pai_const,init_8bit(tkmethod))); + write_rtti_name; + + { write kind of method (can only be function or procedure)} + if rettype.def = pdef(voiddef) then { ### typecast shoudln't be necessary! (sg) } + methodkind := mkProcedure + else + methodkind := mkFunction; + rttilist^.concat(new(pai_const,init_8bit(methodkind))); + + { get # of parameters } + rttilist^.concat(new(pai_const,init_8bit(para^.count))); + + { write parameter info. The parameters must be written in reverse order + if this method uses right to left parameter pushing! } + if (pocall_leftright in proccalloptions) then + pdc:=pparaitem(para^.last) + else + pdc:=pparaitem(para^.first); + while assigned(pdc) do + begin + case pdc^.paratyp of + vs_value: paraspec := 0; + vs_const: paraspec := pfConst; + vs_var : paraspec := pfVar; + end; + { write flags for current parameter } + rttilist^.concat(new(pai_const,init_8bit(paraspec))); + { write name of current parameter ### how can I get this??? (sg)} + rttilist^.concat(new(pai_const,init_8bit(0))); + + { write name of type of current parameter } + pdc^.paratype.def^.write_rtti_name; + + if (pocall_leftright in proccalloptions) then + pdc:=pparaitem(pdc^.previous) + else + pdc:=pparaitem(pdc^.next); + end; + + { write name of result type } + rettype.def^.write_rtti_name; + end; + end; + + + procedure tprocvardef.write_child_rtti_data; + begin + {!!!!!!!!} + end; + + + function tprocvardef.is_publishable : boolean; + begin + is_publishable:=(po_methodpointer in procoptions); + end; + + + function tprocvardef.gettypename : string; + begin + if assigned(rettype.def) and + (rettype.def<>pdef(voiddef)) then + gettypename:='' + else + gettypename:=''; + end; + + +{*************************************************************************** + TOBJECTDEF +***************************************************************************} + +{$ifdef GDB} + const + vtabletype : word = 0; + vtableassigned : boolean = false; +{$endif GDB} + + constructor tobjectdef.init(const n : string;c : pobjectdef); + begin + tdef.init; + deftype:=objectdef; + objectoptions:=[]; + childof:=nil; + symtable:=new(psymtable,init(objectsymtable)); + symtable^.name := stringdup(n); + { create space for vmt !! } + vmt_offset:=0; + symtable^.datasize:=0; + symtable^.defowner:=@self; + symtable^.dataalignment:=packrecordalignment[aktpackrecords]; + set_parent(c); + objname:=stringdup(n); + end; + + + constructor tobjectdef.load; + var + oldread_member : boolean; + begin + tdef.load; + deftype:=objectdef; + savesize:=readlong; + vmt_offset:=readlong; + objname:=stringdup(readstring); + childof:=pobjectdef(readdefref); + readsmallset(objectoptions); + has_rtti:=boolean(readbyte); + + oldread_member:=read_member; + read_member:=true; + symtable:=new(psymtable,loadas(objectsymtable)); + read_member:=oldread_member; + + symtable^.defowner:=@self; + symtable^.name := stringdup(objname^); + + { handles the predefined class tobject } + { the last TOBJECT which is loaded gets } + { it ! } + if (childof=nil) and + is_class and + (objname^='TOBJECT') then + class_tobject:=@self; + end; + + + destructor tobjectdef.done; + begin + if assigned(symtable) then + dispose(symtable,done); + if (oo_is_forward in objectoptions) then + Message1(sym_e_class_forward_not_resolved,objname^); + stringdispose(objname); + tdef.done; + end; + + + procedure tobjectdef.write; + var + oldread_member : boolean; + begin + tdef.write; + writelong(size); + writelong(vmt_offset); + writestring(objname^); + writedefref(childof); + writesmallset(objectoptions); + writebyte(byte(has_rtti)); + current_ppu^.writeentry(ibobjectdef); + + oldread_member:=read_member; + read_member:=true; + symtable^.writeas; + read_member:=oldread_member; + end; + + + procedure tobjectdef.deref; + var + oldrecsyms : psymtable; + begin + inherited deref; + resolvedef(pdef(childof)); + oldrecsyms:=aktrecordsymtable; + aktrecordsymtable:=symtable; + symtable^.deref; + aktrecordsymtable:=oldrecsyms; + end; + + + procedure tobjectdef.set_parent( c : pobjectdef); + begin + { nothing to do if the parent was not forward !} + if assigned(childof) then + exit; + childof:=c; + { some options are inherited !! } + if assigned(c) then + begin + objectoptions:=objectoptions+(c^.objectoptions* + [oo_has_virtual,oo_has_private,oo_has_protected,oo_has_constructor,oo_has_destructor]); + { add the data of the anchestor class } + inc(symtable^.datasize,c^.symtable^.datasize); + if (oo_has_vmt in objectoptions) and + (oo_has_vmt in c^.objectoptions) then + dec(symtable^.datasize,target_os.size_of_pointer); + { if parent has a vmt field then + the offset is the same for the child PM } + if (oo_has_vmt in c^.objectoptions) or is_class then + begin + vmt_offset:=c^.vmt_offset; +{$ifdef INCLUDEOK} + include(objectoptions,oo_has_vmt); +{$else} + objectoptions:=objectoptions+[oo_has_vmt]; +{$endif} + end; + end; + savesize := symtable^.datasize; + end; + + + procedure tobjectdef.insertvmt; + begin + if (oo_has_vmt in objectoptions) then + internalerror(12345) + else + begin + { first round up to multiple of 4 } + if (symtable^.dataalignment=2) then + begin + if (symtable^.datasize and 1)<>0 then + inc(symtable^.datasize); + end + else + if (symtable^.dataalignment>=4) then + begin + if (symtable^.datasize mod 4) <> 0 then + inc(symtable^.datasize,4-(symtable^.datasize mod 4)); + end; + vmt_offset:=symtable^.datasize; + inc(symtable^.datasize,target_os.size_of_pointer); + include(objectoptions,oo_has_vmt); + end; + end; + + + procedure tobjectdef.check_forwards; + begin + symtable^.check_forwards; + if (oo_is_forward in objectoptions) then + begin + { ok, in future, the forward can be resolved } + Message1(sym_e_class_forward_not_resolved,objname^); +{$ifdef INCLUDEOK} + exclude(objectoptions,oo_is_forward); +{$else} + objectoptions:=objectoptions-[oo_is_forward]; +{$endif} + end; + end; + + + { true, if self inherits from d (or if they are equal) } + function tobjectdef.is_related(d : pobjectdef) : boolean; + var + hp : pobjectdef; + begin + hp:=@self; + while assigned(hp) do + begin + if hp=d then + begin + is_related:=true; + exit; + end; + hp:=hp^.childof; + end; + is_related:=false; + end; + + var + sd : pprocdef; + + procedure _searchdestructor(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + + var + p : pprocdef; + + begin + { if we found already a destructor, then we exit } + if assigned(sd) then + exit; + if psym(sym)^.typ=procsym then + begin + p:=pprocsym(sym)^.definition; + while assigned(p) do + begin + if p^.proctypeoption=potype_destructor then + begin + sd:=p; + exit; + end; + p:=p^.nextoverloaded; + end; + end; + end; + + function tobjectdef.searchdestructor : pprocdef; + + var + o : pobjectdef; + + begin + searchdestructor:=nil; + o:=@self; + sd:=nil; + while assigned(o) do + begin + symtable^.foreach({$ifndef TP}@{$endif}_searchdestructor); + if assigned(sd) then + begin + searchdestructor:=sd; + exit; + end; + o:=o^.childof; + end; + end; + + function tobjectdef.size : longint; + begin + if (oo_is_class in objectoptions) then + size:=target_os.size_of_pointer + else + size:=symtable^.datasize; + end; + + + function tobjectdef.alignment:longint; + begin + alignment:=symtable^.dataalignment; + end; + + + function tobjectdef.vmtmethodoffset(index:longint):longint; + begin + { for offset of methods for classes, see rtl/inc/objpash.inc } + if is_class then + vmtmethodoffset:=(index+12)*target_os.size_of_pointer + else +{$ifdef WITHDMT} + vmtmethodoffset:=(index+4)*target_os.size_of_pointer; +{$else WITHDMT} + vmtmethodoffset:=(index+3)*target_os.size_of_pointer; +{$endif WITHDMT} + end; + + + function tobjectdef.vmt_mangledname : string; + {DM: I get a nil pointer on the owner name. I don't know if this + mayhappen, and I have therefore fixed the problem by doing nil pointer + checks.} + var + s1,s2:string; + begin + if not(oo_has_vmt in objectoptions) then + Message1(parser_object_has_no_vmt,objname^); + if owner^.name=nil then + s1:='' + else + s1:=owner^.name^; + if objname=nil then + s2:='' + else + s2:=objname^; + vmt_mangledname:='VMT_'+s1+'$_'+s2; + end; + + + function tobjectdef.rtti_name : string; + var + s1,s2:string; + begin + if owner^.name=nil then + s1:='' + else + s1:=owner^.name^; + if objname=nil then + s2:='' + else + s2:=objname^; + rtti_name:='RTTI_'+s1+'$_'+s2; + end; + + + function tobjectdef.is_class : boolean; + begin + is_class:=(oo_is_class in objectoptions); + end; + + +{$ifdef GDB} + procedure addprocname(p :pnamedindexobject); + var virtualind,argnames : string; + news, newrec : pchar; + pd,ipd : pprocdef; + lindex : longint; + para : pparaitem; + arglength : byte; + sp : char; + + begin + If psym(p)^.typ = procsym then + begin + pd := pprocsym(p)^.definition; + { this will be used for full implementation of object stabs + not yet done } + ipd := pd; + while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded; + if (po_virtualmethod in pd^.procoptions) then + begin + lindex := pd^.extnumber; + {doesnt seem to be necessary + lindex := lindex or $80000000;} + virtualind := '*'+tostr(lindex)+';'+ipd^._class^.numberstring+';' + end else virtualind := '.'; + + { used by gdbpas to recognize constructor and destructors } + if (pd^.proctypeoption=potype_constructor) then + argnames:='__ct__' + else if (pd^.proctypeoption=potype_destructor) then + argnames:='__dt__' + else + argnames := ''; + + { arguments are not listed here } + {we don't need another definition} + para := pparaitem(pd^.para^.first); + while assigned(para) do + begin + if para^.paratype.def^.deftype = formaldef then + begin + if para^.paratyp=vs_var then + argnames := argnames+'3var' + else if para^.paratyp=vs_const then + argnames:=argnames+'5const'; + end + else + begin + { if the arg definition is like (v: ^byte;.. + there is no sym attached to data !!! } + if assigned(para^.paratype.def^.typesym) then + begin + arglength := length(para^.paratype.def^.typesym^.name); + argnames := argnames + tostr(arglength)+para^.paratype.def^.typesym^.name; + end + else + begin + argnames:=argnames+'11unnamedtype'; + end; + end; + para := pparaitem(para^.next); + end; + ipd^.is_def_stab_written := true; + { here 2A must be changed for private and protected } + { 0 is private 1 protected and 2 public } + if (sp_private in psym(p)^.symoptions) then sp:='0' + else if (sp_protected in psym(p)^.symoptions) then sp:='1' + else sp:='2'; + newrec := strpnew(p^.name+'::'+ipd^.numberstring + +'=##'+pd^.rettype.def^.numberstring+';:'+argnames+';'+sp+'A' + +virtualind+';'); + { get spare place for a string at the end } + if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then + begin + getmem(news,stabrecsize+memsizeinc); + strcopy(news,stabrecstring); + freemem(stabrecstring,stabrecsize); + stabrecsize:=stabrecsize+memsizeinc; + stabrecstring:=news; + end; + strcat(StabRecstring,newrec); + {freemem(newrec,memsizeinc); } + strdispose(newrec); + {This should be used for case !!} + RecOffset := RecOffset + pd^.size; + end; + end; + + + function tobjectdef.stabstring : pchar; + var anc : pobjectdef; + oldrec : pchar; + oldrecsize : longint; + str_end : string; + begin + oldrec := stabrecstring; + oldrecsize:=stabrecsize; + stabrecsize:=memsizeinc; + GetMem(stabrecstring,stabrecsize); + strpcopy(stabRecString,'s'+tostr(symtable^.datasize)); + if assigned(childof) then + {only one ancestor not virtual, public, at base offset 0 } + { !1 , 0 2 0 , } + strpcopy(strend(stabrecstring),'!1,020,'+childof^.numberstring+';'); + {virtual table to implement yet} + RecOffset := 0; + symtable^.foreach({$ifndef TP}@{$endif}addname); + if (oo_has_vmt in objectoptions) then + if not assigned(childof) or not(oo_has_vmt in childof^.objectoptions) then + begin + strpcopy(strend(stabrecstring),'$vf'+numberstring+':'+typeglobalnumber('vtblarray') + +','+tostr(vmt_offset*8)+';'); + end; + symtable^.foreach({$ifndef TP}@{$endif}addprocname); + if (oo_has_vmt in objectoptions) then + begin + anc := @self; + while assigned(anc^.childof) and (oo_has_vmt in anc^.childof^.objectoptions) do + anc := anc^.childof; + str_end:=';~%'+anc^.numberstring+';'; + end + else + str_end:=';'; + strpcopy(strend(stabrecstring),str_end); + stabstring := strnew(StabRecString); + freemem(stabrecstring,stabrecsize); + stabrecstring := oldrec; + stabrecsize:=oldrecsize; + end; +{$endif GDB} + + + procedure tobjectdef.write_child_init_data; + begin + symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable); + end; + + + procedure tobjectdef.write_init_data; + begin + if is_class then + rttilist^.concat(new(pai_const,init_8bit(tkclass))) + else + rttilist^.concat(new(pai_const,init_8bit(tkobject))); + + { generate the name } + rttilist^.concat(new(pai_const,init_8bit(length(objname^)))); + rttilist^.concat(new(pai_string,init(objname^))); + + rttilist^.concat(new(pai_const,init_32bit(size))); + count:=0; + symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields); + rttilist^.concat(new(pai_const,init_32bit(count))); + symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable); + end; + + + function tobjectdef.needs_inittable : boolean; + var + oldb : boolean; + begin + if is_class then + needs_inittable:=false + else + begin + { there are recursive calls to needs_inittable possible, } + { so we have to change to old value how else should } + { we do that ? check_rec_rtti can't be a nested } + { procedure of needs_rtti ! } + oldb:=binittable; + binittable:=false; + symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable); + needs_inittable:=binittable; + binittable:=oldb; + end; + end; + + + procedure count_published_properties(sym:pnamedindexobject); + {$ifndef fpc}far;{$endif} + begin + if needs_prop_entry(psym(sym)) and + (psym(sym)^.typ<>varsym) then + inc(count); + end; + + + procedure write_property_info(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + var + proctypesinfo : byte; + + procedure writeproc(proc : psymlist; shiftvalue : byte); + + var + typvalue : byte; + hp : psymlistitem; + address : longint; + + begin + if not(assigned(proc) and assigned(proc^.firstsym)) then + begin + rttilist^.concat(new(pai_const,init_32bit(1))); + typvalue:=3; + end + else if proc^.firstsym^.sym^.typ=varsym then + begin + address:=0; + hp:=proc^.firstsym; + while assigned(hp) do + begin + inc(address,pvarsym(hp^.sym)^.address); + hp:=hp^.next; + end; + rttilist^.concat(new(pai_const,init_32bit(address))); + typvalue:=0; + end + else + begin + if not(po_virtualmethod in pprocdef(proc^.def)^.procoptions) then + begin + rttilist^.concat(new(pai_const_symbol,initname(pprocdef(proc^.def)^.mangledname))); + typvalue:=1; + end + else + begin + { virtual method, write vmt offset } + rttilist^.concat(new(pai_const,init_32bit( + pprocdef(proc^.def)^._class^.vmtmethodoffset(pprocdef(proc^.def)^.extnumber)))); + typvalue:=2; + end; + end; + proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue); + end; + + begin + if needs_prop_entry(psym(sym)) then + case psym(sym)^.typ of + varsym: + begin +{$ifdef dummy} + if not(pvarsym(sym)^.vartype.def^.deftype=objectdef) or + not(pobjectdef(pvarsym(sym)^.vartype.def)^.is_class) then + internalerror(1509992); + { access to implicit class property as field } + proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4); + rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label))); + rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address))); + rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address))); + { per default stored } + rttilist^.concat(new(pai_const,init_32bit(1))); + { index as well as ... } + rttilist^.concat(new(pai_const,init_32bit(0))); + { default value are zero } + rttilist^.concat(new(pai_const,init_32bit(0))); + rttilist^.concat(new(pai_const,init_16bit(count))); + inc(count); + rttilist^.concat(new(pai_const,init_8bit(proctypesinfo))); + rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name)))); + rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name))); +{$endif dummy} + end; + propertysym: + begin + if ppo_indexed in ppropertysym(sym)^.propoptions then + proctypesinfo:=$40 + else + proctypesinfo:=0; + rttilist^.concat(new(pai_const_symbol,initname(ppropertysym(sym)^.proptype.def^.get_rtti_label))); + writeproc(ppropertysym(sym)^.readaccess,0); + writeproc(ppropertysym(sym)^.writeaccess,2); + { isn't it stored ? } + if not(ppo_stored in ppropertysym(sym)^.propoptions) then + begin + rttilist^.concat(new(pai_const,init_32bit(0))); + proctypesinfo:=proctypesinfo or (3 shl 4); + end + else + writeproc(ppropertysym(sym)^.storedaccess,4); + rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.index))); + rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.default))); + rttilist^.concat(new(pai_const,init_16bit(count))); + inc(count); + rttilist^.concat(new(pai_const,init_8bit(proctypesinfo))); + rttilist^.concat(new(pai_const,init_8bit(length(ppropertysym(sym)^.name)))); + rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.name))); + end; + else internalerror(1509992); + end; + end; + + + procedure generate_published_child_rtti(sym : pnamedindexobject);{$ifndef fpc}far;{$endif} + begin + if needs_prop_entry(psym(sym)) then + case psym(sym)^.typ of + varsym: + ; + { now ignored: + pvarsym(sym)^.vartype.def^.get_rtti_label; + } + propertysym: + ppropertysym(sym)^.proptype.def^.get_rtti_label; + else + internalerror(1509991); + end; + end; + + + procedure tobjectdef.write_child_rtti_data; + begin + symtable^.foreach({$ifndef TP}@{$endif}generate_published_child_rtti); + end; + + + procedure tobjectdef.generate_rtti; + begin + if not has_rtti then + begin + has_rtti:=true; + getdatalabel(rtti_label); + write_child_rtti_data; + rttilist^.concat(new(pai_symbol,initname_global(rtti_name,0))); + rttilist^.concat(new(pai_label,init(rtti_label))); + write_rtti_data; + rttilist^.concat(new(pai_symbol_end,initname(rtti_name))); + end; + end; + + type + tclasslistitem = object(tlinkedlist_item) + index : longint; + p : pobjectdef; + end; + pclasslistitem = ^tclasslistitem; + + var + classtablelist : tlinkedlist; + tablecount : longint; + + function searchclasstablelist(p : pobjectdef) : pclasslistitem; + + var + hp : pclasslistitem; + + begin + hp:=pclasslistitem(classtablelist.first); + while assigned(hp) do + if hp^.p=p then + begin + searchclasstablelist:=hp; + exit; + end + else + hp:=pclasslistitem(hp^.next); + searchclasstablelist:=nil; + end; + + procedure count_published_fields(sym:pnamedindexobject); + {$ifndef fpc}far;{$endif} + + var + hp : pclasslistitem; + + begin + if needs_prop_entry(psym(sym)) and + (psym(sym)^.typ=varsym) then + begin + if pvarsym(sym)^.vartype.def^.deftype<>objectdef then + internalerror(0206001); + hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def)); + if not(assigned(hp)) then + begin + hp:=new(pclasslistitem,init); + hp^.p:=pobjectdef(pvarsym(sym)^.vartype.def); + hp^.index:=tablecount; + classtablelist.concat(hp); + inc(tablecount); + end; + inc(count); + end; + end; + + procedure writefields(sym:pnamedindexobject); + {$ifndef fpc}far;{$endif} + + var + hp : pclasslistitem; + + begin + if needs_prop_entry(psym(sym)) and + (psym(sym)^.typ=varsym) then + begin + rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address))); + hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def)); + if not(assigned(hp)) then + internalerror(0206002); + rttilist^.concat(new(pai_const,init_16bit(hp^.index))); + rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name)))); + rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name))); + end; + end; + + function tobjectdef.generate_field_table : pasmlabel; + + var + fieldtable, + classtable : pasmlabel; + hp : pclasslistitem; + + begin + classtablelist.init; + getdatalabel(fieldtable); + getdatalabel(classtable); + count:=0; + tablecount:=0; + symtable^.foreach({$ifdef FPC}@{$endif}count_published_fields); + rttilist^.concat(new(pai_label,init(fieldtable))); + rttilist^.concat(new(pai_const,init_16bit(count))); + rttilist^.concat(new(pai_const_symbol,init(classtable))); + symtable^.foreach({$ifdef FPC}@{$endif}writefields); + + { generate the class table } + rttilist^.concat(new(pai_label,init(classtable))); + rttilist^.concat(new(pai_const,init_16bit(tablecount))); + hp:=pclasslistitem(classtablelist.first); + while assigned(hp) do + begin + rttilist^.concat(new(pai_const_symbol,initname(pobjectdef(hp^.p)^.vmt_mangledname))); + hp:=pclasslistitem(hp^.next); + end; + + generate_field_table:=fieldtable; + classtablelist.done; + end; + + function tobjectdef.next_free_name_index : longint; + var + i : longint; + begin + if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then + i:=childof^.next_free_name_index + else + i:=0; + count:=0; + symtable^.foreach({$ifndef TP}@{$endif}count_published_properties); + next_free_name_index:=i+count; + end; + + + procedure tobjectdef.write_rtti_data; + begin + if is_class then + rttilist^.concat(new(pai_const,init_8bit(tkclass))) + else + rttilist^.concat(new(pai_const,init_8bit(tkobject))); + + { generate the name } + rttilist^.concat(new(pai_const,init_8bit(length(objname^)))); + rttilist^.concat(new(pai_string,init(objname^))); + + { write class type } + rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname))); + + { write owner typeinfo } + if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then + rttilist^.concat(new(pai_const_symbol,initname(childof^.get_rtti_label))) + else + rttilist^.concat(new(pai_const,init_32bit(0))); + + { count total number of properties } + if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then + count:=childof^.next_free_name_index + else + count:=0; + + { write it } + symtable^.foreach({$ifndef TP}@{$endif}count_published_properties); + rttilist^.concat(new(pai_const,init_16bit(count))); + + { write unit name } + if assigned(owner^.name) then + begin + rttilist^.concat(new(pai_const,init_8bit(length(owner^.name^)))); + rttilist^.concat(new(pai_string,init(owner^.name^))); + end + else + rttilist^.concat(new(pai_const,init_8bit(0))); + + { write published properties count } + count:=0; + symtable^.foreach({$ifndef TP}@{$endif}count_published_properties); + rttilist^.concat(new(pai_const,init_16bit(count))); + + { count is used to write nameindex } + { but we need an offset of the owner } + { to give each property an own slot } + if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then + count:=childof^.next_free_name_index + else + count:=0; + + symtable^.foreach({$ifndef TP}@{$endif}write_property_info); + end; + + + function tobjectdef.is_publishable : boolean; + begin + is_publishable:=is_class; + end; + + function tobjectdef.get_rtti_label : string; + + begin + generate_rtti; + get_rtti_label:=rtti_name; + end; + +{**************************************************************************** + TFORWARDDEF +****************************************************************************} + + constructor tforwarddef.init(const s:string;const pos : tfileposinfo); + var + oldregisterdef : boolean; + begin + { never register the forwarddefs, they are disposed at the + end of the type declaration block } + oldregisterdef:=registerdef; + registerdef:=false; + inherited init; + registerdef:=oldregisterdef; + deftype:=forwarddef; + tosymname:=s; + forwardpos:=pos; + end; + + + function tforwarddef.gettypename:string; + begin + gettypename:='unresolved forward to '+tosymname; + end; + + +{**************************************************************************** + TERRORDEF +****************************************************************************} + + constructor terrordef.init; + begin + inherited init; + deftype:=errordef; + end; + + +{$ifdef GDB} + function terrordef.stabstring : pchar; + begin + stabstring:=strpnew('error'+numberstring); + end; +{$endif GDB} + + function terrordef.gettypename:string; + + begin + gettypename:=''; + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.205 2000/06/30 22:11:29 peter + * fixed some getlabel to getdatalabel + + Revision 1.204 2000/06/29 08:42:47 sg + * Fix for class field table writing + + Revision 1.203 2000/06/25 09:25:29 peter + * setdef.typename, show Empty Set if elementtype is not set + + Revision 1.202 2000/06/22 20:01:57 peter + * int64,qword rtti support + + Revision 1.201 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.200 2000/06/02 18:48:47 florian + + fieldtable support for classes + + Revision 1.199 2000/04/01 14:17:08 peter + * arraydef.elesize returns 4 when strings are found in an openarray, + arrayconstructor. Since only the pointers to the strings are stored + + Revision 1.198 2000/04/01 11:44:56 peter + * fixed rtti info for record + + Revision 1.197 2000/03/01 12:35:45 pierre + * fix for bug 855 + + Revision 1.196 2000/02/14 20:58:43 marco + * Basic structures for new sethandling implemented. + + Revision 1.195 2000/02/11 13:53:49 pierre + * avoid stack overflow in tref.done (bug 846) + + Revision 1.194 2000/02/09 13:23:04 peter + * log truncated + + Revision 1.193 2000/02/05 14:33:32 florian + * fixed init table generation for classes and arrays + + Revision 1.192 2000/02/04 20:00:22 florian + * an exception in a construcor calls now the destructor (this applies only + to classes) + + Revision 1.191 2000/01/30 23:29:06 peter + * fixed dup rtti writing for classes + + Revision 1.190 2000/01/28 23:17:53 florian + * virtual XXXX; support for objects, only if -dWITHDMT is defined + + Revision 1.189 2000/01/26 12:02:29 peter + * abstractprocdef.para_size needs alignment parameter + * secondcallparan gets para_alignment size instead of dword_align + + Revision 1.188 2000/01/23 16:35:31 peter + * localbrowser loading of absolute fixed. It needed a symtablestack + which was not setup correctly + + Revision 1.187 2000/01/09 23:16:06 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.186 2000/01/07 01:14:39 peter + * updated copyright to 2000 + + Revision 1.185 2000/01/03 19:26:03 peter + * fixed resolving of ttypesym which are reference from object/record + fields. + + Revision 1.184 1999/12/31 14:24:34 peter + * fixed rtti generation for classes with no published section + + Revision 1.183 1999/12/23 12:19:42 peter + * check_rec_inittable fix from sg + + Revision 1.182 1999/12/19 17:00:27 peter + * has_rtti should be saved in the ppu for objects + + Revision 1.181 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.180 1999/12/06 18:21:03 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + + Revision 1.179 1999/12/01 12:42:33 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.178 1999/12/01 10:26:38 pierre + * restore the correct way for stabs of forward defs + + Revision 1.177 1999/11/30 10:40:54 peter + + ttype, tsymlist + + Revision 1.176 1999/11/09 23:35:49 pierre + + better reference pos for forward defs + + Revision 1.175 1999/11/07 23:57:36 pierre + + higher level browser + + Revision 1.174 1999/11/06 14:34:26 peter + * truncated log to 20 revs + +} diff --git a/befpc/compiler/symdefh.inc b/befpc/compiler/symdefh.inc new file mode 100644 index 0000000..43e268a --- /dev/null +++ b/befpc/compiler/symdefh.inc @@ -0,0 +1,614 @@ +{ + $Id: symdefh.inc,v 1.1.1.1 2001-07-23 17:17:05 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Interface for the definition types of the symtable + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} + +{************************************************ + TDef +************************************************} + + tdef = object(tsymtableentry) + deftype : tdeftype; + typesym : ptypesym; { which type the definition was generated this def } + + has_inittable : boolean; + { adress of init informations } + inittable_label : pasmlabel; + + has_rtti : boolean; + { address of rtti } + rtti_label : pasmlabel; + + nextglobal, + previousglobal : pdef; +{$ifdef GDB} + globalnb : word; + is_def_stab_written : boolean; +{$endif GDB} + constructor init; + constructor load; + destructor done;virtual; + procedure deref;virtual; + function typename:string; + procedure write;virtual; + function size:longint;virtual; + function alignment:longint;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + function is_in_current : boolean; + procedure correct_owner_symtable; { registers enumdef inside objects or + record directly in the owner symtable !! } + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; + function NumberString:string; + procedure set_globalnb; + function allstabstring : pchar; +{$endif GDB} + { init. tables } + function needs_inittable : boolean;virtual; + procedure generate_inittable; + function get_inittable_label : pasmlabel; + { the default implemenation calls write_rtti_data } + { if init and rtti data is different these procedures } + { must be overloaded } + procedure write_init_data;virtual; + procedure write_child_init_data;virtual; + { rtti } + procedure write_rtti_name; + function get_rtti_label : string;virtual; + procedure generate_rtti;virtual; + procedure write_rtti_data;virtual; + procedure write_child_rtti_data;virtual; + function is_intregable : boolean; + function is_fpuregable : boolean; + private + savesize : longint; + end; + + targconvtyp = (act_convertable,act_equal,act_exact); + + tvarspez = (vs_value,vs_const,vs_var); + + pparaitem = ^tparaitem; + tparaitem = object(tlinkedlist_item) + paratype : ttype; + paratyp : tvarspez; + argconvtyp : targconvtyp; + convertlevel : byte; + register : tregister; + end; + + tfiletyp = (ft_text,ft_typed,ft_untyped); + + pfiledef = ^tfiledef; + tfiledef = object(tdef) + filetyp : tfiletyp; + typedfiletype : ttype; + constructor inittext; + constructor inituntyped; + constructor inittyped(const tt : ttype); + constructor inittypeddef(p : pdef); + constructor load; + procedure write;virtual; + procedure deref;virtual; + function gettypename:string;virtual; + procedure setsize; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pformaldef = ^tformaldef; + tformaldef = object(tdef) + constructor init; + constructor load; + procedure write;virtual; + function gettypename:string;virtual; +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pforwarddef = ^tforwarddef; + tforwarddef = object(tdef) + tosymname : string; + forwardpos : tfileposinfo; + constructor init(const s:string;const pos : tfileposinfo); + function gettypename:string;virtual; + end; + + perrordef = ^terrordef; + terrordef = object(tdef) + constructor init; + function gettypename:string;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + end; + + { tpointerdef and tclassrefdef should get a common + base class, but I derived tclassrefdef from tpointerdef + to avoid problems with bugs (FK) + } + + ppointerdef = ^tpointerdef; + tpointerdef = object(tdef) + pointertype : ttype; + is_far : boolean; + constructor init(const tt : ttype); + constructor initfar(const tt : ttype); + constructor initdef(p : pdef); + constructor initfardef(p : pdef); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function gettypename:string;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pprocdef = ^tprocdef; + + pobjectdef = ^tobjectdef; + tobjectdef = object(tdef) + childof : pobjectdef; + objname : pstring; + symtable : psymtable; + objectoptions : tobjectoptions; + { to be able to have a variable vmt position } + { and no vmt field for objects without virtuals } + vmt_offset : longint; + constructor init(const n : string;c : pobjectdef); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function size : longint;virtual; + function alignment:longint;virtual; + function vmtmethodoffset(index:longint):longint; + function is_publishable : boolean;virtual; + function vmt_mangledname : string; + function rtti_name : string; + procedure check_forwards; + function is_related(d : pobjectdef) : boolean; + function is_class : boolean; + function next_free_name_index : longint; + procedure insertvmt; + procedure set_parent(c : pobjectdef); + function searchdestructor : pprocdef; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + { init/final } + function needs_inittable : boolean;virtual; + procedure write_init_data;virtual; + procedure write_child_init_data;virtual; + { rtti } + function get_rtti_label : string;virtual; + procedure generate_rtti;virtual; + procedure write_rtti_data;virtual; + procedure write_child_rtti_data;virtual; + function generate_field_table : pasmlabel; + end; + + pclassrefdef = ^tclassrefdef; + tclassrefdef = object(tpointerdef) + constructor init(def : pdef); + constructor load; + procedure write;virtual; + function gettypename:string;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + parraydef = ^tarraydef; + tarraydef = object(tdef) + private + rangenr : longint; + public + lowrange, + highrange : longint; + elementtype, + rangetype : ttype; + IsVariant, + IsConstructor, + IsArrayOfConst : boolean; + function gettypename:string;virtual; + function elesize : longint; + constructor init(l,h : longint;rd : pdef); + constructor load; + procedure write;virtual; +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + procedure deref;virtual; + function size : longint;virtual; + function alignment : longint;virtual; + { generates the ranges needed by the asm instruction BOUND (i386) + or CMP2 (Motorola) } + procedure genrangecheck; + + { returns the label of the range check string } + function getrangecheckstring : string; + function needs_inittable : boolean;virtual; + procedure write_rtti_data;virtual; + procedure write_child_rtti_data;virtual; + end; + + precorddef = ^trecorddef; + trecorddef = object(tdef) + symtable : psymtable; + constructor init(p : psymtable); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function size:longint;virtual; + function alignment : longint;virtual; + function gettypename:string;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + { init/final } + procedure write_init_data;virtual; + procedure write_child_init_data;virtual; + function needs_inittable : boolean;virtual; + { rtti } + procedure write_rtti_data;virtual; + procedure write_child_rtti_data;virtual; + end; + + porddef = ^torddef; + torddef = object(tdef) + private + rangenr : longint; + public + low,high : longint; + typ : tbasetype; + constructor init(t : tbasetype;v,b : longint); + constructor load; + procedure write;virtual; + function is_publishable : boolean;virtual; + function gettypename:string;virtual; + procedure setsize; + { generates the ranges needed by the asm instruction BOUND } + { or CMP2 (Motorola) } + procedure genrangecheck; + function getrangecheckstring : string; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + { rtti } + procedure write_rtti_data;virtual; + end; + + pfloatdef = ^tfloatdef; + tfloatdef = object(tdef) + typ : tfloattype; + constructor init(t : tfloattype); + constructor load; + procedure write;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + procedure setsize; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + { rtti } + procedure write_rtti_data;virtual; + end; + + pabstractprocdef = ^tabstractprocdef; + tabstractprocdef = object(tdef) + { saves a definition to the return type } + rettype : ttype; + proctypeoption : tproctypeoption; + proccalloptions : tproccalloptions; + procoptions : tprocoptions; + para : plinkedlist; + symtablelevel : byte; + fpu_used : byte; { how many stack fpu must be empty } + constructor init; + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + procedure concatpara(tt:ttype;vsp : tvarspez); + function para_size(alignsize:longint) : longint; + function demangled_paras : string; + function proccalloption2str : string; + procedure test_if_fpu_result; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pprocvardef = ^tprocvardef; + tprocvardef = object(tabstractprocdef) + constructor init; + constructor load; + procedure write;virtual; + function size : longint;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput); virtual; +{$endif GDB} + { rtti } + procedure write_child_rtti_data;virtual; + procedure write_rtti_data;virtual; + end; + + tmessageinf = record + case integer of + 0 : (str : pchar); + 1 : (i : longint); + end; + + tprocdef = object(tabstractprocdef) + private + _mangledname : pchar; + public + extnumber : longint; + messageinf : tmessageinf; + nextoverloaded : pprocdef; + { where is this function defined, needed here because there + is only one symbol for all overloaded functions } + fileinfo : tfileposinfo; + { pointer to the local symbol table } + localst : psymtable; + { pointer to the parameter symbol table } + parast : psymtable; + { symbol owning this definition } + procsym : pprocsym; + { browser info } + lastref, + defref, + crossref, + lastwritten : pref; + refcount : longint; + _class : pobjectdef; + { it's a tree, but this not easy to handle } + { used for inlined procs } + code : pointer; + { true, if the procedure is only declared } + { (forward procedure) } + forwarddef, + { true if the procedure is declared in the interface } + interfacedef : boolean; + { check the problems of manglednames } + count : boolean; + is_used : boolean; + { small set which contains the modified registers } +{$ifdef newcg} + usedregisters : tregisterset; +{$else newcg} + usedregisters : longint; +{$endif newcg} + constructor init; + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function haspara:boolean; + function mangledname : string; + procedure setmangledname(const s : string); + procedure load_references; + function write_references : boolean; + function procname: string; + { debug } +{$ifdef GDB} + function cplusplusmangledname : string; + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + { browser } +{$ifdef BrowserLog} + procedure add_to_browserlog; +{$endif BrowserLog} + end; + + pstringdef = ^tstringdef; + tstringdef = object(tdef) + string_typ : tstringtype; + len : longint; + constructor shortinit(l : byte); + constructor shortload; + constructor longinit(l : longint); + constructor longload; + constructor ansiinit(l : longint); + constructor ansiload; + constructor wideinit(l : longint); + constructor wideload; + function stringtypname:string; + function size : longint;virtual; + procedure write;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + { init/final } + function needs_inittable : boolean;virtual; + { rtti } + procedure write_rtti_data;virtual; + end; + + penumdef = ^tenumdef; + tenumdef = object(tdef) + rangenr, + minval, + maxval : longint; + has_jumps : boolean; + firstenum : penumsym; + basedef : penumdef; + constructor init; + constructor init_subrange(_basedef:penumdef;_min,_max:longint); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + procedure calcsavesize; + procedure setmax(_max:longint); + procedure setmin(_min:longint); + function min:longint; + function max:longint; + function getrangecheckstring:string; + procedure genrangecheck; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + { rtti } + procedure write_child_rtti_data;virtual; + procedure write_rtti_data;virtual; + end; + + psetdef = ^tsetdef; + tsetdef = object(tdef) + elementtype : ttype; + settype : tsettype; + constructor init(s : pdef;high : longint); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + function gettypename:string;virtual; + function is_publishable : boolean;virtual; + { debug } +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + { rtti } + procedure write_rtti_data;virtual; + procedure write_child_rtti_data;virtual; + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.54 2000/06/02 18:48:48 florian + + fieldtable support for classes + + Revision 1.53 2000/02/09 13:23:04 peter + * log truncated + + Revision 1.52 2000/02/04 20:00:22 florian + * an exception in a construcor calls now the destructor (this applies only + to classes) + + Revision 1.51 2000/01/26 12:02:30 peter + * abstractprocdef.para_size needs alignment parameter + * secondcallparan gets para_alignment size instead of dword_align + + Revision 1.50 2000/01/07 01:14:40 peter + * updated copyright to 2000 + + Revision 1.49 2000/01/03 19:26:04 peter + * fixed resolving of ttypesym which are reference from object/record + fields. + + Revision 1.48 1999/11/30 10:40:55 peter + + ttype, tsymlist + + Revision 1.47 1999/11/17 17:05:04 pierre + * Notes/hints changes + + Revision 1.46 1999/11/09 23:35:50 pierre + + better reference pos for forward defs + + Revision 1.45 1999/11/06 14:34:27 peter + * truncated log to 20 revs + + Revision 1.44 1999/10/26 12:30:45 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.43 1999/10/01 10:05:44 peter + + procedure directive support in const declarations, fixes bug 232 + + Revision 1.42 1999/10/01 08:02:48 peter + * forward type declaration rewritten + + Revision 1.41 1999/08/10 12:34:49 pierre + + procsym field in tprocdef to allow correct gdb info generation + + Revision 1.40 1999/08/09 22:19:57 peter + * classes vmt changed to only positive addresses + * sharedlib creation is working + + Revision 1.39 1999/08/07 14:21:02 florian + * some small problems fixed + + Revision 1.38 1999/08/05 16:53:15 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.37 1999/08/03 22:03:16 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.36 1999/08/02 21:29:04 florian + * the main branch psub.pas is now used for + newcg compiler + + Revision 1.35 1999/07/27 23:42:20 peter + * indirect type referencing is now allowed + + Revision 1.34 1999/07/23 16:05:30 peter + * alignment is now saved in the symtable + * C alignment added for records + * PPU version increased to solve .12 <-> .13 probs + +} \ No newline at end of file diff --git a/befpc/compiler/symppu.inc b/befpc/compiler/symppu.inc new file mode 100644 index 0000000..c2cd592 --- /dev/null +++ b/befpc/compiler/symppu.inc @@ -0,0 +1,799 @@ +{ + $Id: symppu.inc,v 1.1.1.1 2001-07-23 17:17:05 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Implementation of the reading of PPU Files for the symtable + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} + + const +{$ifdef FPC} + ppubufsize=32768; +{$ELSE} + {$IFDEF USEOVERLAY} + ppubufsize=512; + {$ELSE} + ppubufsize=4096; + {$ENDIF} +{$ENDIF} + +{$define ORDERSOURCES} + +{***************************************************************************** + PPU Writing +*****************************************************************************} + + procedure writebyte(b:byte); + begin + current_ppu^.putbyte(b); + end; + + + procedure writeword(w:word); + begin + current_ppu^.putword(w); + end; + + + procedure writelong(l:longint); + begin + current_ppu^.putlongint(l); + end; + + + procedure writereal(d:bestreal); + begin + current_ppu^.putreal(d); + end; + + + procedure writestring(const s:string); + begin + current_ppu^.putstring(s); + end; + + + procedure writenormalset(var s); {You cannot pass an array[0..31] of byte!} + begin + current_ppu^.putdata(s,sizeof(tnormalset)); + end; + + + procedure writesmallset(var s); + begin + current_ppu^.putdata(s,4); + end; + + + { posinfo is not relevant for changes in PPU } + procedure writeposinfo(const p:tfileposinfo); + var + oldcrc : boolean; + begin + oldcrc:=current_ppu^.do_crc; + current_ppu^.do_crc:=false; + current_ppu^.putword(p.fileindex); + current_ppu^.putlongint(p.line); + current_ppu^.putword(p.column); + current_ppu^.do_crc:=oldcrc; + end; + + + procedure writederef(p : psymtableentry); + begin + if p=nil then + current_ppu^.putbyte(ord(derefnil)) + else + begin + { Static symtable ? } + if p^.owner^.symtabletype=staticsymtable then + begin + current_ppu^.putbyte(ord(derefaktstaticindex)); + current_ppu^.putword(p^.indexnr); + end + { Local record/object symtable ? } + else if (p^.owner=aktrecordsymtable) then + begin + current_ppu^.putbyte(ord(derefaktrecordindex)); + current_ppu^.putword(p^.indexnr); + end + { Local local/para symtable ? } + else if (p^.owner=aktlocalsymtable) then + begin + current_ppu^.putbyte(ord(derefaktlocal)); + current_ppu^.putword(p^.indexnr); + end + else + begin + current_ppu^.putbyte(ord(derefindex)); + current_ppu^.putword(p^.indexnr); + { Current unit symtable ? } + repeat + if not assigned(p) then + internalerror(556655); + case p^.owner^.symtabletype of + { when writing the pseudo PPU file + to get CRC values the globalsymtable is not yet + a unitsymtable PM } + globalsymtable, + unitsymtable : + begin + { check if the unit is available in the uses + clause, else it's an error } + if p^.owner^.unitid=$ffff then + internalerror(55665566); + current_ppu^.putbyte(ord(derefunit)); + current_ppu^.putword(p^.owner^.unitid); + break; + end; + staticsymtable : + begin + current_ppu^.putbyte(ord(derefaktstaticindex)); + current_ppu^.putword(p^.indexnr); + break; + end; + localsymtable : + begin + p:=p^.owner^.defowner; + current_ppu^.putbyte(ord(dereflocal)); + current_ppu^.putword(p^.indexnr); + end; + parasymtable : + begin + p:=p^.owner^.defowner; + current_ppu^.putbyte(ord(derefpara)); + current_ppu^.putword(p^.indexnr); + end; + objectsymtable, + recordsymtable : + begin + p:=p^.owner^.defowner; + current_ppu^.putbyte(ord(derefrecord)); + current_ppu^.putword(p^.indexnr); + end; + else + internalerror(556656); + end; + until false; + end; + end; + end; + + procedure writedefref(p : pdef); + begin + writederef(p); + end; + + procedure writesymref(p : psym); + begin + writederef(p); + end; + + procedure writesourcefiles; + var + hp : pinputfile; +{$ifdef ORDERSOURCES} + i,j : longint; +{$endif ORDERSOURCES} + begin + { second write the used source files } + current_ppu^.do_crc:=false; + hp:=current_module^.sourcefiles^.files; +{$ifdef ORDERSOURCES} + { write source files directly in good order } + j:=0; + while assigned(hp) do + begin + inc(j); + hp:=hp^.ref_next; + end; + while j>0 do + begin + hp:=current_module^.sourcefiles^.files; + for i:=1 to j-1 do + hp:=hp^.ref_next; + current_ppu^.putstring(hp^.name^); + dec(j); + end; +{$else not ORDERSOURCES} + while assigned(hp) do + begin + { only name and extension } + current_ppu^.putstring(hp^.name^); + hp:=hp^.ref_next; + end; +{$endif ORDERSOURCES} + current_ppu^.writeentry(ibsourcefiles); + current_ppu^.do_crc:=true; + end; + + procedure writeusedmacros; + var + hp : pmacrosym; + i : longint; + begin + { second write the used source files } + current_ppu^.do_crc:=false; + for i:=1 to macros^.symindex^.count do + begin + hp:=pmacrosym(macros^.symindex^.search(i)); + { only used or init defined macros are stored } + if hp^.is_used or hp^.defined_at_startup then + begin + current_ppu^.putstring(hp^.name); + current_ppu^.putbyte(byte(hp^.defined_at_startup)); + current_ppu^.putbyte(byte(hp^.is_used)); + end; + end; + current_ppu^.writeentry(ibusedmacros); + current_ppu^.do_crc:=true; + end; + + + procedure writeusedunit; + var + hp : pused_unit; + begin + numberunits; + hp:=pused_unit(current_module^.used_units.first); + while assigned(hp) do + begin + { implementation units should not change + the CRC PM } + current_ppu^.do_crc:=hp^.in_interface; + current_ppu^.putstring(hp^.name^); + { the checksum should not affect the crc of this unit ! (PFV) } + current_ppu^.do_crc:=false; + current_ppu^.putlongint(hp^.checksum); + current_ppu^.putlongint(hp^.interface_checksum); + current_ppu^.putbyte(byte(hp^.in_interface)); + current_ppu^.do_crc:=true; + hp:=pused_unit(hp^.next); + end; + current_ppu^.do_interface_crc:=true; + current_ppu^.writeentry(ibloadunit); + end; + + + procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean); + var + hcontainer : tlinkcontainer; + s : string; + mask : longint; + begin + hcontainer.init; + while not p.empty do + begin + s:=p.get(mask); + if strippath then + current_ppu^.putstring(SplitFileName(s)) + else + current_ppu^.putstring(s); + current_ppu^.putlongint(mask); + hcontainer.insert(s,mask); + end; + current_ppu^.writeentry(id); + p:=hcontainer; + end; + + + procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean); + begin + Message1(unit_u_ppu_write,s); + + { create unit flags } + with Current_Module^ do + begin +{$ifdef GDB} + if cs_gdb_dbx in aktglobalswitches then + flags:=flags or uf_has_dbx; +{$endif GDB} + if target_os.endian=endian_big then + flags:=flags or uf_big_endian; + if cs_browser in aktmoduleswitches then + flags:=flags or uf_has_browser; + if cs_local_browser in aktmoduleswitches then + flags:=flags or uf_local_browser; + end; + +{$ifdef Test_Double_checksum_write} + If only_crc then + Assign(CRCFile,s+'.INT') + else + Assign(CRCFile,s+'.IMP'); + Rewrite(CRCFile); +{$endif def Test_Double_checksum_write} + { open ppufile } + current_ppu:=new(pppufile,init(s)); + current_ppu^.crc_only:=only_crc; + if not current_ppu^.create then + Message(unit_f_ppu_cannot_write); + +{$ifdef Test_Double_checksum} + if only_crc then + begin + new(current_ppu^.crc_test); + new(current_ppu^.crc_test2); + end + else + begin + current_ppu^.crc_test:=Current_Module^.crc_array; + current_ppu^.crc_index:=Current_Module^.crc_size; + current_ppu^.crc_test2:=Current_Module^.crc_array2; + current_ppu^.crc_index2:=Current_Module^.crc_size2; + end; +{$endif def Test_Double_checksum} + + current_ppu^.change_endian:=source_os.endian<>target_os.endian; + { write symbols and definitions } + unittable^.writeasunit; + + { flush to be sure } + current_ppu^.flush; + { create and write header } + current_ppu^.header.size:=current_ppu^.size; + current_ppu^.header.checksum:=current_ppu^.crc; + current_ppu^.header.interface_checksum:=current_ppu^.interface_crc; + current_ppu^.header.compiler:=wordversion; + current_ppu^.header.cpu:=word(target_cpu); + current_ppu^.header.target:=word(target_info.target); + current_ppu^.header.flags:=current_module^.flags; + If not only_crc then + current_ppu^.writeheader; + { save crc in current_module also } + current_module^.crc:=current_ppu^.crc; + current_module^.interface_crc:=current_ppu^.interface_crc; + if only_crc then + begin +{$ifdef Test_Double_checksum} + Current_Module^.crc_array:=current_ppu^.crc_test; + current_ppu^.crc_test:=nil; + Current_Module^.crc_size:=current_ppu^.crc_index2; + Current_Module^.crc_array2:=current_ppu^.crc_test2; + current_ppu^.crc_test2:=nil; + Current_Module^.crc_size2:=current_ppu^.crc_index2; +{$endif def Test_Double_checksum} + closecurrentppu; + end; +{$ifdef Test_Double_checksum_write} + close(CRCFile); +{$endif Test_Double_checksum_write} + end; + + + procedure closecurrentppu; + begin +{$ifdef Test_Double_checksum} + if assigned(current_ppu^.crc_test) then + dispose(current_ppu^.crc_test); + if assigned(current_ppu^.crc_test2) then + dispose(current_ppu^.crc_test2); +{$endif Test_Double_checksum} + { close } + current_ppu^.close; + dispose(current_ppu,done); + current_ppu:=nil; + end; + + +{***************************************************************************** + PPU Reading +*****************************************************************************} + + function readbyte:byte; + begin + readbyte:=current_ppu^.getbyte; + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + function readword:word; + begin + readword:=current_ppu^.getword; + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + function readlong:longint; + begin + readlong:=current_ppu^.getlongint; + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + function readreal : bestreal; + begin + readreal:=current_ppu^.getreal; + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + function readstring : string; + begin + readstring:=current_ppu^.getstring; + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + procedure readnormalset(var s); {You cannot pass an array [0..31] of byte.} + begin + current_ppu^.getdata(s,sizeof(tnormalset)); + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + procedure readsmallset(var s); + begin + current_ppu^.getdata(s,4); + if current_ppu^.error then + Message(unit_f_ppu_read_error); + end; + + + procedure readposinfo(var p:tfileposinfo); + begin + p.fileindex:=current_ppu^.getword; + p.line:=current_ppu^.getlongint; + p.column:=current_ppu^.getword; + end; + + + function readderef : pderef; + var + hp,p : pderef; + b : tdereftype; + begin + p:=nil; + repeat + hp:=p; + b:=tdereftype(current_ppu^.getbyte); + case b of + derefnil : + break; + derefunit, + derefaktrecordindex, + derefaktlocal, + derefaktstaticindex : + begin + new(p,init(b,current_ppu^.getword)); + p^.next:=hp; + break; + end; + derefindex, + dereflocal, + derefpara, + derefrecord : + begin + new(p,init(b,current_ppu^.getword)); + p^.next:=hp; + end; + end; + until false; + readderef:=p; + end; + + function readdefref : pdef; + begin + readdefref:=pdef(readderef); + end; + + function readsymref : psym; + begin + readsymref:=psym(readderef); + end; + + procedure readusedmacros; + var + hs : string; + mac : pmacrosym; + was_defined_at_startup, + was_used : boolean; + begin + while not current_ppu^.endofentry do + begin + hs:=current_ppu^.getstring; + was_defined_at_startup:=boolean(current_ppu^.getbyte); + was_used:=boolean(current_ppu^.getbyte); + mac:=pmacrosym(macros^.search(hs)); + if assigned(mac) then + begin +{$ifndef EXTDEBUG} + { if we don't have the sources why tell } + if current_module^.sources_avail then +{$endif ndef EXTDEBUG} + if not was_defined_at_startup and was_used and + mac^.defined_at_startup then + Comment(V_Hint,'Conditional '+hs+' was not set at startup '+ + 'in last compilation of '+current_module^.mainsource^); + end + else { not assigned } + if was_defined_at_startup and was_used then + Comment(V_Hint,'Conditional '+hs+' was set at startup '+ + 'in last compilation of '+current_module^.mainsource^); + end; + end; + + procedure readsourcefiles; + var + temp,hs : string; +{$ifdef ORDERSOURCES} + main_dir : string; +{$endif ORDERSOURCES} + incfile_found, + main_found, + is_main : boolean; + ppufiletime, + source_time : longint; + hp : pinputfile; + begin + ppufiletime:=getnamedfiletime(current_module^.ppufilename^); + current_module^.sources_avail:=true; +{$ifdef ORDERSOURCES} + is_main:=true; + main_dir:=''; +{$endif ORDERSOURCES} + while not current_ppu^.endofentry do + begin + hs:=current_ppu^.getstring; +{$ifndef ORDERSOURCES} + is_main:=current_ppu^.endofentry; +{$endif ORDERSOURCES} + temp:=''; + if (current_module^.flags and uf_in_library)<>0 then + begin + current_module^.sources_avail:=false; + temp:=' library'; + end + else if pos('Macro ',hs)=1 then + begin + { we don't want to find this file } + { but there is a problem with file indexing !! } + temp:=''; + end + else + begin + { check the date of the source files } + Source_Time:=GetNamedFileTime(current_module^.path^+hs); + incfile_found:=false; + if Source_Time<>-1 then + hs:=current_module^.path^+hs +{$ifdef ORDERSOURCES} + else if not(is_main) then + begin + Source_Time:=GetNamedFileTime(main_dir+hs); + if Source_Time<>-1 then + hs:=main_dir+hs; + end +{$endif def ORDERSOURCES} + ; + if (Source_Time=-1) then + begin + if is_main then + temp:=unitsearchpath.FindFile(hs,main_found) + else + temp:=includesearchpath.FindFile(hs,incfile_found); + if incfile_found or main_found then + begin + hs:=temp+hs; + Source_Time:=GetNamedFileTime(hs); + end + end; + if Source_Time=-1 then + begin + current_module^.sources_avail:=false; + temp:=' not found'; + end + else + begin + { time newer? But only allow if the file is not searched + in the include path (PFV), else you've problems with + units which use the same includefile names } + if incfile_found then + temp:=' found' + else + begin + temp:=' time '+filetimestring(source_time); + if (source_time>ppufiletime) then + begin + current_module^.do_compile:=true; + current_module^.recompile_reason:=rr_sourcenewer; + temp:=temp+' *' + end; + end; + end; + new(hp,init(hs)); + { the indexing is wrong here PM } + current_module^.sourcefiles^.register_file(hp); + end; +{$ifdef ORDERSOURCES} + if is_main then + begin + stringdispose(current_module^.mainsource); + current_module^.mainsource:=stringdup(hs); + if main_found then + main_dir:=temp; + end; +{$endif ORDERSOURCES} + Message1(unit_u_ppu_source,hs+temp); +{$ifdef ORDERSOURCES} + is_main:=false; +{$endif ORDERSOURCES} + end; +{$ifndef ORDERSOURCES} + { main source is always the last } + stringdispose(current_module^.mainsource); + current_module^.mainsource:=stringdup(hs); + + { the indexing is corrected here PM } + current_module^.sourcefiles^.inverse_register_indexes; +{$endif ORDERSOURCES} + { check if we want to rebuild every unit, only if the sources are + available } + if do_build and current_module^.sources_avail then + begin + current_module^.do_compile:=true; + current_module^.recompile_reason:=rr_build; + end; + end; + + + procedure readloadunit; + var + hs : string; + intfchecksum, + checksum : longint; + in_interface : boolean; + begin + while not current_ppu^.endofentry do + begin + hs:=current_ppu^.getstring; + checksum:=current_ppu^.getlongint; + intfchecksum:=current_ppu^.getlongint; + in_interface:=(current_ppu^.getbyte<>0); + current_module^.used_units.concat(new(pused_unit,init_to_load(hs,checksum,intfchecksum,in_interface))); + end; + end; + + + procedure readlinkcontainer(var p:tlinkcontainer); + var + s : string; + m : longint; + begin + while not current_ppu^.endofentry do + begin + s:=current_ppu^.getstring; + m:=current_ppu^.getlongint; + p.insert(s,m); + end; + end; + + + procedure load_interface; + var + b : byte; + newmodulename : pstring; + begin + { read interface part } + repeat + b:=current_ppu^.readentry; + case b of + ibmodulename : + begin + newmodulename:=stringdup(current_ppu^.getstring); + if newmodulename^<>current_module^.modulename^ then + Message2(unit_f_unit_name_error,current_module^.modulename^,newmodulename^); + stringdispose(current_module^.modulename); + current_module^.modulename:=newmodulename; + end; + ibsourcefiles : + readsourcefiles; + ibusedmacros : + readusedmacros; + ibloadunit : + readloadunit; + iblinkunitofiles : + readlinkcontainer(current_module^.LinkUnitOFiles); + iblinkunitstaticlibs : + readlinkcontainer(current_module^.LinkUnitStaticLibs); + iblinkunitsharedlibs : + readlinkcontainer(current_module^.LinkUnitSharedLibs); + iblinkotherofiles : + readlinkcontainer(current_module^.LinkotherOFiles); + iblinkotherstaticlibs : + readlinkcontainer(current_module^.LinkotherStaticLibs); + iblinkothersharedlibs : + readlinkcontainer(current_module^.LinkotherSharedLibs); + ibendinterface : + break; + else + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + until false; + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.61 2000/02/29 22:32:13 pierre + * first bug with ORDERSOURCES corrected :( + + Revision 1.60 2000/02/29 21:58:31 pierre + * ORDERSOURCES released + + Revision 1.59 2000/02/09 13:23:05 peter + * log truncated + + Revision 1.58 2000/01/07 01:14:40 peter + * updated copyright to 2000 + + Revision 1.57 1999/11/30 10:40:55 peter + + ttype, tsymlist + + Revision 1.56 1999/11/21 01:42:37 pierre + * Nextoverloading ordering fix + + Revision 1.55 1999/11/17 17:05:04 pierre + * Notes/hints changes + + Revision 1.54 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.53 1999/11/06 14:34:27 peter + * truncated log to 20 revs + + Revision 1.52 1999/11/05 17:18:03 pierre + * local browsing works at first level + ie for function defined in interface or implementation + not yet for functions inside other functions + + Revision 1.51 1999/09/16 13:27:08 pierre + + error if PPU modulename is different from what is searched + (8+3 limitations!) + + cond ORDERSOURCES to allow recompilation of FP + if symppu.inc is changed (need PPUversion change!) + + Revision 1.50 1999/09/12 15:45:11 florian + * tnamedindexobject._name should be never accessed direct! Use the + function name instead + + Revision 1.49 1999/09/03 10:54:22 pierre + * message about conditionals changed to Hint + + Revision 1.48 1999/08/31 15:47:56 pierre + + startup conditionals stored in PPU file for debug info + + Revision 1.47 1999/08/27 10:54:45 pierre + * some code adapted to CRC_only computation + + main file is search in unitspathlist + and triggers do_compile flag + * some changes to get identical CRC vaules after + interface and after implementation + + Revision 1.46 1999/08/13 21:33:12 peter + * support for array constructors extended and more error checking + + Revision 1.45 1999/08/03 22:03:17 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/symsym.inc b/befpc/compiler/symsym.inc new file mode 100644 index 0000000..05fd0ef --- /dev/null +++ b/befpc/compiler/symsym.inc @@ -0,0 +1,2314 @@ +{ + $Id: symsym.inc,v 1.1.1.1 2001-07-23 17:17:06 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Implementation for the symbols types of the symtable + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} + +{**************************************************************************** + TSYM (base for all symtypes) +****************************************************************************} + + constructor tsym.init(const n : string); + begin + inherited initname(n); + typ:=abstractsym; + symoptions:=current_object_option; +{$ifdef GDB} + isstabwritten := false; +{$endif GDB} + fileinfo:=tokenpos; + defref:=nil; + refs:=0; + lastwritten:=nil; + refcount:=0; + if (cs_browser in aktmoduleswitches) and make_ref then + begin + defref:=new(pref,init(defref,@tokenpos)); + inc(refcount); + end; + lastref:=defref; + end; + + + constructor tsym.load; + begin + inherited init; + indexnr:=readword; + setname(readstring); + typ:=abstractsym; + readsmallset(symoptions); + readposinfo(fileinfo); + lastref:=nil; + defref:=nil; + refs:=0; + lastwritten:=nil; + refcount:=0; +{$ifdef GDB} + isstabwritten := false; +{$endif GDB} + end; + + + procedure tsym.load_references; + var + pos : tfileposinfo; + move_last : boolean; + begin + move_last:=lastwritten=lastref; + while (not current_ppu^.endofentry) do + begin + readposinfo(pos); + inc(refcount); + lastref:=new(pref,init(lastref,@pos)); + lastref^.is_written:=true; + if refcount=1 then + defref:=lastref; + end; + if move_last then + lastwritten:=lastref; + end; + + { big problem here : + wrong refs were written because of + interface parsing of other units PM + moduleindex must be checked !! } + + function tsym.write_references : boolean; + var + ref : pref; + symref_written,move_last : boolean; + begin + write_references:=false; + if lastwritten=lastref then + exit; + { should we update lastref } + move_last:=true; + symref_written:=false; + { write symbol refs } + if assigned(lastwritten) then + ref:=lastwritten + else + ref:=defref; + while assigned(ref) do + begin + if ref^.moduleindex=current_module^.unit_index then + begin + { write address to this symbol } + if not symref_written then + begin + writesymref(@self); + symref_written:=true; + end; + writeposinfo(ref^.posinfo); + ref^.is_written:=true; + if move_last then + lastwritten:=ref; + end + else if not ref^.is_written then + move_last:=false + else if move_last then + lastwritten:=ref; + ref:=ref^.nextref; + end; + if symref_written then + current_ppu^.writeentry(ibsymref); + write_references:=symref_written; + end; + + +{$ifdef BrowserLog} + procedure tsym.add_to_browserlog; + begin + if assigned(defref) then + begin + browserlog.AddLog('***'+name+'***'); + browserlog.AddLogRefs(defref); + end; + end; +{$endif BrowserLog} + + + destructor tsym.done; + begin + if assigned(defref) then + begin + defref^.freechain; + dispose(defref,done); + end; + inherited done; + end; + + + procedure tsym.write; + begin + writeword(indexnr); + writestring(name); + writesmallset(symoptions); + writeposinfo(fileinfo); + end; + + + procedure tsym.prederef; + begin + end; + + + procedure tsym.deref; + begin + end; + + + function tsym.mangledname : string; + begin + mangledname:=name; + end; + + + { for most symbol types there is nothing to do at all } + procedure tsym.insert_in_data; + begin + end; + + +{$ifdef GDB} + function tsym.stabstring : pchar; + + begin + stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+ + tostr(fileinfo.line)+',0'); + end; + + procedure tsym.concatstabto(asmlist : paasmoutput); + + var stab_str : pchar; + begin + if not isstabwritten then + begin + stab_str := stabstring; + { count_dbx(stab_str); moved to GDB.PAS } + asmlist^.concat(new(pai_stabs,init(stab_str))); + isstabwritten:=true; + end; + end; +{$endif GDB} + + +{**************************************************************************** + TLABELSYM +****************************************************************************} + + constructor tlabelsym.init(const n : string; l : pasmlabel); + + begin + inherited init(n); + typ:=labelsym; + lab:=l; + used:=false; + defined:=false; + code:=nil; + end; + + constructor tlabelsym.load; + + begin + tsym.load; + typ:=labelsym; + { this is all dummy + it is only used for local browsing } + lab:=nil; + code:=nil; + used:=false; + defined:=true; + end; + + destructor tlabelsym.done; + + begin + inherited done; + end; + + + function tlabelsym.mangledname : string; + begin + mangledname:=lab^.name; + end; + + + procedure tlabelsym.write; + begin + if owner^.symtabletype in [unitsymtable,globalsymtable] then + Message(sym_e_ill_label_decl) + else + begin + tsym.write; + current_ppu^.writeentry(iblabelsym); + end; + end; + + +{**************************************************************************** + TUNITSYM +****************************************************************************} + + constructor tunitsym.init(const n : string;ref : punitsymtable); + var + old_make_ref : boolean; + begin + old_make_ref:=make_ref; + make_ref:=false; + inherited init(n); + make_ref:=old_make_ref; + typ:=unitsym; + unitsymtable:=ref; + prevsym:=ref^.unitsym; + ref^.unitsym:=@self; + refs:=0; + end; + + constructor tunitsym.load; + + begin + tsym.load; + typ:=unitsym; + unitsymtable:=punitsymtable(current_module^.globalsymtable); + prevsym:=nil; + end; + + { we need to remove it from the prevsym chain ! } + + procedure tunitsym.restoreunitsym; + var pus,ppus : punitsym; + begin + if assigned(unitsymtable) then + begin + ppus:=nil; + pus:=unitsymtable^.unitsym; + if pus=@self then + unitsymtable^.unitsym:=prevsym + else while assigned(pus) do + begin + if pus=@self then + begin + ppus^.prevsym:=prevsym; + break; + end + else + begin + ppus:=pus; + pus:=ppus^.prevsym; + end; + end; + end; + prevsym:=nil; + end; + + destructor tunitsym.done; + begin + restoreunitsym; + inherited done; + end; + + procedure tunitsym.write; + begin + tsym.write; + current_ppu^.writeentry(ibunitsym); + end; + +{$ifdef GDB} + procedure tunitsym.concatstabto(asmlist : paasmoutput); + begin + {Nothing to write to stabs !} + end; +{$endif GDB} + +{**************************************************************************** + TPROCSYM +****************************************************************************} + + constructor tprocsym.init(const n : string); + + begin + tsym.init(n); + typ:=procsym; + definition:=nil; + owner:=nil; + is_global := false; + end; + + constructor tprocsym.load; + + begin + tsym.load; + typ:=procsym; + definition:=pprocdef(readdefref); + is_global := false; + end; + + destructor tprocsym.done; + + begin + { don't check if errors !! } + if Errorcount=0 then + check_forward; + tsym.done; + end; + + function tprocsym.mangledname : string; + + begin + mangledname:=definition^.mangledname; + end; + + + function tprocsym.demangledname:string; + begin + demangledname:=name+definition^.demangled_paras; + end; + + procedure tprocsym.write_parameter_lists; + + var + p : pprocdef; + + begin + p:=definition; + while assigned(p) do + begin + { force the error to be printed } + Verbose.Message1(sym_b_param_list,name+p^.demangled_paras); + p:=p^.nextoverloaded; + end; + end; + + procedure tprocsym.check_forward; + var + pd : pprocdef; + begin + pd:=definition; + while assigned(pd) do + begin + if pd^.forwarddef then + begin + if assigned(pd^._class) then + MessagePos1(fileinfo,sym_e_forward_not_resolved,pd^._class^.objname^+'.'+demangledname) + else + MessagePos1(fileinfo,sym_e_forward_not_resolved,demangledname); + { Turn futher error messages off } + pd^.forwarddef:=false; + end; + pd:=pd^.nextoverloaded; + { do not check defs of operators in other units } + if assigned(pd) and (pd^.procsym<>@self) then + pd:=nil; + end; + end; + + + procedure tprocsym.deref; +{$ifdef DONOTCHAINOPERATORS} + var + t : ttoken; + last,pd : pprocdef; +{$endif DONOTCHAINOPERATORS} + begin + resolvedef(pdef(definition)); +{$ifdef DONOTCHAINOPERATORS} + if (definition^.proctypeoption=potype_operator) then + begin + last:=definition; + while assigned(last^.nextoverloaded) do + last:=last^.nextoverloaded; + for t:=first_overloaded to last_overloaded do + if (name=overloaded_names[t]) then + begin + if assigned(overloaded_operators[t]) then + begin + pd:=overloaded_operators[t]^.definition; + { test if not already in list, bug report by KC Wong PM } + while assigned(pd) do + if pd=last then + break + else + pd:=pd^.nextoverloaded; + if pd=last then + break; + last^.nextoverloaded:=overloaded_operators[t]^.definition; + end; + overloaded_operators[t]:=@self; + break; + end; + end; +{$endif DONOTCHAINOPERATORS} + end; + + procedure tprocsym.order_overloaded; + var firstdef,currdef,lastdef,nextopdef : pprocdef; + begin + if not assigned(definition) then + exit; + firstdef:=definition; + currdef:=definition; + while assigned(currdef) and (currdef^.owner=firstdef^.owner) do + begin + currdef^.count:=false; + currdef:=currdef^.nextoverloaded; + end; + nextopdef:=currdef; + definition:=definition^.nextoverloaded; + firstdef^.nextoverloaded:=nil; + while (definition<>nextopdef) do + begin + currdef:=firstdef; + lastdef:=definition; + definition:=definition^.nextoverloaded; + if lastdef^.manglednamecurrdef^.nextoverloaded^.mangledname) do + currdef:=currdef^.nextoverloaded; + lastdef^.nextoverloaded:=currdef^.nextoverloaded; + currdef^.nextoverloaded:=lastdef; + end; + end; + definition:=firstdef; + currdef:=definition; + while assigned(currdef) do + begin + currdef^.count:=true; + lastdef:=currdef; + currdef:=currdef^.nextoverloaded; + end; + lastdef^.nextoverloaded:=nextopdef; + end; + + procedure tprocsym.write; + begin + tsym.write; + writedefref(pdef(definition)); + current_ppu^.writeentry(ibprocsym); + end; + + + procedure tprocsym.load_references; + (*var + prdef,prdef2 : pprocdef; + b : byte; *) + begin + inherited load_references; + (*prdef:=definition; + done in tsymtable.load_browser (PM) + { take care about operators !! } + if (current_module^.flags and uf_has_browser) <>0 then + while assigned(prdef) and (prdef^.owner=definition^.owner) do + begin + b:=current_ppu^.readentry; + if b<>ibdefref then + Message(unit_f_ppu_read_error); + prdef2:=pprocdef(readdefref); + resolvedef(prdef2); + if prdef<>prdef2 then + Message(unit_f_ppu_read_error); + prdef^.load_references; + prdef:=prdef^.nextoverloaded; + end; *) + end; + + function tprocsym.write_references : boolean; + var + prdef : pprocdef; + begin + write_references:=false; + if not inherited write_references then + exit; + write_references:=true; + prdef:=definition; + while assigned(prdef) and (prdef^.owner=definition^.owner) do + begin + prdef^.write_references; + prdef:=prdef^.nextoverloaded; + end; + end; + + +{$ifdef BrowserLog} + procedure tprocsym.add_to_browserlog; + var + prdef : pprocdef; + begin + inherited add_to_browserlog; + prdef:=definition; + while assigned(prdef) do + begin + pprocdef(prdef)^.add_to_browserlog; + prdef:=pprocdef(prdef)^.nextoverloaded; + end; + end; +{$endif BrowserLog} + + +{$ifdef GDB} + function tprocsym.stabstring : pchar; + Var RetType : Char; + Obj,Info : String; + stabsstr : string; + p : pchar; + begin + obj := name; + info := ''; + if is_global then + RetType := 'F' + else + RetType := 'f'; + if assigned(owner) then + begin + if (owner^.symtabletype = objectsymtable) then + obj := owner^.name^+'__'+name; + { this code was correct only as long as the local symboltable + of the parent had the same name as the function + but this is no true anymore !! PM + if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then + info := ','+name+','+owner^.name^; } + if (owner^.symtabletype=localsymtable) and assigned(owner^.defowner) and + assigned(pprocdef(owner^.defowner)^.procsym) then + info := ','+name+','+pprocdef(owner^.defowner)^.procsym^.name; + end; + stabsstr:=definition^.mangledname; + getmem(p,length(stabsstr)+255); + strpcopy(p,'"'+obj+':'+RetType + +definition^.rettype.def^.numberstring+info+'",'+tostr(n_function) + +',0,'+ + tostr(aktfilepos.line) + +','); + strpcopy(strend(p),stabsstr); + stabstring:=strnew(p); + freemem(p,length(stabsstr)+255); + end; + + procedure tprocsym.concatstabto(asmlist : paasmoutput); + begin + if (pocall_internproc in definition^.proccalloptions) then exit; + if not isstabwritten then + asmlist^.concat(new(pai_stabs,init(stabstring))); + isstabwritten := true; + if assigned(definition^.parast) then + definition^.parast^.concatstabto(asmlist); + if assigned(definition^.localst) then + definition^.localst^.concatstabto(asmlist); + definition^.is_def_stab_written := true; + end; +{$endif GDB} + + +{**************************************************************************** + TPROGRAMSYM +****************************************************************************} + + constructor tprogramsym.init(const n : string); + begin + inherited init(n); + typ:=programsym; + end; + +{**************************************************************************** + TERRORSYM +****************************************************************************} + + constructor terrorsym.init; + begin + inherited init(''); + typ:=errorsym; + end; + +{**************************************************************************** + TPROPERTYSYM +****************************************************************************} + + constructor tpropertysym.init(const n : string); + begin + inherited init(n); + typ:=propertysym; + propoptions:=[]; + index:=0; + default:=0; + proptype.reset; + indextype.reset; + new(readaccess,init); + new(writeaccess,init); + new(storedaccess,init); + end; + + + constructor tpropertysym.load; + begin + inherited load; + typ:=propertysym; + readsmallset(propoptions); + if (ppo_is_override in propoptions) then + begin + propoverriden:=ppropertysym(readsymref); + { we need to have these objects initialized } + new(readaccess,init); + new(writeaccess,init); + new(storedaccess,init); + end + else + begin + proptype.load; + index:=readlong; + default:=readlong; + indextype.load; + new(readaccess,load); + new(writeaccess,load); + new(storedaccess,load); + end; + end; + + + destructor tpropertysym.done; + begin + dispose(readaccess,done); + dispose(writeaccess,done); + dispose(storedaccess,done); + inherited done; + end; + + + procedure tpropertysym.deref; + begin + if (ppo_is_override in propoptions) then + begin + resolvesym(psym(propoverriden)); + dooverride(propoverriden); + end + else + begin + proptype.resolve; + indextype.resolve; + readaccess^.resolve; + writeaccess^.resolve; + storedaccess^.resolve; + end; + end; + + + function tpropertysym.getsize : longint; + begin + getsize:=0; + end; + + + procedure tpropertysym.write; + begin + tsym.write; + writesmallset(propoptions); + if (ppo_is_override in propoptions) then + writesymref(propoverriden) + else + begin + proptype.write; + writelong(index); + writelong(default); + indextype.write; + readaccess^.write; + writeaccess^.write; + storedaccess^.write; + end; + current_ppu^.writeentry(ibpropertysym); + end; + + + procedure tpropertysym.dooverride(overriden:ppropertysym); + begin + propoverriden:=overriden; + proptype:=overriden^.proptype; + propoptions:=overriden^.propoptions+[ppo_is_override]; + index:=overriden^.index; + default:=overriden^.default; + indextype:=overriden^.indextype; + readaccess^.clear; + readaccess:=overriden^.readaccess^.getcopy; + writeaccess^.clear; + writeaccess:=overriden^.writeaccess^.getcopy; + storedaccess^.clear; + storedaccess:=overriden^.storedaccess^.getcopy; + end; + + +{$ifdef GDB} + function tpropertysym.stabstring : pchar; + begin + { !!!! don't know how to handle } + stabstring:=strpnew(''); + end; + + procedure tpropertysym.concatstabto(asmlist : paasmoutput); + begin + { !!!! don't know how to handle } + end; +{$endif GDB} + +{**************************************************************************** + TFUNCRETSYM +****************************************************************************} + + constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo}); + + begin + tsym.init(n); + typ:=funcretsym; + funcretprocinfo:=approcinfo; + rettype:=pprocinfo(approcinfo)^.returntype; + { address valid for ret in param only } + { otherwise set by insert } + address:=pprocinfo(approcinfo)^.return_offset; + end; + + constructor tfuncretsym.load; + begin + tsym.load; + rettype.load; + address:=readlong; + funcretprocinfo:=nil; + typ:=funcretsym; + end; + + destructor tfuncretsym.done; + begin + inherited done; + end; + + procedure tfuncretsym.write; + begin + tsym.write; + rettype.write; + writelong(address); + current_ppu^.writeentry(ibfuncretsym); + end; + + procedure tfuncretsym.deref; + begin + rettype.resolve; + end; + +{$ifdef GDB} + procedure tfuncretsym.concatstabto(asmlist : paasmoutput); + begin + { Nothing to do here, it is done in genexitcode } + end; +{$endif GDB} + + procedure tfuncretsym.insert_in_data; + var + l : longint; + begin + { if retoffset is already set then reuse it, this is needed + when inserting the result variable } + if procinfo^.return_offset<>0 then + address:=procinfo^.return_offset + else + begin + { allocate space in local if ret in acc or in fpu } + if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then + begin + l:=rettype.def^.size; + inc(owner^.datasize,l); +{$ifdef m68k} + { word alignment required for motorola } + if (l=1) then + inc(owner^.datasize,1) + else +{$endif} + if (l>=4) and ((owner^.datasize and 3)<>0) then + inc(owner^.datasize,4-(owner^.datasize and 3)) + else if (l>=2) and ((owner^.datasize and 1)<>0) then + inc(owner^.datasize,2-(owner^.datasize and 1)); + address:=owner^.datasize; + procinfo^.return_offset:=-owner^.datasize; + end; + end; + end; + + +{**************************************************************************** + TABSOLUTESYM +****************************************************************************} + + constructor tabsolutesym.init(const n : string;const tt : ttype); + begin + inherited init(n,tt); + typ:=absolutesym; + end; + + + constructor tabsolutesym.initdef(const n : string;p : pdef); + var + t : ttype; + begin + t.setdef(p); + tabsolutesym.init(n,t); + end; + + + constructor tabsolutesym.load; + begin + tvarsym.load; + typ:=absolutesym; + ref:=nil; + address:=0; + asmname:=nil; + abstyp:=absolutetyp(readbyte); + absseg:=false; + case abstyp of + tovar : + begin + asmname:=stringdup(readstring); + ref:=srsym; + end; + toasm : + asmname:=stringdup(readstring); + toaddr : + begin + address:=readlong; + absseg:=boolean(readbyte); + end; + end; + end; + + + procedure tabsolutesym.write; + var + hvo : tvaroptions; + begin + { Note: This needs to write everything of tvarsym.write } + tsym.write; + writebyte(byte(varspez)); + if read_member then + writelong(address); + { write only definition or definitionsym } + vartype.write; + hvo:=varoptions-[vo_regable]; + writesmallset(hvo); + writebyte(byte(abstyp)); + case abstyp of + tovar : + writestring(ref^.name); + toasm : + writestring(asmname^); + toaddr : + begin + writelong(address); + writebyte(byte(absseg)); + end; + end; + current_ppu^.writeentry(ibabsolutesym); + end; + + + procedure tabsolutesym.deref; + begin + tvarsym.deref; + if (abstyp=tovar) and (asmname<>nil) then + begin + { search previous loaded symtables } + getsym(asmname^,false); + if not(assigned(srsym)) then + getsymonlyin(owner,asmname^); + if not(assigned(srsym)) then + srsym:=generrorsym; + ref:=srsym; + stringdispose(asmname); + end; + end; + + + function tabsolutesym.mangledname : string; + begin + case abstyp of + tovar : + mangledname:=ref^.mangledname; + toasm : + mangledname:=asmname^; + toaddr : + mangledname:='$'+tostr(address); + else + internalerror(10002); + end; + end; + + + procedure tabsolutesym.insert_in_data; + begin + end; + + +{$ifdef GDB} + procedure tabsolutesym.concatstabto(asmlist : paasmoutput); + begin + { I don't know how to handle this !! } + end; +{$endif GDB} + + +{**************************************************************************** + TVARSYM +****************************************************************************} + + constructor tvarsym.init(const n : string;const tt : ttype); + begin + tsym.init(n); + typ:=varsym; + vartype:=tt; + _mangledname:=nil; + varspez:=vs_value; + address:=0; + localvarsym:=nil; + refs:=0; + varstate:=vs_used; + varoptions:=[]; + { can we load the value into a register ? } + if tt.def^.is_intregable then + include(varoptions,vo_regable) + else + exclude(varoptions,vo_regable); + + if tt.def^.is_fpuregable then + include(varoptions,vo_fpuregable) + else + exclude(varoptions,vo_fpuregable); + reg:=R_NO; + end; + + + constructor tvarsym.init_dll(const n : string;const tt : ttype); + begin + tvarsym.init(n,tt); +{$ifdef INCLUDEOK} + include(varoptions,vo_is_dll_var); +{$else} + varoptions:=varoptions+[vo_is_dll_var]; +{$endif} + end; + + + constructor tvarsym.init_C(const n,mangled : string;const tt : ttype); + begin + tvarsym.init(n,tt); +{$ifdef INCLUDEOK} + include(varoptions,vo_is_C_var); +{$else} + varoptions:=varoptions+[vo_is_C_var]; +{$endif} + setmangledname(mangled); + end; + + + constructor tvarsym.initdef(const n : string;p : pdef); + var + t : ttype; + begin + t.setdef(p); + tvarsym.init(n,t); + end; + + + constructor tvarsym.load; + begin + tsym.load; + typ:=varsym; + _mangledname:=nil; + reg:=R_NO; + refs := 0; + varstate:=vs_used; + varspez:=tvarspez(readbyte); + if read_member then + address:=readlong + else + address:=0; + localvarsym:=nil; + vartype.load; + readsmallset(varoptions); + if (vo_is_C_var in varoptions) then + setmangledname(readstring); + end; + + + destructor tvarsym.done; + begin + strdispose(_mangledname); + inherited done; + end; + + + procedure tvarsym.deref; + begin + vartype.resolve; + end; + + + procedure tvarsym.write; + var + hvo : tvaroptions; + begin + tsym.write; + writebyte(byte(varspez)); + if read_member then + writelong(address); + vartype.write; + { symbols which are load are never candidates for a register, + turn off the regable } + hvo:=varoptions-[vo_regable]; + writesmallset(hvo); + if (vo_is_C_var in varoptions) then + writestring(mangledname); + current_ppu^.writeentry(ibvarsym); + end; + + + procedure tvarsym.setmangledname(const s : string); + begin + _mangledname:=strpnew(s); + end; + + + function tvarsym.mangledname : string; + var + prefix : string; + begin + if assigned(_mangledname) then + begin + mangledname:=strpas(_mangledname); + exit; + end; + case owner^.symtabletype of + staticsymtable : + if (cs_create_smart in aktmoduleswitches) then + prefix:='_'+owner^.name^+'$$$_' + else + prefix:='_'; + unitsymtable, + globalsymtable : + prefix:= + 'U_'+owner^.name^+'_'; + else + Message(sym_e_invalid_call_tvarsymmangledname); + end; + mangledname:=prefix+name; + end; + + + function tvarsym.getsize : longint; + begin + if assigned(vartype.def) then + getsize:=vartype.def^.size + else + getsize:=0; + end; + + + function tvarsym.getvaluesize : longint; + begin + if assigned(vartype.def) and + (varspez=vs_value) and + ((vartype.def^.deftype<>arraydef) or + (Parraydef(vartype.def)^.highrange>=Parraydef(vartype.def)^.lowrange)) then + getvaluesize:=vartype.def^.size + else + getvaluesize:=0; + end; + + + function tvarsym.getpushsize : longint; + begin + if assigned(vartype.def) then + begin + case varspez of + vs_var : + getpushsize:=target_os.size_of_pointer; + vs_value, + vs_const : + begin + if push_addr_param(vartype.def) then + getpushsize:=target_os.size_of_pointer + else + getpushsize:=vartype.def^.size; + end; + end; + end + else + getpushsize:=0; + end; + + + function data_align(length : longint) : longint; + begin + (* this is useless under go32v2 at least + because the section are only align to dword + if length>8 then + data_align:=16 + else if length>4 then + data_align:=8 + else *) + if length>2 then + data_align:=4 + else + if length>1 then + data_align:=2 + else + data_align:=1; + end; + + + procedure tvarsym.insert_in_data; + var + varalign, + l,ali,modulo : longint; + storefilepos : tfileposinfo; + begin + if (vo_is_external in varoptions) then + exit; + { handle static variables of objects especially } + if read_member and (owner^.symtabletype=objectsymtable) and + (sp_static in symoptions) then + begin + { the data filed is generated in parser.pas + with a tobject_FIELDNAME variable } + { this symbol can't be loaded to a register } +{$ifdef INCLUDEOK} + exclude(varoptions,vo_regable); + exclude(varoptions,vo_fpuregable); +{$else} + varoptions:=varoptions-[vo_regable,vo_fpuregable]; +{$endif} + end + else + if not(read_member) then + begin + { made problems with parameters etc. ! (FK) } + { check for instance of an abstract object or class } + { + if (pvarsym(sym)^.definition^.deftype=objectdef) and + ((pobjectdef(pvarsym(sym)^.definition)^.options and oo_is_abstract)<>0) then + Message(sym_e_no_instance_of_abstract_object); + } + storefilepos:=aktfilepos; + aktfilepos:=tokenpos; + if (vo_is_thread_var in varoptions) then + l:=4 + else + l:=getvaluesize; + case owner^.symtabletype of + stt_exceptsymtable: + { can contain only one symbol, address calculated later } + ; + localsymtable : + begin + varstate:=vs_declared; + modulo:=owner^.datasize and 3; +{$ifdef m68k} + { word alignment required for motorola } + if (l=1) then + l:=2 + else +{$endif} +{ + if (cs_optimize in aktglobalswitches) and + (aktoptprocessor in [classp5,classp6]) and + (l>=8) and ((owner^.datasize and 7)<>0) then + inc(owner^.datasize,8-(owner^.datasize and 7)) + else +} + begin + if (l>=4) and (modulo<>0) then + inc(l,4-modulo) + else + if (l>=2) and ((modulo and 1)<>0) then + inc(l,2-(modulo and 1)); + end; + inc(owner^.datasize,l); + address:=owner^.datasize; + end; + staticsymtable : + begin + { enable unitialized warning for local symbols } + varstate:=vs_declared; + if (cs_create_smart in aktmoduleswitches) then + bsssegment^.concat(new(pai_cut,init)); + ali:=data_align(l); + if ali>1 then + begin + modulo:=owner^.datasize mod ali; + if modulo>0 then + inc(owner^.datasize,ali-modulo); + end; +{$ifdef GDB} + if cs_debuginfo in aktmoduleswitches then + concatstabto(bsssegment); +{$endif GDB} + + if (cs_create_smart in aktmoduleswitches) or + DLLSource or + (vo_is_exported in varoptions) or + (vo_is_C_var in varoptions) then + bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))) + else + bsssegment^.concat(new(pai_datablock,init(mangledname,l))); + { increase datasize } + inc(owner^.datasize,l); + { this symbol can't be loaded to a register } +{$ifdef INCLUDEOK} + exclude(varoptions,vo_regable); + exclude(varoptions,vo_fpuregable); +{$else} + varoptions:=varoptions-[vo_regable,vo_fpuregable]; +{$endif} + end; + globalsymtable : + begin + if (cs_create_smart in aktmoduleswitches) then + bsssegment^.concat(new(pai_cut,init)); + ali:=data_align(l); + if ali>1 then + begin + modulo:=owner^.datasize mod ali; + if modulo>0 then + inc(owner^.datasize,ali-modulo); + end; +{$ifdef GDB} + if cs_debuginfo in aktmoduleswitches then + concatstabto(bsssegment); +{$endif GDB} + bsssegment^.concat(new(pai_datablock,init_global(mangledname,l))); + inc(owner^.datasize,l); + { this symbol can't be loaded to a register } +{$ifdef INCLUDEOK} + exclude(varoptions,vo_regable); + exclude(varoptions,vo_fpuregable); +{$else} + varoptions:=varoptions-[vo_regable,vo_fpuregable]; +{$endif} + end; + recordsymtable, + objectsymtable : + begin + { this symbol can't be loaded to a register } +{$ifdef INCLUDEOK} + exclude(varoptions,vo_regable); + exclude(varoptions,vo_fpuregable); +{$else} + varoptions:=varoptions-[vo_regable,vo_fpuregable]; +{$endif} + { get the alignment size } + if (aktpackrecords=packrecord_C) then + begin + varalign:=vartype.def^.alignment; + if (varalign>4) and ((varalign mod 4)<>0) and + (vartype.def^.deftype=arraydef) then + begin + Message1(sym_w_wrong_C_pack,vartype.def^.typename); + end; + if varalign=0 then + varalign:=l; + if (owner^.dataalignment16) and (owner^.dataalignment<32) then + owner^.dataalignment:=32 + else if (varalign>12) and (owner^.dataalignment<16) then + owner^.dataalignment:=16 + { 12 is needed for long double } + else if (varalign>8) and (owner^.dataalignment<12) then + owner^.dataalignment:=12 + else if (varalign>4) and (owner^.dataalignment<8) then + owner^.dataalignment:=8 + else if (varalign>2) and (owner^.dataalignment<4) then + owner^.dataalignment:=4 + else if (varalign>1) and (owner^.dataalignment<2) then + owner^.dataalignment:=2; + end; + if owner^.dataalignment>target_os.maxCrecordalignment then + owner^.dataalignment:=target_os.maxCrecordalignment; + end + else + varalign:=vartype.def^.alignment; + if varalign=0 then + varalign:=l; + { align record and object fields } + if (varalign=1) or (owner^.dataalignment=1) then + begin + address:=owner^.datasize; + inc(owner^.datasize,l) + end + else if (varalign=2) or (owner^.dataalignment=2) then + begin + owner^.datasize:=(owner^.datasize+1) and (not 1); + address:=owner^.datasize; + inc(owner^.datasize,l) + end + else if (varalign<=4) or (owner^.dataalignment=4) then + begin + owner^.datasize:=(owner^.datasize+3) and (not 3); + address:=owner^.datasize; + inc(owner^.datasize,l); + end + else if (varalign<=8) or (owner^.dataalignment=8) then + begin + owner^.datasize:=(owner^.datasize+7) and (not 7); + address:=owner^.datasize; + inc(owner^.datasize,l); + end + { 12 is needed for C long double support } + else if (varalign<=12) and (owner^.dataalignment=12) then + begin + owner^.datasize:=((owner^.datasize+11) div 12) * 12; + address:=owner^.datasize; + inc(owner^.datasize,l); + end + else if (varalign<=16) or (owner^.dataalignment=16) then + begin + owner^.datasize:=(owner^.datasize+15) and (not 15); + address:=owner^.datasize; + inc(owner^.datasize,l); + end + else if (varalign<=32) or (owner^.dataalignment=32) then + begin + owner^.datasize:=(owner^.datasize+31) and (not 31); + address:=owner^.datasize; + inc(owner^.datasize,l); + end + else + internalerror(1000022); + end; + parasymtable : + begin + { here we need the size of a push instead of the + size of the data } + l:=getpushsize; + varstate:=vs_assigned; + address:=owner^.datasize; + owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment); + end + else + begin + modulo:=owner^.datasize and 3; + if (l>=4) and (modulo<>0) then + inc(owner^.datasize,4-modulo) + else + if (l>=2) and ((modulo and 1)<>0) then + inc(owner^.datasize); + address:=owner^.datasize; + inc(owner^.datasize,l); + end; + end; + aktfilepos:=storefilepos; + end; + end; + +{$ifdef GDB} + function tvarsym.stabstring : pchar; + var + st : string[2]; + begin + if (vartype.def^.deftype=objectdef) and + pobjectdef(vartype.def)^.is_class then + st:='*' + else + st:=''; + if (owner^.symtabletype = objectsymtable) and + (sp_static in symoptions) then + begin + if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st; +{$ifndef Delphi} + stabstring := strpnew('"'+owner^.name^+'__'+name+':'+st+ + +vartype.def^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname); +{$endif} + end + else if (owner^.symtabletype = globalsymtable) or + (owner^.symtabletype = unitsymtable) then + begin + { Here we used S instead of + because with G GDB doesn't look at the address field + but searches the same name or with a leading underscore + but these names don't exist in pascal !} + if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st; + stabstring := strpnew('"'+name+':'+st + +vartype.def^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname); + end + else if owner^.symtabletype = staticsymtable then + begin + stabstring := strpnew('"'+name+':S'+st + +vartype.def^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname); + end + else if (owner^.symtabletype in [parasymtable,inlineparasymtable]) then + begin + case varspez of + vs_var : st := 'v'+st; + vs_value, + vs_const : if push_addr_param(vartype.def) then + st := 'v'+st { should be 'i' but 'i' doesn't work } + else + st := 'p'+st; + end; + stabstring := strpnew('"'+name+':'+st + +vartype.def^.numberstring+'",'+ + tostr(N_PSYM)+',0,'+tostr(fileinfo.line)+','+ + tostr(address+owner^.address_fixup)); + {offset to ebp => will not work if the framepointer is esp + so some optimizing will make things harder to debug } + end + else if (owner^.symtabletype in [localsymtable,inlinelocalsymtable]) then + {$ifdef i386} + if reg<>R_NO then + begin + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + stabstring:=strpnew('"'+name+':r'+st + +vartype.def^.numberstring+'",'+ + tostr(N_RSYM)+',0,'+ + tostr(fileinfo.line)+','+tostr(GDB_i386index[reg])); + end + else + {$endif i386} + { I don't know if this will work (PM) } + if (vo_is_C_var in varoptions) then + stabstring := strpnew('"'+name+':S'+st + +vartype.def^.numberstring+'",'+ + tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname) + else + stabstring := strpnew('"'+name+':'+st + +vartype.def^.numberstring+'",'+ + tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address-owner^.address_fixup)) + else + stabstring := inherited stabstring; + end; + + procedure tvarsym.concatstabto(asmlist : paasmoutput); +{$ifdef i386} + var stab_str : pchar; +{$endif i386} + begin + inherited concatstabto(asmlist); +{$ifdef i386} + if (owner^.symtabletype=parasymtable) and + (reg<>R_NO) then + begin + { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", } + { this is the register order for GDB} + stab_str:=strpnew('"'+name+':r' + +vartype.def^.numberstring+'",'+ + tostr(N_RSYM)+',0,'+ + tostr(fileinfo.line)+','+tostr(GDB_i386index[reg])); + asmlist^.concat(new(pai_stabs,init(stab_str))); + end; +{$endif i386} + end; +{$endif GDB} + + +{**************************************************************************** + TTYPEDCONSTSYM +*****************************************************************************} + + constructor ttypedconstsym.init(const n : string;p : pdef;really_const : boolean); + begin + tsym.init(n); + typ:=typedconstsym; + typedconsttype.setdef(p); + is_really_const:=really_const; + prefix:=stringdup(procprefix); + end; + + + constructor ttypedconstsym.inittype(const n : string;const tt : ttype;really_const : boolean); + begin + ttypedconstsym.init(n,nil,really_const); + typedconsttype:=tt; + end; + + + constructor ttypedconstsym.load; + begin + tsym.load; + typ:=typedconstsym; + typedconsttype.load; + prefix:=stringdup(readstring); + is_really_const:=boolean(readbyte); + end; + + + destructor ttypedconstsym.done; + begin + stringdispose(prefix); + tsym.done; + end; + + + function ttypedconstsym.mangledname : string; + begin + mangledname:='TC_'+prefix^+'_'+name; + end; + + + function ttypedconstsym.getsize : longint; + begin + if assigned(typedconsttype.def) then + getsize:=typedconsttype.def^.size + else + getsize:=0; + end; + + + procedure ttypedconstsym.deref; + begin + typedconsttype.resolve; + end; + + + procedure ttypedconstsym.write; + begin + tsym.write; + typedconsttype.write; + writestring(prefix^); + writebyte(byte(is_really_const)); + current_ppu^.writeentry(ibtypedconstsym); + end; + + + procedure ttypedconstsym.insert_in_data; + var + curconstsegment : paasmoutput; + l,ali,modulo : longint; + storefilepos : tfileposinfo; + begin + storefilepos:=aktfilepos; + aktfilepos:=tokenpos; + if is_really_const then + curconstsegment:=consts + else + curconstsegment:=datasegment; + if (cs_create_smart in aktmoduleswitches) then + curconstsegment^.concat(new(pai_cut,init)); + l:=getsize; + ali:=data_align(l); + if ali>1 then + begin + curconstsegment^.concat(new(pai_align,init(ali))); + modulo:=owner^.datasize mod ali; + if modulo>0 then + inc(owner^.datasize,ali-modulo); + end; + { Why was there no owner size update here ??? } + inc(owner^.datasize,l); +{$ifdef GDB} + if cs_debuginfo in aktmoduleswitches then + concatstabto(curconstsegment); +{$endif GDB} + if owner^.symtabletype=globalsymtable then + begin + curconstsegment^.concat(new(pai_symbol,initname_global(mangledname,getsize))); + end + else + if owner^.symtabletype<>unitsymtable then + begin + if (cs_create_smart in aktmoduleswitches) or + DLLSource then + curconstsegment^.concat(new(pai_symbol,initname_global(mangledname,getsize))) + else + curconstsegment^.concat(new(pai_symbol,initname(mangledname,getsize))); + end; + aktfilepos:=storefilepos; + end; + +{$ifdef GDB} + function ttypedconstsym.stabstring : pchar; + var + st : char; + begin + if (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then + st := 'G' + else + st := 'S'; + stabstring := strpnew('"'+name+':'+st+ + typedconsttype.def^.numberstring+'",'+tostr(n_STSYM)+',0,'+ + tostr(fileinfo.line)+','+mangledname); + end; +{$endif GDB} + + +{**************************************************************************** + TCONSTSYM +****************************************************************************} + + constructor tconstsym.init(const n : string;t : tconsttyp;v : longint); + begin + inherited init(n); + typ:=constsym; + consttyp:=t; + value:=v; + ResStrIndex:=0; + consttype.reset; + len:=0; + end; + + + constructor tconstsym.init_def(const n : string;t : tconsttyp;v : longint;def : pdef); + begin + inherited init(n); + typ:=constsym; + consttyp:=t; + value:=v; + consttype.setdef(def); + len:=0; + end; + + + constructor tconstsym.init_string(const n : string;t : tconsttyp;str:pchar;l:longint); + begin + inherited init(n); + typ:=constsym; + consttyp:=t; + value:=longint(str); + consttype.reset; + len:=l; + if t=constresourcestring then + ResStrIndex:=ResourceStrings^.Register(name,pchar(value),len); + end; + + constructor tconstsym.load; + var + pd : pbestreal; + ps : pnormalset; + begin + tsym.load; + typ:=constsym; + consttype.reset; + consttyp:=tconsttyp(readbyte); + case consttyp of + constint, + constbool, + constchar : + value:=readlong; + constpointer, + constord : + begin + consttype.load; + value:=readlong; + end; + conststring,constresourcestring : + begin + len:=readlong; + getmem(pchar(value),len+1); + current_ppu^.getdata(pchar(value)^,len); + if consttyp=constresourcestring then + ResStrIndex:=readlong; + end; + constreal : + begin + new(pd); + pd^:=readreal; + value:=longint(pd); + end; + constset : + begin + consttype.load; + new(ps); + readnormalset(ps^); + value:=longint(ps); + end; + constnil : ; + else + Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); + end; + end; + + + destructor tconstsym.done; + begin + case consttyp of + conststring,constresourcestring : + freemem(pchar(value),len+1); + constreal : + dispose(pbestreal(value)); + constset : + dispose(pnormalset(value)); + end; + inherited done; + end; + + + function tconstsym.mangledname : string; + begin + mangledname:=name; + end; + + + procedure tconstsym.deref; + begin + if consttyp in [constord,constpointer,constset] then + consttype.resolve; + end; + + + procedure tconstsym.write; + begin + tsym.write; + writebyte(byte(consttyp)); + case consttyp of + constnil : ; + constint, + constbool, + constchar : + writelong(value); + constpointer, + constord : + begin + consttype.write; + writelong(value); + end; + conststring,constresourcestring : + begin + writelong(len); + current_ppu^.putdata(pchar(value)^,len); + if consttyp=constresourcestring then + writelong(ResStrIndex); + end; + constreal : + writereal(pbestreal(value)^); + constset : + begin + consttype.write; + writenormalset(pointer(value)^); + end; + else + internalerror(13); + end; + current_ppu^.writeentry(ibconstsym); + end; + +{$ifdef GDB} + function tconstsym.stabstring : pchar; + var st : string; + begin + {even GDB v4.16 only now 'i' 'r' and 'e' !!!} + case consttyp of + conststring : begin + { I had to remove ibm2ascii !! } + st := pstring(value)^; + {st := ibm2ascii(pstring(value)^);} + st := 's'''+st+''''; + end; + constbool, + constint, + constpointer, + constord, + constchar : st := 'i'+tostr(value); + constreal : begin + system.str(pbestreal(value)^,st); + st := 'r'+st; + end; + { if we don't know just put zero !! } + else st:='i0'; + {***SETCONST} + {constset:;} {*** I don't know what to do with a set.} + { sets are not recognized by GDB} + {***} + end; + stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+ + tostr(fileinfo.line)+',0'); + end; + + procedure tconstsym.concatstabto(asmlist : paasmoutput); + begin + if consttyp <> conststring then + inherited concatstabto(asmlist); + end; +{$endif GDB} + + +{**************************************************************************** + TENUMSYM +****************************************************************************} + + constructor tenumsym.init(const n : string;def : penumdef;v : longint); + begin + tsym.init(n); + typ:=enumsym; + definition:=def; + value:=v; + if def^.min>v then + def^.setmin(v); + if def^.max@self then + synonym:=restype.def^.typesym; + restype.def^.typesym:=@self; + end + else + begin + if assigned(restype.def^.typesym) then + begin + synonym:=restype.def^.typesym^.synonym; + if restype.def^.typesym<>@self then + restype.def^.typesym^.synonym:=@self; + end + else + restype.def^.typesym:=@self; + end; + if (restype.def^.deftype=recorddef) and assigned(precorddef(restype.def)^.symtable) and + (restype.def^.typesym=@self) then + precorddef(restype.def)^.symtable^.name:=stringdup('record '+name); + end; +{$endif} + end; + + + procedure ttypesym.write; + begin + tsym.write; + restype.write; + current_ppu^.writeentry(ibtypesym); + end; + + + procedure ttypesym.load_references; + begin + inherited load_references; + if (restype.def^.deftype=recorddef) then + precorddef(restype.def)^.symtable^.load_browser; + if (restype.def^.deftype=objectdef) then + pobjectdef(restype.def)^.symtable^.load_browser; + end; + + + function ttypesym.write_references : boolean; + begin + if not inherited write_references then + { write address of this symbol if record or object + even if no real refs are there + because we need it for the symtable } + if (restype.def^.deftype=recorddef) or + (restype.def^.deftype=objectdef) then + begin + writesymref(@self); + current_ppu^.writeentry(ibsymref); + end; + write_references:=true; + if (restype.def^.deftype=recorddef) then + precorddef(restype.def)^.symtable^.write_browser; + if (restype.def^.deftype=objectdef) then + pobjectdef(restype.def)^.symtable^.write_browser; + end; + + +{$ifdef BrowserLog} + procedure ttypesym.add_to_browserlog; + begin + inherited add_to_browserlog; + if (restype.def^.deftype=recorddef) then + precorddef(restype.def)^.symtable^.writebrowserlog; + if (restype.def^.deftype=objectdef) then + pobjectdef(restype.def)^.symtable^.writebrowserlog; + end; +{$endif BrowserLog} + + +{$ifdef GDB} + function ttypesym.stabstring : pchar; + var + stabchar : string[2]; + short : string; + begin + if restype.def^.deftype in tagtypes then + stabchar := 'Tt' + else + stabchar := 't'; + short := '"'+name+':'+stabchar+restype.def^.numberstring + +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0'; + stabstring := strpnew(short); + end; + + procedure ttypesym.concatstabto(asmlist : paasmoutput); + begin + {not stabs for forward defs } + if assigned(restype.def) then + if (restype.def^.typesym = @self) then + restype.def^.concatstabto(asmlist) + else + inherited concatstabto(asmlist); + end; +{$endif GDB} + + +{**************************************************************************** + TSYSSYM +****************************************************************************} + + constructor tsyssym.init(const n : string;l : longint); + begin + inherited init(n); + typ:=syssym; + number:=l; + end; + + constructor tsyssym.load; + begin + tsym.load; + typ:=syssym; + number:=readlong; + end; + + destructor tsyssym.done; + begin + inherited done; + end; + + procedure tsyssym.write; + begin + tsym.write; + writelong(number); + current_ppu^.writeentry(ibsyssym); + end; + +{$ifdef GDB} + procedure tsyssym.concatstabto(asmlist : paasmoutput); + begin + end; +{$endif GDB} + + +{**************************************************************************** + TMACROSYM +****************************************************************************} + + constructor tmacrosym.init(const n : string); + begin + inherited init(n); + typ:=macrosym; + defined:=true; + defined_at_startup:=false; + is_used:=false; + buftext:=nil; + buflen:=0; + end; + + destructor tmacrosym.done; + begin + if assigned(buftext) then + freemem(buftext,buflen); + inherited done; + end; + + +{ + $Log: not supported by cvs2svn $ + Revision 1.150 2000/06/23 21:32:45 pierre + * alignment for record changed for C packing mostly + + Revision 1.149 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.148 2000/06/02 21:16:42 pierre + * vo_is_exported needs init_global also + + Revision 1.147 2000/06/01 19:09:56 peter + * made resourcestrings OOP so it's easier to handle it per module + + Revision 1.146 2000/05/18 17:05:17 peter + * fixed size of const parameters in asm readers + + Revision 1.145 2000/05/03 14:34:05 pierre + * fix the unitsym chain + + Revision 1.144 2000/04/27 10:06:04 pierre + * fix for snapshot failue + * order_overloaded reintrocduced and adapted to operators + + Revision 1.143 2000/04/26 08:54:19 pierre + * More changes for operator bug + Order_overloaded method removed because it conflicted with + new implementation where the defs are ordered + according to the unit loading order ! + + Revision 1.142 2000/04/19 08:24:41 pierre + * remove a memory leak with resourcestrings + + Revision 1.141 2000/04/03 14:50:05 pierre + * avoid cyclic overloaded list for operators + + Revision 1.140 2000/03/01 00:03:10 pierre + * fixes for locals in inlined procedures + fix for bug797 + + stabs generation for inlined paras and locals + + Revision 1.139 2000/02/11 13:53:49 pierre + * avoid stack overflow in tref.done (bug 846) + + Revision 1.138 2000/02/09 13:23:05 peter + * log truncated + + Revision 1.137 2000/02/04 08:47:10 florian + * better register variable allocation in -Or mode + + Revision 1.136 2000/01/07 01:14:40 peter + * updated copyright to 2000 + + Revision 1.135 2000/01/03 19:26:04 peter + * fixed resolving of ttypesym which are reference from object/record + fields. + + Revision 1.134 1999/12/20 21:42:37 pierre + + dllversion global variable + * FPC_USE_CPREFIX code removed, not necessary anymore + as we use .edata direct writing by default now. + + Revision 1.133 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.132 1999/12/01 12:42:33 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.131 1999/11/30 10:40:55 peter + + ttype, tsymlist + + Revision 1.130 1999/11/26 00:19:12 peter + * property overriding dereference fix, but it need a bigger redesign + which i'll do tomorrow. This quick hack is for the lazarus ppl so + they can hack on mwcustomedit. + + Revision 1.129 1999/11/21 01:42:37 pierre + * Nextoverloading ordering fix + + Revision 1.128 1999/11/20 01:22:20 pierre + + cond FPC_USE_CPREFIX (needs also some RTL changes) + this allows to use unit global vars as DLL exports + (the underline prefix seems needed by dlltool) + + Revision 1.127 1999/11/17 17:05:04 pierre + * Notes/hints changes + + Revision 1.126 1999/11/15 22:00:48 peter + * labels used but not defined give error instead of warning, the warning + is now only with declared but not defined and not used. + + Revision 1.125 1999/11/08 14:02:17 florian + * problem with "index X"-properties solved + * typed constants of class references are now allowed + + Revision 1.124 1999/11/06 14:34:27 peter + * truncated log to 20 revs + + Revision 1.123 1999/11/05 17:18:03 pierre + * local browsing works at first level + ie for function defined in interface or implementation + not yet for functions inside other functions + + Revision 1.122 1999/10/21 16:41:41 florian + * problems with readln fixed: esi wasn't restored correctly when + reading ordinal fields of objects futher the register allocation + didn't take care of the extra register when reading ordinal values + * enumerations can now be used in constant indexes of properties + + Revision 1.121 1999/10/01 08:02:48 peter + * forward type declaration rewritten + + Revision 1.120 1999/09/27 23:44:58 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.119 1999/09/26 21:30:22 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.118 1999/09/20 16:39:03 peter + * cs_create_smart instead of cs_smartlink + * -CX is create smartlink + * -CD is create dynamic, but does nothing atm. + +} \ No newline at end of file diff --git a/befpc/compiler/symsymh.inc b/befpc/compiler/symsymh.inc new file mode 100644 index 0000000..95b66f0 --- /dev/null +++ b/befpc/compiler/symsymh.inc @@ -0,0 +1,413 @@ +{ + $Id: symsymh.inc,v 1.1.1.1 2001-07-23 17:17:07 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Interface for the symbols types of the symtable + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} + +{************************************************ + TSym +************************************************} + + { this object is the base for all symbol objects } + tsym = object(tsymtableentry) + typ : tsymtyp; + symoptions : tsymoptions; + fileinfo : tfileposinfo; +{$ifdef GDB} + isstabwritten : boolean; +{$endif GDB} + refs : longint; + lastref, + defref, + lastwritten : pref; + refcount : longint; + constructor init(const n : string); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure prederef;virtual; { needed for ttypesym to be deref'd first } + procedure deref;virtual; + function mangledname : string;virtual; + procedure insert_in_data;virtual; +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + procedure load_references;virtual; + function write_references : boolean;virtual; +{$ifdef BrowserLog} + procedure add_to_browserlog;virtual; +{$endif BrowserLog} + end; + + plabelsym = ^tlabelsym; + tlabelsym = object(tsym) + lab : pasmlabel; + used, + defined : boolean; + code : pointer; { should be ptree! } + constructor init(const n : string; l : pasmlabel); + destructor done;virtual; + constructor load; + function mangledname : string;virtual; + procedure write;virtual; + end; + + punitsym = ^tunitsym; + tunitsym = object(tsym) + unitsymtable : punitsymtable; + prevsym : punitsym; + constructor init(const n : string;ref : punitsymtable); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure restoreunitsym; +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pmacrosym = ^tmacrosym; + tmacrosym = object(tsym) + defined, + defined_at_startup, + is_used : boolean; + buftext : pchar; + buflen : longint; + { macros aren't written to PPU files ! } + constructor init(const n : string); + destructor done;virtual; + end; + + perrorsym = ^terrorsym; + terrorsym = object(tsym) + constructor init; + end; + + tprocsym = object(tsym) + definition : pprocdef; +{$ifdef CHAINPROCSYMS} + nextprocsym : pprocsym; +{$endif CHAINPROCSYMS} + is_global : boolean; + constructor init(const n : string); + constructor load; + destructor done;virtual; + function mangledname : string;virtual; + function demangledname:string; + { writes all declarations } + procedure write_parameter_lists; + { tests, if all procedures definitions are defined and not } + { only forward } + procedure check_forward; + procedure order_overloaded; + procedure write;virtual; + procedure deref;virtual; + procedure load_references;virtual; + function write_references : boolean;virtual; +{$ifdef BrowserLog} + procedure add_to_browserlog;virtual; +{$endif BrowserLog} +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + ttypesym = object(tsym) + restype : ttype; +{$ifdef SYNONYM} + synonym : ptypesym; +{$endif} +{$ifdef GDB} + isusedinstab : boolean; +{$endif GDB} + constructor init(const n : string;const tt : ttype); + constructor initdef(const n : string;d : pdef); + constructor load; +{$ifdef SYNONYM} + destructor done;virtual; +{$endif} + procedure write;virtual; + procedure prederef;virtual; + procedure load_references;virtual; + function write_references : boolean;virtual; +{$ifdef BrowserLog} + procedure add_to_browserlog;virtual; +{$endif BrowserLog} +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pvarsym = ^tvarsym; + tvarsym = object(tsym) + address : longint; + localvarsym : pvarsym; + vartype : ttype; + varoptions : tvaroptions; + reg : tregister; { if reg<>R_NO, then the variable is an register variable } + varspez : tvarspez; { sets the type of access } + varstate : tvarstate; + constructor init(const n : string;const tt : ttype); + constructor init_dll(const n : string;const tt : ttype); + constructor init_C(const n,mangled : string;const tt : ttype); + constructor initdef(const n : string;p : pdef); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + procedure setmangledname(const s : string); + function mangledname : string;virtual; + procedure insert_in_data;virtual; + function getsize : longint; + function getvaluesize : longint; + function getpushsize : longint; +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + private + _mangledname : pchar; + end; + + ppropertysym = ^tpropertysym; + tpropertysym = object(tsym) + propoptions : tpropertyoptions; + proptype : ttype; + propoverriden : ppropertysym; + indextype : ttype; + index, + default : longint; + readaccess, + writeaccess, + storedaccess : psymlist; + constructor init(const n : string); + destructor done;virtual; + constructor load; + function getsize : longint;virtual; + procedure write;virtual; + procedure deref;virtual; + procedure dooverride(overriden:ppropertysym); +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pfuncretsym = ^tfuncretsym; + tfuncretsym = object(tsym) + funcretprocinfo : pointer{ should be pprocinfo}; + rettype : ttype; + address : longint; + constructor init(const n : string;approcinfo : pointer{pprocinfo}); + constructor load; + destructor done;virtual; + procedure write;virtual; + procedure deref;virtual; + procedure insert_in_data;virtual; +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pabsolutesym = ^tabsolutesym; + tabsolutesym = object(tvarsym) + abstyp : absolutetyp; + absseg : boolean; + ref : psym; + asmname : pstring; + constructor init(const n : string;const tt : ttype); + constructor initdef(const n : string;p : pdef); + constructor load; + procedure deref;virtual; + function mangledname : string;virtual; + procedure write;virtual; + procedure insert_in_data;virtual; +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + ptypedconstsym = ^ttypedconstsym; + ttypedconstsym = object(tsym) + prefix : pstring; + typedconsttype : ttype; + is_really_const : boolean; + constructor init(const n : string;p : pdef;really_const : boolean); + constructor inittype(const n : string;const tt : ttype;really_const : boolean); + constructor load; + destructor done;virtual; + function mangledname : string;virtual; + procedure write;virtual; + procedure deref;virtual; + function getsize:longint; + procedure insert_in_data;virtual; +{$ifdef GDB} + function stabstring : pchar;virtual; +{$endif GDB} + end; + + pconstsym = ^tconstsym; + tconstsym = object(tsym) + consttype : ttype; + consttyp : tconsttyp; + resstrindex, { needed for resource strings } + value, + len : longint; { len is needed for string length } + constructor init(const n : string;t : tconsttyp;v : longint); + constructor init_def(const n : string;t : tconsttyp;v : longint;def : pdef); + constructor init_string(const n : string;t : tconsttyp;str:pchar;l:longint); + constructor load; + destructor done;virtual; + function mangledname : string;virtual; + procedure deref;virtual; + procedure write;virtual; +{$ifdef GDB} + function stabstring : pchar;virtual; + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + tenumsym = object(tsym) + value : longint; + definition : penumdef; + nextenum : penumsym; + constructor init(const n : string;def : penumdef;v : longint); + constructor load; + procedure write;virtual; + procedure deref;virtual; + procedure order; +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + + pprogramsym = ^tprogramsym; + tprogramsym = object(tsym) + constructor init(const n : string); + end; + + psyssym = ^tsyssym; + tsyssym = object(tsym) + number : longint; + constructor init(const n : string;l : longint); + constructor load; + destructor done;virtual; + procedure write;virtual; +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.51 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.50 2000/05/18 17:05:17 peter + * fixed size of const parameters in asm readers + + Revision 1.49 2000/05/03 14:34:05 pierre + * fix the unitsym chain + + Revision 1.48 2000/04/27 10:06:04 pierre + * fix for snapshot failue + * order_overloaded reintrocduced and adapted to operators + + Revision 1.47 2000/04/26 08:54:19 pierre + * More changes for operator bug + Order_overloaded method removed because it conflicted with + new implementation where the defs are ordered + according to the unit loading order ! + + Revision 1.46 2000/02/09 13:23:05 peter + * log truncated + + Revision 1.45 2000/01/07 01:14:41 peter + * updated copyright to 2000 + + Revision 1.44 2000/01/03 19:26:04 peter + * fixed resolving of ttypesym which are reference from object/record + fields. + + Revision 1.43 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.42 1999/11/30 10:40:56 peter + + ttype, tsymlist + + Revision 1.41 1999/11/26 00:19:12 peter + * property overriding dereference fix, but it need a bigger redesign + which i'll do tomorrow. This quick hack is for the lazarus ppl so + they can hack on mwcustomedit. + + Revision 1.40 1999/11/17 17:05:06 pierre + * Notes/hints changes + + Revision 1.39 1999/11/15 22:00:48 peter + * labels used but not defined give error instead of warning, the warning + is now only with declared but not defined and not used. + + Revision 1.38 1999/11/08 14:02:17 florian + * problem with "index X"-properties solved + * typed constants of class references are now allowed + + Revision 1.37 1999/11/06 14:34:28 peter + * truncated log to 20 revs + + Revision 1.36 1999/10/01 08:02:48 peter + * forward type declaration rewritten + + Revision 1.35 1999/09/26 21:30:22 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.34 1999/08/31 15:42:26 pierre + + tmacrosym is_used and defined_at_startup boolean fields added + + Revision 1.33 1999/08/23 11:45:45 michael + * Hopefully final attempt at resourcestrings + + Revision 1.32 1999/08/14 00:39:01 peter + * hack to support property with record fields + + Revision 1.31 1999/08/10 12:33:38 pierre + * pprocsym defined earlier for use in tprocdef + + Revision 1.30 1999/08/03 22:03:21 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.29 1999/07/27 23:42:23 peter + * indirect type referencing is now allowed + + Revision 1.28 1999/07/24 15:13:01 michael + changes for resourcestrings + + Revision 1.27 1999/07/22 09:37:57 florian + + resourcestring implemented + + start of longstring support + +} diff --git a/befpc/compiler/symtable.pas b/befpc/compiler/symtable.pas new file mode 100644 index 0000000..b898c12 --- /dev/null +++ b/befpc/compiler/symtable.pas @@ -0,0 +1,3149 @@ +{ + $Id: symtable.pas,v 1.1.1.1 2001-07-23 17:17:08 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + This unit handles the symbol tables + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} +{$ifdef TP} + {$N+,E+,F+,L-} +{$endif} +unit symtable; + + interface + + uses +{$ifdef TP} +{$ifndef Delphi} + objects, +{$endif Delphi} +{$endif} + strings,cobjects, + globtype,globals,tokens,systems, + symconst, + aasm + ,cpubase + ,cpuinfo +{$ifdef GDB} + ,gdb +{$endif} + ; + +{************************************************ + Some internal constants +************************************************} + + const + hasharraysize = 256; + {$ifdef TP} + indexgrowsize = 16; + {$else} + indexgrowsize = 64; + {$endif} + + +{************************************************ + Needed forward pointers +************************************************} + + type + { needed for owner (table) of symbol } + psymtable = ^tsymtable; + punitsymtable = ^tunitsymtable; + + { needed for names by the definitions } + psym = ^tsym; + pdef = ^tdef; + ptypesym = ^ttypesym; + penumsym = ^tenumsym; + pprocsym = ^tprocsym; + tcallback = procedure(p : psym); + + pref = ^tref; + tref = object + nextref : pref; + posinfo : tfileposinfo; + moduleindex : word; + is_written : boolean; + constructor init(ref:pref;pos:pfileposinfo); + procedure freechain; + destructor done; virtual; + end; + + { Deref entry options } + tdereftype = (derefnil,derefaktrecordindex,derefaktstaticindex, + derefunit,derefrecord,derefindex, + dereflocal,derefpara,derefaktlocal); + + pderef = ^tderef; + tderef = object + dereftype : tdereftype; + index : word; + next : pderef; + constructor init(typ:tdereftype;i:word); + destructor done; + end; + + ttype = object + def : pdef; + sym : psym; + procedure reset; + procedure setdef(p:pdef); + procedure setsym(p:psym); + procedure load; + procedure write; + procedure resolve; + end; + + psymlistitem = ^tsymlistitem; + tsymlistitem = record + sym : psym; + next : psymlistitem; + end; + + psymlist = ^tsymlist; + tsymlist = object + def : pdef; + firstsym, + lastsym : psymlistitem; + constructor init; + constructor load; + destructor done; + function empty:boolean; + procedure setdef(p:pdef); + procedure addsym(p:psym); + procedure clear; + function getcopy:psymlist; + procedure resolve; + procedure write; + end; + + psymtableentry = ^tsymtableentry; + tsymtableentry = object(tnamedindexobject) + owner : psymtable; + end; + +{************************************************ + TDef +************************************************} + +{$i symdefh.inc} + +{************************************************ + TSym +************************************************} + +{$i symsymh.inc} + +{************************************************ + TSymtable +************************************************} + + tsymtabletype = (invalidsymtable,withsymtable,staticsymtable, + globalsymtable,unitsymtable, + objectsymtable,recordsymtable, + macrosymtable,localsymtable, + parasymtable,inlineparasymtable, + inlinelocalsymtable,stt_exceptsymtable, + { only used for PPU reading of static part + of a unit } + staticppusymtable); + + tsearchhasharray = array[0..hasharraysize-1] of psym; + psearchhasharray = ^tsearchhasharray; + + tsymtable = object + symtabletype : tsymtabletype; + { each symtable gets a number } + unitid : word{integer give range check errors PM}; + name : pstring; + datasize : longint; + dataalignment : longint; + symindex, + defindex : pindexarray; + symsearch : pdictionary; + next : psymtable; + defowner : pdef; { for records and objects } + { alignment used in this symtable } +{ alignment : longint; } + { only used for parameter symtable to determine the offset relative } + { to the frame pointer and for local inline } + address_fixup : longint; + { this saves all definition to allow a proper clean up } + { separate lexlevel from symtable type } + symtablelevel : byte; + constructor init(t : tsymtabletype); + destructor done;virtual; + { access } + function getdefnr(l : longint) : pdef; + function getsymnr(l : longint) : psym; + { load/write } + constructor loadas(typ : tsymtabletype); + procedure writeas; + procedure loaddefs; + procedure loadsyms; + procedure writedefs; + procedure writesyms; + procedure deref; + procedure clear; + function rename(const olds,news : stringid):psym; + procedure foreach(proc2call : tnamedindexcallback); + procedure insert(sym : psym); + procedure insert_in(psymt : psymtable;offset : longint); + function search(const s : stringid) : psym; + function speedsearch(const s : stringid;speedvalue : longint) : psym; + procedure registerdef(p : pdef); + procedure allsymbolsused; + procedure allprivatesused; + procedure allunitsused; + procedure check_forwards; + procedure checklabels; + { change alignment for args only parasymtable } + procedure set_alignment(_alignment : longint); + { find arg having offset only parasymtable } + function find_at_offset(l : longint) : pvarsym; +{$ifdef CHAINPROCSYMS} + procedure chainprocsyms; +{$endif CHAINPROCSYMS} +{$ifndef DONOTCHAINOPERATORS} + procedure chainoperators; +{$endif DONOTCHAINOPERATORS} + procedure load_browser; + procedure write_browser; +{$ifdef BrowserLog} + procedure writebrowserlog; +{$endif BrowserLog} +{$ifdef GDB} + procedure concatstabto(asmlist : paasmoutput);virtual; +{$endif GDB} + function getnewtypecount : word; virtual; + end; + + tunitsymtable = object(tsymtable) + unittypecount : word; + unitsym : punitsym; +{$ifdef GDB} + dbx_count : longint; + prev_dbx_counter : plongint; + dbx_count_ok : boolean; + is_stab_written : boolean; +{$endif GDB} + constructor init(t : tsymtabletype;const n : string); + constructor loadasunit; + destructor done;virtual; + procedure writeasunit; +{$ifdef GDB} + procedure concattypestabto(asmlist : paasmoutput); +{$endif GDB} + procedure load_symtable_refs; + function getnewtypecount : word; virtual; + end; + + pwithsymtable = ^twithsymtable; + twithsymtable = object(tsymtable) + { used for withsymtable for allowing constructors } + direct_with : boolean; + { in fact it is a ptree } + withnode : pointer; + { ptree to load of direct with var } + { already usable before firstwith + needed for firstpass of function parameters PM } + withrefnode : pointer; + constructor init; + destructor done;virtual; + end; + +{**************************************************************************** + Var / Consts +****************************************************************************} + + const + systemunit : punitsymtable = nil; { pointer to the system unit } + current_object_option : tsymoptions = [sp_public]; + + var + { for STAB debugging } + globaltypecount : word; + pglobaltypecount : pword; + + registerdef : boolean; { true, when defs should be registered } + + defaultsymtablestack, { symtablestack after default units + have been loaded } + symtablestack : psymtable; { linked list of symtables } + + srsym : psym; { result of the last search } + srsymtable : psymtable; + lastsrsym : psym; { last sym found in statement } + lastsrsymtable : psymtable; + lastsymknown : boolean; + + constsymtable : psymtable; { symtable were the constants can be + inserted } + + voidpointerdef : ppointerdef; { pointer for Void-Pointerdef } + charpointerdef : ppointerdef; { pointer for Char-Pointerdef } + voidfarpointerdef : ppointerdef; + + cformaldef : pformaldef; { unique formal definition } + voiddef : porddef; { Pointer to Void (procedure) } + cchardef : porddef; { Pointer to Char } + cwidechardef : porddef; { Pointer to WideChar } + booldef : porddef; { pointer to boolean type } + u8bitdef : porddef; { Pointer to 8-Bit unsigned } + u16bitdef : porddef; { Pointer to 16-Bit unsigned } + u32bitdef : porddef; { Pointer to 32-Bit unsigned } + s32bitdef : porddef; { Pointer to 32-Bit signed } + + cu64bitdef : porddef; { pointer to 64 bit unsigned def } + cs64bitdef : porddef; { pointer to 64 bit signed def, } + { calculated by the int unit on i386 } + + s32floatdef : pfloatdef; { pointer for realconstn } + s64floatdef : pfloatdef; { pointer for realconstn } + s80floatdef : pfloatdef; { pointer to type of temp. floats } + s32fixeddef : pfloatdef; { pointer to type of temp. fixed } + + cshortstringdef : pstringdef; { pointer to type of short string const } + clongstringdef : pstringdef; { pointer to type of long string const } + cansistringdef : pstringdef; { pointer to type of ansi string const } + cwidestringdef : pstringdef; { pointer to type of wide string const } + openshortstringdef : pstringdef; { pointer to type of an open shortstring, + needed for readln() } + openchararraydef : parraydef; { pointer to type of an open array of char, + needed for readln() } + + cfiledef : pfiledef; { get the same definition for all file } + { uses for stabs } + + firstglobaldef, { linked list of all globals defs } + lastglobaldef : pdef; { used to reset stabs/ranges } + + class_tobject : pobjectdef; { pointer to the anchestor of all } + { clases } + pvmtdef : ppointerdef; { type of classrefs } + + aktprocsym : pprocsym; { pointer to the symbol for the + currently be parsed procedure } + + aktcallprocsym : pprocsym; { pointer to the symbol for the + currently be called procedure, + only set/unset in firstcall } + + aktvarsym : pvarsym; { pointer to the symbol for the + currently read var, only used + for variable directives } + + procprefix : string; { eindeutige Namen bei geschachtel- } + { ten Unterprogrammen erzeugen } + + lexlevel : longint; { level of code } + { 1 for main procedure } + { 2 for normal function or proc } + { higher for locals } + const + main_program_level = 1; + unit_init_level = 1; + normal_function_level = 2; + in_loading : boolean = false; + +{$ifdef i386} + bestrealdef : ^pfloatdef = @s80floatdef; +{$endif} +{$ifdef m68k} + bestrealdef : ^pfloatdef = @s64floatdef; +{$endif} +{$ifdef alpha} + bestrealdef : ^pfloatdef = @s64floatdef; +{$endif} +{$ifdef powerpc} + bestrealdef : ^pfloatdef = @s64floatdef; +{$endif} + + var + + macros : psymtable; { pointer for die Symboltabelle mit } + { Makros } + + read_member : boolean; { true, wenn Members aus einer PPU- } + { Datei gelesen werden, d.h. ein } + { varsym seine Adresse einlesen soll } + + generrorsym : psym; { Jokersymbol, wenn das richtige } + { Symbol nicht gefunden wird } + + generrordef : pdef; { Jokersymbol for eine fehlerhafte } + { Typdefinition } + + aktobjectdef : pobjectdef; { used for private functions check !! } + + const + { last operator which can be overloaded } + first_overloaded = _PLUS; + last_overloaded = _ASSIGNMENT; + type + toverloaded_operators = array[first_overloaded..last_overloaded] of pprocsym; + var + overloaded_operators : toverloaded_operators; + { unequal is not equal} + const + overloaded_names : array [first_overloaded..last_overloaded] of string[16] = + ('plus','minus','star','slash','equal', + 'greater','lower','greater_or_equal', + 'lower_or_equal', + 'sym_diff','starstar', + 'as','is','in','or', + 'and','div','mod','not','shl','shr','xor', + 'assign'); + +{$ifdef UNITALIASES} + type + punit_alias = ^tunit_alias; + tunit_alias = object(tnamedindexobject) + newname : pstring; + constructor init(const n:string); + destructor done;virtual; + end; + var + unitaliases : pdictionary; + + procedure addunitalias(const n:string); + function getunitalias(const n:string):string; +{$endif UNITALIASES} + + +{**************************************************************************** + Functions +****************************************************************************} + +{*** Misc ***} + function globaldef(const s : string) : pdef; + function findunitsymtable(st:psymtable):psymtable; + procedure duplicatesym(sym:psym); + +{*** Search ***} + function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym; + procedure getsym(const s : stringid;notfounderror : boolean); + procedure getsymonlyin(p : psymtable;const s : stringid); + +{*** PPU Write/Loading ***} + procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean); + procedure closecurrentppu; + procedure numberunits; + procedure load_interface; + +{*** GDB ***} +{$ifdef GDB} + function typeglobalnumber(const s : string) : string; +{$endif} + +{*** Definition ***} + procedure reset_global_defs; + +{*** Object Helpers ***} + function search_class_member(pd : pobjectdef;const n : string) : psym; + function search_default_property(pd : pobjectdef) : ppropertysym; + +{*** Macro ***} + procedure def_macro(const s : string); + procedure set_macro(const s : string;value : string); + +{*** symtable stack ***} + procedure dellexlevel; + procedure RestoreUnitSyms; +{$ifdef DEBUG} + procedure test_symtablestack; + procedure list_symtablestack; +{$endif DEBUG} + +{*** Init / Done ***} + procedure InitSymtable; + procedure DoneSymtable; + + +implementation + + uses + version,verbose, + types,ppu, + gendef,files + ,tree + ,cresstr +{$ifdef newcg} + ,cgbase +{$else} + ,hcodegen +{$endif} +{$ifdef BrowserLog} + ,browlog +{$endif BrowserLog} + ,cpuasm + ; + + var + aktrecordsymtable : psymtable; { current record read from ppu symtable } + aktstaticsymtable : psymtable; { current static for local ppu symtable } + aktlocalsymtable : psymtable; { current proc local for local ppu symtable } +{$ifdef GDB} + asmoutput : paasmoutput; +{$endif GDB} +{$ifdef TP} +{$ifndef Delphi} + {$ifndef dpmi} + symbolstream : temsstream; { stream which is used to store some info } + {$else} + symbolstream : tmemorystream; + {$endif} +{$endif Delphi} +{$endif} + + {to dispose the global symtable of a unit } + const + dispose_global : boolean = false; + memsizeinc = 2048; { for long stabstrings } + tagtypes : Set of tdeftype = + [recorddef,enumdef, + {$IfNDef GDBKnowsStrings} + stringdef, + {$EndIf not GDBKnowsStrings} + {$IfNDef GDBKnowsFiles} + filedef, + {$EndIf not GDBKnowsFiles} + objectdef]; + +{***************************************************************************** + Helper Routines +*****************************************************************************} + +{$ifdef unused} + function demangledparas(s : string) : string; + var + r : string; + l : longint; + begin + demangledparas:=''; + r:=','; + { delete leading $$'s } + l:=pos('$$',s); + while l<>0 do + begin + delete(s,1,l+1); + l:=pos('$$',s); + end; + { delete leading _$'s } + l:=pos('_$',s); + while l<>0 do + begin + delete(s,1,l+1); + l:=pos('_$',s); + end; + l:=pos('$',s); + if l=0 then + exit; + delete(s,1,l); + while s<>'' do + begin + l:=pos('$',s); + if l=0 then + l:=length(s)+1; + r:=r+copy(s,1,l-1)+','; + delete(s,1,l); + end; + delete(r,1,1); + delete(r,length(r),1); + demangledparas:=r; + end; +{$endif} + + + procedure numberunits; + var + counter : longint; + hp : pused_unit; + hp1 : pmodule; + begin + { Reset all numbers to -1 } + hp1:=pmodule(loaded_units.first); + while assigned(hp1) do + begin + if assigned(hp1^.globalsymtable) then + psymtable(hp1^.globalsymtable)^.unitid:=$ffff; + hp1:=pmodule(hp1^.next); + end; + { Our own symtable gets unitid 0, for a program there is + no globalsymtable } + if assigned(current_module^.globalsymtable) then + psymtable(current_module^.globalsymtable)^.unitid:=0; + { number units } + counter:=1; + hp:=pused_unit(current_module^.used_units.first); + while assigned(hp) do + begin + psymtable(hp^.u^.globalsymtable)^.unitid:=counter; + inc(counter); + hp:=pused_unit(hp^.next); + end; + end; + + + function findunitsymtable(st:psymtable):psymtable; + begin + findunitsymtable:=nil; + repeat + if not assigned(st) then + internalerror(5566561); + case st^.symtabletype of + localsymtable, + parasymtable, + staticsymtable : + break; + globalsymtable, + unitsymtable : + begin + findunitsymtable:=st; + break; + end; + objectsymtable, + recordsymtable : + st:=st^.defowner^.owner; + else + internalerror(5566562); + end; + until false; + end; + + + procedure setstring(var p : pchar;const s : string); + begin +{$ifndef Delphi} +{$ifdef TP} + + if use_big then + begin + p:=pchar(symbolstream.getsize); + symbolstream.seek(longint(p)); + symbolstream.writestr(@s); + end + else +{$endif TP} +{$endif Delphi} + p:=strpnew(s); + end; + + + procedure duplicatesym(sym:psym); + var + st : psymtable; + begin + Message1(sym_e_duplicate_id,sym^.name); + st:=findunitsymtable(sym^.owner); + with sym^.fileinfo do + begin + if assigned(st) and (st^.unitid<>0) then + Message2(sym_h_duplicate_id_where,'unit '+st^.name^,tostr(line)) + else + Message2(sym_h_duplicate_id_where,current_module^.sourcefiles^.get_file_name(fileindex),tostr(line)); + end; + end; + + +{***************************************************************************** + PPU Reading Writing +*****************************************************************************} + +{$I symppu.inc} + + +{**************************************************************************** + TDeref +****************************************************************************} + + constructor tderef.init(typ:tdereftype;i:word); + begin + dereftype:=typ; + index:=i; + next:=nil; + end; + + + destructor tderef.done; + begin + end; + + +{***************************************************************************** + Symbol / Definition Resolving +*****************************************************************************} + + procedure resolvederef(var p:pderef;var st:psymtable;var idx:word); + var + hp : pderef; + pd : pdef; + begin + st:=nil; + idx:=0; + while assigned(p) do + begin + case p^.dereftype of + derefaktrecordindex : + begin + st:=aktrecordsymtable; + idx:=p^.index; + end; + derefaktstaticindex : + begin + st:=aktstaticsymtable; + idx:=p^.index; + end; + derefaktlocal : + begin + st:=aktlocalsymtable; + idx:=p^.index; + end; + derefunit : + begin +{$ifdef NEWMAP} + st:=psymtable(current_module^.map^[p^.index]^.globalsymtable); +{$else NEWMAP} + st:=psymtable(current_module^.map^[p^.index]); +{$endif NEWMAP} + end; + derefrecord : + begin + pd:=st^.getdefnr(p^.index); + case pd^.deftype of + recorddef : + st:=precorddef(pd)^.symtable; + objectdef : + st:=pobjectdef(pd)^.symtable; + else + internalerror(556658); + end; + end; + dereflocal : + begin + pd:=st^.getdefnr(p^.index); + case pd^.deftype of + procdef : + st:=pprocdef(pd)^.localst; + else + internalerror(556658); + end; + end; + derefpara : + begin + pd:=st^.getdefnr(p^.index); + case pd^.deftype of + procdef : + st:=pprocdef(pd)^.parast; + else + internalerror(556658); + end; + end; + derefindex : + begin + idx:=p^.index; + end; + else + internalerror(556658); + end; + hp:=p; + p:=p^.next; + dispose(hp,done); + end; + end; + + + procedure resolvedef(var def:pdef); + var + st : psymtable; + idx : word; + begin + resolvederef(pderef(def),st,idx); + if assigned(st) then + def:=st^.getdefnr(idx) + else + def:=nil; + end; + + procedure resolvesym(var sym:psym); + var + st : psymtable; + idx : word; + begin + resolvederef(pderef(sym),st,idx); + if assigned(st) then + sym:=st^.getsymnr(idx) + else + sym:=nil; + end; + + + +{**************************************************************************** + TRef +****************************************************************************} + + constructor tref.init(ref :pref;pos : pfileposinfo); + begin + nextref:=nil; + if pos<>nil then + posinfo:=pos^; + if assigned(current_module) then + moduleindex:=current_module^.unit_index; + if assigned(ref) then + ref^.nextref:=@self; + is_written:=false; + end; + + procedure tref.freechain; + var + p,q : pref; + begin + p:=nextref; + nextref:=nil; + while assigned(p) do + begin + q:=p^.nextref; + dispose(p,done); + p:=q; + end; + end; + + destructor tref.done; + var + inputfile : pinputfile; + begin + inputfile:=get_source_file(moduleindex,posinfo.fileindex); + if inputfile<>nil then + dec(inputfile^.ref_count); + nextref:=nil; + end; + + +{**************************************************************************** + TType +****************************************************************************} + + procedure ttype.reset; + begin + def:=nil; + sym:=nil; + end; + + + procedure ttype.setdef(p:pdef); + begin + def:=p; + sym:=nil; + end; + + + procedure ttype.setsym(p:psym); + begin + sym:=p; + case p^.typ of + typesym : + def:=ptypesym(p)^.restype.def; + propertysym : + def:=ppropertysym(p)^.proptype.def; + else + internalerror(1234005); + end; + end; + + + procedure ttype.load; + begin + def:=pdef(readderef); + sym:=psym(readderef); + end; + + + procedure ttype.write; + begin + if assigned(sym) then + begin + writederef(nil); + writederef(sym); + end + else + begin + writederef(def); + writederef(nil); + end; + end; + + + procedure ttype.resolve; + begin + if assigned(sym) then + begin + resolvesym(sym); + setsym(sym); + end + else + resolvedef(def); + end; + + +{**************************************************************************** + TSymList +****************************************************************************} + + constructor tsymlist.init; + begin + def:=nil; { needed for procedures } + firstsym:=nil; + lastsym:=nil; + end; + + + constructor tsymlist.load; + var + sym : psym; + begin + def:=readdefref; + firstsym:=nil; + lastsym:=nil; + repeat + sym:=readsymref; + if sym=nil then + break; + addsym(sym); + until false; + end; + + + destructor tsymlist.done; + begin + clear; + end; + + + function tsymlist.empty:boolean; + begin + empty:=(firstsym=nil); + end; + + + procedure tsymlist.clear; + var + hp : psymlistitem; + begin + while assigned(firstsym) do + begin + hp:=firstsym; + firstsym:=firstsym^.next; + dispose(hp); + end; + firstsym:=nil; + lastsym:=nil; + def:=nil; + end; + + + procedure tsymlist.setdef(p:pdef); + begin + def:=p; + end; + + + procedure tsymlist.addsym(p:psym); + var + hp : psymlistitem; + begin + if not assigned(p) then + exit; + new(hp); + hp^.sym:=p; + hp^.next:=nil; + if assigned(lastsym) then + lastsym^.next:=hp + else + firstsym:=hp; + lastsym:=hp; + end; + + + function tsymlist.getcopy:psymlist; + var + hp : psymlist; + hp2 : psymlistitem; + begin + new(hp,init); + hp^.def:=def; + hp2:=firstsym; + while assigned(hp2) do + begin + hp^.addsym(hp2^.sym); + hp2:=hp2^.next; + end; + getcopy:=hp; + end; + + + procedure tsymlist.write; + var + hp : psymlistitem; + begin + writederef(def); + hp:=firstsym; + while assigned(hp) do + begin + writederef(hp^.sym); + hp:=hp^.next; + end; + writederef(nil); + end; + + + procedure tsymlist.resolve; + var + hp : psymlistitem; + begin + resolvedef(def); + hp:=firstsym; + while assigned(hp) do + begin + resolvesym(hp^.sym); + hp:=hp^.next; + end; + end; + + +{***************************************************************************** + Definition Helpers +*****************************************************************************} + + function globaldef(const s : string) : pdef; + + var st : string; + symt : psymtable; + begin + srsym := nil; + if pos('.',s) > 0 then + begin + st := copy(s,1,pos('.',s)-1); + getsym(st,false); + st := copy(s,pos('.',s)+1,255); + if assigned(srsym) then + begin + if srsym^.typ = unitsym then + begin + symt := punitsym(srsym)^.unitsymtable; + srsym := symt^.search(st); + end else srsym := nil; + end; + end else st := s; + if srsym = nil then getsym(st,false); + if srsym = nil then + getsymonlyin(systemunit,st); + if srsym^.typ<>typesym then + begin + Message(type_e_type_id_expected); + exit; + end; + globaldef := ptypesym(srsym)^.restype.def; + end; + +{***************************************************************************** + Symbol Call Back Functions +*****************************************************************************} + + procedure derefsym(p : pnamedindexobject); + begin + psym(p)^.deref; + end; + + procedure check_forward(sym : pnamedindexobject); + begin + if psym(sym)^.typ=procsym then + pprocsym(sym)^.check_forward + { check also object method table } + { we needn't to test the def list } + { because each object has to have a type sym } + else + if (psym(sym)^.typ=typesym) and + assigned(ptypesym(sym)^.restype.def) and + (ptypesym(sym)^.restype.def^.deftype=objectdef) then + pobjectdef(ptypesym(sym)^.restype.def)^.check_forwards; + end; + + procedure labeldefined(p : pnamedindexobject); + begin + if (psym(p)^.typ=labelsym) and + not(plabelsym(p)^.defined) then + begin + if plabelsym(p)^.used then + Message1(sym_e_label_used_and_not_defined,p^.name) + else + Message1(sym_w_label_not_defined,p^.name); + end; + end; + + procedure unitsymbolused(p : pnamedindexobject); + begin + if (psym(p)^.typ=unitsym) and + (punitsym(p)^.refs=0) and + { do not claim for unit name itself !! } + (punitsym(p)^.unitsymtable^.symtabletype=unitsymtable) then + MessagePos2(psym(p)^.fileinfo,sym_n_unit_not_used, + p^.name,current_module^.modulename^); + end; + + procedure varsymbolused(p : pnamedindexobject); + begin + if (psym(p)^.typ=varsym) and + ((psym(p)^.owner^.symtabletype in + [parasymtable,localsymtable,objectsymtable,staticsymtable])) then + begin + { unused symbol should be reported only if no } + { error is reported } + { if the symbol is in a register it is used } + { also don't count the value parameters which have local copies } + { also don't claim for high param of open parameters (PM) } + if (Errorcount<>0) or + (copy(p^.name,1,3)='val') or + (copy(p^.name,1,4)='high') then + exit; + if (pvarsym(p)^.refs=0) then + begin + if (psym(p)^.owner^.symtabletype=parasymtable) or (vo_is_local_copy in pvarsym(p)^.varoptions) then + begin + MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_not_used,p^.name); + end + else if (psym(p)^.owner^.symtabletype=objectsymtable) then + MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_not_used,psym(p)^.owner^.name^,p^.name) + else + MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_not_used,p^.name); + end + else if pvarsym(p)^.varstate=vs_assigned then + begin + if (psym(p)^.owner^.symtabletype=parasymtable) then + begin + if (pvarsym(p)^.varspez<>vs_var) then + MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,p^.name) + end + else if (vo_is_local_copy in pvarsym(p)^.varoptions) then + begin + if (pvarsym(p)^.varspez<>vs_var) then + MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,p^.name); + end + else if (psym(p)^.owner^.symtabletype=objectsymtable) then + MessagePos2(psym(p)^.fileinfo,sym_n_private_identifier_only_set,psym(p)^.owner^.name^,p^.name) + else if (psym(p)^.owner^.symtabletype<>parasymtable) then + if not (vo_is_exported in pvarsym(p)^.varoptions) then + MessagePos1(psym(p)^.fileinfo,sym_n_local_identifier_only_set,p^.name); + end; + end + else if ((psym(p)^.owner^.symtabletype in + [objectsymtable,parasymtable,localsymtable,staticsymtable])) then + begin + if (Errorcount<>0) then + exit; + { do not claim for inherited private fields !! } + if (psym(p)^.refs=0) and (psym(p)^.owner^.symtabletype=objectsymtable) then + MessagePos2(psym(p)^.fileinfo,sym_n_private_method_not_used,psym(p)^.owner^.name^,p^.name) + { units references are problematic } + else if (psym(p)^.refs=0) and not(psym(p)^.typ in [funcretsym,enumsym,unitsym]) then + if (psym(p)^.typ<>procsym) or not (pprocsym(p)^.is_global) or + { all program functions are declared global + but unused should still be signaled PM } + ((psym(p)^.owner^.symtabletype=staticsymtable) and + not current_module^.is_unit) then + MessagePos2(psym(p)^.fileinfo,sym_h_local_symbol_not_used,SymTypeName[psym(p)^.typ],p^.name); + end; + end; + + procedure TestPrivate(p : pnamedindexobject); + begin + if sp_private in psym(p)^.symoptions then + varsymbolused(p); + end; + + procedure objectprivatesymbolused(p : pnamedindexobject); + begin + { + Don't test simple object aliases PM + } + if (psym(p)^.typ=typesym) and + (ptypesym(p)^.restype.def^.deftype=objectdef) and + (ptypesym(p)^.restype.def^.typesym=ptypesym(p)) then + pobjectdef(ptypesym(p)^.restype.def)^.symtable^.foreach( + {$ifndef TP}@{$endif}TestPrivate); + end; + +{$ifdef GDB} + procedure concatstab(p : pnamedindexobject); + begin + if psym(p)^.typ <> procsym then + psym(p)^.concatstabto(asmoutput); + end; + + procedure resetstab(p : pnamedindexobject); + begin + if psym(p)^.typ <> procsym then + psym(p)^.isstabwritten:=false; + end; + + procedure concattypestab(p : pnamedindexobject); + begin + if psym(p)^.typ = typesym then + begin + psym(p)^.isstabwritten:=false; + psym(p)^.concatstabto(asmoutput); + end; + end; + + procedure forcestabto(asmlist : paasmoutput; pd : pdef); + begin + if not pd^.is_def_stab_written then + begin + if assigned(pd^.typesym) then + pd^.typesym^.isusedinstab := true; + pd^.concatstabto(asmlist); + end; + end; +{$endif} + +{$ifdef CHAINPROCSYMS} + procedure chainprocsym(p : psym); + var + storesymtablestack : psymtable; + begin + if p^.typ=procsym then + begin + storesymtablestack:=symtablestack; + symtablestack:=p^.owner^.next; + while assigned(symtablestack) do + begin + { search for same procsym in other units } + getsym(p^.name,false); + if assigned(srsym) and (srsym^.typ=procsym) then + begin + pprocsym(p)^.nextprocsym:=pprocsym(srsym); + symtablestack:=storesymtablestack; + exit; + end + else if srsym=nil then + symtablestack:=nil + else + symtablestack:=srsymtable^.next; + end; + symtablestack:=storesymtablestack; + end; + end; +{$endif} + +{$ifndef DONOTCHAINOPERATORS} + procedure tsymtable.chainoperators; + var + p : pprocsym; + t : ttoken; + def : pprocdef; + storesymtablestack : psymtable; + begin + storesymtablestack:=symtablestack; + symtablestack:=@self; + make_ref:=false; + for t:=first_overloaded to last_overloaded do + begin + p:=nil; + def:=nil; + overloaded_operators[t]:=nil; + { each operator has a unique lowercased internal name PM } + while assigned(symtablestack) do + begin + getsym(overloaded_names[t],false); + if (t=_STARSTAR) and (srsym=nil) then + begin + symtablestack:=systemunit; + getsym('POWER',false); + end; + if assigned(srsym) then + begin + if (srsym^.typ<>procsym) then + internalerror(12344321); + if assigned(p) then + begin +{$ifdef CHAINPROCSYMS} + p^.nextprocsym:=pprocsym(srsym); +{$endif CHAINPROCSYMS} + def^.nextoverloaded:=pprocsym(srsym)^.definition; + end + else + overloaded_operators[t]:=pprocsym(srsym); + p:=pprocsym(srsym); + def:=p^.definition; + while assigned(def^.nextoverloaded) and + (def^.nextoverloaded^.owner=p^.owner) do + def:=def^.nextoverloaded; + def^.nextoverloaded:=nil; + symtablestack:=srsymtable^.next; + end + else + begin + symtablestack:=nil; +{$ifdef CHAINPROCSYMS} + if assigned(p) then + p^.nextprocsym:=nil; +{$endif CHAINPROCSYMS} + end; + { search for same procsym in other units } + end; + symtablestack:=@self; + end; + make_ref:=true; + symtablestack:=storesymtablestack; + end; +{$endif DONOTCHAINOPERATORS} + + procedure write_refs(sym : pnamedindexobject); + begin + psym(sym)^.write_references; + end; + +{$ifdef BrowserLog} + procedure add_to_browserlog(sym : pnamedindexobject); + begin + psym(sym)^.add_to_browserlog; + end; +{$endif UseBrowser} + + +{***************************************************************************** + Search Symtables for Syms +*****************************************************************************} + + procedure getsym(const s : stringid;notfounderror : boolean); + var + speedvalue : longint; + begin + speedvalue:=getspeedvalue(s); + lastsrsym:=nil; + srsymtable:=symtablestack; + while assigned(srsymtable) do + begin + srsym:=srsymtable^.speedsearch(s,speedvalue); + if assigned(srsym) then + exit + else + srsymtable:=srsymtable^.next; + end; + if notfounderror then + begin + Message1(sym_e_id_not_found,s); + srsym:=generrorsym; + end + else + srsym:=nil; + end; + + + procedure getsymonlyin(p : psymtable;const s : stringid); + begin + { the caller have to take care if srsym=nil (FK) } + srsym:=nil; + if assigned(p) then + begin + srsymtable:=p; + srsym:=srsymtable^.search(s); + if assigned(srsym) then + exit + else + begin + if (punitsymtable(srsymtable)=punitsymtable(current_module^.globalsymtable)) then + begin + getsymonlyin(psymtable(current_module^.localsymtable),s); + if assigned(srsym) then + srsymtable:=psymtable(current_module^.localsymtable) + else + Message1(sym_e_id_not_found,s); + end + else + Message1(sym_e_id_not_found,s); + end; + end; + end; + + + function search_a_symtable(const symbol:string;symtabletype:tsymtabletype):Psym; + {Search for a symbol in a specified symbol table. Returns nil if + the symtable is not found, and also if the symbol cannot be found + in the desired symtable } + var hsymtab:Psymtable; + res:Psym; + begin + res:=nil; + hsymtab:=symtablestack; + while (hsymtab<>nil) and (hsymtab^.symtabletype<>symtabletype) do + hsymtab:=hsymtab^.next; + if hsymtab<>nil then + {We found the desired symtable. Now check if the symbol we + search for is defined in it } + res:=hsymtab^.search(symbol); + search_a_symtable:=res; + end; + + +{**************************************************************************** + TSYMTABLE +****************************************************************************} + + constructor tsymtable.init(t : tsymtabletype); + begin + symtabletype:=t; + symtablelevel:=0; + defowner:=nil; + unitid:=0; + next:=nil; + name:=nil; + address_fixup:=0; + datasize:=0; + if t=parasymtable then + dataalignment:=4 + else + dataalignment:=1; + new(symindex,init(indexgrowsize)); + new(defindex,init(indexgrowsize)); + if symtabletype<>withsymtable then + begin + new(symsearch,init); + symsearch^.noclear:=true; + end + else + symsearch:=nil; + end; + + + destructor tsymtable.done; + begin + stringdispose(name); + dispose(symindex,done); + dispose(defindex,done); + { symsearch can already be disposed or set to nil for withsymtable } + if assigned(symsearch) then + begin + dispose(symsearch,done); + symsearch:=nil; + end; + end; + + + constructor twithsymtable.init; + begin + inherited init(withsymtable); + direct_with:=false; + withnode:=nil; + withrefnode:=nil; + end; + + + destructor twithsymtable.done; + begin + symsearch:=nil; + inherited done; + end; + + +{*********************************************** + Helpers +***********************************************} + + function tsymtable.getnewtypecount : word; + begin + getnewtypecount:=pglobaltypecount^; + inc(pglobaltypecount^); + end; + + procedure tsymtable.registerdef(p : pdef); + begin + defindex^.insert(p); + { set def owner and indexnb } + p^.owner:=@self; + end; + + + procedure order_overloads(p : Pnamedindexobject); + begin + if psym(p)^.typ=procsym then + pprocsym(p)^.order_overloaded; + end; + + procedure tsymtable.foreach(proc2call : tnamedindexcallback); + begin + symindex^.foreach(proc2call); + end; + + +{*********************************************** + LOAD / WRITE SYMTABLE FROM PPU +***********************************************} + + procedure tsymtable.loaddefs; + var + hp : pdef; + b : byte; + begin + { load start of definition section, which holds the amount of defs } + if current_ppu^.readentry<>ibstartdefs then + Message(unit_f_ppu_read_error); + current_ppu^.getlongint; + { read definitions } + repeat + b:=current_ppu^.readentry; + case b of + ibpointerdef : hp:=new(ppointerdef,load); + ibarraydef : hp:=new(parraydef,load); + iborddef : hp:=new(porddef,load); + ibfloatdef : hp:=new(pfloatdef,load); + ibprocdef : hp:=new(pprocdef,load); + ibshortstringdef : hp:=new(pstringdef,shortload); + iblongstringdef : hp:=new(pstringdef,longload); + ibansistringdef : hp:=new(pstringdef,ansiload); + ibwidestringdef : hp:=new(pstringdef,wideload); + ibrecorddef : hp:=new(precorddef,load); + ibobjectdef : hp:=new(pobjectdef,load); + ibenumdef : hp:=new(penumdef,load); + ibsetdef : hp:=new(psetdef,load); + ibprocvardef : hp:=new(pprocvardef,load); + ibfiledef : hp:=new(pfiledef,load); + ibclassrefdef : hp:=new(pclassrefdef,load); + ibformaldef : hp:=new(pformaldef,load); + ibenddefs : break; + ibend : Message(unit_f_ppu_read_error); + else + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + hp^.owner:=@self; + defindex^.insert(hp); + until false; + end; + + + procedure tsymtable.loadsyms; + var + b : byte; + sym : psym; + begin + { load start of definition section, which holds the amount of defs } + if current_ppu^.readentry<>ibstartsyms then + Message(unit_f_ppu_read_error); + { skip amount of symbols, not used currently } + current_ppu^.getlongint; + { load datasize,dataalignment of this symboltable } + datasize:=current_ppu^.getlongint; + dataalignment:=current_ppu^.getlongint; + { now read the symbols } + repeat + b:=current_ppu^.readentry; + case b of + ibtypesym : sym:=new(ptypesym,load); + ibprocsym : sym:=new(pprocsym,load); + ibconstsym : sym:=new(pconstsym,load); + ibvarsym : sym:=new(pvarsym,load); + ibfuncretsym : sym:=new(pfuncretsym,load); + ibabsolutesym : sym:=new(pabsolutesym,load); + ibenumsym : sym:=new(penumsym,load); + ibtypedconstsym : sym:=new(ptypedconstsym,load); + ibpropertysym : sym:=new(ppropertysym,load); + ibunitsym : sym:=new(punitsym,load); + iblabelsym : sym:=new(plabelsym,load); + ibsyssym : sym:=new(psyssym,load); + ibendsyms : break; + ibend : Message(unit_f_ppu_read_error); + else + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + sym^.owner:=@self; + symindex^.insert(sym); + symsearch^.insert(sym); + until false; + end; + + + procedure tsymtable.writedefs; + var + pd : pdef; + begin + { each definition get a number, write then the amount of defs to the + ibstartdef entry } + current_ppu^.putlongint(defindex^.count); + current_ppu^.writeentry(ibstartdefs); + { now write the definition } + pd:=pdef(defindex^.first); + while assigned(pd) do + begin + pd^.write; + pd:=pdef(pd^.next); + end; + { write end of definitions } + current_ppu^.writeentry(ibenddefs); + end; + + + procedure tsymtable.writesyms; + var + pd : psym; + begin + { each definition get a number, write then the amount of syms and the + datasize to the ibsymdef entry } + current_ppu^.putlongint(symindex^.count); + current_ppu^.putlongint(datasize); + current_ppu^.putlongint(dataalignment); + current_ppu^.writeentry(ibstartsyms); + { foreach is used to write all symbols } + pd:=psym(symindex^.first); + while assigned(pd) do + begin + pd^.write; + pd:=psym(pd^.next); + end; + { end of symbols } + current_ppu^.writeentry(ibendsyms); + end; + + + procedure tsymtable.deref; + var + hp : pdef; + hs : psym; + begin + { first deref the ttypesyms } + hs:=psym(symindex^.first); + while assigned(hs) do + begin + hs^.prederef; + hs:=psym(hs^.next); + end; + { deref the definitions } + hp:=pdef(defindex^.first); + while assigned(hp) do + begin + hp^.deref; + hp:=pdef(hp^.next); + end; + { deref the symbols } + hs:=psym(symindex^.first); + while assigned(hs) do + begin + hs^.deref; + hs:=psym(hs^.next); + end; + end; + + { this procedure is reserved for inserting case variant into + a record symtable } + { the offset is the location of the start of the variant + and datasize and dataalignment corresponds to + the complete size (see code in pdecl unit) PM } + procedure tsymtable.insert_in(psymt : psymtable;offset : longint); + var + ps,nps : pvarsym; + pd,npd : pdef; + storesize,storealign : longint; + begin + storesize:=psymt^.datasize; + storealign:=psymt^.dataalignment; + psymt^.datasize:=offset; + ps:=pvarsym(symindex^.first); + while assigned(ps) do + begin + { this is used to insert case variant into the main + record } + psymt^.datasize:=ps^.address+offset; + nps:=pvarsym(ps^.next); + symindex^.deleteindex(ps); + ps^.next:=nil; + ps^.left:=nil; + ps^.right:=nil; + psymt^.insert(ps); + ps:=nps; + end; + pd:=pdef(defindex^.first); + while assigned(pd) do + begin + npd:=pdef(pd^.next); + defindex^.deleteindex(pd); + pd^.next:=nil; + pd^.left:=nil; + pd^.right:=nil; + psymt^.registerdef(pd); + pd:=npd; + end; + psymt^.datasize:=storesize; + psymt^.dataalignment:=storealign; + end; + + constructor tsymtable.loadas(typ : tsymtabletype); + var + storesymtable : psymtable; + st_loading : boolean; + begin + st_loading:=in_loading; + in_loading:=true; + symtabletype:=typ; + new(symindex,init(indexgrowsize)); + new(defindex,init(indexgrowsize)); + new(symsearch,init); + symsearch^.noclear:=true; + { reset } + defowner:=nil; + name:=nil; + if typ=parasymtable then + dataalignment:=4 + else + dataalignment:=1; + datasize:=0; + address_fixup:= 0; + unitid:=0; + { setup symtabletype specific things } + case typ of + unitsymtable : + begin + symtablelevel:=0; +{$ifndef NEWMAP} + current_module^.map^[0]:=@self; +{$else NEWMAP} + current_module^.globalsymtable:=@self; +{$endif NEWMAP} + end; + recordsymtable, + objectsymtable : + begin + storesymtable:=aktrecordsymtable; + aktrecordsymtable:=@self; + end; + parasymtable, + localsymtable : + begin + storesymtable:=aktlocalsymtable; + aktlocalsymtable:=@self; + end; + { used for local browser } + staticppusymtable : + begin + aktstaticsymtable:=@self; + symsearch^.usehash; + end; + end; + + { we need the correct symtable for registering } + if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then + begin + next:=symtablestack; + symtablestack:=@self; + end; + + { load definitions } + loaddefs; + + { load symbols } + loadsyms; + + if not (typ in [localsymtable,parasymtable,recordsymtable,objectsymtable]) then + begin + { now we can deref the syms and defs } + deref; + { restore symtablestack } + symtablestack:=next; + end; + + case typ of + unitsymtable : + begin +{$ifdef NEWMAP} + { necessary for dependencies } + current_module^.globalsymtable:=nil; +{$endif NEWMAP} + end; + recordsymtable, + objectsymtable : + aktrecordsymtable:=storesymtable; + localsymtable, + parasymtable : + aktlocalsymtable:=storesymtable; + end; + + in_loading:=st_loading; + end; + + + procedure tsymtable.writeas; + var + oldtyp : byte; + storesymtable : psymtable; + begin + storesymtable:=aktrecordsymtable; + case symtabletype of + recordsymtable, + objectsymtable : + begin + storesymtable:=aktrecordsymtable; + aktrecordsymtable:=@self; + oldtyp:=current_ppu^.entrytyp; + current_ppu^.entrytyp:=subentryid; + end; + parasymtable, + localsymtable : + begin + storesymtable:=aktlocalsymtable; + aktlocalsymtable:=@self; + end; + end; + { order procsym overloads } + foreach({$ifndef TP}@{$endif}Order_overloads); + { write definitions } + writedefs; + { write symbols } + writesyms; + case symtabletype of + recordsymtable, + objectsymtable : + begin + current_ppu^.entrytyp:=oldtyp; + aktrecordsymtable:=storesymtable; + end; + localsymtable, + parasymtable : + aktlocalsymtable:=storesymtable; + end; + end; + + +{*********************************************** + Get Symbol / Def by Number +***********************************************} + + function tsymtable.getsymnr(l : longint) : psym; + var + hp : psym; + begin + hp:=psym(symindex^.search(l)); + if hp=nil then + internalerror(10999); + getsymnr:=hp; + end; + + function tsymtable.getdefnr(l : longint) : pdef; + var + hp : pdef; + begin + hp:=pdef(defindex^.search(l)); + if hp=nil then + internalerror(10998); + getdefnr:=hp; + end; + + +{*********************************************** + Table Access +***********************************************} + + procedure tsymtable.clear; + begin + { remove no entry from a withsymtable as it is only a pointer to the + recorddef or objectdef symtable } + if symtabletype=withsymtable then + exit; + symindex^.clear; + defindex^.clear; + end; + + + procedure tsymtable.insert(sym:psym); + var + hp : psymtable; + hsym : psym; + begin + { set owner and sym indexnb } + sym^.owner:=@self; +{$ifdef CHAINPROCSYMS} + { set the nextprocsym field } + if sym^.typ=procsym then + chainprocsym(sym); +{$endif CHAINPROCSYMS} + { writes the symbol in data segment if required } + { also sets the datasize of owner } + if not in_loading then + sym^.insert_in_data; + if (symtabletype in [staticsymtable,globalsymtable]) then + begin + hp:=symtablestack; + while assigned(hp) do + begin + if hp^.symtabletype in [staticsymtable,globalsymtable] then + begin + hsym:=hp^.search(sym^.name); + if assigned(hsym) then + DuplicateSym(hsym); + end; + hp:=hp^.next; + end; + end; + { check the current symtable } + hsym:=search(sym^.name); + if assigned(hsym) then + begin + { in TP and Delphi you can have a local with the + same name as the function, the function is then hidden for + the user. (Under delphi it can still be accessed using result), + but don't allow hiding of RESULT } + if (m_tp in aktmodeswitches) and + (hsym^.typ=funcretsym) and + not((m_result in aktmodeswitches) and + (hsym^.name='RESULT')) then + hsym^.owner^.rename(hsym^.name,'hidden'+hsym^.name) + else + begin + DuplicateSym(hsym); + exit; + end; + end; + { check for duplicate id in local and parasymtable symtable } + if (symtabletype=localsymtable) then + { to be on the save side: } + begin + if assigned(next) and + (next^.symtabletype=parasymtable) then + begin + hsym:=next^.search(sym^.name); + if assigned(hsym) then + begin + { a parameter and the function can have the same + name in TP and Delphi, but RESULT not } + if (m_tp in aktmodeswitches) and + (sym^.typ=funcretsym) and + not((m_result in aktmodeswitches) and + (sym^.name='RESULT')) then + sym^.setname('hidden'+sym^.name) + else + begin + DuplicateSym(hsym); + exit; + end; + end; + end + else if (current_module^.flags and uf_local_browser)=0 then + internalerror(43789); + end; + + { check for duplicate id in local symtable of methods } + if (symtabletype=localsymtable) and + assigned(next) and + assigned(next^.next) and + { funcretsym is allowed !! } + (sym^.typ <> funcretsym) and + (next^.next^.symtabletype=objectsymtable) then + begin + hsym:=search_class_member(pobjectdef(next^.next^.defowner),sym^.name); + if assigned(hsym) and + { private ids can be reused } + (not(sp_private in hsym^.symoptions) or + (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then + begin + { delphi allows to reuse the names in a class, but not + in object (tp7 compatible) } + if not((m_delphi in aktmodeswitches) and + (pobjectdef(next^.next^.defowner)^.is_class)) then + begin + DuplicateSym(hsym); + exit; + end; + end; + end; + { check for duplicate id in para symtable of methods } + if (symtabletype=parasymtable) and + assigned(procinfo^._class) and + { but not in nested procedures !} + (not(assigned(procinfo^.parent)) or + (assigned(procinfo^.parent) and + not(assigned(procinfo^.parent^._class))) + ) and + { funcretsym is allowed !! } + (sym^.typ <> funcretsym) then + begin + hsym:=search_class_member(procinfo^._class,sym^.name); + if assigned(hsym) and + { private ids can be reused } + (not(sp_private in hsym^.symoptions) or + (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then + begin + { delphi allows to reuse the names in a class, but not + in object (tp7 compatible) } + if not((m_delphi in aktmodeswitches) and + (procinfo^._class^.is_class)) then + begin + DuplicateSym(hsym); + exit; + end; + end; + end; + { check for duplicate field id in inherited classes } + if (sym^.typ=varsym) and + (symtabletype=objectsymtable) and + assigned(defowner) then + begin + hsym:=search_class_member(pobjectdef(defowner),sym^.name); + { but private ids can be reused } + if assigned(hsym) and + (not(sp_private in hsym^.symoptions) or + (hsym^.owner^.defowner^.owner^.symtabletype<>unitsymtable)) then + begin + DuplicateSym(hsym); + exit; + end; + end; + { register definition of typesym } + if (sym^.typ = typesym) and + assigned(ptypesym(sym)^.restype.def) then + begin + if not(assigned(ptypesym(sym)^.restype.def^.owner)) and + (ptypesym(sym)^.restype.def^.deftype<>errordef) then + registerdef(ptypesym(sym)^.restype.def); +{$ifdef GDB} + if (cs_debuginfo in aktmoduleswitches) and assigned(debuglist) and + (symtabletype in [globalsymtable,staticsymtable]) then + begin + ptypesym(sym)^.isusedinstab := true; + sym^.concatstabto(debuglist); + end; +{$endif GDB} + end; + { insert in index and search hash } + symindex^.insert(sym); + symsearch^.insert(sym); + end; + + + function tsymtable.search(const s : stringid) : psym; + begin + {search:=psym(symsearch^.search(s)); + this bypasses the ref generation (PM) } + search:=speedsearch(s,getspeedvalue(s)); + end; + + + function tsymtable.speedsearch(const s : stringid;speedvalue : longint) : psym; + var + hp : psym; + newref : pref; + begin + hp:=psym(symsearch^.speedsearch(s,speedvalue)); + if assigned(hp) then + begin + { reject non static members in static procedures, + be carefull aktprocsym^.definition is not allways + loaded already (PFV) } + if (symtabletype=objectsymtable) and + not(sp_static in hp^.symoptions) and + allow_only_static + {assigned(aktprocsym) and + assigned(aktprocsym^.definition) and + ((aktprocsym^.definition^.options and postaticmethod)<>0)} then + Message(sym_e_only_static_in_static); + if (symtabletype=unitsymtable) and + assigned(punitsymtable(@self)^.unitsym) then + inc(punitsymtable(@self)^.unitsym^.refs); + { unitsym are only loaded for browsing PM } + { this was buggy anyway because we could use } + { unitsyms from other units in _USES !! } + {if (symtabletype=unitsymtable) and (hp^.typ=unitsym) and + assigned(current_module) and (current_module^.globalsymtable<>@self) then + hp:=nil;} + if assigned(hp) and + (cs_browser in aktmoduleswitches) and make_ref then + begin + new(newref,init(hp^.lastref,@tokenpos)); + { for symbols that are in tables without + browser info or syssyms (PM) } + if hp^.refcount=0 then + begin + hp^.defref:=newref; + hp^.lastref:=newref; + end + else + if resolving_forward and assigned(hp^.defref) then + { put it as second reference } + begin + newref^.nextref:=hp^.defref^.nextref; + hp^.defref^.nextref:=newref; + hp^.lastref^.nextref:=nil; + end + else + hp^.lastref:=newref; + inc(hp^.refcount); + end; + if assigned(hp) and make_ref then + begin + inc(hp^.refs); + end; + end; + speedsearch:=hp; + end; + + + function tsymtable.rename(const olds,news : stringid):psym; + begin + rename:=psym(symsearch^.rename(olds,news)); + end; + + +{*********************************************** + Browser +***********************************************} + + procedure tsymtable.load_browser; + var + b : byte; + sym : psym; + prdef : pdef; + oldrecsyms : psymtable; + begin + if symtabletype in [recordsymtable,objectsymtable] then + begin + oldrecsyms:=aktrecordsymtable; + aktrecordsymtable:=@self; + end; + if symtabletype in [parasymtable,localsymtable] then + begin + oldrecsyms:=aktlocalsymtable; + aktlocalsymtable:=@self; + end; + if symtabletype=staticppusymtable then + aktstaticsymtable:=@self; + b:=current_ppu^.readentry; + if b <> ibbeginsymtablebrowser then + Message1(unit_f_ppu_invalid_entry,tostr(b)); + repeat + b:=current_ppu^.readentry; + case b of + ibsymref : begin + sym:=readsymref; + resolvesym(sym); + if assigned(sym) then + sym^.load_references; + end; + ibdefref : begin + prdef:=readdefref; + resolvedef(prdef); + if assigned(prdef) then + begin + if prdef^.deftype<>procdef then + Message(unit_f_ppu_read_error); + pprocdef(prdef)^.load_references; + end; + end; + ibendsymtablebrowser : break; + else + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + until false; + if symtabletype in [recordsymtable,objectsymtable] then + aktrecordsymtable:=oldrecsyms; + if symtabletype in [parasymtable,localsymtable] then + aktlocalsymtable:=oldrecsyms; + end; + + + procedure tsymtable.write_browser; + var + oldrecsyms : psymtable; + begin + { symbol numbering for references + should have been done in write PM + number_symbols; + number_defs; } + + if symtabletype in [recordsymtable,objectsymtable] then + begin + oldrecsyms:=aktrecordsymtable; + aktrecordsymtable:=@self; + end; + if symtabletype in [parasymtable,localsymtable] then + begin + oldrecsyms:=aktlocalsymtable; + aktlocalsymtable:=@self; + end; + current_ppu^.writeentry(ibbeginsymtablebrowser); + foreach({$ifndef TP}@{$endif}write_refs); + current_ppu^.writeentry(ibendsymtablebrowser); + if symtabletype in [recordsymtable,objectsymtable] then + aktrecordsymtable:=oldrecsyms; + if symtabletype in [parasymtable,localsymtable] then + aktlocalsymtable:=oldrecsyms; + end; + + +{$ifdef BrowserLog} + procedure tsymtable.writebrowserlog; + begin + if cs_browser in aktmoduleswitches then + begin + if assigned(name) then + Browserlog.AddLog('---Symtable '+name^) + else + begin + if (symtabletype=recordsymtable) and + assigned(defowner^.typesym) then + Browserlog.AddLog('---Symtable '+defowner^.typesym^.name) + else + Browserlog.AddLog('---Symtable with no name'); + end; + Browserlog.Ident; + foreach({$ifndef TP}@{$endif}add_to_browserlog); + browserlog.Unident; + end; + end; +{$endif BrowserLog} + + +{*********************************************** + Process all entries +***********************************************} + + { checks, if all procsyms and methods are defined } + procedure tsymtable.check_forwards; + begin + foreach({$ifndef TP}@{$endif}check_forward); + end; + + procedure tsymtable.checklabels; + begin + foreach({$ifndef TP}@{$endif}labeldefined); + end; + + procedure tsymtable.set_alignment(_alignment : longint); + var + sym : pvarsym; + l : longint; + begin + dataalignment:=_alignment; + if (symtabletype<>parasymtable) then + internalerror(1111); + sym:=pvarsym(symindex^.first); + datasize:=0; + { there can be only varsyms } + while assigned(sym) do + begin + l:=sym^.getpushsize; + sym^.address:=datasize; + datasize:=align(datasize+l,dataalignment); + sym:=pvarsym(sym^.next); + end; + end; + + function tsymtable.find_at_offset(l : longint) : pvarsym; + var + sym : pvarsym; + begin + find_at_offset:=nil; + { this can not be done if there is an + hasharray ! } + if (symtabletype<>parasymtable) then + internalerror(1111); + sym:=pvarsym(symindex^.first); + while assigned(sym) do + begin + if sym^.address+address_fixup=l then + begin + find_at_offset:=sym; + exit; + end; + sym:=pvarsym(sym^.next); + end; + end; + + procedure tsymtable.allunitsused; + begin + foreach({$ifndef TP}@{$endif}unitsymbolused); + end; + + procedure tsymtable.allsymbolsused; + begin + foreach({$ifndef TP}@{$endif}varsymbolused); + end; + + procedure tsymtable.allprivatesused; + begin + foreach({$ifndef TP}@{$endif}objectprivatesymbolused); + end; + +{$ifdef CHAINPROCSYMS} + procedure tsymtable.chainprocsyms; + begin + foreach({$ifndef TP}@{$endif}chainprocsym); + end; +{$endif CHAINPROCSYMS} + +{$ifdef GDB} + procedure tsymtable.concatstabto(asmlist : paasmoutput); + begin + asmoutput:=asmlist; + if symtabletype in [inlineparasymtable,inlinelocalsymtable] then + foreach({$ifndef TP}@{$endif}resetstab); + + foreach({$ifndef TP}@{$endif}concatstab); + end; +{$endif} + + +{**************************************************************************** + TUNITSYMTABLE +****************************************************************************} + + constructor tunitsymtable.init(t : tsymtabletype; const n : string); + begin + inherited init(t); + name:=stringdup(upper(n)); + unitid:=0; + unitsym:=nil; + symsearch^.usehash; + { reset GDB things } +{$ifdef GDB} + if (t = globalsymtable) then + begin + prev_dbx_counter := dbx_counter; + dbx_counter := nil; + end; + is_stab_written:=false; + dbx_count := -1; + if cs_gdb_dbx in aktglobalswitches then + begin + dbx_count := 0; + unittypecount:=1; + if (symtabletype=globalsymtable) then + pglobaltypecount := @unittypecount; + unitid:=current_module^.unitcount; + debuglist^.concat(new(pai_asm_comment,init(strpnew('Global '+name^+' has index '+tostr(unitid))))); + debuglist^.concat(new(pai_stabs,init(strpnew('"'+name^+'",'+tostr(N_BINCL)+',0,0,0')))); + inc(current_module^.unitcount); + dbx_count_ok:=false; + dbx_counter:=@dbx_count; + do_count_dbx:=true; + end; +{$endif GDB} + end; + + + constructor tunitsymtable.loadasunit; + var + storeGlobalTypeCount : pword; + b : byte; + begin + unitsym:=nil; + unitid:=0; +{$ifdef GDB} + if cs_gdb_dbx in aktglobalswitches then + begin + UnitTypeCount:=1; + storeGlobalTypeCount:=PGlobalTypeCount; + PglobalTypeCount:=@UnitTypeCount; + end; +{$endif GDB} + + { load symtables } + inherited loadas(unitsymtable); + + { set the name after because it is set to nil in tsymtable.load !! } + name:=stringdup(current_module^.modulename^); + + { dbx count } +{$ifdef GDB} + if (current_module^.flags and uf_has_dbx)<>0 then + begin + b := current_ppu^.readentry; + if b <> ibdbxcount then + Message(unit_f_ppu_dbx_count_problem) + else + dbx_count := readlong; + dbx_count_ok := {true}false; + end + else + begin + dbx_count := -1; + dbx_count_ok:=false; + end; + if cs_gdb_dbx in aktglobalswitches then + PGlobalTypeCount:=storeGlobalTypeCount; + is_stab_written:=false; +{$endif GDB} + + b:=current_ppu^.readentry; + if b<>ibendimplementation then + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + + + destructor tunitsymtable.done; + var + pus : punitsym; + begin + pus:=unitsym; + while assigned(pus) do + begin + unitsym:=pus^.prevsym; + pus^.prevsym:=nil; + pus^.unitsymtable:=nil; + pus:=unitsym; + end; + inherited done; + end; + + procedure tunitsymtable.load_symtable_refs; + var + b : byte; + unitindex : word; + begin + if ((current_module^.flags and uf_local_browser)<>0) then + begin + current_module^.localsymtable:=new(punitsymtable,loadas(staticppusymtable)); + psymtable(current_module^.localsymtable)^.name:= + stringdup('implementation of '+psymtable(current_module^.globalsymtable)^.name^); + end; + { load browser } + if (current_module^.flags and uf_has_browser)<>0 then + begin + {if not (cs_browser in aktmoduleswitches) then + current_ppu^.skipuntilentry(ibendbrowser) + else } + begin + load_browser; + unitindex:=1; + while assigned(current_module^.map^[unitindex]) do + begin + {each unit wrote one browser entry } + load_browser; + inc(unitindex); + end; + b:=current_ppu^.readentry; + if b<>ibendbrowser then + Message1(unit_f_ppu_invalid_entry,tostr(b)); + end; + end; + if ((current_module^.flags and uf_local_browser)<>0) then + psymtable(current_module^.localsymtable)^.load_browser; + end; + + + procedure tunitsymtable.writeasunit; + var + pu : pused_unit; + begin + { first the unitname } + current_ppu^.putstring(name^); + current_ppu^.writeentry(ibmodulename); + + writesourcefiles; + writeusedmacros; + + writeusedunit; + + { write the objectfiles and libraries that come for this unit, + preserve the containers becuase they are still needed to load + the link.res. All doesn't depend on the crc! It doesn't matter + if a unit is in a .o or .a file } + current_ppu^.do_crc:=false; + writelinkcontainer(current_module^.linkunitofiles,iblinkunitofiles,true); + writelinkcontainer(current_module^.linkunitstaticlibs,iblinkunitstaticlibs,true); + writelinkcontainer(current_module^.linkunitsharedlibs,iblinkunitsharedlibs,true); + writelinkcontainer(current_module^.linkotherofiles,iblinkotherofiles,false); + writelinkcontainer(current_module^.linkotherstaticlibs,iblinkotherstaticlibs,true); + writelinkcontainer(current_module^.linkothersharedlibs,iblinkothersharedlibs,true); + current_ppu^.do_crc:=true; + + current_ppu^.writeentry(ibendinterface); + + { write the symtable entries } + inherited writeas; + + { all after doesn't affect crc } + current_ppu^.do_crc:=false; + + { write dbx count } +{$ifdef GDB} + if cs_gdb_dbx in aktglobalswitches then + begin +{$IfDef EXTDEBUG} + writeln('Writing dbx_count ',dbx_count,' in unit ',name^,'.ppu'); +{$ENDIF EXTDEBUG} + current_ppu^.putlongint(dbx_count); + current_ppu^.writeentry(ibdbxcount); + end; +{$endif GDB} + + current_ppu^.writeentry(ibendimplementation); + + { write static symtable + needed for local debugging of unit functions } + if ((current_module^.flags and uf_local_browser)<>0) and + assigned(current_module^.localsymtable) then + psymtable(current_module^.localsymtable)^.writeas; + { write all browser section } + if (current_module^.flags and uf_has_browser)<>0 then + begin + write_browser; + pu:=pused_unit(current_module^.used_units.first); + while assigned(pu) do + begin + psymtable(pu^.u^.globalsymtable)^.write_browser; + pu:=pused_unit(pu^.next); + end; + current_ppu^.writeentry(ibendbrowser); + end; + if ((current_module^.flags and uf_local_browser)<>0) and + assigned(current_module^.localsymtable) then + psymtable(current_module^.localsymtable)^.write_browser; + + { the last entry ibend is written automaticly } + end; + + + function tunitsymtable.getnewtypecount : word; + + begin +{$ifdef GDB} + if not (cs_gdb_dbx in aktglobalswitches) then + getnewtypecount:=tsymtable.getnewtypecount + else +{$endif GDB} + if symtabletype = staticsymtable then + getnewtypecount:=tsymtable.getnewtypecount + else + begin + getnewtypecount:=unittypecount; + inc(unittypecount); + end; + end; + + +{$ifdef GDB} + + procedure tunitsymtable.concattypestabto(asmlist : paasmoutput); + var prev_dbx_count : plongint; + begin + if is_stab_written then exit; + if not assigned(name) then name := stringdup('Main_program'); + if (symtabletype = unitsymtable) and + (current_module^.globalsymtable<>@Self) then + begin + unitid:=current_module^.unitcount; + inc(current_module^.unitcount); + end; + asmlist^.concat(new(pai_asm_comment,init(strpnew('Begin unit '+name^ + +' has index '+tostr(unitid))))); + if cs_gdb_dbx in aktglobalswitches then + begin + if dbx_count_ok then + begin + asmlist^.concat(new(pai_asm_comment,init(strpnew('"repeated" unit '+name^ + +' has index '+tostr(unitid)+' dbx count = '+tostr(dbx_count))))); + asmlist^.concat(new(pai_stabs,init(strpnew('"'+name^+'",' + +tostr(N_EXCL)+',0,0,'+tostr(dbx_count))))); + exit; + end + else if (current_module^.globalsymtable<>@Self) then + begin + prev_dbx_count := dbx_counter; + dbx_counter := nil; + do_count_dbx:=false; + if symtabletype = unitsymtable then + asmlist^.concat(new(pai_stabs,init(strpnew('"'+name^+'",' + +tostr(N_BINCL)+',0,0,0')))); + dbx_counter := @dbx_count; + dbx_count:=0; + do_count_dbx:=assigned(dbx_counter); + end; + end; + asmoutput:=asmlist; + foreach({$ifndef TP}@{$endif}concattypestab); + if cs_gdb_dbx in aktglobalswitches then + begin + if (current_module^.globalsymtable<>@Self) then + begin + dbx_counter := prev_dbx_count; + do_count_dbx:=false; + asmlist^.concat(new(pai_asm_comment,init(strpnew('End unit '+name^ + +' has index '+tostr(unitid))))); + asmlist^.concat(new(pai_stabs,init(strpnew('"'+name^+'",' + +tostr(N_EINCL)+',0,0,0')))); + do_count_dbx:=assigned(dbx_counter); + dbx_count_ok := {true}false; + end; + end; + is_stab_written:=true; + end; +{$endif} + +{**************************************************************************** + Definitions +****************************************************************************} + +{$I symdef.inc} + +{**************************************************************************** + Symbols +****************************************************************************} + +{$I symsym.inc} + +{**************************************************************************** + GDB Helpers +****************************************************************************} + +{$ifdef GDB} + function typeglobalnumber(const s : string) : string; + + var st : string; + symt : psymtable; + old_make_ref : boolean; + begin + old_make_ref:=make_ref; + make_ref:=false; + typeglobalnumber := '0'; + srsym := nil; + if pos('.',s) > 0 then + begin + st := copy(s,1,pos('.',s)-1); + getsym(st,false); + st := copy(s,pos('.',s)+1,255); + if assigned(srsym) then + begin + if srsym^.typ = unitsym then + begin + symt := punitsym(srsym)^.unitsymtable; + srsym := symt^.search(st); + end else srsym := nil; + end; + end else st := s; + if srsym = nil then getsym(st,true); + if srsym^.typ<>typesym then + begin + Message(type_e_type_id_expected); + exit; + end; + typeglobalnumber := ptypesym(srsym)^.restype.def^.numberstring; + make_ref:=old_make_ref; + end; +{$endif GDB} + + +{**************************************************************************** + Definition Helpers +****************************************************************************} + + procedure reset_global_defs; + var + def : pdef; +{$ifdef debug} + prevdef : pdef; +{$endif debug} + begin +{$ifdef debug} + prevdef:=nil; +{$endif debug} +{$ifdef GDB} + pglobaltypecount:=@globaltypecount; +{$endif GDB} + def:=firstglobaldef; + while assigned(def) do + begin +{$ifdef GDB} + if assigned(def^.typesym) then + def^.typesym^.isusedinstab:=false; + def^.is_def_stab_written:=false; +{$endif GDB} + {if not current_module^.in_implementation then} + begin + { reset rangenr's } + case def^.deftype of + orddef : porddef(def)^.rangenr:=0; + enumdef : penumdef(def)^.rangenr:=0; + arraydef : parraydef(def)^.rangenr:=0; + end; + if def^.deftype<>objectdef then + def^.has_rtti:=false; + def^.has_inittable:=false; + end; +{$ifdef debug} + prevdef:=def; +{$endif debug} + def:=def^.nextglobal; + end; + end; + + +{**************************************************************************** + Object Helpers +****************************************************************************} + + function search_class_member(pd : pobjectdef;const n : string) : psym; + { searches n in symtable of pd and all anchestors } + var + sym : psym; + begin + sym:=nil; + while assigned(pd) do + begin + sym:=pd^.symtable^.search(n); + if assigned(sym) then + break; + pd:=pd^.childof; + end; + { this is needed for static methods in do_member_read pexpr unit PM + caused bug0214 } + if assigned(sym) then + begin + srsymtable:=pd^.symtable; + end; + search_class_member:=sym; + end; + + var + _defaultprop : ppropertysym; + + procedure testfordefaultproperty(p : pnamedindexobject); + begin + if (psym(p)^.typ=propertysym) and + (ppo_defaultproperty in ppropertysym(p)^.propoptions) then + _defaultprop:=ppropertysym(p); + end; + + + function search_default_property(pd : pobjectdef) : ppropertysym; + { returns the default property of a class, searches also anchestors } + begin + _defaultprop:=nil; + while assigned(pd) do + begin + pd^.symtable^.foreach({$ifndef TP}@{$endif}testfordefaultproperty); + if assigned(_defaultprop) then + break; + pd:=pd^.childof; + end; + search_default_property:=_defaultprop; + end; + + +{**************************************************************************** + Macro's +****************************************************************************} + + procedure def_macro(const s : string); + var + mac : pmacrosym; + begin + mac:=pmacrosym(macros^.search(s)); + if mac=nil then + begin + mac:=new(pmacrosym,init(s)); + Message1(parser_m_macro_defined,mac^.name); + macros^.insert(mac); + end; + mac^.defined:=true; + mac^.defined_at_startup:=true; + end; + + + procedure set_macro(const s : string;value : string); + var + mac : pmacrosym; + begin + mac:=pmacrosym(macros^.search(s)); + if mac=nil then + begin + mac:=new(pmacrosym,init(s)); + macros^.insert(mac); + end + else + begin + if assigned(mac^.buftext) then + freemem(mac^.buftext,mac^.buflen); + end; + Message2(parser_m_macro_set_to,mac^.name,value); + mac^.buflen:=length(value); + getmem(mac^.buftext,mac^.buflen); + move(value[1],mac^.buftext^,mac^.buflen); + mac^.defined:=true; + mac^.defined_at_startup:=true; + end; + + +{$ifdef UNITALIASES} +{**************************************************************************** + TUNIT_ALIAS + ****************************************************************************} + + constructor tunit_alias.init(const n:string); + var + i : longint; + begin + i:=pos('=',n); + if i=0 then + fail; + inherited initname(Copy(n,1,i-1)); + newname:=stringdup(Copy(n,i+1,255)); + end; + + + destructor tunit_alias.done; + begin + stringdispose(newname); + inherited done; + end; + + + procedure addunitalias(const n:string); + begin + unitaliases^.insert(new(punit_alias,init(Upper(n)))); + end; + + + function getunitalias(const n:string):string; + var + p : punit_alias; + begin + p:=punit_alias(unitaliases^.search(Upper(n))); + if assigned(p) then + getunitalias:=punit_alias(p)^.newname^ + else + getunitalias:=n; + end; +{$endif UNITALIASES} + + +{**************************************************************************** + Symtable Stack +****************************************************************************} + + procedure dellexlevel; + var + p : psymtable; + begin + p:=symtablestack; + symtablestack:=p^.next; + { symbol tables of unit interfaces are never disposed } + { this is handle by the unit unitm } + if not(p^.symtabletype in [unitsymtable,globalsymtable,stt_exceptsymtable]) or dispose_global then + dispose(p,done); + end; + + procedure RestoreUnitSyms; + var + p : psymtable; + begin + p:=symtablestack; + while assigned(p) do + begin + if (p^.symtabletype=unitsymtable) and + assigned(punitsymtable(p)^.unitsym) and + ((punitsymtable(p)^.unitsym^.owner=psymtable(current_module^.globalsymtable)) or + (punitsymtable(p)^.unitsym^.owner=psymtable(current_module^.localsymtable))) then + punitsymtable(p)^.unitsym^.restoreunitsym; + p:=p^.next; + end; + end; + +{$ifdef DEBUG} + procedure test_symtablestack; + var + p : psymtable; + i : longint; + begin + p:=symtablestack; + i:=0; + while assigned(p) do + begin + inc(i); + p:=p^.next; + if i>500 then + Message(sym_f_internal_error_in_symtablestack); + end; + end; + + procedure list_symtablestack; + var + p : psymtable; + i : longint; + begin + p:=symtablestack; + i:=0; + while assigned(p) do + begin + inc(i); + writeln(i,' ',p^.name^); + p:=p^.next; + if i>500 then + Message(sym_f_internal_error_in_symtablestack); + end; + end; +{$endif DEBUG} + + +{**************************************************************************** + Init/Done Symtable +****************************************************************************} + +{$ifndef Delphi} +{$ifdef tp} + procedure do_streamerror; + begin + if symbolstream.status=-2 then + WriteLn('Error: Not enough EMS memory') + else + WriteLn('Error: EMS Error ',symbolstream.status); + halt(1); + end; +{$endif TP} +{$endif Delphi} + + procedure InitSymtable; + var + token : ttoken; + begin +{$ifndef Delphi} +{$ifdef TP} + { Allocate stream } + if use_big then + begin + streamerror:=@do_streamerror; + { symbolstream.init('TMPFILE',stcreate,16000); } + {$ifndef dpmi} + symbolstream.init(10000,4000000); {using ems streams} + {$else} + symbolstream.init(1000000,16000); {using memory streams} + {$endif} + if symbolstream.errorinfo=stiniterror then + do_streamerror; + { write something, because pos 0 means nil pointer } + symbolstream.writestr(@inputfile); + end; +{$endif tp} +{$endif Delphi} + { Reset symbolstack } + registerdef:=false; + read_member:=false; + symtablestack:=nil; + systemunit:=nil; +{$ifdef GDB} + firstglobaldef:=nil; + lastglobaldef:=nil; +{$endif GDB} + globaltypecount:=1; + pglobaltypecount:=@globaltypecount; + { create error syms and def } + generrorsym:=new(perrorsym,init); + generrordef:=new(perrordef,init); +{$ifdef UNITALIASES} + { unit aliases } + unitaliases:=new(pdictionary,init); +{$endif} + for token:=first_overloaded to last_overloaded do + overloaded_operators[token]:=nil; + end; + + + procedure DoneSymtable; + begin + dispose(generrorsym,done); + dispose(generrordef,done); +{$ifdef UNITALIASES} + dispose(unitaliases,done); +{$endif} +{$ifndef Delphi} +{$ifdef TP} + { close the stream } + if use_big then + symbolstream.done; +{$endif} +{$endif Delphi} + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.102 2000/07/03 09:48:23 pierre + * fix for bug 1019 + + Revision 1.101 2000/06/23 21:34:10 pierre + * align all variants to same start address + + Revision 1.100 2000/06/18 18:11:32 peter + * C record packing fixed to also check first entry of the record + if bigger than the recordalignment itself + * variant record alignment uses alignment per variant and saves the + highest alignment value + + Revision 1.99 2000/06/14 19:00:58 peter + * rename the result of a function to hide it instead of using setname + + Revision 1.98 2000/06/14 16:51:18 peter + * removed unused label i left in when testing + + Revision 1.97 2000/06/09 21:34:40 peter + * checking for dup id with para of methods fixed for delphi mode + + Revision 1.96 2000/06/05 20:41:17 pierre + + support for NOT overloading + + unsupported overloaded operators generate errors + + Revision 1.95 2000/06/02 21:17:26 pierre + fix bug in tbs/tbs0317 + + Revision 1.94 2000/06/02 18:48:48 florian + + fieldtable support for classes + + Revision 1.93 2000/06/01 19:07:52 peter + * delphi/tp mode fixes for dup id checking (tbs319,tbf320) + + Revision 1.92 2000/05/23 14:15:44 pierre + * fix for bug 959 + + Revision 1.91 2000/05/12 05:59:57 pierre + * * get it to compile with Delphi by Kovacs Attila Zoltan + + Revision 1.90 2000/05/11 09:40:12 pierre + * some DBX changes but it still does not work ! + + Revision 1.89 2000/05/03 14:34:05 pierre + * fix the unitsym chain + + Revision 1.88 2000/04/27 11:35:04 pierre + * power to ** operator fixed + + Revision 1.87 2000/04/27 10:06:04 pierre + * fix for snapshot failue + * order_overloaded reintrocduced and adapted to operators + + Revision 1.86 2000/04/26 08:54:19 pierre + * More changes for operator bug + Order_overloaded method removed because it conflicted with + new implementation where the defs are ordered + according to the unit loading order ! + + Revision 1.85 2000/04/25 23:55:30 pierre + + Hint about unused unit + * Testop bug fixed !! + Now the operators are only applied if the unit is explicitly loaded + + Revision 1.84 2000/04/24 12:45:44 peter + * made overloaded_operators local per unit, but it still doesn't work + correct + + Revision 1.83 2000/03/27 21:15:34 pierre + * fix bug 294 in a BP compatible way ie. hidding the function result + + Revision 1.82 2000/03/22 09:25:57 florian + * bug 294 fixed: parameters can have now the same name as the function/ + procedure, this is compatible with TP/Delphi + + Revision 1.81 2000/03/20 09:34:33 florian + * in delphi mode: method parameters can now have the same name as parameters + + Revision 1.80 2000/03/01 13:56:31 pierre + * fix for bug 840 + + Revision 1.79 2000/03/01 00:03:10 pierre + * fixes for locals in inlined procedures + fix for bug797 + + stabs generation for inlined paras and locals + + Revision 1.78 2000/02/20 20:49:45 florian + * newcg is compiling + * fixed the dup id problem reported by Paul Y. + + Revision 1.77 2000/02/11 13:53:49 pierre + * avoid stack overflow in tref.done (bug 846) + + Revision 1.76 2000/02/09 13:23:05 peter + * log truncated + + Revision 1.75 2000/01/12 10:38:18 peter + * smartlinking fixes for binary writer + * release alignreg code and moved instruction writing align to cpuasm, + but it doesn't use the specified register yet + + Revision 1.74 2000/01/09 00:37:56 pierre + * avoid testing object types that are simple aliases for unused privates + + Revision 1.73 2000/01/07 01:14:41 peter + * updated copyright to 2000 + + Revision 1.72 2000/01/03 19:26:04 peter + * fixed resolving of ttypesym which are reference from object/record + fields. + + Revision 1.71 1999/12/18 14:55:21 florian + * very basic widestring support + + Revision 1.70 1999/12/02 11:28:27 peter + * moved verbose to implementation uses + + Revision 1.69 1999/12/01 22:32:35 pierre + * give info of original duplicated symbol more often + + Revision 1.68 1999/11/30 10:40:56 peter + + ttype, tsymlist + + Revision 1.67 1999/11/24 11:41:05 pierre + * defaultsymtablestack is now restored after parser.compile + + Revision 1.66 1999/11/22 00:23:09 pierre + * also complain about unused functions in program + + Revision 1.65 1999/11/19 14:49:15 pierre + * avoid certain wrong notes/hints + + Revision 1.64 1999/11/18 15:34:48 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.63 1999/11/17 17:05:06 pierre + * Notes/hints changes + + Revision 1.62 1999/11/15 22:00:48 peter + * labels used but not defined give error instead of warning, the warning + is now only with declared but not defined and not used. + + Revision 1.61 1999/11/15 17:52:59 pierre + + one field added for ttoken record for operator + linking the id to the corresponding operator token that + can now now all be overloaded + * overloaded operators are resetted to nil in InitSymtable + (bug when trying to compile a uint that overloads operators twice) + + Revision 1.60 1999/11/09 23:35:50 pierre + + better reference pos for forward defs + + Revision 1.59 1999/11/06 16:21:57 jonas + + search optimial register to use in alignment code (compile with + -dalignreg, -dalignregdebug to see chosen register in + assembler code). Still needs support in ag386bin. + + Revision 1.58 1999/11/06 14:34:28 peter + * truncated log to 20 revs + + Revision 1.57 1999/11/05 17:18:03 pierre + * local browsing works at first level + ie for function defined in interface or implementation + not yet for functions inside other functions + + Revision 1.56 1999/11/04 23:13:25 peter + * moved unit alias support into ifdef + +} \ No newline at end of file diff --git a/befpc/compiler/systems.pas b/befpc/compiler/systems.pas new file mode 100644 index 0000000..6f56f2b --- /dev/null +++ b/befpc/compiler/systems.pas @@ -0,0 +1,1784 @@ +{ + $Id: systems.pas,v 1.1.1.1 2001-07-23 17:17:09 memson Exp $ + Copyright (C) 1998-2000 by Florian Klaempfl + + This unit contains information about the target systems supported + (these are not processor specific) + + This progsam is free software; you can redistribute it and/or modify + iu under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge- MA 02139, USA. + + **************************************************************************** +} +unit systems; + + interface + + type + tendian = (endian_little,endian_big); + + ttargetcpu=(no_cpu + ,i386,m68k,alpha,powerpc + ); + + tprocessors = (no_processor + ,Class386,ClassP5,ClassP6 + ,MC68000,MC68100,MC68020 + ); + + tsection=(sec_none, + sec_code,sec_data,sec_bss, + sec_idata2,sec_idata4,sec_idata5,sec_idata6,sec_idata7,sec_edata, + sec_stab,sec_stabstr + ); + + type + tasmmode= (asmmode_none + ,asmmode_i386_direct,asmmode_i386_att,asmmode_i386_intel + ,asmmode_m68k_mot,asmmode_alpha_direct,asmmode_powerpc_direct + ); + const + {$ifdef i386} i386asmmodecnt=3; {$else} i386asmmodecnt=0; {$endif} + {$ifdef m68k} m68kasmmodecnt=1; {$else} m68kasmmodecnt=0; {$endif} + {$ifdef alpha} alphaasmmodecnt=1; {$else} alphaasmmodecnt=0; {$endif} + {$ifdef powerpc} powerpcasmmodecnt=1; {$else} powerpcasmmodecnt=0; {$endif} + asmmodecnt=i386asmmodecnt+m68kasmmodecnt+Alphaasmmodecnt+powerpcasmmodecnt+1; + + type + ttarget = (target_none + ,target_i386_GO32V1,target_i386_GO32V2,target_i386_linux, + target_i386_OS2,target_i386_Win32,target_i386_BeOS + ,target_m68k_Amiga,target_m68k_Atari,target_m68k_Mac, + target_m68k_linux,target_m68k_PalmOS,target_alpha_linux, + target_powerpc_linux,target_powerpc_macos + ); + + ttargetflags = (tf_none, + tf_supports_stack_checking,tf_need_export,tf_needs_isconsole + ); + + const + { alias for supported_target field in tasminfo } + target_any = target_none; + + {$ifdef i386} i386targetcnt=6; {$else} i386targetcnt=0; {$endif} + {$ifdef m68k} m68ktargetcnt=5; {$else} m68ktargetcnt=0; {$endif} + {$ifdef alpha} alphatargetcnt=1; {$else} alphatargetcnt=0; {$endif} + {$ifdef powerpc} powerpctargetcnt=2; {$else} powerpctargetcnt=0; {$endif} + targetcnt=i386targetcnt+m68ktargetcnt+alphatargetcnt+powerpctargetcnt+1; + + type + tasm = (as_none + ,as_i386_as,as_i386_as_aout,as_i386_asw, + as_i386_nasmcoff,as_i386_nasmwin32, + as_i386_nasmelf,as_i386_nasmobj, + as_i386_tasm,as_i386_masm, + as_i386_dbg,as_i386_coff,as_i386_pecoff + ,as_m68k_as,as_m68k_gas,as_m68k_mit,as_m68k_mot,as_m68k_mpw, + as_alpha_as,as_powerpc_as,as_powerpc_mpw + ); + { binary assembler writers, needed to test for -a } + const + {$ifdef i386} i386asmcnt=12; {$else} i386asmcnt=0; {$endif} + {$ifdef m68k} m68kasmcnt=5; {$else} m68kasmcnt=0; {$endif} + {$ifdef alpha} alphaasmcnt=1; {$else} alphaasmcnt=0; {$endif} + {$ifdef powerpc} powerpcasmcnt=2; {$else} powerpcasmcnt=0; {$endif} + asmcnt=i386asmcnt+m68kasmcnt+alphaasmcnt+powerpcasmcnt+1; + + binassem : set of tasm = [ + as_i386_dbg,as_i386_coff,as_i386_pecoff + ]; + + type + tar = (ar_none + ,ar_i386_ar,ar_i386_arw + ,ar_m68k_ar,ar_alpha_ar,ar_powerpc_ar + ); + const + {$ifdef i386} i386arcnt=2; {$else} i386arcnt=0; {$endif} + {$ifdef m68k} m68karcnt=1; {$else} m68karcnt=0; {$endif} + {$ifdef alpha} alphaarcnt=1; {$else} alphaarcnt=0; {$endif} + {$ifdef powerpc} powerpcarcnt=1; {$else} powerpcarcnt=0; {$endif} + arcnt=i386arcnt+m68karcnt+alphaarcnt+powerpcarcnt+1; + + type + tres = (res_none + ,res_i386_windres,res_m68k_mpw,res_powerpc_mpw, res_i386_emx + ); + const + {$ifdef i386} i386rescnt=2; {$else} i386rescnt=0; {$endif} + {$ifdef m68k} m68krescnt=1; {$else} m68krescnt=0; {$endif} + {$ifdef alpha} alpharescnt=0; {$else} alpharescnt=0; {$endif} + {$ifdef powerpc} powerpcrescnt=1; {$else} powerpcrescnt=0; {$endif} + rescnt=i386rescnt+m68krescnt+alpharescnt+powerpcrescnt+1; + + type + tos = ( os_none, + os_i386_GO32V1,os_i386_GO32V2,os_i386_Linux,os_i386_OS2, + os_i386_Win32,os_i386_BeOS, + os_m68k_Amiga,os_m68k_Atari,os_m68k_Mac,os_m68k_Linux, + os_m68k_PalmOS,os_alpha_linux,os_powerpc_linux,os_powerpc_macos + ); + const + i386oscnt=6; + m68koscnt=5; + alphaoscnt=1; + powerpcoscnt=2; + oscnt=i386oscnt+m68koscnt+alphaoscnt+powerpcoscnt+1; + + type + tosinfo = packed record + id : tos; + name : string[30]; + shortname : string[9]; + sharedlibext : string[10]; + staticlibext, + sourceext, + pasext, + exeext, + defext, + scriptext : string[4]; + libprefix : string[3]; + Cprefix : string[2]; + newline : string[2]; + endian : tendian; + {longint this is a little overkill no ?? but 256 is possible one day } + stackalignment : word; + maxCrecordalignment : word; + size_of_pointer : byte; + size_of_longint : byte; + use_bound_instruction : boolean; + use_function_relative_addresses : boolean; + end; + + tasminfo = packed record + id : tasm; + idtxt : string[9]; + asmbin : string[8]; + asmcmd : string[50]; + supported_target : ttarget; + allowdirect, + externals, + needar : boolean; + labelprefix : string[2]; + comment : string[2]; + secnames : array[tsection] of string[20]; + end; + + tarinfo = packed record + id : tar; + arcmd : string[50]; + end; + + tresinfo = packed record + id : tres; + resbin : string[8]; + rescmd : string[50]; + end; + + ttargetinfo = packed record + target : ttarget; + flags : set of ttargetflags; + cpu : ttargetcpu; + short_name : string[8]; + unit_env : string[12]; + system_unit : string[8]; + smartext, + unitext, + unitlibext, + asmext, + objext, + resext, + resobjext, + exeext : string[4]; + os : tos; + assem : tasm; + assemsrc : tasm; { default source writing assembler } + ar : tar; + res : tres; + heapsize, + maxheapsize, + stacksize : longint; + end; + + tasmmodeinfo=packed record + id : tasmmode; + idtxt : string[8]; + end; + + var + target_cpu : ttargetcpu; + target_info : ttargetinfo; + target_os : tosinfo; + target_asm : tasminfo; + target_ar : tarinfo; + target_res : tresinfo; + target_path : string[12]; { for rtl//,fcl//, etc. } + source_os : tosinfo; + + function set_target_os(t:tos):boolean; + function set_target_asm(t:tasm):boolean; + function set_target_ar(t:tar):boolean; + function set_target_res(t:tres):boolean; + function set_target_info(t:ttarget):boolean; + + function set_string_target(s : string) : boolean; + function set_string_asm(s : string) : boolean; + function set_string_asmmode(s:string;var t:tasmmode):boolean; + + procedure InitSystems; + + +implementation + + const + +{**************************************************************************** + OS Info +****************************************************************************} + os_infos : array[1..oscnt] of tosinfo = ( + ( + id : os_none; + name : 'No operating system'; + shortname : 'none' + ), + ( + id : os_i386_go32v1; + name : 'GO32 V1 DOS extender'; + shortname : 'go32v1'; + sharedlibext : '.dll'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; { No .exe, the linker only output a.out ! } + defext : '.def'; + scriptext : '.bat'; + libprefix : ''; + Cprefix : '_'; + newline : #13#10; + endian : endian_little; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_i386_go32v2; + name : 'GO32 V2 DOS extender'; + shortname : 'go32v2'; + sharedlibext : '.dll'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : '.exe'; + defext : '.def'; + scriptext : '.bat'; + libprefix : ''; + Cprefix : '_'; + newline : #13#10; + endian : endian_little; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_i386_linux; + name : 'Linux for i386'; + shortname : 'linux'; + sharedlibext : '.so'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : '.def'; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : ''; + newline : #10; + endian : endian_little; + stackalignment : 4; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_i386_os2; + name : 'OS/2 via EMX'; + shortname : 'os2'; + sharedlibext : '.ao2'; + staticlibext : '.ao2'; + sourceext : '.pas'; + pasext : '.pp'; + exeext : '.exe'; + defext : '.def'; + scriptext : '.cmd'; + libprefix : ''; + Cprefix : '_'; + newline : #13#10; + endian : endian_little; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : false + ), + ( + id : os_i386_win32; + name : 'Win32 for i386'; + shortname : 'win32'; + sharedlibext : '.dll'; + staticlibext : '.aw'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : '.exe'; + defext : '.def'; + scriptext : '.bat'; + libprefix : 'lib'; + Cprefix : '_'; + newline : #13#10; + endian : endian_little; + stackalignment : 4; + maxCrecordalignment : 16; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_i386_beos; + name : 'BeOS for i386'; + shortname : 'beos'; + sharedlibext : '.so'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : '.def'; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : ''; + newline : #10; + endian : endian_little; + stackalignment : 4; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_m68k_amiga; + name : 'Commodore Amiga'; + shortname : 'amiga'; + sharedlibext : '.library'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : ''; + scriptext : ''; + libprefix : ''; + Cprefix : '_'; + newline : #10; + endian : endian_big; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : false + ), + ( + id : os_m68k_atari; + name : 'Atari ST/STE'; + shortname : 'atari'; + sharedlibext : '.dll'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : '.tpp'; + defext : ''; + scriptext : ''; + libprefix : ''; + Cprefix : '_'; + newline : #10; + endian : endian_big; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : false + ), + ( + id : os_m68k_mac; + name : 'Macintosh m68k'; + shortname : 'mac'; + sharedlibext : 'Lib'; + staticlibext : 'Lib'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : ''; + scriptext : ''; + libprefix : ''; + Cprefix : '_'; + newline : #13; + endian : endian_big; + stackalignment : 2; + maxCrecordalignment : 4; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : false + ), + ( + id : os_m68k_linux; + name : 'Linux for m68k'; + shortname : 'linux'; + sharedlibext : '.so'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : ''; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : ''; + newline : #10; + endian : endian_big; + stackalignment : 2; + maxCrecordalignment : 32; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_m68k_palmos; + name : 'PalmOS'; + shortname : 'palmos'; + sharedlibext : '.so'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : ''; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : '_'; + newline : #10; + endian : endian_big; + stackalignment : 2; + maxCrecordalignment : 32; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : false + ), + ( + id : os_alpha_linux; + name : 'Linux for Alpha'; + shortname : 'axplinux'; + sharedlibext : '.so'; + staticlibext : '.a'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : '.def'; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : ''; + newline : #10; + endian : endian_little; + stackalignment : 8; + maxCrecordalignment : 32; + size_of_pointer : 8; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_powerpc_linux; + name : 'Linux for PowerPC'; + shortname : 'linuxppc'; + sharedlibext : '.so'; + staticlibext : '.s'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : '.def'; + scriptext : '.sh'; + libprefix : 'lib'; + Cprefix : ''; + newline : #10; + endian : endian_big; + stackalignment : 8; + maxCrecordalignment : 32; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ), + ( + id : os_powerpc_macos; + name : 'MacOs (PowerPC)'; + shortname : 'MacOs/PPC'; + sharedlibext : 'Lib'; + staticlibext : 'Lib'; + sourceext : '.pp'; + pasext : '.pas'; + exeext : ''; + defext : ''; + scriptext : ''; + libprefix : ''; + Cprefix : ''; + newline : #13; + endian : endian_big; + stackalignment : 8; + maxCrecordalignment : 32; + size_of_pointer : 4; + size_of_longint : 4; + use_bound_instruction : false; + use_function_relative_addresses : true + ) + ); + + +{**************************************************************************** + Assembler Info +****************************************************************************} + + as_infos : array[1..asmcnt] of tasminfo = ( + ( + id : as_none; + idtxt : 'no' + ) +{$ifdef i386} + ,( + id : as_i386_as; + idtxt : 'AS'; + asmbin : 'as'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '# '; + secnames : ('', + '.text','.data','.bss', + '','','','','','', + '.stab','.stabstr') + ) + ,( + id : as_i386_as_aout; + idtxt : 'AS_AOUT'; + asmbin : 'as'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_i386_os2; + allowdirect : true; + externals : false; + needar : true; + labelprefix : 'L'; + comment : '# '; + secnames : ('', + '.text','.data','.bss', + '','','','','','', + '.stab','.stabstr') + ) + ,( + id : as_i386_asw; + idtxt : 'ASW'; + asmbin : 'asw'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_i386_win32; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '# '; + secnames : ('', + '.text','.data','.section .bss', + '.section .idata$2','.section .idata$4','.section .idata$5', + '.section .idata$6','.section .idata$7','.section .edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_nasmcoff; + idtxt : 'NASMCOFF'; + asmbin : 'nasm'; + asmcmd : '-f coff -o $OBJ $ASM'; + supported_target : target_i386_go32v2; + allowdirect : true; + externals : true; + needar : true; + labelprefix : 'L'; + comment : '; '; + secnames : ('', + '.text','.data','.bss', + '.idata2','.idata4','.idata5','.idata6','.idata7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_nasmwin32; + idtxt : 'NASMWIN32'; + asmbin : 'nasm'; + asmcmd : '-f win32 -o $OBJ $ASM'; + supported_target : target_i386_win32; + allowdirect : true; + externals : true; + needar : true; + labelprefix : 'L'; + comment : '; '; + secnames : ('', + '.text','.data','.bss', + '.idata2','.idata4','.idata5','.idata6','.idata7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_nasmelf; + idtxt : 'NASMELF'; + asmbin : 'nasm'; + asmcmd : '-f elf -o $OBJ $ASM'; + supported_target : target_any; { what should I write here ?? } + allowdirect : true; + externals : true; + needar : true; + labelprefix : 'L'; + comment : '; '; + secnames : ('', + '.text','.data','.bss', + '.idata2','.idata4','.idata5','.idata6','.idata7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_nasmobj; + idtxt : 'NASMOBJ'; + asmbin : 'nasm'; + asmcmd : '-f obj -o $OBJ $ASM'; + supported_target : target_any; { what should I write here ?? } + allowdirect : true; + externals : true; + needar : true; + labelprefix : 'L'; + comment : '; '; + secnames : ('', + '.text','.data','.bss', + '.idata2','.idata4','.idata5','.idata6','.idata7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_tasm; + idtxt : 'TASM'; + asmbin : 'tasm'; + asmcmd : '/m2 $ASM $OBJ'; + supported_target : target_any; { what should I write here ?? } + allowdirect : true; + externals : true; + needar : true; + labelprefix : '@@'; + comment : '; '; + secnames : ('', + 'CODE','DATA','BSS', + '','','','','','', + '','') + ) + ,( + id : as_i386_masm; + idtxt : 'MASM'; + asmbin : 'masm'; + asmcmd : '$ASM $OBJ'; + supported_target : target_any; { what should I write here ?? } + allowdirect : true; + externals : true; + needar : true; + labelprefix : '.L'; + comment : '; '; + secnames : ('', + 'CODE','DATA','BSS', + '','','','','','', + '','') + ) + ,( + id : as_i386_dbg; + idtxt : 'DBG'; + asmbin : ''; + asmcmd : ''; + supported_target : target_any; + allowdirect : false; + externals : true; + needar : false; + labelprefix : 'L'; + comment : ''; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_coff; + idtxt : 'COFF'; + asmbin : ''; + asmcmd : ''; + supported_target : target_i386_go32v2; + allowdirect : false; + externals : true; + needar : false; + labelprefix : '.L'; + comment : ''; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_i386_pecoff; + idtxt : 'PECOFF'; + asmbin : ''; + asmcmd : ''; + supported_target : target_i386_win32; + allowdirect : false; + externals : true; + needar : false; + labelprefix : '.L'; + comment : ''; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) +{$endif i386} +{$ifdef m68k} + ,( + id : as_m68k_as; + idtxt : 'AS'; + asmbin : 'as'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '# '; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_m68k_gas; + idtxt : 'GAS'; + asmbin : 'as68k'; { Gas for the Amiga} + asmcmd : '--register-prefix-optional -o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '| '; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_m68k_mit; + idtxt : 'MIT'; + asmbin : ''; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '| '; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_m68k_mot; + idtxt : 'MOT'; + asmbin : ''; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '__L'; + comment : '| '; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) + ,( + id : as_m68k_mpw; + idtxt : 'MPW'; + asmbin : ''; + asmcmd : '-model far -o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '__L'; + comment : '* '; + secnames : ('', + '.text','.data','.bss', + '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata', + '.stab','.stabstr') + ) +{$endif m68k} +{$ifdef alpha} + ,( + id : as_alpha_as; + idtxt : 'AS'; + asmbin : 'as'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '# '; + secnames : ('', + '.text','.data','.bss', + '','','','','','', + '.stab','.stabstr') + ) +{$endif} +{$ifdef powerpc} + ,( + id : as_powerpc_as; + idtxt : 'AS'; + asmbin : 'as'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '# '; + secnames : ('', + '.text','.data','.bss', + '','','','','','', + '.stab','.stabstr') + ) + ,( + id : as_powerpc_mpw; + idtxt : 'PPCAsm'; + asmbin : 'PPCAsm'; + asmcmd : '-o $OBJ $ASM'; + supported_target : target_any; + allowdirect : true; + externals : false; + needar : true; + labelprefix : '.L'; + comment : '; '; + secnames : ('', + '.text','.data','.bss', + '','','','','','', + '.stab','.stabstr') + ) +{$endif} + ); + + +{**************************************************************************** + Ar Info +****************************************************************************} + ar_infos : array[1..arcnt] of tarinfo = ( + ( + id : ar_none + ) +{$ifdef i386} + ,( + id : ar_i386_ar; + arcmd : 'ar rs $LIB $FILES' + ), + ( + id : ar_i386_arw; + arcmd : 'arw rs $LIB $FILES' + ) +{$endif i386} +{$ifdef m68k} + ,( + id : ar_m68k_ar; + arcmd : 'ar rs $LIB $FILES' + ) +{$endif m68k} +{$ifdef alpha} + ,( + id : ar_alpha_ar; + arcmd : 'ar rs $LIB $FILES' + ) +{$endif} +{$ifdef powerpc} + ,( + id : ar_powerpc_ar; + arcmd : 'ar rs $LIB $FILES' + ) +{$endif} + ); + + +{**************************************************************************** + Res Info +****************************************************************************} + res_infos : array[1..rescnt] of tresinfo = ( + ( + id : res_none + ) +{$ifdef i386} + ,( + id : res_i386_windres; + resbin : 'windres'; + rescmd : '--include $INC -O coff -o $OBJ $RES' + ) + ,( + id : res_i386_emx; + resbin : 'emxbind'; + rescmd : '-b -r $RES $OBJ' +(* Not really used - see TLinkeros2.SetDefaultInfo in t_os2.pas. *) + ) +{$endif i386} +{$ifdef m68k} + ,( + id : res_m68k_mpw; + resbin : 'rez'; + rescmd : '-i $INC -o $OBJ $RES' + ) +{$endif m68} +{$ifdef powerpc} + ,( + id : res_powerpc_mpw; + resbin : 'rez'; + rescmd : '-i $INC -o $OBJ $RES' + ) +{$endif powerpc} + ); + + +{**************************************************************************** + Targets Info +****************************************************************************} + target_infos : array[1..targetcnt] of ttargetinfo = ( + ( + target : target_none; + flags : []; + cpu : no_cpu; + short_name : 'notarget' + ) +{$ifdef i386} + ,( + target : target_i386_GO32V1; + flags : []; + cpu : i386; + short_name : 'GO32V1'; + unit_env : 'GO32V1UNITS'; + system_unit : 'SYSTEM'; + smartext : '.sl'; + unitext : '.pp1'; + unitlibext : '.ppl'; + asmext : '.s1'; + objext : '.o1'; + resext : '.res'; + resobjext : '.o1r'; + exeext : ''; { The linker produces a.out } + os : os_i386_GO32V1; + assem : as_i386_as; + assemsrc : as_i386_as; + ar : ar_i386_ar; + res : res_none; + heapsize : 2048*1024; + maxheapsize : 32768*1024; + stacksize : 16384 + ), + ( + target : target_i386_GO32V2; + flags : []; + cpu : i386; + short_name : 'GO32V2'; + unit_env : 'GO32V2UNITS'; + system_unit : 'SYSTEM'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : '.exe'; + os : os_i386_GO32V2; + assem : as_i386_coff; + assemsrc : as_i386_as; + ar : ar_i386_ar; + res : res_none; + heapsize : 2048*1024; + maxheapsize : 32768*1024; + stacksize : 16384 + ), + ( + target : target_i386_LINUX; + flags : []; + cpu : i386; + short_name : 'LINUX'; + unit_env : 'LINUXUNITS'; + system_unit : 'syslinux'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_i386_Linux; + assem : as_i386_as; + assemsrc : as_i386_as; + ar : ar_i386_ar; + res : res_none; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_i386_OS2; + flags : [tf_need_export]; + cpu : i386; + short_name : 'OS2'; + unit_env : 'OS2UNITS'; + system_unit : 'SYSOS2'; + smartext : '.sl'; + unitext : '.ppo'; + unitlibext : '.ppl'; + asmext : '.so2'; + objext : '.oo2'; + resext : '.res'; + resobjext : '.oor'; + exeext : ''; { The linker produces a.out } + os : os_i386_OS2; + assem : as_i386_as_aout; + assemsrc : as_i386_as_aout; + ar : ar_i386_ar; + res : res_i386_emx; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 32768 + ), + ( + target : target_i386_WIN32; + flags : []; + cpu : i386; + short_name : 'WIN32'; + unit_env : 'WIN32UNITS'; + system_unit : 'SYSWIN32'; + smartext : '.slw'; + unitext : '.ppw'; + unitlibext : '.ppl'; + asmext : '.sw'; + objext : '.ow'; + resext : '.rc'; + resobjext : '.owr'; + exeext : '.exe'; + os : os_i386_Win32; + assem : as_i386_pecoff; + assemsrc : as_i386_asw; + ar : ar_i386_arw; + res : res_i386_windres; + heapsize : 256*1024; + maxheapsize : 32*1024*1024; + stacksize : 32*1024*1024 + ), + ( + target : target_i386_BEOS; + flags : []; + cpu : i386; + short_name : 'BEOS'; + unit_env : 'BEOSUNITS'; + system_unit : 'sysbeos'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_i386_BeOS; + assem : as_i386_as; + assemsrc : as_i386_as; + ar : ar_i386_ar; + res : res_none; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ) +{$endif i386} +{$ifdef m68k} + ,( + target : target_m68k_Amiga; + flags : []; + cpu : m68k; + short_name : 'AMIGA'; + unit_env : ''; + system_unit : 'sysamiga'; + smartext : '.sl'; + unitext : '.ppa'; + unitlibext : '.ppl'; + asmext : '.asm'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_m68k_Amiga; + assem : as_m68k_as; + assemsrc : as_m68k_as; + ar : ar_m68k_ar; + res : res_none; + heapsize : 128*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_m68k_Atari; + flags : []; + cpu : m68k; + short_name : 'ATARI'; + unit_env : ''; + system_unit : 'SYSATARI'; + smartext : '.sl'; + unitext : '.ppt'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : '.ttp'; + os : os_m68k_Atari; + assem : as_m68k_as; + assemsrc : as_m68k_as; + ar : ar_m68k_ar; + res : res_none; + heapsize : 16*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_m68k_Mac; + flags : []; + cpu : m68k; + short_name : 'MACOS'; + unit_env : ''; + system_unit : 'sysmac'; + smartext : '.sl'; + unitext : '.ppt'; + unitlibext : '.ppl'; + asmext : '.a'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_m68k_Mac; + assem : as_m68k_mpw; + assemsrc : as_m68k_mpw; + ar : ar_m68k_ar; + res : res_none; + heapsize : 128*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_m68k_linux; + flags : []; + cpu : m68k; + short_name : 'LINUX'; + unit_env : 'LINUXUNITS'; + system_unit : 'syslinux'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_m68k_Linux; + assem : as_m68k_as; + assemsrc : as_m68k_as; + ar : ar_m68k_ar; + res : res_none; + heapsize : 128*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_m68k_PalmOS; + flags : []; + cpu : m68k; + short_name : 'PALMOS'; + unit_env : 'PALMUNITS'; + system_unit : 'syspalm'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_m68k_PalmOS; + assem : as_m68k_as; + assemsrc : as_m68k_as; + ar : ar_m68k_ar; + res : res_none; + heapsize : 128*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ) +{$endif m68k} +{$ifdef alpha} + ,( + target : target_alpha_LINUX; + flags : []; + cpu : alpha; + short_name : 'LINUX'; + unit_env : 'LINUXUNITS'; + system_unit : 'syslinux'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_alpha_Linux; + assem : as_alpha_as; + assemsrc : as_alpha_as; + ar : ar_alpha_ar; + res : res_none; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ) +{$endif} +{$ifdef powerpc} + ,( + target : target_powerpc_LINUX; + flags : []; + cpu : powerpc; + short_name : 'LINUX'; + unit_env : ''; + system_unit : 'syslinux'; + smartext : '.sl'; + unitext : '.ppu'; + unitlibext : '.ppl'; + asmext : '.s'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_powerpc_Linux; + assem : as_powerpc_as; + assemsrc : as_powerpc_as; + ar : ar_powerpc_ar; + res : res_none; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ), + ( + target : target_powerpc_MACOS; + flags : []; + cpu : powerpc; + short_name : 'MACOS'; + unit_env : ''; + system_unit : 'sysmac'; + smartext : '.sl'; + unitext : '.ppt'; + unitlibext : '.ppl'; + asmext : '.a'; + objext : '.o'; + resext : '.res'; + resobjext : '.or'; + exeext : ''; + os : os_powerpc_macos; + assem : as_powerpc_mpw; + assemsrc : as_powerpc_mpw; + ar : ar_powerpc_ar; + res : res_powerpc_mpw; + heapsize : 256*1024; + maxheapsize : 32768*1024; + stacksize : 8192 + ) +{$endif} + ); + +{**************************************************************************** + AsmModeInfo +****************************************************************************} + asmmodeinfos : array[1..asmmodecnt] of tasmmodeinfo = ( + ( + id : asmmode_none; + idtxt : 'none' + ) +{$ifdef i386} + ,( + id : asmmode_i386_direct; + idtxt : 'DIRECT' + ), + ( + id : asmmode_i386_att; + idtxt : 'ATT' + ), + ( + id : asmmode_i386_intel; + idtxt : 'INTEL' + ) +{$endif i386} +{$ifdef m68k} + ,( + id : asmmode_m68k_mot; + idtxt : 'MOT' + ) +{$endif m68k} +{$ifdef alpha} + ,( + id : asmmode_alpha_direct; + idtxt : 'DIRECT' + ) +{$endif} +{$ifdef powerpc} + ,( + id : asmmode_powerpc_direct; + idtxt : 'DIRECT' + ) +{$endif} + ); + +{**************************************************************************** + Helpers +****************************************************************************} + +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]; +{$ifndef TP} + {$ifopt H+} + SetLength(upper,length(s)); + {$else} + upper[0]:=s[0]; + {$endif} +{$else} + upper[0]:=s[0]; +{$endif} +end; + +function lower(const s : string) : string; +var + i : longint; +begin + for i:=1 to length(s) do + if s[i] in ['A'..'Z'] then + lower[i]:=char(byte(s[i])+32) + else + lower[i]:=s[i]; + {$ifndef TP} + {$ifopt H+} + setlength(lower,length(s)); + {$else} + lower[0]:=s[0]; + {$endif} + {$else} + lower[0]:=s[0]; + {$endif} +end; + + +function set_target_os(t:tos):boolean; +var + i : longint; +begin + set_target_os:=false; + { target 1 is none } + for i:=2 to oscnt do + if os_infos[i].id=t then + begin + target_os:=os_infos[i]; + set_target_os:=true; + exit; + end; +end; + + +function set_target_asm(t:tasm):boolean; +var + i : longint; +begin + set_target_asm:=false; + for i:=1 to asmcnt do + if as_infos[i].id=t then + begin + target_asm:=as_infos[i]; + set_target_asm:=true; + exit; + end; +end; + + +function set_target_ar(t:tar):boolean; +var + i : longint; +begin + set_target_ar:=false; + for i:=1 to arcnt do + if ar_infos[i].id=t then + begin + target_ar:=ar_infos[i]; + set_target_ar:=true; + exit; + end; +end; + + +function set_target_res(t:tres):boolean; +var + i : longint; +begin + set_target_res:=false; + for i:=1 to rescnt do + if res_infos[i].id=t then + begin + target_res:=res_infos[i]; + set_target_res:=true; + exit; + end; +end; + + +function set_target_info(t:ttarget):boolean; +var + i : longint; +begin + set_target_info:=false; + for i:=1 to targetcnt do + if target_infos[i].target=t then + begin + target_info:=target_infos[i]; + set_target_os(target_info.os); + set_target_asm(target_info.assem); + set_target_ar(target_info.ar); + set_target_res(target_info.res); + target_path:=lower(target_info.short_name); + target_cpu:=target_info.cpu; + set_target_info:=true; + exit; + end; +end; + + +{**************************************************************************** + Load from string +****************************************************************************} + +function set_string_target(s : string) : boolean; +var + i : longint; +begin + set_string_target:=false; + { this should be case insensitive !! PM } + s:=upper(s); + for i:=1 to targetcnt do + if target_infos[i].short_name=s then + begin + set_target_info(target_infos[i].target); + set_string_target:=true; + exit; + end; +end; + + +function set_string_asm(s : string) : boolean; +var + i : longint; +begin + set_string_asm:=false; + { this should be case insensitive !! PM } + s:=upper(s); + for i:=1 to asmcnt do + if as_infos[i].idtxt=s then + begin + target_asm:=as_infos[i]; + set_string_asm:=true; + end; +end; + + +function set_string_asmmode(s:string;var t:tasmmode):boolean; +var + i : longint; +begin + set_string_asmmode:=false; + { this should be case insensitive !! PM } + s:=upper(s); + for i:=1 to asmmodecnt do + if asmmodeinfos[i].idtxt=s then + begin + t:=asmmodeinfos[i].id; + set_string_asmmode:=true; + end; +end; + + +{**************************************************************************** + Initialization of default target +****************************************************************************} + +procedure default_os(t:ttarget); +begin + set_target_info(t); + if source_os.name='' then + source_os:=target_os; +end; + + +procedure set_source_os(t:tos); +var + i : longint; +begin +{ can't use message() here (PFV) } + if source_os.name<>'' then + Writeln('Warning: Source OS Redefined!'); + for i:=1 to oscnt do + if os_infos[i].id=t then + begin + source_os:=os_infos[i]; + exit; + end; +end; + + +procedure InitSystems; +begin +{ first get source OS } + source_os.name:=''; +{ please note then we use cpu86 and cpu68 here on purpose !! } +{$ifdef cpu86} + {$ifdef GO32V1} + set_source_os(os_i386_GO32V1); + {$else} + {$ifdef GO32V2} + set_source_os(os_i386_GO32V2); + {$else} + {$ifdef OS2} + set_source_os(os_i386_OS2); + if (OS_Mode = osDOS) or (OS_Mode = osDPMI) + then source_os.scriptext := '.bat'; +{OS/2 via EMX can be run under DOS as well} + {$else} + {$ifdef LINUX} + set_source_os(os_i386_LINUX); + {$else} + {$ifdef WIN32} + set_source_os(os_i386_WIN32); + {$else} + {$ifdef BEOS} + set_source_os(os_i386_BEOS); + {$endif beos} + {$endif win32} + {$endif linux} + {$endif os2} + {$endif go32v2} + {$endif go32v1} +{$endif cpu86} +{$ifdef cpu68} + {$ifdef AMIGA} + set_source_os(os_m68k_Amiga); + {$else} + {$ifdef ATARI} + set_source_os(os_m68k_Atari); + {$else} + {$ifdef MACOS} + set_source_os(os_m68k_MAC); + {$else} + {$ifdef LINUX} + set_source_os(os_m68k_linux); + {$endif linux} + {$endif macos} + {$endif atari} + {$endif amiga} +{$endif cpu68} + +{ Now default target !! } +{$ifdef i386} + {$ifdef GO32V1} + default_os(target_i386_GO32V1); + {$else} + {$ifdef GO32V2} + default_os(target_i386_GO32V2); + {$else} + {$ifdef OS2} + default_os(target_i386_OS2); + {$else} + {$ifdef LINUX} + default_os(target_i386_LINUX); + {$else} + {$ifdef WIN32} + default_os(target_i386_WIN32); + {$else} + {$ifdef BEOS} + default_os(target_i386_BEOS); + {$else} + default_os(target_i386_GO32V2); + {$endif beos} + {$endif win32} + {$endif linux} + {$endif os2} + {$endif go32v2} + {$endif go32v1} +{$endif i386} +{$ifdef m68k} + {$ifdef AMIGA} + default_os(target_m68k_Amiga); + {$else} + {$ifdef ATARI} + default_os(target_m68k_Atari); + {$else} + {$ifdef MACOS} + default_os(target_m68k_Mac); + {$else} + {$ifdef LINUX} + default_os(target_m68k_linux); + {$else} + default_os(target_m68k_Amiga); + {$endif linux} + {$endif macos} + {$endif atari} + {$endif amiga} +{$endif m68k} +{$ifdef alpha} + default_os(target_alpha_linux); +{$endif alpha} +{$ifdef powerpc} + default_os(target_powerpc_linux); +{$endif powerpc} +end; + + +begin + InitSystems; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.106 2000/06/25 19:08:28 hajny + + $R support for OS/2 (EMX) added + + Revision 1.105 2000/06/23 21:31:18 pierre + + new target_os field: maxCstructalignment + + Revision 1.104 2000/05/23 21:26:52 pierre + + added supported_target fiedl to tasminfo record + to disregard wrong assembler settings + + Revision 1.103 2000/05/11 09:07:45 pierre + * change tosinfo.shortname length, reported by Kovacs Attila Zoltan + + Revision 1.102 2000/04/22 14:25:03 jonas + * aasm.pas: pai_align instead of pai_align_abstract if cpu <> i386 + + systems.pas: info for macos/ppc + * new/cgobj.pas: compiles again without newst define + * new/powerpc/cgcpu: generate different entry/exit code depending on + whether target_os is MacOs or Linux + + Revision 1.101 2000/04/04 14:18:15 pierre + * nasmwin32 is 9 chars long, idtxt changed accordingly + + Revision 1.100 2000/04/04 13:54:58 pierre + + nasmwin32 for win32 object output with nasm assembler + + Revision 1.99 2000/02/09 13:23:06 peter + * log truncated + + Revision 1.98 2000/01/07 01:14:42 peter + * updated copyright to 2000 + + Revision 1.97 1999/11/06 14:34:28 peter + * truncated log to 20 revs + + Revision 1.96 1999/11/03 23:43:45 peter + * fixed ar commands + + Revision 1.95 1999/10/21 14:29:37 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + + Revision 1.94 1999/09/15 22:09:27 florian + + rtti is now automatically generated for published classes, i.e. + they are handled like an implicit property + + Revision 1.93 1999/09/15 20:24:56 daniel + + Dw switch now does something. + + Revision 1.92 1999/09/07 15:02:41 pierre + * powerpc default was alpha !! + + Revision 1.91 1999/08/16 15:35:29 pierre + * fix for DLL relocation problems + * external bss vars had wrong stabs for pecoff + + -WB11000000 to specify default image base, allows to + load several DLLs with debugging info included + (relocatable DLL are stripped because the relocation + of the .Stab section is misplaced by ldw) + + Revision 1.90 1999/08/04 13:03:11 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.89 1999/08/04 00:23:32 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.88 1999/08/03 22:03:23 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.87 1999/08/03 17:09:43 florian + * the alpha compiler can be compiled now + + Revision 1.86 1999/08/03 15:52:00 michael + * changed shortname for linux alpha + + Revision 1.85 1999/08/03 13:50:19 michael + + Changes for alpha + + Revision 1.84 1999/08/02 23:56:51 michael + + Added alpha cpu and linux for alpha os + +} \ No newline at end of file diff --git a/befpc/compiler/t_beos.pas b/befpc/compiler/t_beos.pas new file mode 100644 index 0000000..fdffe87 --- /dev/null +++ b/befpc/compiler/t_beos.pas @@ -0,0 +1,374 @@ +{ + Based on t_linux.pas - Copyright (c) 1998-2000 by Peter Vreman + + This unit implements support import,export,link routines + for the (i386) BeOS target + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit t_beos; +interface + + uses + import,export,link,t_linux,beos; + + type + pimportlibbeos=^timportlibbeos; + timportlibbeos=object(timportliblinux) + end; + + pexportlibbeos=^texportliblinux; + texportlibbeos=object(texportliblinux) + end; + + plinkerbeos=^tlinkerbeos; + tlinkerbeos=object(tlinker) + private + Function WriteResponseFile(isdll:boolean;makelib:boolean) : Boolean; + public + constructor Init; + procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + function MakeSharedLibrary:boolean;virtual; + end; + + +implementation + + uses + verbose,strings,cobjects,systems,globtype,globals, + symconst,script, + files,aasm,cpuasm,cpubase,symtable{$IFDEF NEWST},symbols{$ENDIF NEWST}; + +{***************************************************************************** + TLINKERBEOS +*****************************************************************************} + +Constructor TLinkerBeOS.Init; +begin + Inherited Init; + LibrarySearchPath.AddPath(beos.GetEnv('BELIBRARIES'),true); {format:'path1;path2;...'} +end; + + +procedure TLinkerBeOS.SetDefaultInfo; +begin + with Info do + begin + ExeCmd[1]:='sh $RES $EXE $OPT $STATIC $STRIP -L.'; +{ ExeCmd[1]:='sh $RES $EXE $OPT $DYNLINK $STATIC $STRIP -L.';} + DllCmd[1]:='sh $RES $EXE $OPT -L.'; + +{ DllCmd[1]:='sh $RES $EXE $OPT -L. -g -nostart -soname=$EXE'; + } DllCmd[2]:='strip --strip-unneeded $EXE'; +{ DynamicLinker:='/lib/ld-linux.so.2';} + end; +end; + + +function TLinkerBeOS.WriteResponseFile(isdll:boolean;makelib:boolean) : Boolean; +Var + linkres : TLinkRes; + i : longint; + cprtobj, + prtobj : string[80]; +{$IFDEF NEWST} + HPath : PStringItem; +{$ELSE} + HPath : PStringQueueItem; +{$ENDIF NEWST} + s : string; + found, + linkdynamic, + linklibc:boolean; +begin + WriteResponseFile:=False; +{ set special options for some targets } + linkdynamic:=not(SharedLibFiles.empty); + linklibc:=SharedLibFiles.Find('root'); + + prtobj:='prt0'; + cprtobj:='cprt0'; + if (cs_profile in aktmoduleswitches) or + (not SharedLibFiles.Empty) then begin + AddSharedLibrary('root'); + linklibc:=true; + end; + + if (not linklibc) and makelib then begin + linklibc:=true; + cprtobj:='dllprt.o'; + end; + + if linklibc=true then begin + prtobj:=cprtobj; + writeln('LINKLIBC=True'); + end; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + if not isdll then LinkRes.Add('ld -o $1 $2 $3 $4 $5 $6 $7 $8 $9 \') + else LinkRes.Add('ld -o $1 -e 0 $2 $3 $4 $5 $6 $7 $8 $9\'); + + LinkRes.Add('-m elf_i386_be -shared -Bsymbolic \'); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^+' \'); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^+' \'); + HPath:=HPath^.Next; + end; + + { try to add crti and crtbegin if linking to C } + if linklibc then + begin + s:=librarysearchpath.FindFile('crti.o',found)+'crti.o'; + if found then LinkRes.AddFileName(s+' \'); + + s:=librarysearchpath.FindFile('crtbegin.o',found)+'crtbegin.o'; + if found then LinkRes.AddFileName(s+' \'); + +{ s:=librarysearchpath.FindFile('start_dyn.o',found)+'start_dyn.o'; + if found then LinkRes.AddFileName(s+' \');} + + if prtobj<>'' then LinkRes.AddFileName(FindObjectFile(prtobj,'')+' \'); + + if isdll then LinkRes.AddFileName(FindObjectFile('func.o','')+' \'); + + s:=librarysearchpath.FindFile('init_term_dyn.o',found)+'init_term_dyn.o'; + if found then LinkRes.AddFileName(s+' \'); + + end else begin + if prtobj<>'' then LinkRes.AddFileName(FindObjectFile(prtobj,'')+' \'); + end; + + + { main objectfiles } + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(s+' \'); + end; + +{ LinkRes.Add('-lroot \'); + LinkRes.Add('/boot/develop/tools/gnupro/lib/gcc-lib/i586-beos/2.9-beos-991026/crtend.o \'); + LinkRes.Add('/boot/develop/lib/x86/crtn.o \');} + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(s+' \') + end; + end; + + { Write sharedlibraries like -l } + if not SharedLibFiles.Empty then + begin + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if s<>'c' then + begin + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s+' \'); + end + else + begin + linklibc:=true; + linkdynamic:=false; { libc will include the ld-linux for us } + end; + end; + { be sure that libc is the last lib } +{ if linklibc then LinkRes.Add('-lroot');} +{ if linkdynamic and (Info.DynamicLinker<>'') then + LinkRes.AddFileName(Info.DynamicLinker);} + end; + if isdll then LinkRes.Add('-lroot \'); + + { objects which must be at the end } + if linklibc then + begin + s:=librarysearchpath.FindFile('crtend.o',found)+'crtend.o'; + if found then + LinkRes.AddFileName(s+' \'); + s:=librarysearchpath.FindFile('crtn.o',found)+'crtn.o'; + if found then + LinkRes.AddFileName(s+' \'); + end; + +{ Write and Close response } + linkres.Add(' '); + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; + + +function TLinkerBeOS.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + success : boolean; +{ DynLinkStr : string[60];} + StaticStr, + StripStr : string[40]; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + StaticStr:=''; + StripStr:=''; +{ DynLinkStr:='';} + if (cs_link_staticflag in aktglobalswitches) then + StaticStr:='-static'; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; +{ If (cs_profile in aktmoduleswitches) or + ((Info.DynamicLinker<>'') and (not SharedLibFiles.Empty)) then + DynLinkStr:='-dynamic-linker='+Info.DynamicLinker;} + +{ Write used files and libraries } + WriteResponseFile(false,false); + +{ Call linker } + SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.exefilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$STATIC',StaticStr); + Replace(cmdstr,'$STRIP',StripStr); +{ Replace(cmdstr,'$DYNLINK',DynLinkStr);} + success:=DoExec(FindUtil(BinStr),CmdStr,true,false); + +{ Remove ReponseFile } + //if (success) and not(cs_link_extern in aktglobalswitches) then + // RemoveFile(outputexedir+Info.ResName); + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + + +Function TLinkerBeOS.MakeSharedLibrary:boolean; +var + binstr, + cmdstr : string; + success : boolean; +begin + MakeSharedLibrary:=false; + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.sharedlibfilename^); + +{ Write used files and libraries } + WriteResponseFile(true,true); + +{ Call linker } + SplitBinCmd(Info.DllCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.sharedlibfilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + success:=DoExec(FindUtil(binstr),cmdstr,true,false); + +{ Strip the library ? } + if success and (cs_link_strip in aktglobalswitches) then + begin + SplitBinCmd(Info.DllCmd[2],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.sharedlibfilename^); + success:=DoExec(FindUtil(binstr),cmdstr,true,false); + end; + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeSharedLibrary:=success; { otherwise a recursive call to link method } +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.15 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.14 2000/03/21 21:36:52 peter + * only include crtbegin when linking to libc + + Revision 1.13 2000/03/12 08:24:03 daniel + * Modification for new symtable + + Revision 1.12 2000/03/02 13:12:37 daniel + * Removed a comment to fix gtk. + + Revision 1.11 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.10 2000/02/27 14:46:04 peter + * check for ld-so.2.0.* then no glibc21 is used, else glibc21 is used + + Revision 1.9 2000/02/09 10:35:48 peter + * -Xt option to link staticly against c libs + + Revision 1.8 2000/01/11 09:52:07 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.7 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.6 2000/01/07 01:14:42 peter + * updated copyright to 2000 + + Revision 1.5 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.4 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.3 1999/11/05 13:15:00 florian + * some fixes to get the new cg compiling again + + Revision 1.2 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/t_go32v1.pas b/befpc/compiler/t_go32v1.pas new file mode 100644 index 0000000..79e75d9 --- /dev/null +++ b/befpc/compiler/t_go32v1.pas @@ -0,0 +1,230 @@ +{ + $Id: t_go32v1.pas,v 1.1.1.1 2001-07-23 17:17:23 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements support import,export,link routines + for the (i386) go32v1 target + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit t_go32v1; + + interface + uses + link; + + type + plinkergo32v1=^tlinkergo32v1; + tlinkergo32v1=object(tlinker) + private + Function WriteResponseFile(isdll:boolean) : Boolean; + public + constructor Init; + procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + end; + + + implementation + + uses + globtype,globals,cobjects,systems,verbose,script,files; + + +{**************************************************************************** + TLinkergo32v1 +****************************************************************************} + +Constructor TLinkergo32v1.Init; +begin + Inherited Init; + { allow duplicated libs (PM) } + SharedLibFiles.doubles:=true; + StaticLibFiles.doubles:=true; +end; + + +procedure TLinkergo32v1.SetDefaultInfo; +begin + with Info do + begin + ExeCmd[1]:='ld -oformat coff-go32 $OPT $STRIP -o $EXE @$RES'; + ExeCmd[2]:='aout2exe $EXE'; + end; +end; + + +Function TLinkergo32v1.WriteResponseFile(isdll:boolean) : Boolean; +Var + linkres : TLinkRes; + i : longint; +{$IFDEF NEWST} + HPath : PStringItem; +{$ELSE} + HPath : PStringQueueItem; +{$ENDIF} + s : string; + linklibc : boolean; +begin + WriteResponseFile:=False; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^); + HPath:=HPath^.Next; + end; + + { add objectfiles, start with prt0 always } + LinkRes.AddFileName(FindObjectFile('prt0','')); + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(s); + end; + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + LinkRes.Add('-('); + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(s) + end; + LinkRes.Add('-)'); + end; + + { Write sharedlibraries like -l, also add the needed dynamic linker + here to be sure that it gets linked this is needed for glibc2 systems (PFV) } + linklibc:=false; + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if s<>'c' then + begin + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s); + end + else + begin + LinkRes.Add('-l'+s); + linklibc:=true; + end; + end; + { be sure that libc&libgcc is the last lib } + if linklibc then + begin + LinkRes.Add('-lc'); + LinkRes.Add('-lgcc'); + end; + +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; + + +function TLinkergo32v1.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + success : boolean; + StripStr : string[40]; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + StripStr:=''; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; + +{ Write used files and libraries } + WriteResponseFile(false); + +{ Call linker } + SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.exefilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$STRIP',StripStr); + success:=DoExec(FindUtil(BinStr),cmdstr,true,false); + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.10 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.9 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.8 2000/02/09 13:23:06 peter + * log truncated + + Revision 1.7 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.6 2000/01/07 01:14:42 peter + * updated copyright to 2000 + + Revision 1.5 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.4 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.3 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.2 1999/10/22 14:42:40 peter + * reset linklibc + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/t_go32v2.pas b/befpc/compiler/t_go32v2.pas new file mode 100644 index 0000000..c5c8659 --- /dev/null +++ b/befpc/compiler/t_go32v2.pas @@ -0,0 +1,337 @@ +{ + $Id: t_go32v2.pas,v 1.1.1.1 2001-07-23 17:17:23 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements support import,export,link routines + for the (i386) Go32v2 target + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit t_go32v2; + + interface + uses + link; + + type + plinkergo32v2=^tlinkergo32v2; + tlinkergo32v2=object(tlinker) + private + Function WriteResponseFile(isdll:boolean) : Boolean; + public + constructor Init; + procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + end; + + + implementation + + uses + strings,globtype,globals,cobjects,systems,verbose,script,files; + + +{**************************************************************************** + TLinkerGo32v2 +****************************************************************************} + +Constructor TLinkerGo32v2.Init; +begin + Inherited Init; + { allow duplicated libs (PM) } + SharedLibFiles.doubles:=true; + StaticLibFiles.doubles:=true; +end; + + +procedure TLinkerGo32v2.SetDefaultInfo; +begin + with Info do + begin + ExeCmd[1]:='ld -oformat coff-go32-exe $OPT $STRIP -o $EXE @$RES'; + end; +end; + + +Function TLinkerGo32v2.WriteResponseFile(isdll:boolean) : Boolean; +Var + linkres : TLinkRes; + i : longint; +{$IFDEF NEWST} + HPath : PStringItem; +{$ELSE} + HPath : PStringQueueItem; +{$ENDIF NEWST} + s : string; + linklibc : boolean; +begin + WriteResponseFile:=False; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+GetShortName(HPath^.Data^)); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+GetShortName(HPath^.Data^)); + HPath:=HPath^.Next; + end; + + { add objectfiles, start with prt0 always } + LinkRes.AddFileName(GetShortName(FindObjectFile('prt0',''))); + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(GetShortName(s)); + end; + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + LinkRes.Add('-('); + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(GetShortName(s)) + end; + LinkRes.Add('-)'); + end; + + { Write sharedlibraries like -l, also add the needed dynamic linker + here to be sure that it gets linked this is needed for glibc2 systems (PFV) } + linklibc:=false; + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if s<>'c' then + begin + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s); + end + else + begin + LinkRes.Add('-l'+s); + linklibc:=true; + end; + end; + { be sure that libc&libgcc is the last lib } + if linklibc then + begin + LinkRes.Add('-lc'); + LinkRes.Add('-lgcc'); + end; + +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; + + +function TLinkerGo32v2.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + success : boolean; + StripStr : string[40]; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + StripStr:=''; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; + +{ Write used files and libraries } + WriteResponseFile(false); + +{ Call linker } + SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.exefilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$STRIP',StripStr); + success:=DoExec(FindUtil(BinStr),cmdstr,true,false); + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + + +{$ifdef notnecessary} +procedure tlinkergo32v2.postprocessexecutable(const n : string); +type + tcoffheader=packed record + mach : word; + nsects : word; + time : longint; + sympos : longint; + syms : longint; + opthdr : word; + flag : word; + end; + tcoffsechdr=packed record + name : array[0..7] of char; + vsize : longint; + rvaofs : longint; + datalen : longint; + datapos : longint; + relocpos : longint; + lineno1 : longint; + nrelocs : word; + lineno2 : word; + flags : longint; + end; + psecfill=^tsecfill; + tsecfill=record + fillpos, + fillsize : longint; + next : psecfill; + end; +var + f : file; + coffheader : tcoffheader; + firstsecpos, + maxfillsize, + l : longint; + coffsec : tcoffsechdr; + secroot,hsecroot : psecfill; + zerobuf : pointer; +begin + { when -s is used quit, because there is no .exe } + if cs_link_extern in aktglobalswitches then + exit; + { open file } + assign(f,n); + {$I-} + reset(f,1); + if ioresult<>0 then + Message1(execinfo_f_cant_open_executable,n); + { read headers } + seek(f,2048); + blockread(f,coffheader,sizeof(tcoffheader)); + { read section info } + maxfillsize:=0; + firstsecpos:=0; + secroot:=nil; + for l:=1to coffheader.nSects do + begin + blockread(f,coffsec,sizeof(tcoffsechdr)); + if coffsec.datapos>0 then + begin + if secroot=nil then + firstsecpos:=coffsec.datapos; + new(hsecroot); + hsecroot^.fillpos:=coffsec.datapos+coffsec.vsize; + hsecroot^.fillsize:=coffsec.datalen-coffsec.vsize; + hsecroot^.next:=secroot; + secroot:=hsecroot; + if secroot^.fillsize>maxfillsize then + maxfillsize:=secroot^.fillsize; + end; + end; + if firstsecpos>0 then + begin + l:=firstsecpos-filepos(f); + if l>maxfillsize then + maxfillsize:=l; + end + else + l:=0; + { get zero buffer } + getmem(zerobuf,maxfillsize); + fillchar(zerobuf^,maxfillsize,0); + { zero from sectioninfo until first section } + blockwrite(f,zerobuf^,l); + { zero section alignments } + while assigned(secroot) do + begin + seek(f,secroot^.fillpos); + blockwrite(f,zerobuf^,secroot^.fillsize); + hsecroot:=secroot; + secroot:=secroot^.next; + dispose(hsecroot); + end; + freemem(zerobuf,maxfillsize); + close(f); + {$I+} + i:=ioresult; + postprocessexecutable:=true; +end; +{$endif} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.11 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.10 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.9 2000/02/09 13:23:06 peter + * log truncated + + Revision 1.8 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.7 2000/01/07 01:14:42 peter + * updated copyright to 2000 + + Revision 1.6 1999/12/06 18:21:04 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + + Revision 1.5 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.4 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.3 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.2 1999/10/22 14:42:40 peter + * reset linklibc + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/t_linux.pas b/befpc/compiler/t_linux.pas new file mode 100644 index 0000000..216dffa --- /dev/null +++ b/befpc/compiler/t_linux.pas @@ -0,0 +1,534 @@ +{ + $Id: t_linux.pas,v 1.1.1.1 2001-07-23 17:17:23 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements support import,export,link routines + for the (i386) Linux target + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit t_linux; +interface + + uses + import,export,link; + + type + pimportliblinux=^timportliblinux; + timportliblinux=object(timportlib) + procedure preparelib(const s:string);virtual; + procedure importprocedure(const func,module:string;index:longint;const name:string);virtual; + procedure importvariable(const varname,module:string;const name:string);virtual; + procedure generatelib;virtual; + end; + + pexportliblinux=^texportliblinux; + texportliblinux=object(texportlib) + procedure preparelib(const s : string);virtual; + procedure exportprocedure(hp : pexported_item);virtual; + procedure exportvar(hp : pexported_item);virtual; + procedure generatelib;virtual; + end; + + plinkerlinux=^tlinkerlinux; + tlinkerlinux=object(tlinker) + private + Glibc2, + Glibc21 : boolean; + Function WriteResponseFile(isdll:boolean) : Boolean; + public + constructor Init; + procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + function MakeSharedLibrary:boolean;virtual; + end; + + +implementation + + uses + verbose,strings,cobjects,systems,globtype,globals, + symconst,script, + files,aasm,cpuasm,cpubase,symtable{$IFDEF NEWST},symbols{$ENDIF NEWST}; + +{***************************************************************************** + TIMPORTLIBLINUX +*****************************************************************************} + +procedure timportliblinux.preparelib(const s : string); +begin +end; + + +procedure timportliblinux.importprocedure(const func,module : string;index : longint;const name : string); +begin + { insert sharedlibrary } +{$IFDEF NEWST} + current_module^.linkothersharedlibs. + insert(new(Plinkitem,init(SplitName(module),link_allways))); + { do nothing with the procedure, only set the mangledname } + if name<>'' then + aktprocdef^.setmangledname(name) + else + message(parser_e_empty_import_name); +{$ELSE} + current_module^.linkothersharedlibs. + insert(SplitName(module),link_allways); + { do nothing with the procedure, only set the mangledname } + if name<>'' then + aktprocsym^.definition^.setmangledname(name) + else + message(parser_e_empty_import_name); +{$ENDIF NEWST} +end; + + +procedure timportliblinux.importvariable(const varname,module:string;const name:string); +begin + { insert sharedlibrary } +{$IFDEF NEWST} + current_module^.linkothersharedlibs. + insert(new(Plinkitem,init(SplitName(module),link_allways))); +{$ELSE} + current_module^.linkothersharedlibs. + insert(SplitName(module),link_allways); +{$ENDIF NEWST} + { reset the mangledname and turn off the dll_var option } + aktvarsym^.setmangledname(name); +{$IFDEF NEWST} + exclude(aktvarsym^.properties,vo_is_dll_var); +{$ELSE} +{$ifdef INCLUDEOK} + exclude(aktvarsym^.varoptions,vo_is_dll_var); +{$else} + aktvarsym^.varoptions:=aktvarsym^.varoptions-[vo_is_dll_var]; +{$endif} +{$ENDIF NEWST} +end; + + +procedure timportliblinux.generatelib; +begin +end; + + +{***************************************************************************** + TEXPORTLIBLINUX +*****************************************************************************} + +procedure texportliblinux.preparelib(const s:string); +begin +end; + + +procedure texportliblinux.exportprocedure(hp : pexported_item); +var + hp2 : pexported_item; +begin + { first test the index value } + if (hp^.options and eo_index)<>0 then + begin + Comment(V_Error,'can''t export with index under linux'); + exit; + end; + { use pascal name is none specified } + if (hp^.options and eo_name)=0 then + begin + hp^.name:=stringdup(hp^.sym^.name); + hp^.options:=hp^.options or eo_name; + end; + { now place in correct order } + hp2:=pexported_item(current_module^._exports^.first); + while assigned(hp2) and + (hp^.name^>hp2^.name^) do + hp2:=pexported_item(hp2^.next); + { insert hp there !! } + if assigned(hp2) and (hp2^.name^=hp^.name^) then + begin + { this is not allowed !! } + Message1(parser_e_export_name_double,hp^.name^); + exit; + end; + if hp2=pexported_item(current_module^._exports^.first) then + current_module^._exports^.insert(hp) + else if assigned(hp2) then + begin + hp^.next:=hp2; + hp^.previous:=hp2^.previous; + if assigned(hp2^.previous) then + hp2^.previous^.next:=hp; + hp2^.previous:=hp; + end + else + current_module^._exports^.concat(hp); +end; + + +procedure texportliblinux.exportvar(hp : pexported_item); +begin + hp^.is_var:=true; + exportprocedure(hp); +end; + + +procedure texportliblinux.generatelib; +var + hp2 : pexported_item; +begin + hp2:=pexported_item(current_module^._exports^.first); + while assigned(hp2) do + begin + if not hp2^.is_var then + begin +{$ifdef i386} + { place jump in codesegment } + codesegment^.concat(new(pai_align,init_op(4,$90))); + codesegment^.concat(new(pai_symbol,initname_global(hp2^.name^,0))); + codesegment^.concat(new(paicpu,op_sym(A_JMP,S_NO,newasmsymbol(hp2^.sym^.mangledname)))); + codesegment^.concat(new(pai_symbol_end,initname(hp2^.name^))); +{$endif i386} + end + else + Comment(V_Error,'Exporting of variables is not supported under linux'); + hp2:=pexported_item(hp2^.next); + end; +end; + + +{***************************************************************************** + TLINKERLINUX +*****************************************************************************} + +Constructor TLinkerLinux.Init; +begin + Inherited Init; + LibrarySearchPath.AddPath('/lib;/usr/lib;/usr/X11R6/lib',true); +end; + + +procedure TLinkerLinux.SetDefaultInfo; +{ + This will also detect which libc version will be used +} +begin + Glibc2:=false; + Glibc21:=false; + with Info do + begin + ExeCmd[1]:='ld $OPT $DYNLINK $STATIC $STRIP -L. -o $EXE $RES'; + DllCmd[1]:='ld $OPT -shared -L. -o $EXE $RES'; + DllCmd[2]:='strip --strip-unneeded $EXE'; + { first try glibc2 } + DynamicLinker:='/lib/ld-linux.so.2'; + if FileExists(DynamicLinker) then + begin + Glibc2:=true; + { Check for 2.0 files, else use the glibc 2.1 stub } + if FileExists('/lib/ld-2.0.*') then + Glibc21:=false + else + Glibc21:=true; + end + else + DynamicLinker:='/lib/ld-linux.so.1'; + end; +end; + + +Function TLinkerLinux.WriteResponseFile(isdll:boolean) : Boolean; +Var + linkres : TLinkRes; + i : longint; + cprtobj, + gprtobj, + prtobj : string[80]; +{$IFDEF NEWST} + HPath : PStringItem; +{$ELSE} + HPath : PStringQueueItem; +{$ENDIF NEWST} + s : string; + found, + linkdynamic, + linklibc : boolean; +begin + WriteResponseFile:=False; +{ set special options for some targets } + linkdynamic:=not(SharedLibFiles.empty); + linklibc:=SharedLibFiles.Find('c'); + prtobj:='prt0'; + cprtobj:='cprt0'; + gprtobj:='gprt0'; + if glibc21 then + begin + cprtobj:='cprt21'; + gprtobj:='gprt21'; + end; + if cs_profile in aktmoduleswitches then + begin + prtobj:=gprtobj; + if not glibc2 then + AddSharedLibrary('gmon'); + AddSharedLibrary('c'); + linklibc:=true; + end + else + begin + if linklibc then + prtobj:=cprtobj; + end; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('SEARCH_DIR('+HPath^.Data^+')'); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('SEARCH_DIR('+HPath^.Data^+')'); + HPath:=HPath^.Next; + end; + + LinkRes.Add('INPUT('); + { add objectfiles, start with prt0 always } + if prtobj<>'' then + LinkRes.AddFileName(FindObjectFile(prtobj,'')); + { try to add crti and crtbegin if linking to C } + if linklibc then + begin + s:=librarysearchpath.FindFile('crtbegin.o',found)+'crtbegin.o'; + if found then + LinkRes.AddFileName(s); + s:=librarysearchpath.FindFile('crti.o',found)+'crti.o'; + if found then + LinkRes.AddFileName(s); + end; + { main objectfiles } + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(s); + end; + { objects which must be at the end } + if linklibc then + begin + s:=librarysearchpath.FindFile('crtend.o',found)+'crtend.o'; + if found then + LinkRes.AddFileName(s); + s:=librarysearchpath.FindFile('crtn.o',found)+'crtn.o'; + if found then + LinkRes.AddFileName(s); + end; + LinkRes.Add(')'); + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + LinkRes.Add('GROUP('); + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(s) + end; + LinkRes.Add(')'); + end; + + { Write sharedlibraries like -l, also add the needed dynamic linker + here to be sure that it gets linked this is needed for glibc2 systems (PFV) } + if not SharedLibFiles.Empty then + begin + LinkRes.Add('INPUT('); + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if s<>'c' then + begin + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s); + end + else + begin + linklibc:=true; + linkdynamic:=false; { libc will include the ld-linux for us } + end; + end; + { be sure that libc is the last lib } + if linklibc then + LinkRes.Add('-lc'); + { when we have -static for the linker the we also need libgcc } + if (cs_link_staticflag in aktglobalswitches) then + LinkRes.Add('-lgcc'); + if linkdynamic and (Info.DynamicLinker<>'') then + LinkRes.AddFileName(Info.DynamicLinker); + LinkRes.Add(')'); + end; +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; + + +function TLinkerLinux.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + success : boolean; + DynLinkStr : string[60]; + StaticStr, + StripStr : string[40]; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + StaticStr:=''; + StripStr:=''; + DynLinkStr:=''; + if (cs_link_staticflag in aktglobalswitches) then + StaticStr:='-static'; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; + If (cs_profile in aktmoduleswitches) or + ((Info.DynamicLinker<>'') and (not SharedLibFiles.Empty)) then + DynLinkStr:='-dynamic-linker='+Info.DynamicLinker; + +{ Write used files and libraries } + WriteResponseFile(false); + +{ Call linker } + SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.exefilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$STATIC',StaticStr); + Replace(cmdstr,'$STRIP',StripStr); + Replace(cmdstr,'$DYNLINK',DynLinkStr); + success:=DoExec(FindUtil(BinStr),CmdStr,true,false); + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + + +Function TLinkerLinux.MakeSharedLibrary:boolean; +var + binstr, + cmdstr : string; + success : boolean; +begin + MakeSharedLibrary:=false; + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.sharedlibfilename^); + +{ Write used files and libraries } + WriteResponseFile(true); + +{ Call linker } + SplitBinCmd(Info.DllCmd[1],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.sharedlibfilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + success:=DoExec(FindUtil(binstr),cmdstr,true,false); + +{ Strip the library ? } + if success and (cs_link_strip in aktglobalswitches) then + begin + SplitBinCmd(Info.DllCmd[2],binstr,cmdstr); + Replace(cmdstr,'$EXE',current_module^.sharedlibfilename^); + success:=DoExec(FindUtil(binstr),cmdstr,true,false); + end; + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeSharedLibrary:=success; { otherwise a recursive call to link method } +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.15 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.14 2000/03/21 21:36:52 peter + * only include crtbegin when linking to libc + + Revision 1.13 2000/03/12 08:24:03 daniel + * Modification for new symtable + + Revision 1.12 2000/03/02 13:12:37 daniel + * Removed a comment to fix gtk. + + Revision 1.11 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.10 2000/02/27 14:46:04 peter + * check for ld-so.2.0.* then no glibc21 is used, else glibc21 is used + + Revision 1.9 2000/02/09 10:35:48 peter + * -Xt option to link staticly against c libs + + Revision 1.8 2000/01/11 09:52:07 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.7 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.6 2000/01/07 01:14:42 peter + * updated copyright to 2000 + + Revision 1.5 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.4 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.3 1999/11/05 13:15:00 florian + * some fixes to get the new cg compiling again + + Revision 1.2 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/t_os2.pas b/befpc/compiler/t_os2.pas new file mode 100644 index 0000000..5a3a33b --- /dev/null +++ b/befpc/compiler/t_os2.pas @@ -0,0 +1,559 @@ +{ + $Id: t_os2.pas,v 1.1.1.1 2001-07-23 17:17:23 memson Exp $ + Copyright (c) 1998-2000 by Daniel Mantione + Portions Copyright (c) 1998-2000 Eberhard Mattes + + Unit to write out import libraries and def files for OS/2 + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{ + A lot of code in this unit has been ported from C to Pascal from the + emximp utility, part of the EMX development system. Emximp is copyrighted + by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal + port, please send questions to Daniel Mantione + . +} +unit t_os2; + +interface +uses + import,link,comprsrc; + +type + pimportlibos2=^timportlibos2; + timportlibos2=object(timportlib) + procedure preparelib(const s:string);virtual; + procedure importprocedure(const func,module:string;index:longint;const name:string);virtual; + procedure generatelib;virtual; + end; + + plinkeros2=^tlinkeros2; + tlinkeros2=object(tlinker) + private + Function WriteResponseFile(isdll:boolean) : Boolean; + public + constructor Init; + procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + end; + + +{***************************************************************************} + +{***************************************************************************} + +implementation + + uses +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + globtype,strings,cobjects,comphook,systems, + globals,verbose,files,script; + +const profile_flag:boolean=false; + +const n_ext = 1; + n_abs = 2; + n_text = 4; + n_data = 6; + n_bss = 8; + n_imp1 = $68; + n_imp2 = $6a; + +type reloc=packed record {This is the layout of a relocation table + entry.} + address:longint; {Fixup location} + remaining:longint; + {Meaning of bits for remaining: + 0..23: Symbol number or segment + 24: Self-relative fixup if non-zero + 25..26: Fixup size (0: 1 byte, 1: 2, 2: 4 bytes) + 27: Reference to symbol or segment + 28..31 Not used} + end; + + nlist=packed record {This is the layout of a symbol table entry.} + strofs:longint; {Offset in string table} + typ:byte; {Type of the symbol} + other:byte; {Other information} + desc:word; {More information} + value:longint; {Value (address)} + end; + + a_out_header=packed record + magic:word; {Magic word, must be $0107} + machtype:byte; {Machine type} + flags:byte; {Flags} + text_size:longint; {Length of text, in bytes} + data_size:longint; {Length of initialized data, in bytes} + bss_size:longint; {Length of uninitialized data, in bytes} + sym_size:longint; {Length of symbol table, in bytes} + entry:longint; {Start address (entry point)} + trsize:longint; {Length of relocation info for text, bytes} + drsize:longint; {Length of relocation info for data, bytes} + end; + + ar_hdr=packed record + ar_name:array[0..15] of char; + ar_date:array[0..11] of char; + ar_uid:array[0..5] of char; + ar_gid:array[0..5] of char; + ar_mode:array[0..7] of char; + ar_size:array[0..9] of char; + ar_fmag:array[0..1] of char; + end; + +var aout_str_size:longint; + aout_str_tab:array[0..2047] of byte; + aout_sym_count:longint; + aout_sym_tab:array[0..5] of nlist; + + aout_text:array[0..63] of byte; + aout_text_size:longint; + + aout_treloc_tab:array[0..1] of reloc; + aout_treloc_count:longint; + + aout_size:longint; + seq_no:longint; + + ar_member_size:longint; + + out_file:file; + +procedure write_ar(const name:string;size:longint); + +var ar:ar_hdr; + time:datetime; + dummy:word; + numtime:longint; + tmp:string[19]; + + +begin + ar_member_size:=size; + fillchar(ar.ar_name,sizeof(ar.ar_name),' '); + move(name[1],ar.ar_name,length(name)); + getdate(time.year,time.month,time.day,dummy); + gettime(time.hour,time.min,time.sec,dummy); + packtime(time,numtime); + str(numtime,tmp); + fillchar(ar.ar_date,sizeof(ar.ar_date),' '); + move(tmp[1],ar.ar_date,length(tmp)); + ar.ar_uid:='0 '; + ar.ar_gid:='0 '; + ar.ar_mode:='100666'#0#0; + str(size,tmp); + fillchar(ar.ar_size,sizeof(ar.ar_size),' '); + move(tmp[1],ar.ar_size,length(tmp)); + ar.ar_fmag:='`'#10; + blockwrite(out_file,ar,sizeof(ar)); +end; + +procedure finish_ar; + +var a:byte; + +begin + a:=0; + if odd(ar_member_size) then + blockwrite(out_file,a,1); +end; + +procedure aout_init; + +begin + aout_str_size:=sizeof(longint); + aout_sym_count:=0; + aout_text_size:=0; + aout_treloc_count:=0; +end; + +function aout_sym(const name:string;typ,other:byte;desc:word; + value:longint):longint; + +begin + if aout_str_size+length(name)+1>sizeof(aout_str_tab) then + Do_halt($da); + if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then + Do_halt($da); + aout_sym_tab[aout_sym_count].strofs:=aout_str_size; + aout_sym_tab[aout_sym_count].typ:=typ; + aout_sym_tab[aout_sym_count].other:=other; + aout_sym_tab[aout_sym_count].desc:=desc; + aout_sym_tab[aout_sym_count].value:=value; + strPcopy(@aout_str_tab[aout_str_size],name); + aout_str_size:=aout_str_size+length(name)+1; + aout_sym:=aout_sym_count; + inc(aout_sym_count); +end; + +procedure aout_text_byte(b:byte); + +begin + if aout_text_size>=sizeof(aout_text) then + Do_halt($da); + aout_text[aout_text_size]:=b; + inc(aout_text_size); +end; + +procedure aout_text_dword(d:longint); + +type li_ar=array[0..3] of byte; + +begin + aout_text_byte(li_ar(d)[0]); + aout_text_byte(li_ar(d)[1]); + aout_text_byte(li_ar(d)[2]); + aout_text_byte(li_ar(d)[3]); +end; + +procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint); + +begin + if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then + Do_halt($da); + aout_treloc_tab[aout_treloc_count].address:=address; + aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+ + len shl 25+ext shl 27; + inc(aout_treloc_count); +end; + +procedure aout_finish; + +begin + while (aout_text_size and 3)<>0 do + aout_text_byte ($90); + aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count* + sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size; +end; + +procedure aout_write; + +var ao:a_out_header; + +begin + ao.magic:=$0107; + ao.machtype:=0; + ao.flags:=0; + ao.text_size:=aout_text_size; + ao.data_size:=0; + ao.bss_size:=0; + ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]); + ao.entry:=0; + ao.trsize:=aout_treloc_count*sizeof(reloc); + ao.drsize:=0; + blockwrite(out_file,ao,sizeof(ao)); + blockwrite(out_file,aout_text,aout_text_size); + blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count); + blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count); + longint((@aout_str_tab)^):=aout_str_size; + blockwrite(out_file,aout_str_tab,aout_str_size); +end; + +procedure timportlibos2.preparelib(const s:string); + +{This code triggers a lot of bugs in the compiler. +const armag='!'#10; + ar_magic:array[1..length(armag)] of char=armag;} +const ar_magic:array[1..8] of char='!'#10; + +begin + seq_no:=1; + if not (cs_create_smart in aktmoduleswitches) then +{$IFDEF NEWST} + current_module^.linkotherstaticlibs. + insert(new(Plinkitem,init(s,link_allways))); +{$ELSE} + current_module^.linkotherstaticlibs.insert(s,link_allways); +{$ENDIF NEWST} + assign(out_file,current_module^.outputpath^+s+'.ao2'); + rewrite(out_file,1); + blockwrite(out_file,ar_magic,sizeof(ar_magic)); +end; + +procedure timportlibos2.importprocedure(const func,module:string;index:longint;const name:string); +{func = Name of function to import. + module = Name of DLL to import from. + index = Index of function in DLL. Use 0 to import by name. + name = Name of function in DLL. Ignored when index=0;} +var tmp1,tmp2,tmp3:string; + sym_mcount,sym_import:longint; + fixup_mcount,fixup_import:longint; +begin + aout_init; + tmp2:=func; + if profile_flag and not (copy(func,1,4)='_16_') then + begin + {sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);} + sym_mcount:=aout_sym('__mcount',n_ext,0,0,0); + {Use, say, "_$U_DosRead" for "DosRead" to import the + non-profiled function.} + tmp2:='__$U_'+func; + sym_import:=aout_sym(tmp2,n_ext,0,0,0); + aout_text_byte($55); {push ebp} + aout_text_byte($89); {mov ebp, esp} + aout_text_byte($e5); + aout_text_byte($e8); {call _mcount} + fixup_mcount:=aout_text_size; + aout_text_dword(0-(aout_text_size+4)); + aout_text_byte($5d); {pop ebp} + aout_text_byte($e9); {jmp _$U_DosRead} + fixup_import:=aout_text_size; + aout_text_dword(0-(aout_text_size+4)); + + aout_treloc(fixup_mcount,sym_mcount,1,2,1); + aout_treloc (fixup_import, sym_import,1,2,1); + end; + str(seq_no,tmp1); + tmp1:='IMPORT#'+tmp1; + if name='' then + begin + str(index,tmp3); + tmp3:=func+'='+module+'.'+tmp3; + end + else + tmp3:=func+'='+module+'.'+name; + aout_sym(tmp2,n_imp1+n_ext,0,0,0); + aout_sym(tmp3,n_imp2+n_ext,0,0,0); + aout_finish; + write_ar(tmp1,aout_size); + aout_write; + finish_ar; + inc(seq_no); +end; + +procedure timportlibos2.generatelib; + +begin + close(out_file); +end; + + +{**************************************************************************** + TLinkeros2 +****************************************************************************} + +Constructor TLinkeros2.Init; +begin + Inherited Init; + { allow duplicated libs (PM) } + SharedLibFiles.doubles:=true; + StaticLibFiles.doubles:=true; +end; + + +procedure TLinkeros2.SetDefaultInfo; +begin + with Info do + begin + ExeCmd[1]:='ld $OPT -o $EXE @$RES'; + ExeCmd[2]:='emxbind -b $STRIP $PM $RSRC -k$STACKKB -h$HEAPMB -o $EXE.exe $EXE -aim -s$DOSHEAPKB'; + end; +end; + + +Function TLinkeros2.WriteResponseFile(isdll:boolean) : Boolean; +Var + linkres : TLinkRes; + i : longint; +{$IFDEF NEWST} + HPath : PStringItem; +{$ELSE} + HPath : PStringQueueItem; +{$ENDIF NEWST} + s : string; +begin + WriteResponseFile:=False; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('-L'+HPath^.Data^); + HPath:=HPath^.Next; + end; + + { add objectfiles, start with prt0 always } + LinkRes.AddFileName(FindObjectFile('prt0','')); + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(s); + end; + + { Write staticlibraries } + { No group !! This will not work correctly PM } + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(s) + end; + + { Write sharedlibraries like -l, also add the needed dynamic linker + here to be sure that it gets linked this is needed for glibc2 systems (PFV) } + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s); + end; + +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; + + +function TLinkeros2.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + success : boolean; + i : longint; + PMStr, + StripStr: string[40]; + RsrcStr : string; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + if (cs_link_strip in aktglobalswitches) then + StripStr := '-s' + else + StripStr := ''; + if usewindowapi then + PMStr := '-p' + else + PMStr := ''; + if not (Current_Module^.ResourceFiles.Empty) then + RsrcStr := '-r ' + Current_Module^.ResourceFiles.Get + else + RsrcStr := ''; +(* Only one resource file supported, discard everything else + (should be already empty anyway, however. *) + Current_Module^.ResourceFiles.Clear; +{ Write used files and libraries } + WriteResponseFile(false); + +{ Call linker } + success:=false; + for i:=1 to 2 do + begin + SplitBinCmd(Info.ExeCmd[i],binstr,cmdstr); + if binstr<>'' then + begin + Replace(cmdstr,'$HEAPMB',tostr((maxheapsize+1048575) shr 20)); + {Size of the stack when an EMX program runs in OS/2.} + Replace(cmdstr,'$STACKKB',tostr((stacksize+1023) shr 10)); + {When an EMX program runs in DOS, the heap and stack share the + same memory pool. The heap grows upwards, the stack grows downwards.} + Replace(cmdstr,'$DOSHEAPKB',tostr((stacksize+maxheapsize+1023) shr 10)); + Replace(cmdstr,'$STRIP',StripStr); + Replace(cmdstr,'$PM',PMStr); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RSRC',RsrcStr); + Replace(cmdstr,'$EXE',current_module^.exefilename^); + success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false); +(* We still want to have the PPAS script complete, right? + if not success then + break; +*) + end; + end; + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + RemoveFile(outputexedir+Info.ResName); + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.14 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.13 2000/06/28 03:34:06 hajny + * little corrections for EMX resources + + Revision 1.12 2000/06/25 19:08:28 hajny + + $R support for OS/2 (EMX) added + + Revision 1.11 2000/04/01 10:45:14 hajny + * .ao2 bug fixed + + Revision 1.10 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.9 2000/02/09 13:23:06 peter + * log truncated + + Revision 1.8 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.7 2000/01/07 01:14:43 peter + * updated copyright to 2000 + + Revision 1.6 1999/11/30 10:40:56 peter + + ttype, tsymlist + + Revision 1.5 1999/11/29 20:15:29 hajny + * missing space in EMXBIND params + + Revision 1.4 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.3 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.2 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} diff --git a/befpc/compiler/t_win32.pas b/befpc/compiler/t_win32.pas new file mode 100644 index 0000000..c18b6d0 --- /dev/null +++ b/befpc/compiler/t_win32.pas @@ -0,0 +1,1405 @@ +{ + $Id: t_win32.pas,v 1.1.1.1 2001-07-23 17:17:25 memson Exp $ + Copyright (c) 1998-2000 by Peter Vreman + + This unit implements support import,export,link routines + for the (i386) Win32 target + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit t_win32; + + interface + + uses + import,export,link; + + const + winstackpagesize = 4096; + + type + pimportlibwin32=^timportlibwin32; + timportlibwin32=object(timportlib) + procedure preparelib(const s:string);virtual; + procedure importprocedure(const func,module:string;index:longint;const name:string);virtual; + procedure importvariable(const varname,module:string;const name:string);virtual; + procedure generatelib;virtual; + procedure generatesmartlib;virtual; + end; + + pexportlibwin32=^texportlibwin32; + texportlibwin32=object(texportlib) + st : string; + last_index : longint; + procedure preparelib(const s:string);virtual; + procedure exportprocedure(hp : pexported_item);virtual; + procedure exportvar(hp : pexported_item);virtual; + procedure generatelib;virtual; + end; + + plinkerwin32=^tlinkerwin32; + tlinkerwin32=object(tlinker) + private + Function WriteResponseFile(isdll:boolean) : Boolean; + Function PostProcessExecutable(const fn:string;isdll:boolean) : Boolean; + public + Constructor Init; + Procedure SetDefaultInfo;virtual; + function MakeExecutable:boolean;virtual; + function MakeSharedLibrary:boolean;virtual; + end; + + + implementation + + uses +{$ifdef PAVEL_LINKLIB} +{$ifdef Delphi} + dmisc, +{$else Delphi} + dos, +{$endif Delphi} + impdef, +{$endif PAVEL_LINKLIB} + aasm,files,globtype,globals,cobjects,systems,verbose, + script,gendef, + cpubase,cpuasm +{$ifdef GDB} + ,gdb +{$endif} + ; + + function DllName(Const Name : string) : string; + var n : string; + begin + n:=Upper(SplitExtension(Name)); + if (n='.DLL') or (n='.DRV') or (n='.EXE') then + DllName:=Name + else + DllName:=Name+target_os.sharedlibext; + end; + + +{***************************************************************************** + TIMPORTLIBWIN32 +*****************************************************************************} + + procedure timportlibwin32.preparelib(const s : string); + begin + if not(assigned(importssection)) then + importssection:=new(paasmoutput,init); + end; + + + procedure timportlibwin32.importprocedure(const func,module : string;index : longint;const name : string); + var + hp1 : pimportlist; + hp2 : pimported_item; + hs : string; + begin + hs:=DllName(module); + { search for the module } + hp1:=pimportlist(current_module^.imports^.first); + while assigned(hp1) do + begin + if hs=hp1^.dllname^ then + break; + hp1:=pimportlist(hp1^.next); + end; + { generate a new item ? } + if not(assigned(hp1)) then + begin + hp1:=new(pimportlist,init(hs)); + current_module^.imports^.concat(hp1); + end; + { search for reuse of old import item } + hp2:=pimported_item(hp1^.imported_items^.first); + while assigned(hp2) do + begin + if hp2^.func^=func then + break; + hp2:=pimported_item(hp2^.next); + end; + if not assigned(hp2) then + begin + hp2:=new(pimported_item,init(func,name,index)); + hp1^.imported_items^.concat(hp2); + end; + end; + + + procedure timportlibwin32.importvariable(const varname,module:string;const name:string); + var + hp1 : pimportlist; + hp2 : pimported_item; + hs : string; + begin + hs:=DllName(module); + { search for the module } + hp1:=pimportlist(current_module^.imports^.first); + while assigned(hp1) do + begin + if hs=hp1^.dllname^ then + break; + hp1:=pimportlist(hp1^.next); + end; + { generate a new item ? } + if not(assigned(hp1)) then + begin + hp1:=new(pimportlist,init(hs)); + current_module^.imports^.concat(hp1); + end; + hp2:=new(pimported_item,init_var(varname,name)); + hp1^.imported_items^.concat(hp2); + end; + + + procedure timportlibwin32.generatesmartlib; + var + hp1 : pimportlist; + hp2 : pimported_item; + lhead,lname,lcode, + lidata4,lidata5 : pasmlabel; + r : preference; + begin + hp1:=pimportlist(current_module^.imports^.first); + while assigned(hp1) do + begin + { Get labels for the sections } + getdatalabel(lhead); + getdatalabel(lname); + getlabel(lidata4); + getlabel(lidata5); + { create header for this importmodule } + importssection^.concat(new(pai_cut,init_begin)); + importssection^.concat(new(pai_section,init(sec_idata2))); + importssection^.concat(new(pai_label,init(lhead))); + { pointer to procedure names } + importssection^.concat(new(pai_const_symbol,init_rva(lidata4))); + { two empty entries follow } + importssection^.concat(new(pai_const,init_32bit(0))); + importssection^.concat(new(pai_const,init_32bit(0))); + { pointer to dll name } + importssection^.concat(new(pai_const_symbol,init_rva(lname))); + { pointer to fixups } + importssection^.concat(new(pai_const_symbol,init_rva(lidata5))); + { first write the name references } + importssection^.concat(new(pai_section,init(sec_idata4))); + importssection^.concat(new(pai_const,init_32bit(0))); + importssection^.concat(new(pai_label,init(lidata4))); + { then the addresses and create also the indirect jump } + importssection^.concat(new(pai_section,init(sec_idata5))); + importssection^.concat(new(pai_const,init_32bit(0))); + importssection^.concat(new(pai_label,init(lidata5))); + + { create procedures } + hp2:=pimported_item(hp1^.imported_items^.first); + while assigned(hp2) do + begin + { insert cuts } + importssection^.concat(new(pai_cut,init)); + { create indirect jump } + if not hp2^.is_var then + begin + getlabel(lcode); + new(r); + reset_reference(r^); + r^.symbol:=lcode; + { place jump in codesegment, insert a code section in the + importsection to reduce the amount of .s files (PFV) } + importssection^.concat(new(pai_section,init(sec_code))); +{$IfDef GDB} + if (cs_debuginfo in aktmoduleswitches) then + importssection^.concat(new(pai_stab_function_name,init(nil))); +{$EndIf GDB} + importssection^.concat(new(pai_symbol,initname_global(hp2^.func^,0))); + importssection^.concat(new(paicpu,op_ref(A_JMP,S_NO,r))); + importssection^.concat(new(pai_align,init_op(4,$90))); + end; + { create head link } + importssection^.concat(new(pai_section,init(sec_idata7))); + importssection^.concat(new(pai_const_symbol,init_rva(lhead))); + { fixup } + getlabel(pasmlabel(hp2^.lab)); + importssection^.concat(new(pai_section,init(sec_idata4))); + importssection^.concat(new(pai_const_symbol,init_rva(hp2^.lab))); + { add jump field to importsection } + importssection^.concat(new(pai_section,init(sec_idata5))); + if hp2^.is_var then + importssection^.concat(new(pai_symbol,initname_global(hp2^.func^,0))) + else + importssection^.concat(new(pai_label,init(lcode))); + if hp2^.name^<>'' then + importssection^.concat(new(pai_const_symbol,init_rva(hp2^.lab))) + else + importssection^.concat(new(pai_const,init_32bit($80000000 or hp2^.ordnr))); + { finally the import information } + importssection^.concat(new(pai_section,init(sec_idata6))); + importssection^.concat(new(pai_label,init(hp2^.lab))); + importssection^.concat(new(pai_const,init_16bit(hp2^.ordnr))); + importssection^.concat(new(pai_string,init(hp2^.name^+#0))); + importssection^.concat(new(pai_align,init_op(2,0))); + hp2:=pimported_item(hp2^.next); + end; + + { write final section } + importssection^.concat(new(pai_cut,init_end)); + { end of name references } + importssection^.concat(new(pai_section,init(sec_idata4))); + importssection^.concat(new(pai_const,init_32bit(0))); + { end if addresses } + importssection^.concat(new(pai_section,init(sec_idata5))); + importssection^.concat(new(pai_const,init_32bit(0))); + { dllname } + importssection^.concat(new(pai_section,init(sec_idata7))); + importssection^.concat(new(pai_label,init(lname))); + importssection^.concat(new(pai_string,init(hp1^.dllname^+#0))); + + hp1:=pimportlist(hp1^.next); + end; + end; + + + procedure timportlibwin32.generatelib; + var + hp1 : pimportlist; + hp2 : pimported_item; + l1,l2,l3,l4 : pasmlabel; + r : preference; + begin + hp1:=pimportlist(current_module^.imports^.first); + while assigned(hp1) do + begin + { align codesegment for the jumps } + importssection^.concat(new(pai_section,init(sec_code))); + importssection^.concat(new(pai_align,init_op(4,$90))); + { Get labels for the sections } + getlabel(l1); + getlabel(l2); + getlabel(l3); + importssection^.concat(new(pai_section,init(sec_idata2))); + { pointer to procedure names } + importssection^.concat(new(pai_const_symbol,init_rva(l2))); + { two empty entries follow } + importssection^.concat(new(pai_const,init_32bit(0))); + importssection^.concat(new(pai_const,init_32bit(0))); + { pointer to dll name } + importssection^.concat(new(pai_const_symbol,init_rva(l1))); + { pointer to fixups } + importssection^.concat(new(pai_const_symbol,init_rva(l3))); + + { only create one section for each else it will + create a lot of idata* } + + { first write the name references } + importssection^.concat(new(pai_section,init(sec_idata4))); + importssection^.concat(new(pai_label,init(l2))); + + hp2:=pimported_item(hp1^.imported_items^.first); + while assigned(hp2) do + begin + getlabel(pasmlabel(hp2^.lab)); + if hp2^.name^<>'' then + importssection^.concat(new(pai_const_symbol,init_rva(hp2^.lab))) + else + importssection^.concat(new(pai_const,init_32bit($80000000 or hp2^.ordnr))); + hp2:=pimported_item(hp2^.next); + end; + { finalize the names ... } + importssection^.concat(new(pai_const,init_32bit(0))); + + { then the addresses and create also the indirect jump } + importssection^.concat(new(pai_section,init(sec_idata5))); + importssection^.concat(new(pai_label,init(l3))); + hp2:=pimported_item(hp1^.imported_items^.first); + while assigned(hp2) do + begin + if not hp2^.is_var then + begin + getlabel(l4); + { create indirect jump } + new(r); + reset_reference(r^); + r^.symbol:=l4; + { place jump in codesegment } + importssection^.concat(new(pai_section,init(sec_code))); + importssection^.concat(new(pai_symbol,initname_global(hp2^.func^,0))); + importssection^.concat(new(paicpu,op_ref(A_JMP,S_NO,r))); + importssection^.concat(new(pai_align,init_op(4,$90))); + { add jump field to importsection } + importssection^.concat(new(pai_section,init(sec_idata5))); + importssection^.concat(new(pai_label,init(l4))); + end + else + begin + importssection^.concat(new(pai_symbol,initname_global(hp2^.func^,0))); + end; + importssection^.concat(new(pai_const_symbol,init_rva(hp2^.lab))); + hp2:=pimported_item(hp2^.next); + end; + { finalize the addresses } + importssection^.concat(new(pai_const,init_32bit(0))); + + { finally the import information } + importssection^.concat(new(pai_section,init(sec_idata6))); + hp2:=pimported_item(hp1^.imported_items^.first); + while assigned(hp2) do + begin + importssection^.concat(new(pai_label,init(hp2^.lab))); + { the ordinal number } + importssection^.concat(new(pai_const,init_16bit(hp2^.ordnr))); + importssection^.concat(new(pai_string,init(hp2^.name^+#0))); + importssection^.concat(new(pai_align,init_op(2,0))); + hp2:=pimported_item(hp2^.next); + end; + { create import dll name } + importssection^.concat(new(pai_section,init(sec_idata7))); + importssection^.concat(new(pai_label,init(l1))); + importssection^.concat(new(pai_string,init(hp1^.dllname^+#0))); + + hp1:=pimportlist(hp1^.next); + end; + end; + + +{***************************************************************************** + TEXPORTLIBWIN32 +*****************************************************************************} + + procedure texportlibwin32.preparelib(const s:string); + begin + if not(assigned(exportssection)) then + exportssection:=new(paasmoutput,init); + last_index:=0; + end; + + + + procedure texportlibwin32.exportvar(hp : pexported_item); + begin + { same code used !! PM } + exportprocedure(hp); + end; + + + procedure texportlibwin32.exportprocedure(hp : pexported_item); + { must be ordered at least for win32 !! } + var + hp2 : pexported_item; + begin + { first test the index value } + if (hp^.options and eo_index)<>0 then + begin + if (hp^.index<=0) or (hp^.index>$ffff) then + begin + message1(parser_e_export_invalid_index,tostr(hp^.index)); + exit; + end; + if (hp^.index<=last_index) then + begin + message1(parser_e_export_ordinal_double,tostr(hp^.index)); + { disregard index value } + inc(last_index); + hp^.index:=last_index; + exit; + end + else + begin + last_index:=hp^.index; + end; + end + else + begin + inc(last_index); + hp^.index:=last_index; + end; + { use pascal name is none specified } + if (hp^.options and eo_name)=0 then + begin + hp^.name:=stringdup(hp^.sym^.name); + hp^.options:=hp^.options or eo_name; + end; + { now place in correct order } + hp2:=pexported_item(current_module^._exports^.first); + while assigned(hp2) and + (hp^.name^>hp2^.name^) do + hp2:=pexported_item(hp2^.next); + { insert hp there !! } + if assigned(hp2) and (hp2^.name^=hp^.name^) then + begin + { this is not allowed !! } + message1(parser_e_export_name_double,hp^.name^); + exit; + end; + if hp2=pexported_item(current_module^._exports^.first) then + current_module^._exports^.insert(hp) + else if assigned(hp2) then + begin + hp^.next:=hp2; + hp^.previous:=hp2^.previous; + if assigned(hp2^.previous) then + hp2^.previous^.next:=hp; + hp2^.previous:=hp; + end + else + current_module^._exports^.concat(hp); + end; + + + procedure texportlibwin32.generatelib; + var + ordinal_base,ordinal_max,ordinal_min : longint; + current_index : longint; + entries,named_entries : longint; + name_label,dll_name_label,export_address_table : pasmlabel; + export_name_table_pointers,export_ordinal_table : pasmlabel; + hp,hp2 : pexported_item; + tempexport : plinkedlist; + address_table,name_table_pointers, + name_table,ordinal_table : paasmoutput; + begin + + hp:=pexported_item(current_module^._exports^.first); + if not assigned(hp) then + exit; + + ordinal_max:=0; + ordinal_min:=$7FFFFFFF; + entries:=0; + named_entries:=0; + getlabel(dll_name_label); + getlabel(export_address_table); + getlabel(export_name_table_pointers); + getlabel(export_ordinal_table); + + { count entries } + while assigned(hp) do + begin + inc(entries); + if (hp^.index>ordinal_max) then + ordinal_max:=hp^.index; + if (hp^.index>0) and (hp^.index0 then + begin + getlabel(name_label); + name_table_pointers^.concat(new(pai_const_symbol,init_rva(name_label))); + ordinal_table^.concat(new(pai_const,init_16bit(hp^.index-ordinal_base))); + name_table^.concat(new(pai_align,init_op(2,0))); + name_table^.concat(new(pai_label,init(name_label))); + name_table^.concat(new(pai_string,init(hp^.name^+#0))); + end; + hp:=pexported_item(hp^.next); + end; + { order in increasing ordinal values } + { into tempexport list } + tempexport:=new(plinkedlist,init); + hp:=pexported_item(current_module^._exports^.first); + while assigned(hp) do + begin + current_module^._exports^.remove(hp); + hp2:=pexported_item(tempexport^.first); + while assigned(hp2) and (hp^.index>hp2^.index) do + begin + hp2:=pexported_item(hp2^.next); + end; + if hp2=pexported_item(tempexport^.first) then + tempexport^.insert(hp) + else + begin + if assigned(hp2) then + begin + hp^.next:=hp2; + hp^.previous:=hp2^.previous; + hp2^.previous:=hp; + if assigned(hp^.previous) then + hp^.previous^.next:=hp; + end + else + tempexport^.concat(hp); + end; + hp:=pexported_item(current_module^._exports^.first);; + end; + + { write the export adress table } + current_index:=ordinal_base; + hp:=pexported_item(tempexport^.first); + while assigned(hp) do + begin + { fill missing values } + while current_index'' then + LinkRes.AddFileName(GetShortName(s)); + end; + LinkRes.Add(')'); + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + LinkRes.Add('GROUP('); + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(GetShortName(s)); + end; + LinkRes.Add(')'); + end; + + { Write sharedlibraries like -l, also add the needed dynamic linker + here to be sure that it gets linked this is needed for glibc2 systems (PFV) } + if not SharedLibFiles.Empty then + begin + linklibc:=false; + LinkRes.Add('INPUT('); + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if pos('.',s)=0 then + { we never directly link a DLL + its allways through an import library PM } + { libraries created by C compilers have .a extensions } + s2:=s+'.a'{ target_os.sharedlibext } + else + s2:=s; + s2:=FindLibraryFile(s2,'',found); + if found then + begin + LinkRes.Add(s2); + continue; + end; + if pos(target_os.libprefix,s)=1 then + s:=copy(s,length(target_os.libprefix)+1,255); + if s<>'c' then + begin + i:=Pos(target_os.sharedlibext,S); + if i>0 then + Delete(S,i,255); + LinkRes.Add('-l'+s); + end + else + begin + LinkRes.Add('-l'+s); + linklibc:=true; + end; + end; + { be sure that libc is the last lib } + if linklibc then + LinkRes.Add('-lc'); + LinkRes.Add(')'); + end; +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; +{$else PAVEL_LINKLIB} +Function TLinkerWin32.WriteResponseFile(isdll:boolean) : Boolean; +Var + linkres : TLinkRes; + HPath : {$ifdef NEWST} PStringItem {$else} PStringQueueItem {$endif}; + s,s2 : string; + success : boolean; +function ExpandName(const s:string):string; +var + sysdir:string; +procedure GetSysDir; + begin + sysdir:=GetEnv('windir'); + if sysdir<>''then + begin + if not(sysdir[length(sysdir)]in['\','/'])then + sysdir:=sysdir+dirsep; + end; + end; +function IsFile(d:string;var PathToDll:string):longbool; + var + f:file; + attr:word; + begin + PathToDll:=''; + if d<>''then + if d[length(d)]<>dirsep then + d:=d+dirsep; + d:=d+s; + assign(f,d); + GetFattr(f,Attr); + if DOSerror<>0 then + IsFile:=false + else + begin + if(attr and directory)=0 then + begin + IsFile:=true; + PathToDll:=GetShortName(d); + end + else + IsFile:=false; + end; + end; +var + PathToDll:string; +begin + if not isFile('',PathToDll)then + begin + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + if isFile(GetShortName(HPath^.Data^),PathToDll)then + break; + HPath:=HPath^.Next; + end; + if PathToDll='' then + begin + GetSysDir; + if not isFile(sysdir,PathToDll)then + if not isFile(sysdir+'system32',PathToDll)then + if not isFile(sysdir+'system',PathToDll)then + begin + message1(exec_w_libfile_not_found,S2); + PathToDll:=S2; + end; + end; + end; + ExpandName:=PathToDll; +end; +function DotPos(const s:string):longint; +var + i:longint; +begin + DotPos:=0; + for i:=length(s)downto 1 do + begin + if s[i]in['/','\',':']then + exit + else if s[i]='.'then + begin + DotPos:=i; + exit; + end; + end; +end; +procedure strip(var s:string); + var + d:dirstr; + n:namestr; + e:extstr; + begin + fsplit(s,d,n,e); + s:=n; + end; +function do_makedef(const s:string):longbool; + begin + if cs_link_extern in aktglobalswitches then + do_makedef:=DoExec(FindUtil('fpimpdef'),'-o deffile.$$$ -i '+s,false,false) + else + do_makedef:=makedef(s,'deffile.$$$'); + end; +begin + WriteResponseFile:=False; + While not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.Get; + if DotPos(s)=0 then + s2:=s+target_os.sharedlibext + else + s2:=s; + strip(s); + if not do_makedef(ExpandName(s2))then + begin + Message(exec_w_error_while_linking); + aktglobalswitches:=aktglobalswitches+[cs_link_extern]; + end + else + begin + s:=target_os.libprefix+s+target_os.staticlibext; + success:=DoExec(FindUtil('dlltool'),'-l '+s+' -D '+s2+' -d deffile.$$$',false,false); + ObjectFiles.insert(s); + if not success then + break; + end; + end; + + { Open link.res file } + LinkRes.Init(outputexedir+Info.ResName); + + { Write path to search libraries } + HPath:=current_module^.locallibrarysearchpath.First; + while assigned(HPath) do + begin + LinkRes.Add('SEARCH_DIR('+GetShortName(HPath^.Data^)+')'); + HPath:=HPath^.Next; + end; + HPath:=LibrarySearchPath.First; + while assigned(HPath) do + begin + LinkRes.Add('SEARCH_DIR('+GetShortName(HPath^.Data^)+')'); + HPath:=HPath^.Next; + end; + + { add objectfiles, start with prt0 always } + LinkRes.Add('INPUT('); + if isdll then + LinkRes.AddFileName(GetShortName(FindObjectFile('wdllprt0'))) + else + LinkRes.AddFileName(GetShortName(FindObjectFile('wprt0'))); + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.Get; + if s<>'' then + LinkRes.AddFileName(GetShortName(s)); + end; + LinkRes.Add(')'); + + { Write staticlibraries } + if not StaticLibFiles.Empty then + begin + LinkRes.Add('GROUP('); + While not StaticLibFiles.Empty do + begin + S:=StaticLibFiles.Get; + LinkRes.AddFileName(GetShortName(s)); + end; + LinkRes.Add(')'); + end; + +{ Write and Close response } + linkres.writetodisk; + linkres.done; + + WriteResponseFile:=True; +end; +{$endif PAVEL_LINKLIB} + + +function TLinkerWin32.MakeExecutable:boolean; +var + binstr, + cmdstr : string; + found, + success : boolean; + i : longint; + AsBinStr : string[80]; + StripStr, + RelocStr, + AppTypeStr, + ImageBaseStr : string[40]; +begin + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.exefilename^); + +{ Create some replacements } + RelocStr:=''; + AppTypeStr:=''; + ImageBaseStr:=''; + StripStr:=''; + AsBinStr:=FindExe('asw',found); + if RelocSection then + { Using short form to avoid problems with 128 char limitation under Dos. } + RelocStr:='-b base.$$$'; + if apptype=at_gui then + AppTypeStr:='--subsystem windows'; + if assigned(DLLImageBase) then + ImageBaseStr:='--image-base=0x'+DLLImageBase^; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; + +{ Write used files and libraries } + WriteResponseFile(false); + +{ Call linker } + success:=false; + for i:=1 to 3 do + begin + SplitBinCmd(Info.ExeCmd[i],binstr,cmdstr); + if binstr<>'' then + begin + Replace(cmdstr,'$EXE',current_module^.exefilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$APPTYPE',AppTypeStr); + Replace(cmdstr,'$ASBIN',AsbinStr); + Replace(cmdstr,'$RELOC',RelocStr); + Replace(cmdstr,'$IMAGEBASE',ImageBaseStr); + Replace(cmdstr,'$STRIP',StripStr); + if not DefFile.Empty {and UseDefFileForExport} then + begin + DefFile.WriteFile; + Replace(cmdstr,'$DEF','-d '+deffile.fname); + end + else + Replace(cmdstr,'$DEF',''); + success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false); + if not success then + break; + end; + end; + +{ Post process } + if success then + success:=PostProcessExecutable(current_module^.exefilename^,false); + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + begin + RemoveFile(outputexedir+Info.ResName); + RemoveFile('base.$$$'); + RemoveFile('exp.$$$'); + RemoveFile('deffile.$$$'); + end; + + MakeExecutable:=success; { otherwise a recursive call to link method } +end; + + +Function TLinkerWin32.MakeSharedLibrary:boolean; +var + binstr, + cmdstr : string; + found, + success : boolean; + i : longint; + AsBinStr : string[80]; + StripStr, + RelocStr, + AppTypeStr, + ImageBaseStr : string[40]; +begin + MakeSharedLibrary:=false; + if not(cs_link_extern in aktglobalswitches) then + Message1(exec_i_linking,current_module^.sharedlibfilename^); + +{ Create some replacements } + RelocStr:=''; + AppTypeStr:=''; + ImageBaseStr:=''; + StripStr:=''; + AsBinStr:=FindExe('asw',found); + if RelocSection then + { Using short form to avoid problems with 128 char limitation under Dos. } + RelocStr:='-b base.$$$'; + if apptype=at_gui then + AppTypeStr:='--subsystem windows'; + if assigned(DLLImageBase) then + ImageBaseStr:='--image-base=0x'+DLLImageBase^; + if (cs_link_strip in aktglobalswitches) then + StripStr:='-s'; + +{ Write used files and libraries } + WriteResponseFile(true); + +{ Call linker } + success:=false; + for i:=1 to 3 do + begin + SplitBinCmd(Info.DllCmd[i],binstr,cmdstr); + if binstr<>'' then + begin + Replace(cmdstr,'$EXE',current_module^.sharedlibfilename^); + Replace(cmdstr,'$OPT',Info.ExtraOptions); + Replace(cmdstr,'$RES',outputexedir+Info.ResName); + Replace(cmdstr,'$APPTYPE',AppTypeStr); + Replace(cmdstr,'$ASBIN',AsbinStr); + Replace(cmdstr,'$RELOC',RelocStr); + Replace(cmdstr,'$IMAGEBASE',ImageBaseStr); + Replace(cmdstr,'$STRIP',StripStr); + if not DefFile.Empty {and UseDefFileForExport} then + begin + DefFile.WriteFile; + Replace(cmdstr,'$DEF','-d '+deffile.fname); + end + else + Replace(cmdstr,'$DEF',''); + success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false); + if not success then + break; + end; + end; + +{ Post process } + if success then + success:=PostProcessExecutable(current_module^.sharedlibfilename^,true); + +{ Remove ReponseFile } + if (success) and not(cs_link_extern in aktglobalswitches) then + begin + RemoveFile(outputexedir+Info.ResName); + RemoveFile('base.$$$'); + RemoveFile('exp.$$$'); + end; + MakeSharedLibrary:=success; { otherwise a recursive call to link method } +end; + + +function tlinkerwin32.postprocessexecutable(const fn : string;isdll:boolean):boolean; +type + tdosheader = packed record + e_magic : word; + e_cblp : word; + e_cp : word; + e_crlc : word; + e_cparhdr : word; + e_minalloc : word; + e_maxalloc : word; + e_ss : word; + e_sp : word; + e_csum : word; + e_ip : word; + e_cs : word; + e_lfarlc : word; + e_ovno : word; + e_res : array[0..3] of word; + e_oemid : word; + e_oeminfo : word; + e_res2 : array[0..9] of word; + e_lfanew : longint; + end; + tpeheader = packed record + PEMagic : array[0..3] of char; + Machine : word; + NumberOfSections : word; + TimeDateStamp : longint; + PointerToSymbolTable : longint; + NumberOfSymbols : longint; + SizeOfOptionalHeader : word; + Characteristics : word; + Magic : word; + MajorLinkerVersion : byte; + MinorLinkerVersion : byte; + SizeOfCode : longint; + SizeOfInitializedData : longint; + SizeOfUninitializedData : longint; + AddressOfEntryPoint : longint; + BaseOfCode : longint; + BaseOfData : longint; + ImageBase : longint; + SectionAlignment : longint; + FileAlignment : longint; + MajorOperatingSystemVersion : word; + MinorOperatingSystemVersion : word; + MajorImageVersion : word; + MinorImageVersion : word; + MajorSubsystemVersion : word; + MinorSubsystemVersion : word; + Reserved1 : longint; + SizeOfImage : longint; + SizeOfHeaders : longint; + CheckSum : longint; + Subsystem : word; + DllCharacteristics : word; + SizeOfStackReserve : longint; + SizeOfStackCommit : longint; + SizeOfHeapReserve : longint; + SizeOfHeapCommit : longint; + LoaderFlags : longint; + NumberOfRvaAndSizes : longint; + DataDirectory : array[1..$80] of byte; + end; + tcoffsechdr=packed record + name : array[0..7] of char; + vsize : longint; + rvaofs : longint; + datalen : longint; + datapos : longint; + relocpos : longint; + lineno1 : longint; + nrelocs : word; + lineno2 : word; + flags : longint; + end; + psecfill=^tsecfill; + tsecfill=record + fillpos, + fillsize : longint; + next : psecfill; + end; +var + f : file; + cmdstr : string; + dosheader : tdosheader; + peheader : tpeheader; + firstsecpos, + maxfillsize, + l,peheaderpos : longint; + coffsec : tcoffsechdr; + secroot,hsecroot : psecfill; + zerobuf : pointer; +begin + postprocessexecutable:=false; + { when -s is used or it's a dll then quit } + if (cs_link_extern in aktglobalswitches) then + begin + if apptype=at_gui then + cmdstr:='--subsystem gui' + else if apptype=at_cui then + cmdstr:='--subsystem console'; + if dllversion<>'' then + cmdstr:=cmdstr+' --version '+dllversion; + cmdstr:=cmdstr+' --input '+fn; + cmdstr:=cmdstr+' --stack '+tostr(stacksize); + DoExec(FindUtil('postw32'),cmdstr,false,false); + postprocessexecutable:=true; + exit; + end; + { open file } + assign(f,fn); + {$I-} + reset(f,1); + if ioresult<>0 then + Message1(execinfo_f_cant_open_executable,fn); + { read headers } + blockread(f,dosheader,sizeof(tdosheader)); + peheaderpos:=dosheader.e_lfanew; + seek(f,peheaderpos); + blockread(f,peheader,sizeof(tpeheader)); + { write info } + Message1(execinfo_x_codesize,tostr(peheader.SizeOfCode)); + Message1(execinfo_x_initdatasize,tostr(peheader.SizeOfInitializedData)); + Message1(execinfo_x_uninitdatasize,tostr(peheader.SizeOfUninitializedData)); + { change stack size (PM) } + { I am not sure that the default value is adequate !! } + peheader.SizeOfStackReserve:=stacksize; + { change the header } + { sub system } + { gui=2 } + { cui=3 } + if apptype=at_gui then + peheader.Subsystem:=2 + else if apptype=at_cui then + peheader.Subsystem:=3; + if dllversion<>'' then + begin + peheader.MajorImageVersion:=dllmajor; + peheader.MinorImageVersion:=dllminor; + end; + { reset timestamp } + peheader.TimeDateStamp:=0; + { write header back } + seek(f,peheaderpos); + blockwrite(f,peheader,sizeof(tpeheader)); + if ioresult<>0 then + Message1(execinfo_f_cant_process_executable,fn); + seek(f,peheaderpos); + blockread(f,peheader,sizeof(tpeheader)); + { write the value after the change } + Message1(execinfo_x_stackreserve,tostr(peheader.SizeOfStackReserve)); + Message1(execinfo_x_stackcommit,tostr(peheader.SizeOfStackCommit)); + { read section info } + maxfillsize:=0; + firstsecpos:=0; + secroot:=nil; + for l:=1 to peheader.NumberOfSections do + begin + blockread(f,coffsec,sizeof(tcoffsechdr)); + if coffsec.datapos>0 then + begin + if secroot=nil then + firstsecpos:=coffsec.datapos; + new(hsecroot); + hsecroot^.fillpos:=coffsec.datapos+coffsec.vsize; + hsecroot^.fillsize:=coffsec.datalen-coffsec.vsize; + hsecroot^.next:=secroot; + secroot:=hsecroot; + if secroot^.fillsize>maxfillsize then + maxfillsize:=secroot^.fillsize; + end; + end; + if firstsecpos>0 then + begin + l:=firstsecpos-filepos(f); + if l>maxfillsize then + maxfillsize:=l; + end + else + l:=0; + { get zero buffer } + getmem(zerobuf,maxfillsize); + fillchar(zerobuf^,maxfillsize,0); + { zero from sectioninfo until first section } + blockwrite(f,zerobuf^,l); + { zero section alignments } + while assigned(secroot) do + begin + seek(f,secroot^.fillpos); + blockwrite(f,zerobuf^,secroot^.fillsize); + hsecroot:=secroot; + secroot:=secroot^.next; + dispose(hsecroot); + end; + freemem(zerobuf,maxfillsize); + close(f); + {$I+} + if ioresult<>0 then; + postprocessexecutable:=true; +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.25 2000/07/08 20:43:38 peter + * findobjectfile gets extra arg with directory where the unit is found + and the .o should be looked first + + Revision 1.24 2000/06/20 12:44:30 pierre + * do not create an empty export section + + Revision 1.23 2000/05/23 20:18:25 pierre + + pavel's code integrated, but onyl inside + ifdef pavel_linklib ! + + Revision 1.22 2000/04/14 11:16:10 pierre + * partial linklib change + I could not use Pavel's code because it broke the current way + linklib is used, which is messy :( + + add postw32 call if external linking on win32 + + Revision 1.21 2000/03/10 09:14:40 pierre + * dlltool is also needed if we use DefFile + + Revision 1.20 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.19 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.18 2000/01/12 10:31:45 peter + * fixed group() writing + + Revision 1.17 2000/01/11 09:52:07 peter + * fixed placing of .sl directories + * use -b again for base-file selection + * fixed group writing for linux with smartlinking + + Revision 1.16 2000/01/09 00:55:51 pierre + * GROUP of smartlink units put before the C libraries + to allow for smartlinking code that uses C code. + + Revision 1.15 2000/01/07 01:14:43 peter + * updated copyright to 2000 + + Revision 1.14 2000/01/07 00:10:26 peter + * --base-file instead of -b as dlltool 2.9.1 doesn't understand it + * clear timestamp in pe header + + Revision 1.13 1999/12/20 23:23:30 pierre + + $description $version + + Revision 1.12 1999/12/08 10:40:01 pierre + + allow use of unit var in exports of DLL for win32 + by using direct export writing by default instead of use of DEFFILE + that does not allow assembler labels that do not + start with an underscore. + Use -WD to force use of Deffile for Win32 DLL + + Revision 1.11 1999/12/06 18:21:04 peter + * support !ENVVAR for long commandlines + * win32/go32v2 write short pathnames to link.res so c:\Program Files\ is + finally supported as installdir. + + Revision 1.10 1999/11/24 11:45:36 pierre + * $STRIP was missign in DllCmd[1] + + Revision 1.9 1999/11/22 22:20:43 pierre + * Def file syntax for win32 with index corrected + * direct output of .edata leads to same indexes + (index 5 leads to next export being 6 unless otherwise + specified like for enums) + + Revision 1.8 1999/11/16 23:39:04 peter + * use outputexedir for link.res location + + Revision 1.7 1999/11/15 15:01:56 pierre + + Pavel's changes to support reloc section in exes + + Revision 1.6 1999/11/12 11:03:50 peter + * searchpaths changed to stringqueue object + + Revision 1.5 1999/11/04 10:55:31 peter + * TSearchPathString for the string type of the searchpaths, which is + ansistring under FPC/Delphi + + Revision 1.4 1999/11/02 15:06:58 peter + * import library fixes for win32 + * alignment works again + + Revision 1.3 1999/10/28 10:33:06 pierre + * Libs can be link serveral times + + Revision 1.2 1999/10/22 14:42:40 peter + * reset linklibc + + Revision 1.1 1999/10/21 14:29:38 peter + * redesigned linker object + + library support for linux (only procedures can be exported) + +} \ No newline at end of file diff --git a/befpc/compiler/tcadd.pas b/befpc/compiler/tcadd.pas new file mode 100644 index 0000000..643a1df --- /dev/null +++ b/befpc/compiler/tcadd.pas @@ -0,0 +1,1408 @@ +{ + $Id: tcadd.pas,v 1.1.1.1 2001-07-23 17:17:13 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for add node + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcadd; +interface + + uses + tree; + + procedure firstadd(var p : ptree); + function isbinaryoverloaded(var p : ptree) : boolean; + + +implementation + + uses + globtype,systems,tokens, + cobjects,verbose,globals, + symconst,symtable,aasm,types, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen, +{$endif newcg} + htypechk,pass_1, + cpubase,tccnv + ; + + function isbinaryoverloaded(var p : ptree) : boolean; + + var + rd,ld : pdef; + t : ptree; + optoken : ttoken; + + begin + isbinaryoverloaded:=false; + { overloaded operator ? } + { load easier access variables } + rd:=p^.right^.resulttype; + ld:=p^.left^.resulttype; + if isbinaryoperatoroverloadable(ld,rd,voiddef,p^.treetype) then + begin + isbinaryoverloaded:=true; + {!!!!!!!!! handle paras } + case p^.treetype of + { the nil as symtable signs firstcalln that this is + an overloaded operator } + addn: + optoken:=_PLUS; + subn: + optoken:=_MINUS; + muln: + optoken:=_STAR; + starstarn: + optoken:=_STARSTAR; + slashn: + optoken:=_SLASH; + ltn: + optoken:=tokens._lt; + gtn: + optoken:=tokens._gt; + lten: + optoken:=_lte; + gten: + optoken:=_gte; + equaln,unequaln : + optoken:=_EQUAL; + symdifn : + optoken:=_SYMDIF; + modn : + optoken:=_OP_MOD; + orn : + optoken:=_OP_OR; + xorn : + optoken:=_OP_XOR; + andn : + optoken:=_OP_AND; + divn : + optoken:=_OP_DIV; + shln : + optoken:=_OP_SHL; + shrn : + optoken:=_OP_SHR; + else + exit; + end; + t:=gencallnode(overloaded_operators[optoken],nil); + { we have to convert p^.left and p^.right into + callparanodes } + if t^.symtableprocentry=nil then + begin + CGMessage(parser_e_operator_not_overloaded); + putnode(t); + end + else + begin + inc(t^.symtableprocentry^.refs); + t^.left:=gencallparanode(p^.left,nil); + t^.left:=gencallparanode(p^.right,t^.left); + if p^.treetype=unequaln then + t:=gensinglenode(notn,t); + firstpass(t); + putnode(p); + p:=t; + end; + end; + end; + +{***************************************************************************** + FirstAdd +*****************************************************************************} + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + + procedure firstadd(var p : ptree); + + procedure make_bool_equal_size(var p:ptree); + begin + if porddef(p^.left^.resulttype)^.typ>porddef(p^.right^.resulttype)^.typ then + begin + p^.right:=gentypeconvnode(p^.right,porddef(p^.left^.resulttype)); + p^.right^.convtyp:=tc_bool_2_int; + p^.right^.explizit:=true; + firstpass(p^.right); + end + else + if porddef(p^.left^.resulttype)^.typrv),booldef); + gten : t:=genordinalconstnode(ord(lv>=rv),booldef); + equaln : t:=genordinalconstnode(ord(lv=rv),booldef); + unequaln : t:=genordinalconstnode(ord(lv<>rv),booldef); + slashn : begin + { int/int becomes a real } + if int(rv)=0 then + begin + Message(parser_e_invalid_float_operation); + t:=genrealconstnode(0,bestrealdef^); + end + else + t:=genrealconstnode(int(lv)/int(rv),bestrealdef^); + firstpass(t); + end; + else + CGMessage(type_e_mismatch); + end; + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + + { both real constants ? } + if (lt=realconstn) and (rt=realconstn) then + begin + lvd:=p^.left^.value_real; + rvd:=p^.right^.value_real; + case p^.treetype of + addn : t:=genrealconstnode(lvd+rvd,bestrealdef^); + subn : t:=genrealconstnode(lvd-rvd,bestrealdef^); + muln : t:=genrealconstnode(lvd*rvd,bestrealdef^); + starstarn, + caretn : begin + if lvd<0 then + begin + Message(parser_e_invalid_float_operation); + t:=genrealconstnode(0,bestrealdef^); + end + else if lvd=0 then + t:=genrealconstnode(1.0,bestrealdef^) + else + t:=genrealconstnode(exp(ln(lvd)*rvd),bestrealdef^); + end; + slashn : + begin + if rvd=0 then + begin + Message(parser_e_invalid_float_operation); + t:=genrealconstnode(0,bestrealdef^); + end + else + t:=genrealconstnode(lvd/rvd,bestrealdef^); + end; + ltn : t:=genordinalconstnode(ord(lvdrvd),booldef); + gten : t:=genordinalconstnode(ord(lvd>=rvd),booldef); + equaln : t:=genordinalconstnode(ord(lvd=rvd),booldef); + unequaln : t:=genordinalconstnode(ord(lvd<>rvd),booldef); + else + CGMessage(type_e_mismatch); + end; + disposetree(p); + p:=t; + firstpass(p); + exit; + end; + + { concating strings ? } + concatstrings:=false; + s1:=nil; + s2:=nil; + if (lt=ordconstn) and (rt=ordconstn) and + is_char(ld) and is_char(rd) then + begin + s1:=strpnew(char(byte(p^.left^.value))); + s2:=strpnew(char(byte(p^.right^.value))); + l1:=1; + l2:=1; + concatstrings:=true; + end + else + if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then + begin + s1:=getpcharcopy(p^.left); + l1:=p^.left^.length; + s2:=strpnew(char(byte(p^.right^.value))); + l2:=1; + concatstrings:=true; + end + else + if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then + begin + s1:=strpnew(char(byte(p^.left^.value))); + l1:=1; + s2:=getpcharcopy(p^.right); + l2:=p^.right^.length; + concatstrings:=true; + end + else if (lt=stringconstn) and (rt=stringconstn) then + begin + s1:=getpcharcopy(p^.left); + l1:=p^.left^.length; + s2:=getpcharcopy(p^.right); + l2:=p^.right^.length; + concatstrings:=true; + end; + + { I will need to translate all this to ansistrings !!! } + if concatstrings then + begin + case p^.treetype of + addn : + t:=genpcharconstnode(concatansistrings(s1,s2,l1,l2),l1+l2); + ltn : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<0),booldef); + lten : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<=0),booldef); + gtn : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)>0),booldef); + gten : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)>=0),booldef); + equaln : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)=0),booldef); + unequaln : + t:=genordinalconstnode(byte(compareansistrings(s1,s2,l1,l2)<>0),booldef); + end; + ansistringdispose(s1,l1); + ansistringdispose(s2,l2); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + + { if both are orddefs then check sub types } + if (ld^.deftype=orddef) and (rd^.deftype=orddef) then + begin + { 2 booleans ? } + if is_boolean(ld) and is_boolean(rd) then + begin + case p^.treetype of + andn, + orn: + begin + make_bool_equal_size(p); + calcregisters(p,0,0,0); + p^.location.loc:=LOC_JUMP; + end; + xorn,ltn,lten,gtn,gten: + begin + make_bool_equal_size(p); + if (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) and + (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) then + calcregisters(p,2,0,0) + else + calcregisters(p,1,0,0); + end; + unequaln, + equaln: + begin + make_bool_equal_size(p); + { Remove any compares with constants } + if (p^.left^.treetype=ordconstn) then + begin + hp:=p^.right; + b:=(p^.left^.value<>0); + ot:=p^.treetype; + disposetree(p^.left); + putnode(p); + p:=hp; + if (not(b) and (ot=equaln)) or + (b and (ot=unequaln)) then + begin + p:=gensinglenode(notn,p); + firstpass(p); + end; + exit; + end; + if (p^.right^.treetype=ordconstn) then + begin + hp:=p^.left; + b:=(p^.right^.value<>0); + ot:=p^.treetype; + disposetree(p^.right); + putnode(p); + p:=hp; + if (not(b) and (ot=equaln)) or + (b and (ot=unequaln)) then + begin + p:=gensinglenode(notn,p); + firstpass(p); + end; + exit; + end; + if (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) and + (p^.left^.location.loc in [LOC_JUMP,LOC_FLAGS]) then + calcregisters(p,2,0,0) + else + calcregisters(p,1,0,0); + end; + else + CGMessage(type_e_mismatch); + end; + + { these one can't be in flags! } + if p^.treetype in [xorn,unequaln,equaln] then + begin + if p^.left^.location.loc=LOC_FLAGS then + begin + p^.left:=gentypeconvnode(p^.left,porddef(p^.left^.resulttype)); + p^.left^.convtyp:=tc_bool_2_int; + p^.left^.explizit:=true; + firstpass(p^.left); + end; + if p^.right^.location.loc=LOC_FLAGS then + begin + p^.right:=gentypeconvnode(p^.right,porddef(p^.right^.resulttype)); + p^.right^.convtyp:=tc_bool_2_int; + p^.right^.explizit:=true; + firstpass(p^.right); + end; + { readjust registers } + calcregisters(p,1,0,0); + end; + convdone:=true; + end + else + { Both are chars? only convert to shortstrings for addn } + if is_char(rd) and is_char(ld) then + begin + if p^.treetype=addn then + begin + p^.left:=gentypeconvnode(p^.left,cshortstringdef); + p^.right:=gentypeconvnode(p^.right,cshortstringdef); + firstpass(p^.left); + firstpass(p^.right); + { here we call STRCOPY } + procinfo^.flags:=procinfo^.flags or pi_do_call; + calcregisters(p,0,0,0); + p^.location.loc:=LOC_MEM; + end + else + calcregisters(p,1,0,0); + convdone:=true; + end + { is there a 64 bit type ? } + else if ((porddef(rd)^.typ=s64bit) or (porddef(ld)^.typ=s64bit)) and + { the / operator is handled later } + (p^.treetype<>slashn) then + begin + if (porddef(ld)^.typ<>s64bit) then + begin + p^.left:=gentypeconvnode(p^.left,cs64bitdef); + firstpass(p^.left); + end; + if (porddef(rd)^.typ<>s64bit) then + begin + p^.right:=gentypeconvnode(p^.right,cs64bitdef); + firstpass(p^.right); + end; + calcregisters(p,2,0,0); + convdone:=true; + end + else if ((porddef(rd)^.typ=u64bit) or (porddef(ld)^.typ=u64bit)) and + { the / operator is handled later } + (p^.treetype<>slashn) then + begin + if (porddef(ld)^.typ<>u64bit) then + begin + p^.left:=gentypeconvnode(p^.left,cu64bitdef); + firstpass(p^.left); + end; + if (porddef(rd)^.typ<>u64bit) then + begin + p^.right:=gentypeconvnode(p^.right,cu64bitdef); + firstpass(p^.right); + end; + calcregisters(p,2,0,0); + convdone:=true; + end + else + { is there a cardinal? } + if ((porddef(rd)^.typ=u32bit) or (porddef(ld)^.typ=u32bit)) and + { the / operator is handled later } + (p^.treetype<>slashn) then + begin + { convert constants to u32bit } +{$ifndef cardinalmulfix} + if (porddef(ld)^.typ<>u32bit) then + begin + { s32bit will be used for when the other is also s32bit } + + { the following line doesn't make any sense: it's the same as } + { if ((porddef(rd)^.typ=u32bit) or (porddef(ld)^.typ=u32bit)) and } + { (porddef(ld)^.typ<>u32bit) and (porddef(rd)^.typ=s32bit) then } + { which can be simplified to } + { if ((porddef(rd)^.typ=u32bit) and (porddef(rd)^.typ=s32bit) then } + { which can never be true (JM) } + if (porddef(rd)^.typ=s32bit) and (lt<>ordconstn) then + p^.left:=gentypeconvnode(p^.left,s32bitdef) + else + p^.left:=gentypeconvnode(p^.left,u32bitdef); + firstpass(p^.left); + end; + if (porddef(rd)^.typ<>u32bit) then + begin + { s32bit will be used for when the other is also s32bit } + if (porddef(ld)^.typ=s32bit) and (rt<>ordconstn) then + p^.right:=gentypeconvnode(p^.right,s32bitdef) + else + p^.right:=gentypeconvnode(p^.right,u32bitdef); + firstpass(p^.right); + end; +{$else cardinalmulfix} + { only do a conversion if the nodes have different signs } + if (porddef(rd)^.typ=u32bit) xor (porddef(ld)^.typ=u32bit) then + if (porddef(rd)^.typ=u32bit) then + begin + { can we make them both unsigned? } + if is_constintnode(p^.left) and + ((p^.treetype <> subn) and + (p^.left^.value > 0)) then + p^.left:=gentypeconvnode(p^.left,u32bitdef) + else + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + end + else {if (porddef(ld)^.typ=u32bit) then} + begin + { can we make them both unsigned? } + if is_constintnode(p^.right) and + (p^.right^.value > 0) then + p^.right:=gentypeconvnode(p^.right,u32bitdef) + else + p^.right:=gentypeconvnode(p^.right,s32bitdef); + firstpass(p^.right); + end; +{$endif cardinalmulfix} + calcregisters(p,1,0,0); + { for unsigned mul we need an extra register } +{ p^.registers32:=p^.left^.registers32+p^.right^.registers32; } + if p^.treetype=muln then + inc(p^.registers32); + convdone:=true; + end; + end + else + + { left side a setdef, must be before string processing, + else array constructor can be seen as array of char (PFV) } + if (ld^.deftype=setdef) {or is_array_constructor(ld)} then + begin + { trying to add a set element? } + if (p^.treetype=addn) and (rd^.deftype<>setdef) then + begin + if (rt=setelementn) then + begin + if not(is_equal(psetdef(ld)^.elementtype.def,rd)) then + CGMessage(type_e_set_element_are_not_comp); + end + else + CGMessage(type_e_mismatch) + end + else + begin + if not(p^.treetype in [addn,subn,symdifn,muln,equaln,unequaln +{$IfNDef NoSetInclusion} + ,lten,gten +{$EndIf NoSetInclusion} + ]) then + CGMessage(type_e_set_operation_unknown); + { right def must be a also be set } + if (rd^.deftype<>setdef) or not(is_equal(rd,ld)) then + CGMessage(type_e_set_element_are_not_comp); + end; + + { ranges require normsets } + if (psetdef(ld)^.settype=smallset) and + (rt=setelementn) and + assigned(p^.right^.right) then + begin + { generate a temporary normset def } + tempdef:=new(psetdef,init(psetdef(ld)^.elementtype.def,255)); + p^.left:=gentypeconvnode(p^.left,tempdef); + firstpass(p^.left); + dispose(tempdef,done); + ld:=p^.left^.resulttype; + end; + + { if the destination is not a smallset then insert a typeconv + which loads a smallset into a normal set } + if (psetdef(ld)^.settype<>smallset) and + (psetdef(rd)^.settype=smallset) then + begin + if (p^.right^.treetype=setconstn) then + begin + t:=gensetconstnode(p^.right^.value_set,psetdef(p^.left^.resulttype)); + t^.left:=p^.right^.left; + putnode(p^.right); + p^.right:=t; + end + else + p^.right:=gentypeconvnode(p^.right,psetdef(p^.left^.resulttype)); + firstpass(p^.right); + end; + + { do constant evaluation } + if (p^.right^.treetype=setconstn) and + not assigned(p^.right^.left) and + (p^.left^.treetype=setconstn) and + not assigned(p^.left^.left) then + begin + new(resultset); + case p^.treetype of + addn : begin + for i:=0 to 31 do + resultset^[i]:= + p^.right^.value_set^[i] or p^.left^.value_set^[i]; + t:=gensetconstnode(resultset,psetdef(ld)); + end; + muln : begin + for i:=0 to 31 do + resultset^[i]:= + p^.right^.value_set^[i] and p^.left^.value_set^[i]; + t:=gensetconstnode(resultset,psetdef(ld)); + end; + subn : begin + for i:=0 to 31 do + resultset^[i]:= + p^.left^.value_set^[i] and not(p^.right^.value_set^[i]); + t:=gensetconstnode(resultset,psetdef(ld)); + end; + symdifn : begin + for i:=0 to 31 do + resultset^[i]:= + p^.left^.value_set^[i] xor p^.right^.value_set^[i]; + t:=gensetconstnode(resultset,psetdef(ld)); + end; + unequaln : begin + b:=true; + for i:=0 to 31 do + if p^.right^.value_set^[i]=p^.left^.value_set^[i] then + begin + b:=false; + break; + end; + t:=genordinalconstnode(ord(b),booldef); + end; + equaln : begin + b:=true; + for i:=0 to 31 do + if p^.right^.value_set^[i]<>p^.left^.value_set^[i] then + begin + b:=false; + break; + end; + t:=genordinalconstnode(ord(b),booldef); + end; +{$IfNDef NoSetInclusion} + lten : Begin + b := true; + For i := 0 to 31 Do + If (p^.right^.value_set^[i] And p^.left^.value_set^[i]) <> + p^.left^.value_set^[i] Then + Begin + b := false; + Break + End; + t := genordinalconstnode(ord(b),booldef); + End; + gten : Begin + b := true; + For i := 0 to 31 Do + If (p^.left^.value_set^[i] And p^.right^.value_set^[i]) <> + p^.right^.value_set^[i] Then + Begin + b := false; + Break + End; + t := genordinalconstnode(ord(b),booldef); + End; +{$EndIf NoSetInclusion} + end; + dispose(resultset); + disposetree(p); + p:=t; + firstpass(p); + exit; + end + else + if psetdef(ld)^.settype=smallset then + begin + { are we adding set elements ? } + if p^.right^.treetype=setelementn then + calcregisters(p,2,0,0) + else + calcregisters(p,1,0,0); + p^.location.loc:=LOC_REGISTER; + end + else + begin + calcregisters(p,0,0,0); + { here we call SET... } + procinfo^.flags:=procinfo^.flags or pi_do_call; + p^.location.loc:=LOC_MEM; + end; + convdone:=true; + end + else + { compare pchar to char arrays by addresses + like BP/Delphi } + if (is_pchar(ld) and is_chararray(rd)) or + (is_pchar(rd) and is_chararray(ld)) then + begin + if is_chararray(rd) then + begin + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + end + else + begin + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.left); + end; + p^.location.loc:=LOC_REGISTER; + calcregisters(p,1,0,0); + convdone:=true; + end + else + { is one of the operands a string?, + chararrays are also handled as strings (after conversion) } + if (rd^.deftype=stringdef) or (ld^.deftype=stringdef) or + ((is_chararray(rd) or is_char(rd)) and + (is_chararray(ld) or is_char(ld))) then + begin + if is_widestring(rd) or is_widestring(ld) then + begin + if not(is_widestring(rd)) then + p^.right:=gentypeconvnode(p^.right,cwidestringdef); + if not(is_widestring(ld)) then + p^.left:=gentypeconvnode(p^.left,cwidestringdef); + p^.resulttype:=cwidestringdef; + { this is only for add, the comparisaion is handled later } + p^.location.loc:=LOC_REGISTER; + end + else if is_ansistring(rd) or is_ansistring(ld) then + begin + if not(is_ansistring(rd)) then + p^.right:=gentypeconvnode(p^.right,cansistringdef); + if not(is_ansistring(ld)) then + p^.left:=gentypeconvnode(p^.left,cansistringdef); + { we use ansistrings so no fast exit here } + procinfo^.no_fast_exit:=true; + p^.resulttype:=cansistringdef; + { this is only for add, the comparisaion is handled later } + p^.location.loc:=LOC_REGISTER; + end + else if is_longstring(rd) or is_longstring(ld) then + begin + if not(is_longstring(rd)) then + p^.right:=gentypeconvnode(p^.right,clongstringdef); + if not(is_longstring(ld)) then + p^.left:=gentypeconvnode(p^.left,clongstringdef); + p^.resulttype:=clongstringdef; + { this is only for add, the comparisaion is handled later } + p^.location.loc:=LOC_MEM; + end + else + begin + if not(is_shortstring(rd)) +{$ifdef newoptimizations2} +{$ifdef i386} + { shortstring + char handled seperately (JM) } + and (not(cs_optimize in aktglobalswitches) or + (p^.treetype <> addn) or not(is_char(rd))) +{$endif i386} +{$endif newoptimizations2} + then + p^.right:=gentypeconvnode(p^.right,cshortstringdef); + if not(is_shortstring(ld)) then + p^.left:=gentypeconvnode(p^.left,cshortstringdef); + p^.resulttype:=cshortstringdef; + { this is only for add, the comparisaion is handled later } + p^.location.loc:=LOC_MEM; + end; + { only if there is a type cast we need to do again } + { the first pass } + if p^.left^.treetype=typeconvn then + firstpass(p^.left); + if p^.right^.treetype=typeconvn then + firstpass(p^.right); + { here we call STRCONCAT or STRCMP or STRCOPY } + procinfo^.flags:=procinfo^.flags or pi_do_call; + if p^.location.loc=LOC_MEM then + calcregisters(p,0,0,0) + else + calcregisters(p,1,0,0); +{$ifdef newoptimizations} +{$ifdef i386} + { not always necessary, only if it is not a constant char and } + { not a regvar, but don't know how to check this here (JM) } + if is_char(rd) then + inc(p^.registers32); +{$endif i386} +{$endif newoptimizations} + convdone:=true; + end + else + + { is one a real float ? } + if (rd^.deftype=floatdef) or (ld^.deftype=floatdef) then + begin + { if one is a fixed, then convert to f32bit } + if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ=f32bit)) or + ((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ=f32bit)) then + begin + if not is_integer(rd) or (p^.treetype<>muln) then + p^.right:=gentypeconvnode(p^.right,s32fixeddef); + if not is_integer(ld) or (p^.treetype<>muln) then + p^.left:=gentypeconvnode(p^.left,s32fixeddef); + firstpass(p^.left); + firstpass(p^.right); + calcregisters(p,1,0,0); + p^.location.loc:=LOC_REGISTER; + end + else + { convert both to bestreal } + begin + p^.right:=gentypeconvnode(p^.right,bestrealdef^); + p^.left:=gentypeconvnode(p^.left,bestrealdef^); + firstpass(p^.left); + firstpass(p^.right); + calcregisters(p,0,1,0); + p^.location.loc:=LOC_FPU; + end; + convdone:=true; + end + else + + { pointer comperation and subtraction } + if (rd^.deftype=pointerdef) and (ld^.deftype=pointerdef) then + begin + p^.location.loc:=LOC_REGISTER; + { p^.right:=gentypeconvnode(p^.right,ld); } + { firstpass(p^.right); } + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : + begin + if is_equal(p^.right^.resulttype,voidpointerdef) then + begin + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + end + else if is_equal(p^.left^.resulttype,voidpointerdef) then + begin + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.left); + end + else if not(is_equal(ld,rd)) then + CGMessage(type_e_mismatch); + end; + ltn,lten,gtn,gten: + begin + if is_equal(p^.right^.resulttype,voidpointerdef) then + begin + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + end + else if is_equal(p^.left^.resulttype,voidpointerdef) then + begin + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.left); + end + else if not(is_equal(ld,rd)) then + CGMessage(type_e_mismatch); + if not(cs_extsyntax in aktmoduleswitches) then + CGMessage(type_e_mismatch); + end; + subn: + begin + if not(is_equal(ld,rd)) then + CGMessage(type_e_mismatch); + if not(cs_extsyntax in aktmoduleswitches) then + CGMessage(type_e_mismatch); + p^.resulttype:=s32bitdef; + exit; + end; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (rd^.deftype=objectdef) and (ld^.deftype=objectdef) and + pobjectdef(rd)^.is_class and pobjectdef(ld)^.is_class then + begin + p^.location.loc:=LOC_REGISTER; + if pobjectdef(rd)^.is_related(pobjectdef(ld)) then + p^.right:=gentypeconvnode(p^.right,ld) + else + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.right); + firstpass(p^.left); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (rd^.deftype=classrefdef) and (ld^.deftype=classrefdef) then + begin + p^.location.loc:=LOC_REGISTER; + if pobjectdef(pclassrefdef(rd)^.pointertype.def)^.is_related(pobjectdef( + pclassrefdef(ld)^.pointertype.def)) then + p^.right:=gentypeconvnode(p^.right,ld) + else + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.right); + firstpass(p^.left); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + { allows comperasion with nil pointer } + if (rd^.deftype=objectdef) and + pobjectdef(rd)^.is_class then + begin + p^.location.loc:=LOC_REGISTER; + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.left); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (ld^.deftype=objectdef) and + pobjectdef(ld)^.is_class then + begin + p^.location.loc:=LOC_REGISTER; + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (rd^.deftype=classrefdef) then + begin + p^.left:=gentypeconvnode(p^.left,rd); + firstpass(p^.left); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (ld^.deftype=classrefdef) then + begin + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln : ; + else + CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + { support procvar=nil,procvar<>nil } + if ((ld^.deftype=procvardef) and (rt=niln)) or + ((rd^.deftype=procvardef) and (lt=niln)) then + begin + calcregisters(p,1,0,0); + p^.location.loc:=LOC_REGISTER; + case p^.treetype of + equaln,unequaln : ; + else + CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + +{$ifdef SUPPORT_MMX} + if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and + is_mmx_able_array(rd) and is_equal(ld,rd) then + begin + firstpass(p^.right); + firstpass(p^.left); + case p^.treetype of + addn,subn,xorn,orn,andn: + ; + { mul is a little bit restricted } + muln: + if not(mmx_type(p^.left^.resulttype) in + [mmxu16bit,mmxs16bit,mmxfixed16]) then + CGMessage(type_e_mismatch); + else + CGMessage(type_e_mismatch); + end; + p^.location.loc:=LOC_MMXREGISTER; + calcregisters(p,0,0,1); + convdone:=true; + end + else +{$endif SUPPORT_MMX} + + { this is a little bit dangerous, also the left type } + { should be checked! This broke the mmx support } + if (rd^.deftype=pointerdef) or + is_zero_based_array(rd) then + begin + if is_zero_based_array(rd) then + begin + p^.resulttype:=new(ppointerdef,init(parraydef(rd)^.elementtype)); + p^.right:=gentypeconvnode(p^.right,p^.resulttype); + firstpass(p^.right); + end; + p^.location.loc:=LOC_REGISTER; + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + calcregisters(p,1,0,0); + if p^.treetype=addn then + begin + if not(cs_extsyntax in aktmoduleswitches) or + (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then + CGMessage(type_e_mismatch); + { Dirty hack, to support multiple firstpasses (PFV) } + if (p^.resulttype=nil) and + (rd^.deftype=pointerdef) and + (ppointerdef(rd)^.pointertype.def^.size>1) then + begin + p^.left:=gennode(muln,p^.left,genordinalconstnode(ppointerdef(rd)^.pointertype.def^.size,s32bitdef)); + firstpass(p^.left); + end; + end + else + CGMessage(type_e_mismatch); + convdone:=true; + end + else + + if (ld^.deftype=pointerdef) or + is_zero_based_array(ld) then + begin + if is_zero_based_array(ld) then + begin + p^.resulttype:=new(ppointerdef,init(parraydef(ld)^.elementtype)); + p^.left:=gentypeconvnode(p^.left,p^.resulttype); + firstpass(p^.left); + end; + p^.location.loc:=LOC_REGISTER; + p^.right:=gentypeconvnode(p^.right,s32bitdef); + firstpass(p^.right); + calcregisters(p,1,0,0); + case p^.treetype of + addn,subn : begin + if not(cs_extsyntax in aktmoduleswitches) or + (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then + CGMessage(type_e_mismatch); + { Dirty hack, to support multiple firstpasses (PFV) } + if (p^.resulttype=nil) and + (ld^.deftype=pointerdef) and + (ppointerdef(ld)^.pointertype.def^.size>1) then + begin + p^.right:=gennode(muln,p^.right, + genordinalconstnode(ppointerdef(ld)^.pointertype.def^.size,s32bitdef)); + firstpass(p^.right); + end; + end; + else + CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (rd^.deftype=procvardef) and (ld^.deftype=procvardef) and is_equal(rd,ld) then + begin + calcregisters(p,1,0,0); + p^.location.loc:=LOC_REGISTER; + case p^.treetype of + equaln,unequaln : ; + else + CGMessage(type_e_mismatch); + end; + convdone:=true; + end + else + + if (ld^.deftype=enumdef) and (rd^.deftype=enumdef) then + begin + if not(is_equal(ld,rd)) then + begin + p^.right:=gentypeconvnode(p^.right,ld); + firstpass(p^.right); + end; + calcregisters(p,1,0,0); + case p^.treetype of + equaln,unequaln, + ltn,lten,gtn,gten : ; + else CGMessage(type_e_mismatch); + end; + convdone:=true; + end; + + { the general solution is to convert to 32 bit int } + if not convdone then + begin + { but an int/int gives real/real! } + if p^.treetype=slashn then + begin + CGMessage(type_h_use_div_for_int); + p^.right:=gentypeconvnode(p^.right,bestrealdef^); + p^.left:=gentypeconvnode(p^.left,bestrealdef^); + firstpass(p^.left); + firstpass(p^.right); + { maybe we need an integer register to save } + { a reference } + if ((p^.left^.location.loc<>LOC_FPU) or + (p^.right^.location.loc<>LOC_FPU)) and + (p^.left^.registers32=p^.right^.registers32) then + calcregisters(p,1,1,0) + else + calcregisters(p,0,1,0); + p^.location.loc:=LOC_FPU; + end + else + begin + p^.right:=gentypeconvnode(p^.right,s32bitdef); + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + firstpass(p^.right); + calcregisters(p,1,0,0); + p^.location.loc:=LOC_REGISTER; + end; + end; + + if codegenerror then + exit; + + { determines result type for comparions } + { here the is a problem with multiple passes } + { example length(s)+1 gets internal 'longint' type first } + { if it is a arg it is converted to 'LONGINT' } + { but a second first pass will reset this to 'longint' } + case p^.treetype of + ltn,lten,gtn,gten,equaln,unequaln: + begin + if (not assigned(p^.resulttype)) or + (p^.resulttype^.deftype=stringdef) then + p^.resulttype:=booldef; + if is_64bitint(p^.left^.resulttype) then + p^.location.loc:=LOC_JUMP + else + p^.location.loc:=LOC_FLAGS; + end; + xorn: + begin + if not assigned(p^.resulttype) then + p^.resulttype:=p^.left^.resulttype; + p^.location.loc:=LOC_REGISTER; + end; + addn: + begin + if not assigned(p^.resulttype) then + begin + { for strings, return is always a 255 char string } + if is_shortstring(p^.left^.resulttype) then + p^.resulttype:=cshortstringdef + else + p^.resulttype:=p^.left^.resulttype; + end; + end; +{$ifdef cardinalmulfix} + muln: + { if we multiply an unsigned with a signed number, the result is signed } + { in the other cases, the result remains signed or unsigned depending on } + { the multiplication factors (JM) } + if (p^.left^.resulttype^.deftype = orddef) and + (p^.right^.resulttype^.deftype = orddef) and + is_signed(p^.right^.resulttype) then + p^.resulttype := p^.right^.resulttype + else p^.resulttype := p^.left^.resulttype; +(* + subn: + { if we substract a u32bit from a positive constant, the result becomes } + { s32bit as well (JM) } + begin + if (p^.right^.resulttype^.deftype = orddef) and + (p^.left^.resulttype^.deftype = orddef) and + (porddef(p^.right^.resulttype)^.typ = u32bit) and + is_constintnode(p^.left) and +{ (porddef(p^.left^.resulttype)^.typ <> u32bit) and} + (p^.left^.value > 0) then + begin + p^.left := gentypeconvnode(p^.left,u32bitdef); + firstpass(p^.left); + end; + p^.resulttype:=p^.left^.resulttype; + end; +*) +{$endif cardinalmulfix} + else + p^.resulttype:=p^.left^.resulttype; + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.79 2000/06/02 21:24:48 pierre + * operator overloading now uses isbinaryoperatoracceptable + and is unaryoperatoracceptable + + Revision 1.78 2000/05/31 06:58:41 florian + * forgot to commit a fix for the enumeration subrange problem, yesterday + + Revision 1.77 2000/05/11 17:53:40 peter + * small fix for previous commit + + Revision 1.76 2000/05/11 16:47:37 peter + * fixed check for overloaded operator with array and chararray check + + Revision 1.75 2000/04/25 14:43:36 jonas + - disabled "string_var := string_var + ... " and "string_var + char_var" + optimizations (were only active with -dnewoptimizations) because of + several internal issues + + Revision 1.74 2000/04/21 12:35:05 jonas + + special code for string + char, between -dnewoptimizations + + Revision 1.73 2000/03/28 21:14:18 pierre + * fix for bug 891 + + Revision 1.72 2000/03/20 10:16:51 florian + * fixed /, / and / + + Revision 1.71 2000/03/18 15:01:19 jonas + * moved a $maxfpuregisters directive a bit up because it was being + ignored + + Revision 1.70 2000/02/19 10:12:48 florian + * fixed one more internalerror 10 + + Revision 1.69 2000/02/17 14:53:42 florian + * some updates for the newcg + + Revision 1.68 2000/02/14 22:34:28 florian + * fixed another internalerror + + Revision 1.67 2000/02/13 22:46:28 florian + * fixed an internalerror with writeln + * fixed arrayconstructor_to_set to force the generation of better code + and added a more strict type checking + + Revision 1.66 2000/02/13 14:21:51 jonas + * modifications to make the compiler functional when compiled with + -Or + + Revision 1.65 2000/02/09 13:23:06 peter + * log truncated + + Revision 1.64 2000/02/04 08:47:10 florian + * better register variable allocation in -Or mode + + Revision 1.63 2000/01/07 01:14:43 peter + * updated copyright to 2000 + + Revision 1.62 2000/01/04 20:10:20 florian + * mmx support fixed + + Revision 1.61 1999/12/11 18:53:31 jonas + * fixed type conversions of results of operations with cardinals + (between -dcardinalmulfix) + + Revision 1.60 1999/12/09 23:18:04 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.59 1999/12/01 12:42:33 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.58 1999/11/30 10:40:56 peter + + ttype, tsymlist + + Revision 1.57 1999/11/26 13:51:29 pierre + * fix for overloading of shr shl mod and div + + Revision 1.56 1999/11/18 15:34:48 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.55 1999/11/17 17:05:06 pierre + * Notes/hints changes + + Revision 1.54 1999/11/16 23:45:28 pierre + * global var token was changed by overload code (form bug 707) + + Revision 1.53 1999/11/15 21:53:42 peter + * fixed constant eval for bool xor/or/and bool + + Revision 1.52 1999/11/15 17:53:00 pierre + + one field added for ttoken record for operator + linking the id to the corresponding operator token that + can now now all be overloaded + * overloaded operators are resetted to nil in InitSymtable + (bug when trying to compile a uint that overloads operators twice) + + Revision 1.51 1999/11/06 14:34:29 peter + * truncated log to 20 revs + + Revision 1.50 1999/09/27 23:45:00 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.49 1999/09/16 13:39:14 peter + * arrayconstructor 2 set conversion is now called always in the + beginning of firstadd + + Revision 1.48 1999/09/15 20:35:45 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.47 1999/09/13 16:28:05 peter + * typo in previous commit open_array -> chararray :( + + Revision 1.46 1999/09/10 15:40:46 peter + * fixed array check for operators, becuase array can also be a set + + Revision 1.45 1999/09/08 16:05:29 peter + * pointer add/sub is now as expected and the same results as inc/dec + +} \ No newline at end of file diff --git a/befpc/compiler/tccal.pas b/befpc/compiler/tccal.pas new file mode 100644 index 0000000..2c8ac02 --- /dev/null +++ b/befpc/compiler/tccal.pas @@ -0,0 +1,1338 @@ +{ + $Id: tccal.pas,v 1.1.1.1 2001-07-23 17:17:15 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for call nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef FPC} + {$goto on} +{$endif FPC} + +unit tccal; + +interface + + uses + symtable,tree; + + + procedure gen_high_tree(p:ptree;openstring:boolean); + + procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean); + procedure firstcalln(var p : ptree); + procedure firstprocinline(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,aasm,types, + htypechk,pass_1,cpubase +{$ifdef newcg} + ,cgbase + ,tgobj +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$ifdef m68k} + ,tgen68k +{$endif m68k} +{$endif newcg} + ; + +{***************************************************************************** + FirstCallParaN +*****************************************************************************} + + procedure gen_high_tree(p:ptree;openstring:boolean); + var + len : longint; + st : psymtable; + loadconst : boolean; + begin + if assigned(p^.hightree) then + exit; + len:=-1; + loadconst:=true; + case p^.left^.resulttype^.deftype of + arraydef : + begin + if is_open_array(p^.left^.resulttype) or + is_array_of_const(p^.left^.resulttype) then + begin + st:=p^.left^.symtable; + getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name); + p^.hightree:=genloadnode(pvarsym(srsym),st); + loadconst:=false; + end + else + begin + { this is an empty constructor } + len:=parraydef(p^.left^.resulttype)^.highrange- + parraydef(p^.left^.resulttype)^.lowrange; + end; + end; + stringdef : + begin + if openstring then + begin + if is_open_string(p^.left^.resulttype) then + begin + st:=p^.left^.symtable; + getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name); + p^.hightree:=genloadnode(pvarsym(srsym),st); + loadconst:=false; + end + else + len:=pstringdef(p^.left^.resulttype)^.len; + end + else + { passing a string to an array of char } + begin + if (p^.left^.treetype=stringconstn) then + begin + len:=str_length(p^.left); + if len>0 then + dec(len); + end + else + begin + p^.hightree:=gennode(subn,geninlinenode(in_length_string,false,getcopy(p^.left)), + genordinalconstnode(1,s32bitdef)); + firstpass(p^.hightree); + p^.hightree:=gentypeconvnode(p^.hightree,s32bitdef); + loadconst:=false; + end; + end; + end; + else + len:=0; + end; + if loadconst then + p^.hightree:=genordinalconstnode(len,s32bitdef); + firstpass(p^.hightree); + end; + + + procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean); + var + old_get_para_resulttype : boolean; + old_array_constructor : boolean; + oldtype : pdef; +{$ifdef extdebug} + store_count_ref : boolean; +{$endif def extdebug} + {convtyp : tconverttype;} + begin + inc(parsing_para_level); +{$ifdef extdebug} + if do_count then + begin + store_count_ref:=count_ref; + count_ref:=true; + end; +{$endif def extdebug} + if assigned(p^.right) then + begin + if defcoll=nil then + firstcallparan(p^.right,nil,do_count) + else + firstcallparan(p^.right,pparaitem(defcoll^.next),do_count); + p^.registers32:=p^.right^.registers32; + p^.registersfpu:=p^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.right^.registersmmx; +{$endif} + end; + if defcoll=nil then + begin + old_array_constructor:=allow_array_constructor; + old_get_para_resulttype:=get_para_resulttype; + get_para_resulttype:=true; + allow_array_constructor:=true; + firstpass(p^.left); + get_para_resulttype:=old_get_para_resulttype; + allow_array_constructor:=old_array_constructor; + if codegenerror then + begin + dec(parsing_para_level); + exit; + end; + p^.resulttype:=p^.left^.resulttype; + end + { if we know the routine which is called, then the type } + { conversions are inserted } + else + begin + { Do we need arrayconstructor -> set conversion, then insert + it here before the arrayconstructor node breaks the tree + with its conversions of enum->ord } + if (p^.left^.treetype=arrayconstructn) and + (defcoll^.paratype.def^.deftype=setdef) then + p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def); + + { set some settings needed for arrayconstructor } + if is_array_constructor(p^.left^.resulttype) then + begin + if is_array_of_const(defcoll^.paratype.def) then + begin + if assigned(aktcallprocsym) and + (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and + (po_external in aktcallprocsym^.definition^.procoptions) then + p^.left^.cargs:=true; + { force variant array } + p^.left^.forcevaria:=true; + end + else + begin + p^.left^.novariaallowed:=true; + p^.left^.constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def; + end; + end; + + if do_count then + begin + { not completly proper, but avoids some warnings } + if (defcoll^.paratyp=vs_var) then + set_funcret_is_valid(p^.left); + + { protected has nothing to do with read/write + if (defcoll^.paratyp=vs_var) then + test_protected(p^.left); + } + { set_varstate(p^.left,defcoll^.paratyp<>vs_var); + must only be done after typeconv PM } + { only process typeconvn and arrayconstructn, else it will + break other trees } + { But this is need to get correct varstate !! PM } + old_array_constructor:=allow_array_constructor; + old_get_para_resulttype:=get_para_resulttype; + allow_array_constructor:=true; + get_para_resulttype:=false; + if (p^.left^.treetype in [arrayconstructn,typeconvn]) then + firstpass(p^.left); + if not assigned(p^.resulttype) then + p^.resulttype:=p^.left^.resulttype; + get_para_resulttype:=old_get_para_resulttype; + allow_array_constructor:=old_array_constructor; + end; + { check if local proc/func is assigned to procvar } + if p^.left^.resulttype^.deftype=procvardef then + test_local_to_procvar(pprocvardef(p^.left^.resulttype),defcoll^.paratype.def); + { property is not allowed as var parameter } + if (defcoll^.paratyp=vs_var) and + (p^.left^.isproperty) then + CGMessagePos(p^.left^.fileinfo,type_e_argument_cant_be_assigned); + { generate the high() value tree } + if push_high_param(defcoll^.paratype.def) then + gen_high_tree(p,is_open_string(defcoll^.paratype.def)); + if not(is_shortstring(p^.left^.resulttype) and + is_shortstring(defcoll^.paratype.def)) and + (defcoll^.paratype.def^.deftype<>formaldef) then + begin + if (defcoll^.paratyp=vs_var) and + { allows conversion from word to integer and + byte to shortint } + (not( + (p^.left^.resulttype^.deftype=orddef) and + (defcoll^.paratype.def^.deftype=orddef) and + (p^.left^.resulttype^.size=defcoll^.paratype.def^.size) + ) and + { an implicit pointer conversion is allowed } + not( + (p^.left^.resulttype^.deftype=pointerdef) and + (defcoll^.paratype.def^.deftype=pointerdef) + ) and + { child classes can be also passed } + not( + (p^.left^.resulttype^.deftype=objectdef) and + (defcoll^.paratype.def^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_related(pobjectdef(defcoll^.paratype.def)) + ) and + { passing a single element to a openarray of the same type } + not( + (is_open_array(defcoll^.paratype.def) and + is_equal(parraydef(defcoll^.paratype.def)^.elementtype.def,p^.left^.resulttype)) + ) and + { an implicit file conversion is also allowed } + { from a typed file to an untyped one } + not( + (p^.left^.resulttype^.deftype=filedef) and + (defcoll^.paratype.def^.deftype=filedef) and + (pfiledef(defcoll^.paratype.def)^.filetyp = ft_untyped) and + (pfiledef(p^.left^.resulttype)^.filetyp = ft_typed) + ) and + not(is_equal(p^.left^.resulttype,defcoll^.paratype.def))) then + begin + CGMessagePos2(p^.left^.fileinfo,parser_e_call_by_ref_without_typeconv, + p^.left^.resulttype^.typename,defcoll^.paratype.def^.typename); + end; + { Process open parameters } + if push_high_param(defcoll^.paratype.def) then + begin + { insert type conv but hold the ranges of the array } + oldtype:=p^.left^.resulttype; + p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def); + firstpass(p^.left); + p^.left^.resulttype:=oldtype; + end + else + begin + p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def); + firstpass(p^.left); + end; + if codegenerror then + begin + dec(parsing_para_level); + exit; + end; + end; + { check var strings } + if (cs_strict_var_strings in aktlocalswitches) and + is_shortstring(p^.left^.resulttype) and + is_shortstring(defcoll^.paratype.def) and + (defcoll^.paratyp=vs_var) and + not(is_open_string(defcoll^.paratype.def)) and + not(is_equal(p^.left^.resulttype,defcoll^.paratype.def)) then + begin + aktfilepos:=p^.left^.fileinfo; + CGMessage(type_e_strict_var_string_violation); + end; + + { Variablen for call by reference may not be copied } + { into a register } + { is this usefull here ? } + { this was missing in formal parameter list } + if (defcoll^.paratype.def=pdef(cformaldef)) then + begin + if defcoll^.paratyp=vs_var then + begin + if not valid_for_formal_var(p^.left) then + begin + aktfilepos:=p^.left^.fileinfo; + CGMessage(parser_e_illegal_parameter_list); + end; + end; + if defcoll^.paratyp=vs_const then + begin + if not valid_for_formal_const(p^.left) then + begin + aktfilepos:=p^.left^.fileinfo; + CGMessage(parser_e_illegal_parameter_list); + end; + end; + end; + + if defcoll^.paratyp in [vs_var,vs_const] then + begin + { Causes problems with const ansistrings if also } + { done for vs_const (JM) } + if defcoll^.paratyp = vs_var then + set_unique(p^.left); + make_not_regable(p^.left); + end; + + if do_count then + set_varstate(p^.left,defcoll^.paratyp <> vs_var); + { must only be done after typeconv PM } + p^.resulttype:=defcoll^.paratype.def; + end; + if p^.left^.registers32>p^.registers32 then + p^.registers32:=p^.left^.registers32; + if p^.left^.registersfpu>p^.registersfpu then + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + if p^.left^.registersmmx>p^.registersmmx then + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + dec(parsing_para_level); +{$ifdef extdebug} + if do_count then + count_ref:=store_count_ref; +{$endif def extdebug} + end; + + +{***************************************************************************** + FirstCallN +*****************************************************************************} + + procedure firstcalln(var p : ptree); + type + pprocdefcoll = ^tprocdefcoll; + tprocdefcoll = record + data : pprocdef; + nextpara : pparaitem; + firstpara : pparaitem; + next : pprocdefcoll; + end; + var + hp,procs,hp2 : pprocdefcoll; + pd : pprocdef; + oldcallprocsym : pprocsym; + def_from,def_to,conv_to : pdef; + hpt,pt,inlinecode : ptree; + exactmatch,inlined : boolean; + paralength,lastpara : longint; + lastparatype : pdef; + pdc : pparaitem; +{$ifdef TEST_PROCSYMS} + nextprocsym : pprocsym; + symt : psymtable; +{$endif TEST_PROCSYMS} + + { only Dummy } + hcvt : tconverttype; +{$ifdef m68k} + regi : tregister; +{$endif} + method_must_be_valid : boolean; + label + errorexit; + + { check if the resulttype from tree p is equal with def, needed + for stringconstn and formaldef } + function is_equal(p:ptree;def:pdef) : boolean; + + begin + { safety check } + if not (assigned(def) or assigned(p^.resulttype)) then + begin + is_equal:=false; + exit; + end; + { all types can be passed to a formaldef } + is_equal:=(def^.deftype=formaldef) or + (types.is_equal(p^.resulttype,def)) + { to support ansi/long/wide strings in a proper way } + { string and string[10] are assumed as equal } + { when searching the correct overloaded procedure } + or + ( + (def^.deftype=stringdef) and (p^.resulttype^.deftype=stringdef) and + (pstringdef(def)^.string_typ=pstringdef(p^.resulttype)^.string_typ) + ) + or + ( + (p^.left^.treetype=stringconstn) and + (is_ansistring(p^.resulttype) and is_pchar(def)) + ) + or + ( + (p^.left^.treetype=ordconstn) and + (is_char(p^.resulttype) and (is_shortstring(def) or is_ansistring(def))) + ) + { set can also be a not yet converted array constructor } + or + ( + (def^.deftype=setdef) and (p^.resulttype^.deftype=arraydef) and + (parraydef(p^.resulttype)^.IsConstructor) and not(parraydef(p^.resulttype)^.IsVariant) + ) + { in tp7 mode proc -> procvar is allowed } + or + ( + (m_tp_procvar in aktmodeswitches) and + (def^.deftype=procvardef) and (p^.left^.treetype=calln) and + (proc_to_procvar_equal(pprocdef(p^.left^.procdefinition),pprocvardef(def))) + ) + ; + end; + + function is_in_limit(def_from,def_to : pdef) : boolean; + + begin + is_in_limit:=(def_from^.deftype = orddef) and + (def_to^.deftype = orddef) and + (porddef(def_from)^.low>porddef(def_to)^.low) and + (porddef(def_from)^.highnil then we called firstpass already } + { it seems to be bad because of the registers } + { at least we can avoid the overloaded search !! } + procs:=nil; + { made this global for disposing !! } + + oldcallprocsym:=aktcallprocsym; + aktcallprocsym:=nil; + + inlined:=false; + if assigned(p^.procdefinition) and + (pocall_inline in p^.procdefinition^.proccalloptions) then + begin + inlinecode:=p^.right; + if assigned(inlinecode) then + begin + inlined:=true; +{$ifdef INCLUDEOK} + exclude(p^.procdefinition^.proccalloptions,pocall_inline); +{$else} + p^.procdefinition^.proccalloptions:=p^.procdefinition^.proccalloptions-[pocall_inline]; +{$endif} + end; + p^.right:=nil; + end; + if assigned(p^.procdefinition) and + (po_containsself in p^.procdefinition^.procoptions) then + message(cg_e_cannot_call_message_direct); + + { procedure variable ? } + if assigned(p^.right) then + begin + { procedure does a call } + procinfo^.flags:=procinfo^.flags or pi_do_call; +{$ifndef newcg} + { calc the correture value for the register } +{$ifdef i386} + incrementregisterpushed($ff); +{$endif} +{$ifdef m68k} + for regi:=R_D0 to R_A6 do + inc(reg_pushes[regi],t_times*2); +{$endif} +{$endif newcg} + { calculate the type of the parameters } + if assigned(p^.left) then + begin + firstcallparan(p^.left,nil,false); + if codegenerror then + goto errorexit; + end; + firstpass(p^.right); + set_varstate(p^.right,true); + + { check the parameters } + pdc:=pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first); + pt:=p^.left; + while assigned(pdc) and assigned(pt) do + begin + pt:=pt^.right; + pdc:=pparaitem(pdc^.next); + end; + if assigned(pt) or assigned(pdc) then + begin + if assigned(pt) then + aktfilepos:=pt^.fileinfo; + CGMessage(parser_e_illegal_parameter_list); + end; + { insert type conversions } + if assigned(p^.left) then + begin + firstcallparan(p^.left,pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first),true); + if codegenerror then + goto errorexit; + end; + p^.resulttype:=pprocvardef(p^.right^.resulttype)^.rettype.def; + + { this was missing, leads to a bug below if + the procvar is a function } + p^.procdefinition:=pabstractprocdef(p^.right^.resulttype); + end + else + { not a procedure variable } + begin + { determine the type of the parameters } + if assigned(p^.left) then + begin + firstcallparan(p^.left,nil,false); + if codegenerror then + goto errorexit; + end; + + aktcallprocsym:=pprocsym(p^.symtableprocentry); + { do we know the procedure to call ? } + if not(assigned(p^.procdefinition)) then + begin +{$ifdef TEST_PROCSYMS} + if (p^.unit_specific) or + assigned(p^.methodpointer) then + nextprocsym:=nil + else while not assigned(procs) do + begin + symt:=p^.symtableproc; + srsym:=nil; + while assigned(symt^.next) and not assigned(srsym) do + begin + symt:=symt^.next; + getsymonlyin(symt,actprocsym^.name); + if assigned(srsym) then + if srsym^.typ<>procsym then + begin + { reject all that is not a procedure } + srsym:=nil; + { don't search elsewhere } + while assigned(symt^.next) do + symt:=symt^.next; + end; + end; + nextprocsym:=srsym; + end; +{$endif TEST_PROCSYMS} + { determine length of parameter list } + pt:=p^.left; + paralength:=0; + while assigned(pt) do + begin + inc(paralength); + pt:=pt^.right; + end; + + { link all procedures which have the same # of parameters } + pd:=aktcallprocsym^.definition; + while assigned(pd) do + begin + { only when the # of parameter are equal } + if (pd^.para^.count=paralength) then + begin + new(hp); + hp^.data:=pd; + hp^.next:=procs; + hp^.nextpara:=pparaitem(pd^.para^.first); + hp^.firstpara:=pparaitem(pd^.para^.first); + procs:=hp; + end; + pd:=pd^.nextoverloaded; + end; + + { no procedures found? then there is something wrong + with the parameter size } + if not assigned(procs) then + begin + { in tp mode we can try to convert to procvar if + there are no parameters specified } + if not(assigned(p^.left)) and + (m_tp_procvar in aktmodeswitches) then + begin + if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and + (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then + hpt:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc, + getcopy(p^.methodpointer)) + else + hpt:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc); + disposetree(p); + firstpass(hpt); + p:=hpt; + end + else + begin + if assigned(p^.left) then + aktfilepos:=p^.left^.fileinfo; + CGMessage(parser_e_wrong_parameter_size); + aktcallprocsym^.write_parameter_lists; + end; + goto errorexit; + end; + + { now we can compare parameter after parameter } + pt:=p^.left; + { we start with the last parameter } + lastpara:=paralength+1; + lastparatype:=nil; + while assigned(pt) do + begin + dec(lastpara); + { walk all procedures and determine how this parameter matches and set: + 1. pt^.exact_match_found if one parameter has an exact match + 2. exactmatch if an equal or exact match is found + + 3. para^.argconvtyp to exact,equal or convertable + (when convertable then also convertlevel is set) + 4. pt^.convlevel1found if there is a convertlevel=1 + 5. pt^.convlevel2found if there is a convertlevel=2 + } + exactmatch:=false; + hp:=procs; + while assigned(hp) do + begin + if is_equal(pt,hp^.nextpara^.paratype.def) then + begin + if hp^.nextpara^.paratype.def=pt^.resulttype then + begin + pt^.exact_match_found:=true; + hp^.nextpara^.argconvtyp:=act_exact; + end + else + hp^.nextpara^.argconvtyp:=act_equal; + exactmatch:=true; + end + else + begin + hp^.nextpara^.argconvtyp:=act_convertable; + hp^.nextpara^.convertlevel:=isconvertable(pt^.resulttype,hp^.nextpara^.paratype.def, + hcvt,pt^.left^.treetype,false); + case hp^.nextpara^.convertlevel of + 1 : pt^.convlevel1found:=true; + 2 : pt^.convlevel2found:=true; + end; + end; + + hp:=hp^.next; + end; + + { If there was an exactmatch then delete all convertables } + if exactmatch then + begin + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep if not convertable } + if (hp^.nextpara^.argconvtyp<>act_convertable) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; + end + else + { No exact match was found, remove all procedures that are + not convertable (convertlevel=0) } + begin + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep if not convertable } + if (hp^.nextpara^.convertlevel<>0) then + begin + hp^.next:=procs; + procs:=hp; + end + else + begin + { save the type for nice error message } + lastparatype:=hp^.nextpara^.paratype.def; + dispose(hp); + end; + hp:=hp2; + end; + end; + { update nextpara for all procedures } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=pparaitem(hp^.nextpara^.next); + hp:=hp^.next; + end; + { load next parameter or quit loop if no procs left } + if assigned(procs) then + pt:=pt^.right + else + break; + end; + + { All parameters are checked, check if there are any + procedures left } + if not assigned(procs) then + begin + { there is an error, must be wrong type, because + wrong size is already checked (PFV) } + if (not assigned(lastparatype)) or + (not assigned(pt)) or + (not assigned(pt^.resulttype)) then + internalerror(39393) + else + begin + aktfilepos:=pt^.fileinfo; + CGMessage3(type_e_wrong_parameter_type,tostr(lastpara), + pt^.resulttype^.typename,lastparatype^.typename); + end; + aktcallprocsym^.write_parameter_lists; + goto errorexit; + end; + + { if there are several choices left then for orddef } + { if a type is totally included in the other } + { we don't fear an overflow , } + { so we can do as if it is an exact match } + { this will convert integer to longint } + { rather than to words } + { conversion of byte to integer or longint } + {would still not be solved } + if assigned(procs) and assigned(procs^.next) then + begin + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.firstpara; + hp:=hp^.next; + end; + pt:=p^.left; + while assigned(pt) do + begin + { matches a parameter of one procedure exact ? } + exactmatch:=false; + def_from:=pt^.resulttype; + hp:=procs; + while assigned(hp) do + begin + if not is_equal(pt,hp^.nextpara^.paratype.def) then + begin + def_to:=hp^.nextpara^.paratype.def; + if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and + (is_in_limit(def_from,def_to) or + ((hp^.nextpara^.paratyp=vs_var) and + (def_from^.size=def_to^.size))) then + begin + exactmatch:=true; + conv_to:=def_to; + end; + end; + hp:=hp^.next; + end; + + { .... if yes, del all the other procedures } + if exactmatch then + begin + { the first .... } + while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.paratype.def)) do + begin + hp:=procs^.next; + dispose(procs); + procs:=hp; + end; + { and the others } + hp:=procs; + while (assigned(hp)) and assigned(hp^.next) do + begin + if not(is_in_limit(def_from,hp^.next^.nextpara^.paratype.def)) then + begin + hp2:=hp^.next^.next; + dispose(hp^.next); + hp^.next:=hp2; + end + else + begin + def_to:=hp^.next^.nextpara^.paratype.def; + if (conv_to^.size>def_to^.size) or + ((porddef(conv_to)^.lowporddef(def_to)^.high)) then + begin + hp2:=procs; + procs:=hp; + conv_to:=def_to; + dispose(hp2); + end + else + hp:=hp^.next; + end; + end; + end; + { update nextpara for all procedures } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=pparaitem(hp^.nextpara^.next); + hp:=hp^.next; + end; + pt:=pt^.right; + end; + end; + + { let's try to eliminate equal if there is an exact match + is there } + if assigned(procs) and assigned(procs^.next) then + begin + { reset nextpara for all procs left } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.firstpara; + hp:=hp^.next; + end; + + pt:=p^.left; + while assigned(pt) do + begin + if pt^.exact_match_found then + begin + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep the exact matches, dispose the others } + if (hp^.nextpara^.argconvtyp=act_exact) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; + end; + { update nextpara for all procedures } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=pparaitem(hp^.nextpara^.next); + hp:=hp^.next; + end; + pt:=pt^.right; + end; + end; + + { Check if there are convertlevel 1 and 2 differences + left for the parameters, then discard all convertlevel + 2 procedures. The value of convlevelXfound can still + be used, because all convertables are still here or + not } + if assigned(procs) and assigned(procs^.next) then + begin + { reset nextpara for all procs left } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=hp^.firstpara; + hp:=hp^.next; + end; + + pt:=p^.left; + while assigned(pt) do + begin + if pt^.convlevel1found and pt^.convlevel2found then + begin + hp:=procs; + procs:=nil; + while assigned(hp) do + begin + hp2:=hp^.next; + { keep all not act_convertable and all convertlevels=1 } + if (hp^.nextpara^.argconvtyp<>act_convertable) or + (hp^.nextpara^.convertlevel=1) then + begin + hp^.next:=procs; + procs:=hp; + end + else + dispose(hp); + hp:=hp2; + end; + end; + { update nextpara for all procedures } + hp:=procs; + while assigned(hp) do + begin + hp^.nextpara:=pparaitem(hp^.nextpara^.next); + hp:=hp^.next; + end; + pt:=pt^.right; + end; + end; + + if not(assigned(procs)) or assigned(procs^.next) then + begin + CGMessage(cg_e_cant_choose_overload_function); + aktcallprocsym^.write_parameter_lists; + goto errorexit; + end; +{$ifdef TEST_PROCSYMS} + if (procs=nil) and assigned(nextprocsym) then + begin + p^.symtableprocentry:=nextprocsym; + p^.symtableproc:=symt; + end; + end ; { of while assigned(p^.symtableprocentry) do } +{$endif TEST_PROCSYMS} + if make_ref then + begin + procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@p^.fileinfo)); + inc(procs^.data^.refcount); + if procs^.data^.defref=nil then + procs^.data^.defref:=procs^.data^.lastref; + end; + + p^.procdefinition:=procs^.data; + p^.resulttype:=procs^.data^.rettype.def; + { big error for with statements + p^.symtableproc:=p^.procdefinition^.owner; + but neede for overloaded operators !! } + if p^.symtableproc=nil then + p^.symtableproc:=p^.procdefinition^.owner; + + p^.location.loc:=LOC_MEM; +{$ifdef CHAINPROCSYMS} + { object with method read; + call to read(x) will be a usual procedure call } + if assigned(p^.methodpointer) and + (p^.procdefinition^._class=nil) then + begin + { not ok for extended } + case p^.methodpointer^.treetype of + typen,hnewn : fatalerror(no_para_match); + end; + disposetree(p^.methodpointer); + p^.methodpointer:=nil; + end; +{$endif CHAINPROCSYMS} + end; { end of procedure to call determination } + + is_const:=(pocall_internconst in p^.procdefinition^.proccalloptions) and + ((block_type=bt_const) or + (assigned(p^.left) and (p^.left^.left^.treetype in [realconstn,ordconstn]))); + { handle predefined procedures } + if (pocall_internproc in p^.procdefinition^.proccalloptions) or is_const then + begin + if assigned(p^.left) then + begin + { settextbuf needs two args } + if assigned(p^.left^.right) then + pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left) + else + begin + pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left^.left); + putnode(p^.left); + end; + end + else + begin + pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,nil); + end; + putnode(p); + firstpass(pt); + p:=pt; + goto errorexit; + end + else + { no intern procedure => we do a call } + { calc the correture value for the register } + { handle predefined procedures } + if (pocall_inline in p^.procdefinition^.proccalloptions) then + begin + if assigned(p^.methodpointer) then + CGMessage(cg_e_unable_inline_object_methods); + if assigned(p^.right) and (p^.right^.treetype<>procinlinen) then + CGMessage(cg_e_unable_inline_procvar); + { p^.treetype:=procinlinen; } + if not assigned(p^.right) then + begin + if assigned(pprocdef(p^.procdefinition)^.code) then + inlinecode:=genprocinlinenode(p,ptree(pprocdef(p^.procdefinition)^.code)) + else + CGMessage(cg_e_no_code_for_inline_stored); + if assigned(inlinecode) then + begin + { consider it has not inlined if called + again inside the args } +{$ifdef INCLUDEOK} + exclude(p^.procdefinition^.proccalloptions,pocall_inline); +{$else} + p^.procdefinition^.proccalloptions:=p^.procdefinition^.proccalloptions-[pocall_inline]; +{$endif} + firstpass(inlinecode); + inlined:=true; + end; + end; + end + else + procinfo^.flags:=procinfo^.flags or pi_do_call; + + {if (po_interrupt in p^.procdefinition^.procoptions) then + CGmessage1(cg_e_no_call_to_interrupt,p^.symtableprocentry^.name);} + { work trough all parameters to insert the type conversions } + { !!! done now after internproc !! (PM) } + if assigned(p^.left) then + begin + firstcallparan(p^.left,pparaitem(p^.procdefinition^.para^.first),true); + end; +{$ifndef newcg} +{$ifdef i386} + incrementregisterpushed(pprocdef(p^.procdefinition)^.usedregisters); +{$endif} +{$ifdef m68k} + for regi:=R_D0 to R_A6 do + begin + if (pprocdef(p^.procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then + inc(reg_pushes[regi],t_times*2); + end; +{$endif} +{$endif newcg} + end; + { ensure that the result type is set } + p^.resulttype:=p^.procdefinition^.rettype.def; + { get a register for the return value } + if (p^.resulttype<>pdef(voiddef)) then + begin + if (p^.procdefinition^.proctypeoption=potype_constructor) then + begin + { extra handling of classes } + { p^.methodpointer should be assigned! } + if assigned(p^.methodpointer) and assigned(p^.methodpointer^.resulttype) and + (p^.methodpointer^.resulttype^.deftype=classrefdef) then + begin + p^.location.loc:=LOC_REGISTER; + p^.registers32:=1; + { the result type depends on the classref } + p^.resulttype:=pclassrefdef(p^.methodpointer^.resulttype)^.pointertype.def; + end + { a object constructor returns the result with the flags } + else + p^.location.loc:=LOC_FLAGS; + end + else + begin +{$ifdef SUPPORT_MMX} + if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(p^.resulttype) then + begin + p^.location.loc:=LOC_MMXREGISTER; + p^.registersmmx:=1; + end + else +{$endif SUPPORT_MMX} + if ret_in_acc(p^.resulttype) then + begin + p^.location.loc:=LOC_REGISTER; + if is_64bitint(p^.resulttype) then + p^.registers32:=2 + else + p^.registers32:=1; + + { wide- and ansistrings are returned in EAX } + { but they are imm. moved to a memory location } + if is_widestring(p^.resulttype) or + is_ansistring(p^.resulttype) then + begin + p^.location.loc:=LOC_MEM; + { this is wrong we still need one register PM + p^.registers32:=0; } + { we use ansistrings so no fast exit here } + procinfo^.no_fast_exit:=true; + p^.registers32:=1; + end; + end + else if (p^.resulttype^.deftype=floatdef) then + begin + p^.location.loc:=LOC_FPU; + p^.registersfpu:=1; + end + else + p^.location.loc:=LOC_MEM; + end; + end; + { a fpu can be used in any procedure !! } + p^.registersfpu:=p^.procdefinition^.fpu_used; + { if this is a call to a method calc the registers } + if (p^.methodpointer<>nil) then + begin + case p^.methodpointer^.treetype of + { but only, if this is not a supporting node } + typen: ; + { we need one register for new return value PM } + hnewn : if p^.registers32=0 then + p^.registers32:=1; + else + begin + if (p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and + assigned(p^.symtable) and (p^.symtable^.symtabletype=withsymtable) and + not pwithsymtable(p^.symtable)^.direct_with then + begin + CGmessage(cg_e_cannot_call_cons_dest_inside_with); + end; { Is accepted by Delphi !! } + { this is not a good reason to accept it in FPC if we produce + wrong code for it !!! (PM) } + + { R.Assign is not a constructor !!! } + { but for R^.Assign, R must be valid !! } + if (p^.procdefinition^.proctypeoption=potype_constructor) or + ((p^.methodpointer^.treetype=loadn) and + (not(oo_has_virtual in pobjectdef(p^.methodpointer^.resulttype)^.objectoptions))) then + method_must_be_valid:=false + else + method_must_be_valid:=true; + firstpass(p^.methodpointer); + set_varstate(p^.methodpointer,method_must_be_valid); + { The object is already used ven if it is called once } + if (p^.methodpointer^.treetype=loadn) and + (p^.methodpointer^.symtableentry^.typ=varsym) then + pvarsym(p^.methodpointer^.symtableentry)^.varstate:=vs_used; + + p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu); + p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.methodpointer^.registersmmx,p^.registersmmx); +{$endif SUPPORT_MMX} + end; + end; + end; + + if inlined then + p^.right:=inlinecode; + { determine the registers of the procedure variable } + { is this OK for inlined procs also ?? (PM) } + if assigned(p^.right) then + begin + p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu); + p^.registers32:=max(p^.right^.registers32,p^.registers32); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.right^.registersmmx,p^.registersmmx); +{$endif SUPPORT_MMX} + end; + { determine the registers of the procedure } + if assigned(p^.left) then + begin + p^.registersfpu:=max(p^.left^.registersfpu,p^.registersfpu); + p^.registers32:=max(p^.left^.registers32,p^.registers32); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.left^.registersmmx,p^.registersmmx); +{$endif SUPPORT_MMX} + end; + errorexit: + { Reset some settings back } + if assigned(procs) then + dispose(procs); + if inlined then +{$ifdef INCLUDEOK} + include(p^.procdefinition^.proccalloptions,pocall_inline); +{$else} + p^.procdefinition^.proccalloptions:=p^.procdefinition^.proccalloptions+[pocall_inline]; +{$endif} + aktcallprocsym:=oldcallprocsym; + end; + + +{***************************************************************************** + FirstProcInlineN +*****************************************************************************} + + procedure firstprocinline(var p : ptree); + begin + { left contains the code in tree form } + { but it has already been firstpassed } + { so firstpass(p^.left); does not seem required } + { might be required later if we change the arg handling !! } + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.86 2000/05/25 07:44:11 jonas + * const parameters were not prevented from becoming regvars (causing + errors later on in the code generating stage) + + Revision 1.85 2000/05/09 14:16:00 pierre + * calling interrupt routine supported + + Revision 1.84 2000/04/24 12:48:38 peter + * removed unused vars + + Revision 1.83 2000/04/02 18:30:12 florian + * fixed another problem with readln(); + * the register allocator takes now care of necessary pushes/pops for + readln/writeln + + Revision 1.82 2000/02/29 22:13:41 pierre + + use $GOTO ON + + Revision 1.81 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.80 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.79 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.78 2000/01/07 09:35:12 pierre + * set_varstate must be called after typeconv insertions + + Revision 1.77 2000/01/07 01:14:44 peter + * updated copyright to 2000 + + Revision 1.76 1999/12/19 15:13:56 peter + * constant array type conversion fixed + + Revision 1.75 1999/12/09 23:18:04 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.74 1999/11/30 10:40:57 peter + + ttype, tsymlist + + Revision 1.73 1999/11/18 15:34:49 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.72 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.71 1999/11/06 14:34:29 peter + * truncated log to 20 revs + + Revision 1.70 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.69 1999/10/22 14:37:30 peter + * error when properties are passed to var parameters + + Revision 1.68 1999/10/13 10:35:27 peter + * var must match exactly error msg extended with got and expected type + * array constructor type check now gives error on wrong types + + Revision 1.67 1999/10/12 15:50:54 pierre + * error if calling interrupt procedure + + Revision 1.66 1999/09/27 23:45:00 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.65 1999/09/16 23:05:56 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.64 1999/09/14 07:59:48 florian + * finally!? fixed + with do + My last and also Peter's fix before were wrong :( + + Revision 1.63 1999/09/10 18:48:11 florian + * some bug fixes (e.g. must_be_valid and procinfo^.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.62 1999/08/23 23:42:52 pierre + * hnewn reg allocation corrected + + Revision 1.61 1999/08/17 13:26:08 peter + * arrayconstructor -> arrayofconst fixed when arraycosntructor was not + variant. + + Revision 1.60 1999/08/16 23:23:39 peter + * arrayconstructor -> openarray type conversions for element types + + Revision 1.59 1999/08/13 21:33:16 peter + * support for array constructors extended and more error checking + +} \ No newline at end of file diff --git a/befpc/compiler/tccnv.pas b/befpc/compiler/tccnv.pas new file mode 100644 index 0000000..6af63db --- /dev/null +++ b/befpc/compiler/tccnv.pas @@ -0,0 +1,1106 @@ +{ + $Id: tccnv.pas,v 1.1.1.1 2001-07-23 17:17:15 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for type converting nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef TP} + {$E+,F+,N+,D+,L+,Y+} +{$endif} +unit tccnv; +interface + + uses + tree; + + procedure arrayconstructor_to_set(var p:ptree); + + procedure firsttypeconv(var p : ptree); + procedure firstas(var p : ptree); + procedure firstis(var p : ptree); + + +implementation + + uses + globtype,systems,tokens, + cobjects,verbose,globals, + symconst,symtable,aasm,types, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen, +{$endif newcg} + htypechk,pass_1,cpubase; + + +{***************************************************************************** + Array constructor to Set Conversion +*****************************************************************************} + + procedure arrayconstructor_to_set(var p:ptree); + var + constp, + buildp, + p2,p3,p4 : ptree; + pd : pdef; + constset : pconstset; + constsetlo, + constsethi : longint; + + procedure update_constsethi(p:pdef); + begin + if ((p^.deftype=orddef) and + (porddef(p)^.high>=constsethi)) then + begin + constsethi:=porddef(p)^.high; + if pd=nil then + begin + if (constsethi>255) or + (porddef(p)^.low<0) then + pd:=u8bitdef + else + pd:=p; + end; + if constsethi>255 then + constsethi:=255; + end + else if ((p^.deftype=enumdef) and + (penumdef(p)^.max>=constsethi)) then + begin + if pd=nil then + pd:=p; + constsethi:=penumdef(p)^.max; + end; + end; + + procedure do_set(pos : longint); + var + mask,l : longint; + begin + if (pos>255) or (pos<0) then + Message(parser_e_illegal_set_expr); + if pos>constsethi then + constsethi:=pos; + if pos0 then + Message(parser_e_illegal_set_expr); + constset^[l]:=constset^[l] or mask; + end; + + var + l : longint; + lr,hr : longint; + + begin + new(constset); + FillChar(constset^,sizeof(constset^),0); + pd:=nil; + constsetlo:=0; + constsethi:=0; + constp:=gensinglenode(setconstn,nil); + constp^.value_set:=constset; + buildp:=constp; + if assigned(p^.left) then + begin + while assigned(p) do + begin + p4:=nil; { will contain the tree to create the set } + { split a range into p2 and p3 } + if p^.left^.treetype=arrayconstructrangen then + begin + p2:=p^.left^.left; + p3:=p^.left^.right; + { node is not used anymore } + putnode(p^.left); + end + else + begin + p2:=p^.left; + p3:=nil; + end; + firstpass(p2); + if assigned(p3) then + firstpass(p3); + if codegenerror then + break; + case p2^.resulttype^.deftype of + enumdef, + orddef: + begin + getrange(p2^.resulttype,lr,hr); + if assigned(p3) then + begin + { this isn't good, you'll get problems with + type t010 = 0..10; + ts = set of t010; + var s : ts;b : t010 + begin s:=[1,2,b]; end. + if is_integer(p3^.resulttype) then + begin + p3:=gentypeconvnode(p3,u8bitdef); + firstpass(p3); + end; + } + + if assigned(pd) and not(is_equal(pd,p3^.resulttype)) then + begin + aktfilepos:=p3^.fileinfo; + CGMessage(type_e_typeconflict_in_set); + end + else + begin + if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then + begin + if not(is_integer(p3^.resulttype)) then + pd:=p3^.resulttype + else + begin + p3:=gentypeconvnode(p3,u8bitdef); + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + firstpass(p3); + end; + + for l:=p2^.value to p3^.value do + do_set(l); + disposetree(p3); + disposetree(p2); + end + else + begin + update_constsethi(p2^.resulttype); + p2:=gentypeconvnode(p2,pd); + firstpass(p2); + + update_constsethi(p3^.resulttype); + p3:=gentypeconvnode(p3,pd); + firstpass(p3); + + + if assigned(pd) then + p3:=gentypeconvnode(p3,pd) + else + p3:=gentypeconvnode(p3,u8bitdef); + firstpass(p3); + p4:=gennode(setelementn,p2,p3); + end; + end; + end + else + begin + { Single value } + if p2^.treetype=ordconstn then + begin + if not(is_integer(p2^.resulttype)) then + update_constsethi(p2^.resulttype) + else + begin + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + end; + + do_set(p2^.value); + disposetree(p2); + end + else + begin + update_constsethi(p2^.resulttype); + + if assigned(pd) then + p2:=gentypeconvnode(p2,pd) + else + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + + p4:=gennode(setelementn,p2,nil); + end; + end; + end; + stringdef : begin + { if we've already set elements which are constants } + { throw an error } + if ((pd=nil) and assigned(buildp)) or + not(is_equal(pd,cchardef)) then + CGMessage(type_e_typeconflict_in_set) + else + for l:=1 to length(pstring(p2^.value_str)^) do + do_set(ord(pstring(p2^.value_str)^[l])); + if pd=nil then + pd:=cchardef; + disposetree(p2); + end; + else + CGMessage(type_e_ordinal_expr_expected); + end; + { insert the set creation tree } + if assigned(p4) then + buildp:=gennode(addn,buildp,p4); + { load next and dispose current node } + p2:=p; + p:=p^.right; + putnode(p2); + end; + if (pd=nil) then + begin + pd:=u8bitdef; + constsethi:=255; + end; + end + else + begin + { empty set [], only remove node } + putnode(p); + end; + { set the initial set type } + constp^.resulttype:=new(psetdef,init(pd,constsethi)); + { set the new tree } + p:=buildp; + end; + + +{***************************************************************************** + FirstTypeConv +*****************************************************************************} + + type + tfirstconvproc = procedure(var p : ptree); + + procedure first_int_to_int(var p : ptree); + begin + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.resulttype^.size>p^.left^.resulttype^.size) then + p^.location.loc:=LOC_REGISTER; + if is_64bitint(p^.resulttype) then + p^.registers32:=max(p^.registers32,2) + else + p^.registers32:=max(p^.registers32,1); + end; + + + procedure first_cstring_to_pchar(var p : ptree); + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_string_to_chararray(var p : ptree); + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_string_to_string(var p : ptree); + var + hp : ptree; + begin + if pstringdef(p^.resulttype)^.string_typ<> + pstringdef(p^.left^.resulttype)^.string_typ then + begin + if p^.left^.treetype=stringconstn then + begin + p^.left^.stringtype:=pstringdef(p^.resulttype)^.string_typ; + p^.left^.resulttype:=p^.resulttype; + { remove typeconv node } + hp:=p; + p:=p^.left; + putnode(hp); + exit; + end + else + procinfo^.flags:=procinfo^.flags or pi_do_call; + end; + { for simplicity lets first keep all ansistrings + as LOC_MEM, could also become LOC_REGISTER } + if pstringdef(p^.resulttype)^.string_typ in [st_ansistring,st_widestring] then + { we may use ansistrings so no fast exit here } + procinfo^.no_fast_exit:=true; + p^.location.loc:=LOC_MEM; + end; + + + procedure first_char_to_string(var p : ptree); + var + hp : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genstringconstnode(chr(p^.left^.value),st_default); + hp^.stringtype:=pstringdef(p^.resulttype)^.string_typ; + firstpass(hp); + disposetree(p); + p:=hp; + end + else + p^.location.loc:=LOC_MEM; + end; + + + procedure first_nothing(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + + procedure first_array_to_pointer(var p : ptree); + begin + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_int_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genrealconstnode(p^.left^.value,pfloatdef(p^.resulttype)); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_int_to_fix(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genfixconstnode(p^.left^.value shl 16,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_real_to_fix(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=fixconstn then + begin + t:=genfixconstnode(round(p^.left^.value_real*65536),p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + { at least one fpu and int register needed } + if p^.registers32<1 then + p^.registers32:=1; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_fix_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=fixconstn then + begin + t:=genrealconstnode(round(p^.left^.value_fix/65536.0),p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_real_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=realconstn then + begin + t:=genrealconstnode(p^.left^.value_real,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + { comp isn't a floating type } +{$ifdef i386} + if (pfloatdef(p^.resulttype)^.typ=s64comp) and + (pfloatdef(p^.left^.resulttype)^.typ<>s64comp) and + not (p^.explizit) then + CGMessage(type_w_convert_real_2_comp); +{$endif} + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_pointer_to_array(var p : ptree); + begin + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REFERENCE; + end; + + + procedure first_chararray_to_string(var p : ptree); + begin + { the only important information is the location of the } + { result } + { other stuff is done by firsttypeconv } + p^.location.loc:=LOC_MEM; + end; + + + procedure first_cchar_to_pchar(var p : ptree); + begin + p^.left:=gentypeconvnode(p^.left,cshortstringdef); + { convert constant char to constant string } + firstpass(p^.left); + { evalute tree } + firstpass(p); + end; + + + procedure first_bool_to_int(var p : ptree); + begin + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (p^.explizit) and + (p^.left^.resulttype^.size=p^.resulttype^.size) and + (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + exit; + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_int_to_bool(var p : ptree); + begin + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (p^.explizit) and + (p^.left^.resulttype^.size=p^.resulttype^.size) and + (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + exit; + p^.location.loc:=LOC_REGISTER; + { need if bool to bool !! + not very nice !! + p^.left:=gentypeconvnode(p^.left,s32bitdef); + p^.left^.explizit:=true; + firstpass(p^.left); } + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_bool_to_bool(var p : ptree); + begin + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_proc_to_procvar(var p : ptree); + begin + { hmmm, I'am not sure if that is necessary (FK) } + firstpass(p^.left); + if codegenerror then + exit; + + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_illegal_expression); + + p^.registers32:=p^.left^.registers32; + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_load_smallset(var p : ptree); + begin + end; + + + procedure first_cord_to_pointer(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genpointerconstnode(p^.left^.value,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end + else + internalerror(432472389); + end; + + + procedure first_pchar_to_string(var p : ptree); + begin + p^.location.loc:=LOC_REFERENCE; + end; + + + procedure first_ansistring_to_pchar(var p : ptree); + begin + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_arrayconstructor_to_set(var p:ptree); + var + hp : ptree; + begin + if p^.left^.treetype<>arrayconstructn then + internalerror(5546); + { remove typeconv node } + hp:=p; + p:=p^.left; + putnode(hp); + { create a set constructor tree } + arrayconstructor_to_set(p); + { now firstpass the set } + firstpass(p); + end; + + + procedure firsttypeconv(var p : ptree); + var + hp : ptree; + aprocdef : pprocdef; + const + firstconvert : array[tconverttype] of tfirstconvproc = ( + first_nothing, {equal} + first_nothing, {not_possible} + first_string_to_string, + first_char_to_string, + first_pchar_to_string, + first_cchar_to_pchar, + first_cstring_to_pchar, + first_ansistring_to_pchar, + first_string_to_chararray, + first_chararray_to_string, + first_array_to_pointer, + first_pointer_to_array, + first_int_to_int, + first_int_to_bool, + first_bool_to_bool, + first_bool_to_int, + first_real_to_real, + first_int_to_real, + first_int_to_fix, + first_real_to_fix, + first_fix_to_real, + first_proc_to_procvar, + first_arrayconstructor_to_set, + first_load_smallset, + first_cord_to_pointer + ); + begin + aprocdef:=nil; + { if explicite type cast, then run firstpass } + if (p^.explizit) or not assigned(p^.left^.resulttype) then + firstpass(p^.left); + if (p^.left^.treetype=typen) and (p^.left^.resulttype=generrordef) then + begin + codegenerror:=true; + Message(parser_e_no_type_not_allowed_here); + end; + if codegenerror then + begin + p^.resulttype:=generrordef; + exit; + end; + + if not assigned(p^.left^.resulttype) then + begin + codegenerror:=true; + internalerror(52349); + exit; + end; + + { load the value_str from the left part } + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif} + set_location(p^.location,p^.left^.location); + + { remove obsolete type conversions } + if is_equal(p^.left^.resulttype,p^.resulttype) then + begin + { becuase is_equal only checks the basetype for sets we need to + check here if we are loading a smallset into a normalset } + if (p^.resulttype^.deftype=setdef) and + (p^.left^.resulttype^.deftype=setdef) and + (psetdef(p^.resulttype)^.settype<>smallset) and + (psetdef(p^.left^.resulttype)^.settype=smallset) then + begin + { try to define the set as a normalset if it's a constant set } + if p^.left^.treetype=setconstn then + begin + p^.resulttype:=p^.left^.resulttype; + psetdef(p^.resulttype)^.settype:=normset + end + else + p^.convtyp:=tc_load_smallset; + exit; + end + else + begin + hp:=p; + p:=p^.left; + p^.resulttype:=hp^.resulttype; + putnode(hp); + exit; + end; + end; + aprocdef:=assignment_overloaded(p^.left^.resulttype,p^.resulttype); + if assigned(aprocdef) then + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + hp:=gencallnode(overloaded_operators[_assignment],nil); + { tell explicitly which def we must use !! (PM) } + hp^.procdefinition:=aprocdef; + hp^.left:=gencallparanode(p^.left,nil); + putnode(p); + p:=hp; + firstpass(p); + exit; + end; + + if isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype,p^.explizit)=0 then + begin + {Procedures have a resulttype of voiddef and functions of their + own resulttype. They will therefore always be incompatible with + a procvar. Because isconvertable cannot check for procedures we + use an extra check for them.} + if (m_tp_procvar in aktmodeswitches) then + begin + if (p^.resulttype^.deftype=procvardef) and + (is_procsym_load(p^.left) or is_procsym_call(p^.left)) then + begin + if is_procsym_call(p^.left) then + begin + {if p^.left^.right=nil then + begin} + if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable){ and + (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) }then + hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc, + getcopy(p^.left^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc); + disposetree(p^.left); + firstpass(hp); + p^.left:=hp; + aprocdef:=pprocdef(p^.left^.resulttype); + (* end + else + begin + p^.left^.right^.treetype:=loadn; + p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry; + P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition; + hp:=p^.left^.right; + putnode(p^.left); + p^.left:=hp; + { should we do that ? } + firstpass(p^.left); + if not is_equal(p^.left^.resulttype,p^.resulttype) then + begin + CGMessage(type_e_mismatch); + exit; + end + else + begin + hp:=p; + p:=p^.left; + p^.resulttype:=hp^.resulttype; + putnode(hp); + exit; + end; + end; *) + end + else + begin + if (p^.left^.treetype<>addrn) then + aprocdef:=pprocsym(p^.left^.symtableentry)^.definition; + end; + p^.convtyp:=tc_proc_2_procvar; + { Now check if the procedure we are going to assign to + the procvar, is compatible with the procvar's type } + if assigned(aprocdef) then + begin + if not proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then + CGMessage2(type_e_incompatible_types,aprocdef^.typename,p^.resulttype^.typename); + firstconvert[p^.convtyp](p); + end + else + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + exit; + end; + end; + if p^.explizit then + begin + { check if the result could be in a register } + if not(p^.resulttype^.is_intregable) and + not(p^.resulttype^.is_fpuregable) then + make_not_regable(p^.left); + { boolean to byte are special because the + location can be different } + + if is_integer(p^.resulttype) and + is_boolean(p^.left^.resulttype) then + begin + p^.convtyp:=tc_bool_2_int; + firstconvert[p^.convtyp](p); + exit; + end; + { ansistring to pchar } + if is_pchar(p^.resulttype) and + is_ansistring(p^.left^.resulttype) then + begin + p^.convtyp:=tc_ansistring_2_pchar; + firstconvert[p^.convtyp](p); + exit; + end; + { do common tc_equal cast } + p^.convtyp:=tc_equal; + + { enum to ordinal will always be s32bit } + if (p^.left^.resulttype^.deftype=enumdef) and + is_ordinal(p^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end + else + begin + if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then + CGMessage(cg_e_illegal_type_conversion); + end; + end + + { ordinal to enumeration } + else + if (p^.resulttype^.deftype=enumdef) and + is_ordinal(p^.left^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end + else + begin + if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then + CGMessage(cg_e_illegal_type_conversion); + end; + end + + { nil to ordinal node } + else if is_ordinal(p^.resulttype) and + (p^.left^.treetype=niln) then + begin + hp:=genordinalconstnode(0,p^.resulttype); + firstpass(hp); + disposetree(p); + p:=hp; + exit; + end + + {Are we typecasting an ordconst to a char?} + else + if is_char(p^.resulttype) and + is_ordinal(p^.left^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + firstpass(hp); + disposetree(p); + p:=hp; + exit; + end + else + begin + { this is wrong because it converts to a 4 byte long var !! + if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then } + if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then + CGMessage(cg_e_illegal_type_conversion); + end; + end + + { only if the same size or formal def } + { why do we allow typecasting of voiddef ?? (PM) } + else + begin + if not( + (p^.left^.resulttype^.deftype=formaldef) or + (p^.left^.resulttype^.size=p^.resulttype^.size) or + (is_equal(p^.left^.resulttype,voiddef) and + (p^.left^.treetype=derefn)) + ) then + CGMessage(cg_e_illegal_type_conversion); + if ((p^.left^.resulttype^.deftype=orddef) and + (p^.resulttype^.deftype=pointerdef)) or + ((p^.resulttype^.deftype=orddef) and + (p^.left^.resulttype^.deftype=pointerdef)) + {$ifdef extdebug}and (p^.firstpasscount=0){$endif} then + CGMessage(cg_d_pointer_to_longint_conv_not_portable); + end; + + { the conversion into a strutured type is only } + { possible, if the source is no register } + if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or + ((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.is_class)) + ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) { and + it also works if the assignment is overloaded + YES but this code is not executed if assignment is overloaded (PM) + not assigned(assignment_overloaded(p^.left^.resulttype,p^.resulttype))} then + CGMessage(cg_e_illegal_type_conversion); + end + else + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + + { tp7 procvar support, when right is not a procvardef and we got a + loadn of a procvar then convert to a calln, the check for the + result is already done in is_convertible, also no conflict with + @procvar is here because that has an extra addrn } + if (m_tp_procvar in aktmodeswitches) and + (p^.resulttype^.deftype<>procvardef) and + (p^.left^.resulttype^.deftype=procvardef) and + (p^.left^.treetype=loadn) then + begin + hp:=gencallnode(nil,nil); + hp^.right:=p^.left; + firstpass(hp); + p^.left:=hp; + end; + + + { ordinal contants can be directly converted } + { but not int64/qword } + if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) and + not(is_64bitint(p^.resulttype)) then + begin + { range checking is done in genordinalconstnode (PFV) } + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end; + if p^.convtyp<>tc_equal then + firstconvert[p^.convtyp](p); + end; + + +{***************************************************************************** + FirstIs +*****************************************************************************} + + procedure firstis(var p : ptree); + begin + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + if (p^.right^.resulttype^.deftype<>classrefdef) then + CGMessage(type_e_mismatch); + + left_right_max(p); + + { left must be a class } + if (p^.left^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(type_e_mismatch); + + { the operands must be related } + if (not(pobjectdef(p^.left^.resulttype)^.is_related( + pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related( + pobjectdef(p^.left^.resulttype)))) then + CGMessage(type_e_mismatch); + + p^.location.loc:=LOC_FLAGS; + p^.resulttype:=booldef; + end; + + +{***************************************************************************** + FirstAs +*****************************************************************************} + + procedure firstas(var p : ptree); + begin + firstpass(p^.right); + set_varstate(p^.right,true); + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + + if (p^.right^.resulttype^.deftype<>classrefdef) then + CGMessage(type_e_mismatch); + + left_right_max(p); + + { left must be a class } + if (p^.left^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(type_e_mismatch); + + { the operands must be related } + if (not(pobjectdef(p^.left^.resulttype)^.is_related( + pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related( + pobjectdef(p^.left^.resulttype)))) then + CGMessage(type_e_mismatch); + + set_location(p^.location,p^.left^.location); + p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.pointertype.def; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.62 2000/03/14 15:05:18 pierre + * fix for bug 866 + + Revision 1.61 2000/02/14 18:12:50 florian + * fixed set problem s:=[]; + + Revision 1.60 2000/02/13 22:46:28 florian + * fixed an internalerror with writeln + * fixed arrayconstructor_to_set to force the generation of better code + and added a more strict type checking + + Revision 1.59 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.58 2000/01/09 23:16:07 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.57 2000/01/07 01:14:44 peter + * updated copyright to 2000 + + Revision 1.56 1999/12/19 12:08:27 florian + * bug reported by Alex S. fixed: it wasn't possible to type cast nil in const + declarations: const l = longint(nil); + + Revision 1.55 1999/12/09 23:18:04 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.54 1999/11/30 10:40:57 peter + + ttype, tsymlist + + Revision 1.53 1999/11/18 15:34:49 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.52 1999/11/06 14:34:29 peter + * truncated log to 20 revs + + Revision 1.51 1999/11/05 13:15:00 florian + * some fixes to get the new cg compiling again + + Revision 1.50 1999/09/27 23:45:00 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.49 1999/09/26 21:30:22 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.48 1999/09/17 17:14:12 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.47 1999/09/11 09:08:34 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.46 1999/08/13 15:43:59 peter + * fixed proc->procvar conversion for tp_procvar mode, it now uses + also the genload(method)call() function + + Revision 1.45 1999/08/07 14:21:04 florian + * some small problems fixed + + Revision 1.44 1999/08/04 13:03:14 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.43 1999/08/04 00:23:36 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.42 1999/08/03 22:03:28 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/tccon.pas b/befpc/compiler/tccon.pas new file mode 100644 index 0000000..7c74d07 --- /dev/null +++ b/befpc/compiler/tccon.pas @@ -0,0 +1,160 @@ +{ + $Id: tccon.pas,v 1.1.1.1 2001-07-23 17:17:15 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tccon; +interface + + uses + tree; + + procedure firstrealconst(var p : ptree); + procedure firstfixconst(var p : ptree); + procedure firstordconst(var p : ptree); + procedure firstpointerconst(var p : ptree); + procedure firststringconst(var p : ptree); + procedure firstsetconst(var p : ptree); + procedure firstniln(var p : ptree); + + +implementation + + uses + cobjects,verbose,globals,systems, + symconst,symtable,aasm,types, + hcodegen,pass_1,cpubase; + +{***************************************************************************** + FirstRealConst +*****************************************************************************} + + procedure firstrealconst(var p : ptree); + begin + if (p^.value_real=1.0) or (p^.value_real=0.0) then + begin + p^.location.loc:=LOC_FPU; + p^.registersfpu:=1; + end + else + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstFixConst +*****************************************************************************} + + procedure firstfixconst(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstOrdConst +*****************************************************************************} + + procedure firstordconst(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstPointerConst +*****************************************************************************} + + procedure firstpointerconst(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstStringConst +*****************************************************************************} + + procedure firststringconst(var p : ptree); + begin +{ if cs_ansistrings in aktlocalswitches then + p^.resulttype:=cansistringdef + else + p^.resulttype:=cshortstringdef; } + case p^.stringtype of + st_shortstring : + p^.resulttype:=cshortstringdef; + st_ansistring : + p^.resulttype:=cansistringdef; + st_widestring : + p^.resulttype:=cwidestringdef; + st_longstring : + p^.resulttype:=clongstringdef; + end; + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstSetConst +*****************************************************************************} + + procedure firstsetconst(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstNilN +*****************************************************************************} + + procedure firstniln(var p : ptree); + begin + p^.resulttype:=voidpointerdef; + p^.location.loc:=LOC_MEM; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.11 2000/01/07 01:14:45 peter + * updated copyright to 2000 + + Revision 1.10 1999/09/26 21:30:22 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.9 1999/09/04 20:52:07 florian + * bug 580 fixed + + Revision 1.8 1999/08/04 00:23:38 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.7 1999/08/03 22:03:29 peter + * moved bitmask constants to sets + * some other type/const renamings + +} diff --git a/befpc/compiler/tcflw.pas b/befpc/compiler/tcflw.pas new file mode 100644 index 0000000..b444d44 --- /dev/null +++ b/befpc/compiler/tcflw.pas @@ -0,0 +1,721 @@ +{ + $Id: tcflw.pas,v 1.1.1.1 2001-07-23 17:17:16 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for nodes that influence + the flow + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcflw; +interface + + uses + tree; + + procedure first_while_repeat(var p : ptree); + procedure firstif(var p : ptree); + procedure firstfor(var p : ptree); + procedure firstexit(var p : ptree); + procedure firstgoto(var p : ptree); + procedure firstlabel(var p : ptree); + procedure firstraise(var p : ptree); + procedure firsttryexcept(var p : ptree); + procedure firsttryfinally(var p : ptree); + procedure firston(var p : ptree); + +var + { the block node of the current exception block to check gotos } + aktexceptblock : ptree; + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types,htypechk,pass_1,cpubase +{$ifdef newcg} + ,tgobj + ,tgcpu + ,cgbase +{$else newcg} + ,hcodegen + ,temp_gen +{$ifdef i386} + ,tgeni386 +{$endif} +{$ifdef m68k} + ,tgen68k +{$endif m68k} +{$endif newcg} + ; + +{***************************************************************************** + First_While_RepeatN +*****************************************************************************} + + procedure first_while_repeat(var p : ptree); + var + old_t_times : longint; + begin + old_t_times:=t_times; + + { calc register weight } + if not(cs_littlesize in aktglobalswitches ) then + t_times:=t_times*8; +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + if not is_boolean(p^.left^.resulttype) then + begin + CGMessage(type_e_mismatch); + exit; + end; + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + + { loop instruction } + if assigned(p^.right) then + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.right); + if codegenerror then + exit; + + if p^.registers32assignn then + CGMessage(cg_e_illegal_expression); + +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.left); + set_varstate(p^.left,false); + +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + if assigned(p^.t1) then + begin + firstpass(p^.t1); + if codegenerror then + exit; + end; + + p^.registers32:=p^.t1^.registers32; + p^.registersfpu:=p^.t1^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if p^.left^.registers32>p^.registers32 then + p^.registers32:=p^.left^.registers32; + if p^.left^.registersfpu>p^.registersfpu then + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + if p^.left^.registersmmx>p^.registersmmx then + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + + { process count var } +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.t2); + set_varstate(p^.t2,true); + if codegenerror then + exit; + + { Check count var, record fields are also allowed in tp7 } + hp:=p^.t2; + while (hp^.treetype=subscriptn) do + hp:=hp^.left; + { we need a simple loadn, but the load must be in a global symtable or + in the same lexlevel } + if not(hp^.treetype in [loadn,funcretn]) or + ((hp^.symtable^.symtablelevel>1) and (hp^.symtable^.symtablelevel<>lexlevel)) then + CGMessagePos(hp^.fileinfo,cg_e_illegal_count_var) + else + begin + if hp^.symtableentry^.typ=varsym then + pvarsym(hp^.symtableentry)^.varstate:=vs_used; + if (not(is_ordinal(p^.t2^.resulttype)) or is_64bitint(p^.t2^.resulttype)) then + CGMessagePos(hp^.fileinfo,type_e_ordinal_expr_expected); + end; + + if p^.t2^.registers32>p^.registers32 then + p^.registers32:=p^.t2^.registers32; + if p^.t2^.registersfpu>p^.registersfpu then + p^.registersfpu:=p^.t2^.registersfpu; +{$ifdef SUPPORT_MMX} + if p^.t2^.registersmmx>p^.registersmmx then + p^.registersmmx:=p^.t2^.registersmmx; +{$endif SUPPORT_MMX} + +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.right); + set_varstate(p^.right,true); + if p^.right^.treetype<>ordconstn then + begin + p^.right:=gentypeconvnode(p^.right,p^.t2^.resulttype); +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.right); + end; + + if p^.right^.registers32>p^.registers32 then + p^.registers32:=p^.right^.registers32; + if p^.right^.registersfpu>p^.registersfpu then + p^.registersfpu:=p^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + if p^.right^.registersmmx>p^.registersmmx then + p^.registersmmx:=p^.right^.registersmmx; +{$endif SUPPORT_MMX} + { we need at least one register for comparisons PM } + if p^.registers32=0 then + inc(p^.registers32); + t_times:=old_t_times; + end; + + +{***************************************************************************** + FirstExit +*****************************************************************************} + + procedure firstexit(var p : ptree); + var + pt : ptree; + begin + if assigned(p^.left) then + begin + firstpass(p^.left); + procinfo^.funcret_state:=vs_assigned; + if codegenerror then + exit; + { Check the 2 types } + p^.left:=gentypeconvnode(p^.left,p^.resulttype); + firstpass(p^.left); + if ret_in_param(p^.resulttype) or procinfo^.no_fast_exit then + begin + pt:=genzeronode(funcretn); + pt^.rettype.setdef(p^.resulttype); + pt^.funcretprocinfo:=procinfo; + p^.left:=gennode(assignn,pt,p^.left); + firstpass(p^.left); + end; + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + end; + end; + + +{***************************************************************************** + FirstGoto +*****************************************************************************} + + procedure firstgoto(var p : ptree); + begin + p^.resulttype:=voiddef; + end; + + +{***************************************************************************** + FirstLabel +*****************************************************************************} + + procedure firstlabel(var p : ptree); + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + p^.exceptionblock:=aktexceptblock; + firstpass(p^.left); + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + p^.resulttype:=voiddef; + end; + + +{***************************************************************************** + FirstRaise +*****************************************************************************} + + procedure firstraise(var p : ptree); + begin + p^.resulttype:=voiddef; + if assigned(p^.left) then + begin + { first para must be a _class_ } + firstpass(p^.left); + if (p^.left^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(type_e_mismatch); + set_varstate(p^.left,true); + if codegenerror then + exit; + { insert needed typeconvs for addr,frame } + if assigned(p^.right) then + begin + { addr } + firstpass(p^.right); + p^.right:=gentypeconvnode(p^.right,s32bitdef); + firstpass(p^.right); + if codegenerror then + exit; + { frame } + if assigned(p^.frametree) then + begin + firstpass(p^.frametree); + p^.frametree:=gentypeconvnode(p^.frametree,s32bitdef); + firstpass(p^.frametree); + if codegenerror then + exit; + end; + end; + left_right_max(p); + end; + end; + + +{***************************************************************************** + FirstTryExcept +*****************************************************************************} + + procedure firsttryexcept(var p : ptree); + + var + oldexceptblock : ptree; + + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.left; + firstpass(p^.left); + aktexceptblock:=oldexceptblock; + { on statements } + if assigned(p^.right) then + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + firstpass(p^.right); + aktexceptblock:=oldexceptblock; + p^.registers32:=max(p^.registers32,p^.right^.registers32); + p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx); +{$endif SUPPORT_MMX} + end; + { else block } + if assigned(p^.t1) then + begin + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.t1; + firstpass(p^.t1); + aktexceptblock:=oldexceptblock; + p^.registers32:=max(p^.registers32,p^.t1^.registers32); + p^.registersfpu:=max(p^.registersfpu,p^.t1^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.registersmmx,p^.t1^.registersmmx); +{$endif SUPPORT_MMX} + end; + end; + + +{***************************************************************************** + FirstTryFinally +*****************************************************************************} + + procedure firsttryfinally(var p : ptree); + + var + oldexceptblock : ptree; + + begin + p^.resulttype:=voiddef; +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.left; + firstpass(p^.left); + aktexceptblock:=oldexceptblock; + set_varstate(p^.left,true); +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + firstpass(p^.right); + aktexceptblock:=oldexceptblock; + set_varstate(p^.right,true); + if codegenerror then + exit; + left_right_max(p); + end; + + +{***************************************************************************** + FirstOn +*****************************************************************************} + + procedure firston(var p : ptree); + + var + oldexceptblock : ptree; + + begin + { that's really an example procedure for a firstpass :) } + if (p^.excepttype^.deftype<>objectdef) or + not(pobjectdef(p^.excepttype)^.is_class) then + CGMessage(type_e_mismatch); +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + p^.resulttype:=voiddef; + p^.registers32:=0; + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + if assigned(p^.left) then + begin + firstpass(p^.left); + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + end; + +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + if assigned(p^.right) then + begin + oldexceptblock:=aktexceptblock; + aktexceptblock:=p^.right; + firstpass(p^.right); + aktexceptblock:=oldexceptblock; + p^.registers32:=max(p^.registers32,p^.right^.registers32); + p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx); +{$endif SUPPORT_MMX} + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.38 2000/06/02 21:14:34 pierre + * fix for tbs/tbs0318.pp bug + + Revision 1.37 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.36 2000/03/19 14:17:05 florian + * crash when using exception classes without sysutils unit fixed + + Revision 1.35 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.34 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.33 2000/02/01 09:43:22 peter + * allow funcret also as counter variable + + Revision 1.32 2000/01/07 01:14:45 peter + * updated copyright to 2000 + + Revision 1.31 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.30 1999/12/13 11:21:24 peter + * better position for for counter errors + + Revision 1.29 1999/12/09 23:18:05 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.28 1999/12/02 17:27:56 peter + * give error when for counter is in other lexlevel + + Revision 1.27 1999/11/30 10:40:58 peter + + ttype, tsymlist + + Revision 1.26 1999/11/18 15:34:49 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.25 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.24 1999/11/06 14:34:30 peter + * truncated log to 20 revs + + Revision 1.23 1999/10/05 22:01:53 pierre + * bug exit('test') + fail for classes + + Revision 1.22 1999/10/04 20:27:41 peter + * fixed first pass for if branches if the expression got an error + + Revision 1.20 1999/09/27 23:45:01 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.19 1999/09/16 23:05:56 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + + Revision 1.18 1999/09/16 10:44:30 pierre + * firstexit must now set procinfo^.funcret_is_valid + + Revision 1.17 1999/08/23 23:41:45 pierre + * for reg allocation corrected + + Revision 1.16 1999/08/05 16:53:20 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.15 1999/08/04 00:23:39 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.14 1999/08/03 22:03:30 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.13 1999/08/01 18:28:15 florian + * modifications for the new code generator + +} \ No newline at end of file diff --git a/befpc/compiler/tcinl.pas b/befpc/compiler/tcinl.pas new file mode 100644 index 0000000..a148e7f --- /dev/null +++ b/befpc/compiler/tcinl.pas @@ -0,0 +1,1434 @@ +{ + $Id: tcinl.pas,v 1.1.1.1 2001-07-23 17:17:17 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for inline nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcinl; +interface + + uses + tree; + + procedure firstinline(var p : ptree); + + +implementation + + uses + cobjects,verbose,globals,systems, + globtype, + symconst,symtable,aasm,types, + htypechk,pass_1, + tccal,cpubase +{$ifdef newcg} + ,cgbase + ,tgobj + ,tgcpu +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$endif newcg} + ; + +{***************************************************************************** + FirstInLine +*****************************************************************************} + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + procedure firstinline(var p : ptree); + var + vl,vl2 : longint; + vr : bestreal; + p1,hp,hpp : ptree; +{$ifndef NOCOLONCHECK} + frac_para,length_para : ptree; +{$endif ndef NOCOLONCHECK} + extra_register, + isreal, + dowrite, + file_is_typed : boolean; + + procedure do_lowhigh(adef : pdef); + + var + v : longint; + enum : penumsym; + + begin + case Adef^.deftype of + orddef: + begin + if p^.inlinenumber=in_low_x then + v:=porddef(adef)^.low + else + v:=porddef(adef)^.high; + hp:=genordinalconstnode(v,adef); + firstpass(hp); + disposetree(p); + p:=hp; + end; + enumdef: + begin + enum:=Penumdef(Adef)^.firstenum; + if p^.inlinenumber=in_high_x then + while enum^.nextenum<>nil do + enum:=enum^.nextenum; + hp:=genenumnode(enum); + disposetree(p); + p:=hp; + end; + else + internalerror(87); + end; + end; + + function getconstrealvalue : bestreal; + + begin + case p^.left^.treetype of + ordconstn: + getconstrealvalue:=p^.left^.value; + realconstn: + getconstrealvalue:=p^.left^.value_real; + else + internalerror(309992); + end; + end; + + procedure setconstrealvalue(r : bestreal); + + var + hp : ptree; + + begin + hp:=genrealconstnode(r,bestrealdef^); + disposetree(p); + p:=hp; + firstpass(p); + end; + + procedure handleextendedfunction; + + begin + p^.location.loc:=LOC_FPU; + p^.resulttype:=s80floatdef; + { redo firstpass for varstate status PM } + set_varstate(p^.left,true); + if (p^.left^.resulttype^.deftype<>floatdef) or + (pfloatdef(p^.left^.resulttype)^.typ<>s80real) then + begin + p^.left:=gentypeconvnode(p^.left,s80floatdef); + firstpass(p^.left); + end; + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + end; + + begin + { if we handle writeln; p^.left contains no valid address } + if assigned(p^.left) then + begin + if p^.left^.treetype=callparan then + firstcallparan(p^.left,nil,false) + else + firstpass(p^.left); + left_right_max(p); + set_location(p^.location,p^.left^.location); + end; + inc(parsing_para_level); + { handle intern constant functions in separate case } + if p^.inlineconst then + begin + hp:=nil; + { no parameters? } + if not assigned(p^.left) then + begin + case p^.inlinenumber of + in_const_pi : + hp:=genrealconstnode(pi,bestrealdef^); + else + internalerror(89); + end; + end + else + { process constant expression with parameter } + begin + vl:=0; + vl2:=0; { second parameter Ex: ptr(vl,vl2) } + vr:=0; + isreal:=false; + case p^.left^.treetype of + realconstn : + begin + isreal:=true; + vr:=p^.left^.value_real; + end; + ordconstn : + vl:=p^.left^.value; + callparan : + begin + { both exists, else it was not generated } + vl:=p^.left^.left^.value; + vl2:=p^.left^.right^.left^.value; + end; + else + CGMessage(cg_e_illegal_expression); + end; + case p^.inlinenumber of + in_const_trunc : + begin + if isreal then + begin + if (vr>=2147483648.0) or (vr<=-2147483649.0) then + begin + CGMessage(parser_e_range_check_error); + hp:=genordinalconstnode(1,s32bitdef) + end + else + hp:=genordinalconstnode(trunc(vr),s32bitdef) + end + else + hp:=genordinalconstnode(trunc(vl),s32bitdef); + end; + in_const_round : + begin + if isreal then + begin + if (vr>=2147483647.5) or (vr<=-2147483648.5) then + begin + CGMessage(parser_e_range_check_error); + hp:=genordinalconstnode(1,s32bitdef) + end + else + hp:=genordinalconstnode(round(vr),s32bitdef) + end + else + hp:=genordinalconstnode(round(vl),s32bitdef); + end; + in_const_frac : + begin + if isreal then + hp:=genrealconstnode(frac(vr),bestrealdef^) + else + hp:=genrealconstnode(frac(vl),bestrealdef^); + end; + in_const_int : + begin + if isreal then + hp:=genrealconstnode(int(vr),bestrealdef^) + else + hp:=genrealconstnode(int(vl),bestrealdef^); + end; + in_const_abs : + begin + if isreal then + hp:=genrealconstnode(abs(vr),bestrealdef^) + else + hp:=genordinalconstnode(abs(vl),p^.left^.resulttype); + end; + in_const_sqr : + begin + if isreal then + hp:=genrealconstnode(sqr(vr),bestrealdef^) + else + hp:=genordinalconstnode(sqr(vl),p^.left^.resulttype); + end; + in_const_odd : + begin + if isreal then + CGMessage1(type_e_integer_expr_expected,p^.left^.resulttype^.typename) + else + hp:=genordinalconstnode(byte(odd(vl)),booldef); + end; + in_const_swap_word : + begin + if isreal then + CGMessage1(type_e_integer_expr_expected,p^.left^.resulttype^.typename) + else + hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),p^.left^.resulttype); + end; + in_const_swap_long : + begin + if isreal then + CGMessage(type_e_mismatch) + else + hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),p^.left^.resulttype); + end; + in_const_ptr : + begin + if isreal then + CGMessage(type_e_mismatch) + else + hp:=genordinalconstnode((vl2 shl 16) or vl,voidpointerdef); + end; + in_const_sqrt : + begin + if isreal then + begin + if vr<0.0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(sqrt(vr),bestrealdef^) + end + else + begin + if vl<0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(sqrt(vl),bestrealdef^); + end; + end; + in_const_arctan : + begin + if isreal then + hp:=genrealconstnode(arctan(vr),bestrealdef^) + else + hp:=genrealconstnode(arctan(vl),bestrealdef^); + end; + in_const_cos : + begin + if isreal then + hp:=genrealconstnode(cos(vr),bestrealdef^) + else + hp:=genrealconstnode(cos(vl),bestrealdef^); + end; + in_const_sin : + begin + if isreal then + hp:=genrealconstnode(sin(vr),bestrealdef^) + else + hp:=genrealconstnode(sin(vl),bestrealdef^); + end; + in_const_exp : + begin + if isreal then + hp:=genrealconstnode(exp(vr),bestrealdef^) + else + hp:=genrealconstnode(exp(vl),bestrealdef^); + end; + in_const_ln : + begin + if isreal then + begin + if vr<=0.0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(ln(vr),bestrealdef^) + end + else + begin + if vl<=0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(ln(vl),bestrealdef^); + end; + end; + else + internalerror(88); + end; + end; + disposetree(p); + if hp=nil then + hp:=genzeronode(errorn); + firstpass(hp); + p:=hp; + end + else + begin + case p^.inlinenumber of + in_lo_qword, + in_hi_qword, + in_lo_long, + in_hi_long, + in_lo_word, + in_hi_word: + + begin + set_varstate(p^.left,true); + if p^.registers32<1 then + p^.registers32:=1; + if p^.inlinenumber in [in_lo_word,in_hi_word] then + p^.resulttype:=u8bitdef + else if p^.inlinenumber in [in_lo_qword,in_hi_qword] then + begin + p^.resulttype:=u32bitdef; + if (m_tp in aktmodeswitches) or + (m_delphi in aktmodeswitches) then + CGMessage(type_w_maybe_wrong_hi_lo); + end + else + begin + p^.resulttype:=u16bitdef; + if (m_tp in aktmodeswitches) or + (m_delphi in aktmodeswitches) then + CGMessage(type_w_maybe_wrong_hi_lo); + end; + p^.location.loc:=LOC_REGISTER; + if not is_integer(p^.left^.resulttype) then + CGMessage(type_e_mismatch) + else + begin + if p^.left^.treetype=ordconstn then + begin + case p^.inlinenumber of + in_lo_word : hp:=genordinalconstnode(p^.left^.value and $ff,p^.left^.resulttype); + in_hi_word : hp:=genordinalconstnode(p^.left^.value shr 8,p^.left^.resulttype); + in_lo_long : hp:=genordinalconstnode(p^.left^.value and $ffff,p^.left^.resulttype); + in_hi_long : hp:=genordinalconstnode(p^.left^.value shr 16,p^.left^.resulttype); + in_lo_qword : hp:=genordinalconstnode(p^.left^.value and $ffffffff,p^.left^.resulttype); + in_hi_qword : hp:=genordinalconstnode(p^.left^.value shr 32,p^.left^.resulttype); + end; + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + end; + + in_sizeof_x: + begin + set_varstate(p^.left,false); + if push_high_param(p^.left^.resulttype) then + begin + getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); + hp:=gennode(addn,genloadnode(pvarsym(srsym),p^.left^.symtable), + genordinalconstnode(1,s32bitdef)); + if (p^.left^.resulttype^.deftype=arraydef) and + (parraydef(p^.left^.resulttype)^.elesize<>1) then + hp:=gennode(muln,hp,genordinalconstnode(parraydef(p^.left^.resulttype)^.elesize,s32bitdef)); + disposetree(p); + p:=hp; + firstpass(p); + end; + if p^.registers32<1 then + p^.registers32:=1; + p^.resulttype:=s32bitdef; + p^.location.loc:=LOC_REGISTER; + end; + + in_typeof_x: + begin + set_varstate(p^.left,false); + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + p^.resulttype:=voidpointerdef; + end; + + in_ord_x: + begin + set_varstate(p^.left,true); + if (p^.left^.treetype=ordconstn) then + begin + hp:=genordinalconstnode(p^.left^.value,s32bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + { otherwise you get a crash if you try ord on an expression containing } + { an undeclared variable (JM) } + if not assigned(p^.left^.resulttype) then + exit; + if (p^.left^.resulttype^.deftype=orddef) then + if (porddef(p^.left^.resulttype)^.typ in [uchar,bool8bit]) then + begin + if porddef(p^.left^.resulttype)^.typ=bool8bit then + begin + hp:=gentypeconvnode(p^.left,u8bitdef); + putnode(p); + p:=hp; + p^.convtyp:=tc_bool_2_int; + p^.explizit:=true; + firstpass(p); + end + else + begin + hp:=gentypeconvnode(p^.left,u8bitdef); + putnode(p); + p:=hp; + p^.explizit:=true; + firstpass(p); + end; + end + { can this happen ? } + else if (porddef(p^.left^.resulttype)^.typ=uvoid) then + CGMessage(type_e_mismatch) + else + { all other orddef need no transformation } + begin + hp:=p^.left; + putnode(p); + p:=hp; + end + else if (p^.left^.resulttype^.deftype=enumdef) then + begin + hp:=gentypeconvnode(p^.left,s32bitdef); + putnode(p); + p:=hp; + p^.explizit:=true; + firstpass(p); + end + else + begin + { can anything else be ord() ?} + CGMessage(type_e_mismatch); + end; + end; + end; + + in_chr_byte: + begin + set_varstate(p^.left,true); + hp:=gentypeconvnode(p^.left,cchardef); + putnode(p); + p:=hp; + p^.explizit:=true; + firstpass(p); + end; + + in_length_string: + begin + set_varstate(p^.left,true); + if is_ansistring(p^.left^.resulttype) then + p^.resulttype:=s32bitdef + else + p^.resulttype:=u8bitdef; + { we don't need string conversations here } + if (p^.left^.treetype=typeconvn) and + (p^.left^.left^.resulttype^.deftype=stringdef) then + begin + hp:=p^.left^.left; + putnode(p^.left); + p^.left:=hp; + end; + + { check the type, must be string or char } + if (p^.left^.resulttype^.deftype<>stringdef) and + (not is_char(p^.left^.resulttype)) then + CGMessage(type_e_mismatch); + + { evaluates length of constant strings direct } + if (p^.left^.treetype=stringconstn) then + begin + hp:=genordinalconstnode(p^.left^.length,s32bitdef); + disposetree(p); + firstpass(hp); + p:=hp; + end + { length of char is one allways } + else if is_constcharnode(p^.left) then + begin + hp:=genordinalconstnode(1,s32bitdef); + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + + in_assigned_x: + begin + set_varstate(p^.left,true); + p^.resulttype:=booldef; + p^.location.loc:=LOC_FLAGS; + end; + + in_ofs_x, + in_seg_x : + set_varstate(p^.left,false); + in_pred_x, + in_succ_x: + begin + p^.resulttype:=p^.left^.resulttype; + if is_64bitint(p^.resulttype) then + begin + if (p^.registers32<2) then + p^.registers32:=2 + end + else + begin + if (p^.registers32<1) then + p^.registers32:=1; + end; + p^.location.loc:=LOC_REGISTER; + set_varstate(p^.left,true); + if not is_ordinal(p^.resulttype) then + CGMessage(type_e_ordinal_expr_expected) + else + begin + if (p^.resulttype^.deftype=enumdef) and + (penumdef(p^.resulttype)^.has_jumps) then + CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible) + else + if p^.left^.treetype=ordconstn then + begin + if p^.inlinenumber=in_succ_x then + hp:=genordinalconstnode(p^.left^.value+1,p^.left^.resulttype) + else + hp:=genordinalconstnode(p^.left^.value-1,p^.left^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + end; + + in_inc_x, + in_dec_x: + begin + p^.resulttype:=voiddef; + if assigned(p^.left) then + begin + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,true); + if codegenerror then + exit; + { first param must be var } + valid_for_assign(p^.left^.left,false); + { check type } + if (p^.left^.resulttype^.deftype in [enumdef,pointerdef]) or + is_ordinal(p^.left^.resulttype) then + begin + { two paras ? } + if assigned(p^.left^.right) then + begin + { insert a type conversion } + { the second param is always longint } + p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,s32bitdef); + { check the type conversion } + firstpass(p^.left^.right^.left); + + { need we an additional register ? } + if not(is_constintnode(p^.left^.right^.left)) and + (p^.left^.right^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and + (p^.left^.right^.left^.registers32<=1) then + inc(p^.registers32); + + { do we need an additional register to restore the first parameter? } + if p^.left^.right^.left^.registers32>=p^.registers32 then + inc(p^.registers32); + + if assigned(p^.left^.right^.right) then + CGMessage(cg_e_illegal_expression); + end; + end + else + CGMessage(type_e_ordinal_expr_expected); + end + else + CGMessage(type_e_mismatch); + end; + + in_read_x, + in_readln_x, + in_write_x, + in_writeln_x : + begin + { needs a call } + procinfo^.flags:=procinfo^.flags or pi_do_call; + p^.resulttype:=voiddef; + { true, if readln needs an extra register } + extra_register:=false; + { we must know if it is a typed file or not } + { but we must first do the firstpass for it } + file_is_typed:=false; + if assigned(p^.left) then + begin + dowrite:=(p^.inlinenumber in [in_write_x,in_writeln_x]); + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,dowrite); + { now we can check } + hp:=p^.left; + while assigned(hp^.right) do + hp:=hp^.right; + { if resulttype is not assigned, then automatically } + { file is not typed. } + if assigned(hp) and assigned(hp^.resulttype) then + Begin + if (hp^.resulttype^.deftype=filedef) then + if (pfiledef(hp^.resulttype)^.filetyp=ft_untyped) then + begin + if (p^.inlinenumber in [in_readln_x,in_writeln_x]) then + CGMessage(type_e_no_readln_writeln_for_typed_file) + else + CGMessage(type_e_no_read_write_for_untyped_file); + end + else if (pfiledef(hp^.resulttype)^.filetyp=ft_typed) then + begin + file_is_typed:=true; + { test the type } + if (p^.inlinenumber in [in_readln_x,in_writeln_x]) then + CGMessage(type_e_no_readln_writeln_for_typed_file); + hpp:=p^.left; + while (hpp<>hp) do + begin + if (hpp^.left^.treetype=typen) then + CGMessage(type_e_cant_read_write_type); + if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typedfiletype.def) then + CGMessage(type_e_mismatch); + { generate the high() value for the shortstring } + if ((not dowrite) and is_shortstring(hpp^.left^.resulttype)) or + (is_chararray(hpp^.left^.resulttype)) then + gen_high_tree(hpp,true); + { read(ln) is call by reference (JM) } + if not dowrite then + make_not_regable(hpp^.left); + hpp:=hpp^.right; + end; + end; + end; { endif assigned(hp) } + + { insert type conversions for write(ln) } + if (not file_is_typed) then + begin + hp:=p^.left; + while assigned(hp) do + begin + incrementregisterpushed($ff); + if (hp^.left^.treetype=typen) then + CGMessage(type_e_cant_read_write_type); + if assigned(hp^.left^.resulttype) then + begin + isreal:=false; + { support writeln(procvar) } + if (hp^.left^.resulttype^.deftype=procvardef) then + begin + p1:=gencallnode(nil,nil); + p1^.right:=hp^.left; + p1^.resulttype:=pprocvardef(hp^.left^.resulttype)^.rettype.def; + firstpass(p1); + hp^.left:=p1; + end; + case hp^.left^.resulttype^.deftype of + filedef : + begin + { only allowed as first parameter } + if assigned(hp^.right) then + CGMessage(type_e_cant_read_write_type); + end; + stringdef : + begin + { generate the high() value for the shortstring } + if (not dowrite) and + is_shortstring(hp^.left^.resulttype) then + gen_high_tree(hp,true); + end; + pointerdef : + begin + if not is_pchar(hp^.left^.resulttype) then + CGMessage(type_e_cant_read_write_type); + end; + floatdef : + begin + isreal:=true; + end; + orddef : + begin + case porddef(hp^.left^.resulttype)^.typ of + uchar, + u32bit,s32bit, + u64bit,s64bit: + ; + u8bit,s8bit, + u16bit,s16bit : + if dowrite then + hp^.left:=gentypeconvnode(hp^.left,s32bitdef); + bool8bit, + bool16bit, + bool32bit : + if dowrite then + hp^.left:=gentypeconvnode(hp^.left,booldef) + else + CGMessage(type_e_cant_read_write_type); + else + CGMessage(type_e_cant_read_write_type); + end; + if not(dowrite) and + not(is_64bitint(hp^.left^.resulttype)) then + extra_register:=true; + end; + arraydef : + begin + if is_chararray(hp^.left^.resulttype) then + gen_high_tree(hp,true) + else + CGMessage(type_e_cant_read_write_type); + end; + else + CGMessage(type_e_cant_read_write_type); + end; + + { some format options ? } + if hp^.is_colon_para then + begin + if hp^.right^.is_colon_para then + begin + frac_para:=hp; + length_para:=hp^.right; + hp:=hp^.right; + hpp:=hp^.right; + end + else + begin + length_para:=hp; + frac_para:=nil; + hpp:=hp^.right; + end; + { can be nil if you use "write(e:0:6)" while e is undeclared (JM) } + if assigned(hpp^.left^.resulttype) then + isreal:=(hpp^.left^.resulttype^.deftype=floatdef) + else exit; + if (not is_integer(length_para^.left^.resulttype)) then + CGMessage1(type_e_integer_expr_expected,length_para^.left^.resulttype^.typename) + else + length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef); + if assigned(frac_para) then + begin + if isreal then + begin + if (not is_integer(frac_para^.left^.resulttype)) then + CGMessage1(type_e_integer_expr_expected,frac_para^.left^.resulttype^.typename) + else + frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef); + end + else + CGMessage(parser_e_illegal_colon_qualifier); + end; + { do the checking for the colon'd arg } + hp:=length_para; + end; + end; + hp:=hp^.right; + end; + end; + { pass all parameters again for the typeconversions } + if codegenerror then + exit; + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,true); + { calc registers } + left_right_max(p); + if extra_register then + inc(p^.registers32); + end; + end; + + in_settextbuf_file_x : + begin + { warning here p^.left is the callparannode + not the argument directly } + { p^.left^.left is text var } + { p^.left^.right^.left is the buffer var } + { firstcallparan(p^.left,nil); + already done in firstcalln } + { now we know the type of buffer } + getsymonlyin(systemunit,'SETTEXTBUF'); + hp:=gencallnode(pprocsym(srsym),systemunit); + hp^.left:=gencallparanode( + genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left); + putnode(p); + p:=hp; + firstpass(p); + end; + + { the firstpass of the arg has been done in firstcalln ? } + in_reset_typedfile, + in_rewrite_typedfile : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + firstpass(p^.left); + set_varstate(p^.left,true); + p^.resulttype:=voiddef; + end; + + in_str_x_string : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + p^.resulttype:=voiddef; + { check the amount of parameters } + if not(assigned(p^.left)) or + not(assigned(p^.left^.right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + { first pass just the string for first local use } + hp:=p^.left^.right; + p^.left^.right:=nil; + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,false); + { remove warning when result is passed } + set_funcret_is_valid(p^.left^.left); + p^.left^.right:=hp; + firstcallparan(p^.left^.right,nil,true); + set_varstate(p^.left^.right,true); + hp:=p^.left; + { valid string ? } + if not assigned(hp) or + (hp^.left^.resulttype^.deftype<>stringdef) or + (hp^.right=nil) then + CGMessage(cg_e_illegal_expression); + { we need a var parameter } + valid_for_assign(hp^.left,false); + { generate the high() value for the shortstring } + if is_shortstring(hp^.left^.resulttype) then + gen_high_tree(hp,true); + + { !!!! check length of string } + + while assigned(hp^.right) do + hp:=hp^.right; + { check and convert the first param } + if hp^.is_colon_para then + CGMessage(cg_e_illegal_expression); + + isreal:=false; + case hp^.resulttype^.deftype of + orddef : + begin + case porddef(hp^.left^.resulttype)^.typ of + u32bit,s32bit, + s64bit,u64bit: + ; + u8bit,s8bit, + u16bit,s16bit: + hp^.left:=gentypeconvnode(hp^.left,s32bitdef); + else + CGMessage(type_e_integer_or_real_expr_expected); + end; + end; + floatdef : + begin + isreal:=true; + end; + else + CGMessage(type_e_integer_or_real_expr_expected); + end; + + { some format options ? } + hpp:=p^.left^.right; + if assigned(hpp) and hpp^.is_colon_para then + begin + firstpass(hpp^.left); + set_varstate(hpp^.left,true); + if (not is_integer(hpp^.left^.resulttype)) then + CGMessage1(type_e_integer_expr_expected,hpp^.left^.resulttype^.typename) + else + hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef); + hpp:=hpp^.right; + if assigned(hpp) and hpp^.is_colon_para then + begin + if isreal then + begin + if (not is_integer(hpp^.left^.resulttype)) then + CGMessage1(type_e_integer_expr_expected,hpp^.left^.resulttype^.typename) + else + begin + firstpass(hpp^.left); + set_varstate(hpp^.left,true); + hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef); + end; + end + else + CGMessage(parser_e_illegal_colon_qualifier); + end; + end; + + { pass all parameters again for the typeconversions } + if codegenerror then + exit; + firstcallparan(p^.left,nil,true); + { calc registers } + left_right_max(p); + end; + + in_val_x : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + p^.resulttype:=voiddef; + { check the amount of parameters } + if not(assigned(p^.left)) or + not(assigned(p^.left^.right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + If Assigned(p^.left^.right^.right) Then + {there is a "code" parameter} + Begin + { first pass just the code parameter for first local use} + hp := p^.left^.right; + p^.left^.right := nil; + make_not_regable(p^.left^.left); + firstcallparan(p^.left, nil,true); + set_varstate(p^.left,false); + if codegenerror then exit; + p^.left^.right := hp; + {code has to be a var parameter} + if valid_for_assign(p^.left^.left,false) then + begin + if (p^.left^.left^.resulttype^.deftype <> orddef) or + not(porddef(p^.left^.left^.resulttype)^.typ in + [u16bit,s16bit,u32bit,s32bit]) then + CGMessage(type_e_mismatch); + end; + hpp := p^.left^.right + End + Else hpp := p^.left; + {now hpp = the destination value tree} + { first pass just the destination parameter for first local use} + hp:=hpp^.right; + hpp^.right:=nil; + {hpp = destination} + make_not_regable(hpp^.left); + firstcallparan(hpp,nil,true); + set_varstate(hpp,false); + + if codegenerror then + exit; + { remove warning when result is passed } + set_funcret_is_valid(hpp^.left); + hpp^.right := hp; + if valid_for_assign(hpp^.left,false) then + begin + If Not((hpp^.left^.resulttype^.deftype = floatdef) or + ((hpp^.left^.resulttype^.deftype = orddef) And + (POrdDef(hpp^.left^.resulttype)^.typ in + [u32bit,s32bit, + u8bit,s8bit,u16bit,s16bit,s64bit,u64bit]))) Then + CGMessage(type_e_mismatch); + end; + {hp = source (String)} + { count_ref := false; WHY ?? } + firstcallparan(hp,nil,true); + set_varstate(hp,true); + if codegenerror then + exit; + { if not a stringdef then insert a type conv which + does the other type checking } + If (hp^.left^.resulttype^.deftype<>stringdef) then + begin + hp^.left:=gentypeconvnode(hp^.left,cshortstringdef); + firstpass(hp); + end; + { calc registers } + left_right_max(p); + + { val doesn't calculate the registers really } + { correct, we need one register extra (FK) } + if is_64bitint(hpp^.left^.resulttype) then + inc(p^.registers32,2) + else + inc(p^.registers32,1); + end; + + in_include_x_y, + in_exclude_x_y: + begin + p^.resulttype:=voiddef; + if assigned(p^.left) then + begin + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,true); + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + { remove warning when result is passed } + set_funcret_is_valid(p^.left^.left); + { first param must be var } + valid_for_assign(p^.left^.left,false); + { check type } + if (p^.left^.resulttype^.deftype=setdef) then + begin + { two paras ? } + if assigned(p^.left^.right) then + begin + { insert a type conversion } + { to the type of the set elements } + p^.left^.right^.left:=gentypeconvnode( + p^.left^.right^.left, + psetdef(p^.left^.resulttype)^.elementtype.def); + { check the type conversion } + firstpass(p^.left^.right^.left); + { only three parameters are allowed } + if assigned(p^.left^.right^.right) then + CGMessage(cg_e_illegal_expression); + end; + end + else + CGMessage(type_e_mismatch); + end + else + CGMessage(type_e_mismatch); + end; + + in_low_x, + in_high_x: + begin + set_varstate(p^.left,false); + { this fixes tests\webtbs\tbug879.pp (FK) + if p^.left^.treetype in [typen,loadn,subscriptn] then + begin + } + case p^.left^.resulttype^.deftype of + orddef,enumdef: + begin + do_lowhigh(p^.left^.resulttype); + firstpass(p); + end; + setdef: + begin + do_lowhigh(Psetdef(p^.left^.resulttype)^.elementtype.def); + firstpass(p); + end; + arraydef: + begin + if p^.inlinenumber=in_low_x then + begin + hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange, + Parraydef(p^.left^.resulttype)^.rangetype.def); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + if is_open_array(p^.left^.resulttype) or + is_array_of_const(p^.left^.resulttype) then + begin + getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); + hp:=genloadnode(pvarsym(srsym),p^.left^.symtable); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange, + Parraydef(p^.left^.resulttype)^.rangetype.def); + disposetree(p); + p:=hp; + firstpass(p); + end; + end; + end; + stringdef: + begin + if p^.inlinenumber=in_low_x then + begin + hp:=genordinalconstnode(0,u8bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + if is_open_string(p^.left^.resulttype) then + begin + getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name); + hp:=genloadnode(pvarsym(srsym),p^.left^.symtable); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end; + end; + end; + else + CGMessage(type_e_mismatch); + end; + { + end + else + CGMessage(type_e_varid_or_typeid_expected); + } + end; + + in_cos_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + setconstrealvalue(cos(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sin_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + setconstrealvalue(sin(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_arctan_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + setconstrealvalue(arctan(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_pi: + if block_type=bt_const then + setconstrealvalue(pi) + else + begin + p^.location.loc:=LOC_FPU; + p^.resulttype:=s80floatdef; + end; + + in_abs_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + setconstrealvalue(abs(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sqr_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + setconstrealvalue(sqr(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sqrt_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<0.0 then + begin + CGMessage(type_e_wrong_math_argument); + setconstrealvalue(0); + end + else + setconstrealvalue(sqrt(vr)); + end + else + handleextendedfunction; + end; + + in_ln_extended: + begin + if p^.left^.treetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<=0.0 then + begin + CGMessage(type_e_wrong_math_argument); + setconstrealvalue(0); + end + else + setconstrealvalue(ln(vr)); + end + else + handleextendedfunction; + end; + +{$ifdef SUPPORT_MMX} + in_mmx_pcmpeqb..in_mmx_pcmpgtw: + begin + end; +{$endif SUPPORT_MMX} + in_assert_x_y : + begin + p^.resulttype:=voiddef; + if assigned(p^.left) then + begin + firstcallparan(p^.left,nil,true); + set_varstate(p^.left,true); + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + { check type } + if is_boolean(p^.left^.resulttype) then + begin + { must always be a string } + p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,cshortstringdef); + firstpass(p^.left^.right^.left); + end + else + CGMessage(type_e_mismatch); + end + else + CGMessage(type_e_mismatch); + { We've checked the whole statement for correctness, now we + can remove it if assertions are off } + if not(cs_do_assertion in aktlocalswitches) then + begin + disposetree(p^.left); + putnode(p); + { we need a valid node, so insert a nothingn } + p:=genzeronode(nothingn); + end; + end; + + else + internalerror(8); + end; + end; + { generate an error if no resulttype is set } + if not assigned(p^.resulttype) then + p^.resulttype:=generrordef; + dec(parsing_para_level); + end; +{$ifdef fpc} +{$maxfpuregisters default} +{$endif fpc} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.73 2000/04/02 18:30:12 florian + * fixed another problem with readln(); + * the register allocator takes now care of necessary pushes/pops for + readln/writeln + + Revision 1.72 2000/03/27 09:42:50 pierre + + add error if trying to use readln or writeln for files + or read or write on untyped files. + Reset and rewrite are still incompatible with BP + (reset(dat,1); is allowed for typed file !) + + Revision 1.71 2000/03/22 17:34:53 jonas + * fix for webbug 886 + + Revision 1.70 2000/03/21 09:12:40 florian + * fixed bug 879: high and low take now any kind of expression + + Revision 1.69 2000/02/18 13:52:38 jonas + * fixed crash when using undeclared variable in ord construct + + Revision 1.68 2000/02/17 15:39:29 jonas + * fixed crashing bug when trying to write an undefined fp var with + formatting parameters + + Revision 1.67 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.66 2000/02/13 14:21:51 jonas + * modifications to make the compiler functional when compiled with + -Or + + Revision 1.65 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.64 2000/01/07 01:14:45 peter + * updated copyright to 2000 + + Revision 1.63 1999/12/30 15:02:10 peter + * fixed crash with undefined variable + + Revision 1.62 1999/12/02 12:38:45 florian + + added support for succ/pred() + + Revision 1.61 1999/11/30 10:40:58 peter + + ttype, tsymlist + + Revision 1.60 1999/11/18 15:34:49 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.59 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.58 1999/11/06 14:34:30 peter + * truncated log to 20 revs + + Revision 1.57 1999/10/29 15:28:51 peter + * fixed assert, the tree is now disposed in firstpass if assertions + are off. + + Revision 1.56 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.55 1999/10/22 14:37:31 peter + * error when properties are passed to var parameters + + Revision 1.54 1999/10/21 16:41:41 florian + * problems with readln fixed: esi wasn't restored correctly when + reading ordinal fields of objects futher the register allocation + didn't take care of the extra register when reading ordinal values + * enumerations can now be used in constant indexes of properties + + Revision 1.53 1999/09/28 20:48:27 florian + * fixed bug 610 + + added $D- for TP in symtable.pas else it can't be compiled anymore + (too much symbols :() + + Revision 1.52 1999/09/27 23:45:01 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.51 1999/09/15 20:35:46 florian + * small fix to operator overloading when in MMX mode + + the compiler uses now fldz and fld1 if possible + + some fixes to floating point registers + + some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined + * .... ??? + + Revision 1.50 1999/09/07 14:05:11 pierre + * halt removed in do_lowhigh + + Revision 1.49 1999/08/28 15:34:21 florian + * bug 519 fixed + + Revision 1.48 1999/08/23 23:41:04 pierre + * in_inc_x register allocation corrected + + Revision 1.47 1999/08/06 12:43:13 jonas + * fix for regvars with the val code + + Revision 1.46 1999/08/05 16:53:23 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.45 1999/08/04 00:23:40 florian + * renamed i386asm and i386base to cpuasm and cpubase + +} \ No newline at end of file diff --git a/befpc/compiler/tcld.pas b/befpc/compiler/tcld.pas new file mode 100644 index 0000000..8f5687e --- /dev/null +++ b/befpc/compiler/tcld.pas @@ -0,0 +1,612 @@ +{ + $Id: tcld.pas,v 1.1.1.1 2001-07-23 17:17:18 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for load/assignment nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcld; +interface + + uses + tree; + + procedure firstload(var p : ptree); + procedure firstassignment(var p : ptree); + procedure firstfuncret(var p : ptree); + procedure firstarrayconstructrange(var p:ptree); + procedure firstarrayconstruct(var p : ptree); + procedure firsttype(var p : ptree); + + +implementation + + uses + cobjects,verbose,globtype,globals,systems, + symconst,symtable,aasm,types, + htypechk,pass_1, + tccnv,cpubase +{$ifdef newcg} + ,cgbase + ,tgobj + ,tgcpu +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$endif newcg} + ; + +{***************************************************************************** + FirstLoad +*****************************************************************************} + + procedure firstload(var p : ptree); + var + p1 : ptree; + + begin + if (p^.symtable^.symtabletype=withsymtable) and + (pwithsymtable(p^.symtable)^.direct_with) and + (p^.symtableentry^.typ=varsym) then + begin + p1:=getcopy(ptree(pwithsymtable(p^.symtable)^.withrefnode)); + p1:=gensubscriptnode(pvarsym(p^.symtableentry),p1); + putnode(p); + p:=p1; + firstpass(p); + exit; + end; + + p^.location.loc:=LOC_REFERENCE; + p^.registers32:=0; + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + if p^.symtableentry^.typ=funcretsym then + begin + p1:=genzeronode(funcretn); + p1^.funcretprocinfo:=pprocinfo(pfuncretsym(p^.symtableentry)^.funcretprocinfo); + p1^.rettype:=pfuncretsym(p^.symtableentry)^.rettype; + firstpass(p1); + putnode(p); + p:=p1; + exit; + end; + if p^.symtableentry^.typ=absolutesym then + begin + p^.resulttype:=pabsolutesym(p^.symtableentry)^.vartype.def; + if pabsolutesym(p^.symtableentry)^.abstyp=tovar then + p^.symtableentry:=pabsolutesym(p^.symtableentry)^.ref; + p^.symtable:=p^.symtableentry^.owner; + p^.is_absolute:=true; + end; + case p^.symtableentry^.typ of + absolutesym :; + constsym: + begin + if pconstsym(p^.symtableentry)^.consttyp=constresourcestring then + begin + p^.resulttype:=cansistringdef; + { we use ansistrings so no fast exit here } + if assigned(procinfo) then + procinfo^.no_fast_exit:=true; + p^.location.loc:=LOC_MEM; + end + else + internalerror(22799); + end; + varsym : + begin + if not(p^.is_absolute) and (p^.resulttype=nil) then + p^.resulttype:=pvarsym(p^.symtableentry)^.vartype.def; + if (p^.symtable^.symtabletype in [parasymtable,localsymtable]) and + (lexlevel>p^.symtable^.symtablelevel) then + begin + { if the variable is in an other stackframe then we need + a register to dereference } + if (p^.symtable^.symtablelevel)>0 then + begin + p^.registers32:=1; + { further, the variable can't be put into a register } + pvarsym(p^.symtableentry)^.varoptions:= + pvarsym(p^.symtableentry)^.varoptions-[vo_fpuregable,vo_regable]; + end; + end; + if (pvarsym(p^.symtableentry)^.varspez=vs_const) then + p^.location.loc:=LOC_MEM; + { we need a register for call by reference parameters } + if (pvarsym(p^.symtableentry)^.varspez=vs_var) or + ((pvarsym(p^.symtableentry)^.varspez=vs_const) and + push_addr_param(pvarsym(p^.symtableentry)^.vartype.def)) or + { call by value open arrays are also indirect addressed } + is_open_array(pvarsym(p^.symtableentry)^.vartype.def) then + p^.registers32:=1; + if p^.symtable^.symtabletype=withsymtable then + inc(p^.registers32); + + if ([vo_is_thread_var,vo_is_dll_var]*pvarsym(p^.symtableentry)^.varoptions)<>[] then + p^.registers32:=1; + { a class variable is a pointer !!! + yes, but we have to resolve the reference in an + appropriate tree node (FK) + + if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and + ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oo_is_class)<>0) then + p^.registers32:=1; + } + + { count variable references } + + { this will create problem with local var set by + under_procedures + if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym) + and ((pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst) + or (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst))) then } + if t_times<1 then + inc(pvarsym(p^.symtableentry)^.refs) + else + inc(pvarsym(p^.symtableentry)^.refs,t_times); + end; + typedconstsym : + if not p^.is_absolute then + p^.resulttype:=ptypedconstsym(p^.symtableentry)^.typedconsttype.def; + procsym : + begin + if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then + CGMessage(parser_e_no_overloaded_procvars); + p^.resulttype:=pprocsym(p^.symtableentry)^.definition; + { if the owner of the procsym is a object, } + { left must be set, if left isn't set } + { it can be only self } + { this code is only used in TP procvar mode } + if (m_tp_procvar in aktmodeswitches) and + not(assigned(p^.left)) and + (pprocsym(p^.symtableentry)^.owner^.symtabletype=objectsymtable) then + p^.left:=genselfnode(pobjectdef(p^.symtableentry^.owner^.defowner)); + { method pointer ? } + if assigned(p^.left) then + begin + firstpass(p^.left); + p^.registers32:=max(p^.registers32,p^.left^.registers32); + p^.registersfpu:=max(p^.registersfpu,p^.left^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.registersmmx,p^.left^.registersmmx); +{$endif SUPPORT_MMX} + end; + end; + else internalerror(3); + end; + end; + + +{***************************************************************************** + FirstAssignment +*****************************************************************************} + + procedure firstassignment(var p : ptree); +{$ifdef newoptimizations2} + var + hp : ptree; +{$endif newoptimizations2} + begin + { must be made unique } + set_unique(p^.left); + + { set we the function result? } + set_funcret_is_valid(p^.left); + + firstpass(p^.left); + set_varstate(p^.left,false); + if codegenerror then + exit; + + { assignements to open arrays aren't allowed } + if is_open_array(p^.left^.resulttype) then + CGMessage(type_e_mismatch); + + { test if we can avoid copying string to temp + as in s:=s+...; (PM) } +{$ifdef dummyi386} + if ((p^.right^.treetype=addn) or (p^.right^.treetype=subn)) and + equal_trees(p^.left,p^.right^.left) and + (ret_in_acc(p^.left^.resulttype)) and + (not cs_rangechecking in aktmoduleswitches^) then + begin + disposetree(p^.right^.left); + hp:=p^.right; + p^.right:=p^.right^.right; + if hp^.treetype=addn then + p^.assigntyp:=at_plus + else + p^.assigntyp:=at_minus; + putnode(hp); + end; + if p^.assigntyp<>at_normal then + begin + { for fpu type there is no faster way } + if is_fpu(p^.left^.resulttype) then + case p^.assigntyp of + at_plus : p^.right:=gennode(addn,getcopy(p^.left),p^.right); + at_minus : p^.right:=gennode(subn,getcopy(p^.left),p^.right); + at_star : p^.right:=gennode(muln,getcopy(p^.left),p^.right); + at_slash : p^.right:=gennode(slashn,getcopy(p^.left),p^.right); + end; + end; +{$endif i386} + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + { some string functions don't need conversion, so treat them separatly } + if is_shortstring(p^.left^.resulttype) and (assigned(p^.right^.resulttype)) then + begin + if not (is_shortstring(p^.right^.resulttype) or + is_ansistring(p^.right^.resulttype) or + is_char(p^.right^.resulttype)) then + begin + p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype); + firstpass(p^.right); + if codegenerror then + exit; + end; + { we call STRCOPY } + procinfo^.flags:=procinfo^.flags or pi_do_call; + { test for s:=s+anything ... } + { the problem is for + s:=s+s+s; + this is broken here !! } +{$ifdef newoptimizations2} + { the above is fixed now, but still problem with s := s + f(); if } + { f modifies s (bad programming, so only enable if uncertain } + { optimizations are on) (JM) } + if (cs_UncertainOpts in aktglobalswitches) then + begin + hp := p^.right; + while hp^.treetype=addn do hp:=hp^.left; + if equal_trees(p^.left,hp) and + not multiple_uses(p^.left,p^.right) then + begin + p^.concat_string:=true; + hp:=p^.right; + while hp^.treetype=addn do + begin + hp^.use_strconcat:=true; + hp:=hp^.left; + end; + end; + end; +{$endif newoptimizations2} + end + else + begin + p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype); + firstpass(p^.right); + if codegenerror then + exit; + end; + + { test if node can be assigned, properties are allowed } + valid_for_assign(p^.left,true); + + { check if local proc/func is assigned to procvar } + if p^.right^.resulttype^.deftype=procvardef then + test_local_to_procvar(pprocvardef(p^.right^.resulttype),p^.left^.resulttype); + + p^.resulttype:=voiddef; + { + p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); + p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); + } + p^.registers32:=p^.left^.registers32+p^.right^.registers32; + p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); +{$endif SUPPORT_MMX} + end; + + +{***************************************************************************** + FirstFuncRet +*****************************************************************************} + + procedure firstfuncret(var p : ptree); + begin + p^.resulttype:=p^.rettype.def; + p^.location.loc:=LOC_REFERENCE; + if ret_in_param(p^.rettype.def) or + (procinfo<>pprocinfo(p^.funcretprocinfo)) then + p^.registers32:=1; + end; + + +{***************************************************************************** + FirstArrayConstructRange +*****************************************************************************} + + procedure firstarrayconstructrange(var p:ptree); + begin + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + calcregisters(p,0,0,0); + p^.resulttype:=p^.left^.resulttype; + end; + + +{***************************************************************************** + FirstArrayConstruct +*****************************************************************************} + + procedure firstarrayconstruct(var p : ptree); + var + pd : pdef; + thp, + chp, + hp : ptree; + len : longint; + varia : boolean; + begin + { are we allowing array constructor? Then convert it to a set } + if not allow_array_constructor then + begin + arrayconstructor_to_set(p); + firstpass(p); + exit; + end; + { only pass left tree, right tree contains next construct if any } + pd:=p^.constructdef; + len:=0; + varia:=false; + if assigned(p^.left) then + begin + hp:=p; + while assigned(hp) do + begin + firstpass(hp^.left); + set_varstate(hp^.left,true); + if (not get_para_resulttype) and (not p^.novariaallowed) then + begin + case hp^.left^.resulttype^.deftype of + enumdef : + begin + hp^.left:=gentypeconvnode(hp^.left,s32bitdef); + firstpass(hp^.left); + end; + orddef : + begin + if is_integer(hp^.left^.resulttype) and + not(is_64bitint(hp^.left^.resulttype)) then + begin + hp^.left:=gentypeconvnode(hp^.left,s32bitdef); + firstpass(hp^.left); + end; + end; + floatdef : + begin + hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); + firstpass(hp^.left); + end; + stringdef : + begin + if p^.cargs then + begin + hp^.left:=gentypeconvnode(hp^.left,charpointerdef); + firstpass(hp^.left); + end; + end; + procvardef : + begin + hp^.left:=gentypeconvnode(hp^.left,voidpointerdef); + firstpass(hp^.left); + end; + pointerdef, + classrefdef, + objectdef : ; + else + CGMessagePos1(hp^.left^.fileinfo,type_e_wrong_type_in_array_constructor,hp^.left^.resulttype^.typename); + end; + end; + if (pd=nil) then + pd:=hp^.left^.resulttype + else + begin + if ((p^.novariaallowed) or (not varia)) and + (not is_equal(pd,hp^.left^.resulttype)) then + begin + { if both should be equal try inserting a conversion } + if p^.novariaallowed then + begin + hp^.left:=gentypeconvnode(hp^.left,pd); + firstpass(hp^.left); + end; + varia:=true; + end; + end; + inc(len); + hp:=hp^.right; + end; + { swap the tree for cargs } + if p^.cargs and (not p^.cargswap) then + begin + chp:=nil; + hp:=p; + while assigned(hp) do + begin + thp:=hp^.right; + hp^.right:=chp; + chp:=hp; + hp:=thp; + end; + p:=chp; + p^.cargs:=true; + p^.cargswap:=true; + end; + end; + calcregisters(p,0,0,0); + { looks a little bit dangerous to me } + { len-1 gives problems with is_open_array if len=0, } + { is_open_array checks now for isconstructor (FK) } + { if no type is set then we set the type to voiddef to overcome a + 0 addressing } + if not assigned(pd) then + pd:=voiddef; + { skip if already done ! (PM) } + if not assigned(p^.resulttype) or + (p^.resulttype^.deftype<>arraydef) or + not parraydef(p^.resulttype)^.IsConstructor or + (parraydef(p^.resulttype)^.lowrange<>0) or + (parraydef(p^.resulttype)^.highrange<>len-1) then + p^.resulttype:=new(parraydef,init(0,len-1,s32bitdef)); + parraydef(p^.resulttype)^.elementtype.def:=pd; + parraydef(p^.resulttype)^.IsConstructor:=true; + parraydef(p^.resulttype)^.IsVariant:=varia; + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + Type +*****************************************************************************} + + procedure firsttype(var p : ptree); + begin + { do nothing, p^.resulttype is already set } + end; + + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.67 2000/07/06 19:06:30 peter + * fixed crash with objects unit and -Sd mode + + Revision 1.66 2000/05/15 19:29:50 peter + * fixed crash with resourcestring in const + + Revision 1.65 2000/05/14 18:48:24 florian + + Int64/QWord stuff for array of const added + + Revision 1.64 2000/04/25 14:43:36 jonas + - disabled "string_var := string_var + ... " and "string_var + char_var" + optimizations (were only active with -dnewoptimizations) because of + several internal issues + + Revision 1.63 2000/04/23 21:04:09 jonas + * only enable string_concat optimization with uncertain optimizations, + because it gives wrong results with "s := s + f()" where s is a + string and f() is a call to a function that modifies s + + Revision 1.62 2000/04/08 16:22:11 jonas + * fixed concat_string optimization and enabled it when + -dnewoptimizations is used + + Revision 1.61 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.60 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.59 2000/02/09 13:23:07 peter + * log truncated + + Revision 1.58 2000/01/21 22:06:16 florian + * fixed for the fix of bug 793 + * fpu variables modified by nested subroutines aren't regable anymore + * $maxfpuregisters doesn't modify anymore the behavior of a procedure before + + Revision 1.57 2000/01/07 01:14:46 peter + * updated copyright to 2000 + + Revision 1.56 2000/01/06 01:08:59 pierre + * fix for web bug 776 + + Revision 1.55 1999/12/31 14:26:27 peter + * fixed crash with empty array constructors + + Revision 1.54 1999/12/09 23:18:05 pierre + * no_fast_exit if procedure contains implicit termination code + + Revision 1.53 1999/12/02 17:28:53 peter + * fixed procvar -> pointer for array of const + + Revision 1.52 1999/11/30 10:40:58 peter + + ttype, tsymlist + + Revision 1.51 1999/11/18 15:34:50 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.50 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.49 1999/11/06 14:34:30 peter + * truncated log to 20 revs + + Revision 1.48 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.47 1999/10/13 10:35:27 peter + * var must match exactly error msg extended with got and expected type + * array constructor type check now gives error on wrong types + + Revision 1.46 1999/09/27 23:45:01 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.45 1999/09/17 17:14:12 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.44 1999/09/11 19:47:26 florian + * bug fix for @tobject.method, fixes bug 557, 605 and 606 + + Revision 1.43 1999/09/11 09:08:34 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.42 1999/09/10 18:48:11 florian + * some bug fixes (e.g. must_be_valid and procinfo^.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.41 1999/08/16 23:23:41 peter + * arrayconstructor -> openarray type conversions for element types + + Revision 1.40 1999/08/13 21:33:17 peter + * support for array constructors extended and more error checking + + Revision 1.39 1999/08/05 16:53:24 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + +} diff --git a/befpc/compiler/tcmat.pas b/befpc/compiler/tcmat.pas new file mode 100644 index 0000000..a6cfbd1 --- /dev/null +++ b/befpc/compiler/tcmat.pas @@ -0,0 +1,535 @@ +{ + $Id: tcmat.pas,v 1.1.1.1 2001-07-23 17:17:18 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for math nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcmat; +interface + + uses + tree; + + procedure firstmoddiv(var p : ptree); + procedure firstshlshr(var p : ptree); + procedure firstunaryminus(var p : ptree); + procedure firstnot(var p : ptree); + + +implementation + + uses + globtype,systems,tokens, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + htypechk,pass_1,cpubase, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen, +{$endif newcg} + { for isbinaryoverloaded function } + tcadd; + +{***************************************************************************** + FirstModDiv +*****************************************************************************} + + procedure firstmoddiv(var p : ptree); + var + t : ptree; + rv,lv : longint; + rd,ld : pdef; + + begin + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + if isbinaryoverloaded(p) then + exit; + + { check for division by zero } + rv:=p^.right^.value; + lv:=p^.left^.value; + if is_constintnode(p^.right) and (rv=0) then + begin + Message(parser_e_division_by_zero); + { recover } + rv:=1; + end; + + if is_constintnode(p^.left) and is_constintnode(p^.right) then + begin + case p^.treetype of + modn : t:=genordinalconstnode(lv mod rv,s32bitdef); + divn : t:=genordinalconstnode(lv div rv,s32bitdef); + end; + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + if (p^.left^.resulttype^.deftype=orddef) and (p^.right^.resulttype^.deftype=orddef) and + (is_64bitint(p^.left^.resulttype) or is_64bitint(p^.right^.resulttype)) then + begin + rd:=p^.right^.resulttype; + ld:=p^.left^.resulttype; + if (porddef(rd)^.typ=s64bit) or (porddef(ld)^.typ=s64bit) then + begin + if (porddef(ld)^.typ<>s64bit) then + begin + p^.left:=gentypeconvnode(p^.left,cs64bitdef); + firstpass(p^.left); + end; + if (porddef(rd)^.typ<>s64bit) then + begin + p^.right:=gentypeconvnode(p^.right,cs64bitdef); + firstpass(p^.right); + end; + calcregisters(p,2,0,0); + end + else if (porddef(rd)^.typ=u64bit) or (porddef(ld)^.typ=u64bit) then + begin + if (porddef(ld)^.typ<>u64bit) then + begin + p^.left:=gentypeconvnode(p^.left,cu64bitdef); + firstpass(p^.left); + end; + if (porddef(rd)^.typ<>u64bit) then + begin + p^.right:=gentypeconvnode(p^.right,cu64bitdef); + firstpass(p^.right); + end; + calcregisters(p,2,0,0); + end; + p^.resulttype:=p^.left^.resulttype; + end + else + begin + if not(p^.right^.resulttype^.deftype=orddef) or + not(porddef(p^.right^.resulttype)^.typ in [s32bit,u32bit]) then + p^.right:=gentypeconvnode(p^.right,s32bitdef); + + if not(p^.left^.resulttype^.deftype=orddef) or + not(porddef(p^.left^.resulttype)^.typ in [s32bit,u32bit]) then + p^.left:=gentypeconvnode(p^.left,s32bitdef); + + firstpass(p^.left); + firstpass(p^.right); + +{$ifdef cardinalmulfix} +{ if we divide a u32bit by a positive constant, the result is also u32bit (JM) } + if (p^.left^.resulttype^.deftype = orddef) and + (p^.left^.resulttype^.deftype = orddef) then + begin + if (porddef(p^.left^.resulttype)^.typ = u32bit) and + is_constintnode(p^.right) and +{ (porddef(p^.right^.resulttype)^.typ <> u32bit) and} + (p^.right^.value > 0) then + begin + p^.right := gentypeconvnode(p^.right,u32bitdef); + firstpass(p^.right); + end; +{ adjust also the left resulttype if necessary } + if (porddef(p^.right^.resulttype)^.typ = u32bit) and + is_constintnode(p^.left) and + { (porddef(p^.left^.resulttype)^.typ <> u32bit) and} + (p^.left^.value > 0) then + begin + p^.left := gentypeconvnode(p^.left,u32bitdef); + firstpass(p^.left); + end; + end; +{$endif cardinalmulfix} + + { the resulttype depends on the right side, because the left becomes } + { always 64 bit } + p^.resulttype:=p^.right^.resulttype; + + if codegenerror then + exit; + + left_right_max(p); + if p^.left^.registers32<=p^.right^.registers32 then + inc(p^.registers32); + end; + p^.location.loc:=LOC_REGISTER; + end; + + +{***************************************************************************** + FirstShlShr +*****************************************************************************} + + procedure firstshlshr(var p : ptree); + var + t : ptree; + regs : longint; + begin + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + if isbinaryoverloaded(p) then + exit; + + if is_constintnode(p^.left) and is_constintnode(p^.right) then + begin + case p^.treetype of + shrn : t:=genordinalconstnode(p^.left^.value shr p^.right^.value,s32bitdef); + shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef); + end; + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + { 64 bit ints have their own shift handling } + if not(is_64bitint(p^.left^.resulttype)) then + begin + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + regs:=1; + p^.resulttype:=s32bitdef; + end + else + begin + p^.resulttype:=p^.left^.resulttype; + regs:=2; + end; + + p^.right:=gentypeconvnode(p^.right,s32bitdef); + firstpass(p^.right); + + if codegenerror then + exit; + + if (p^.right^.treetype<>ordconstn) then + inc(regs); + calcregisters(p,regs,0,0); + + p^.location.loc:=LOC_REGISTER; + end; + + +{***************************************************************************** + FirstUnaryMinus +*****************************************************************************} + + procedure firstunaryminus(var p : ptree); + var + t : ptree; + minusdef : pprocdef; + begin + firstpass(p^.left); + set_varstate(p^.left,true); + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + p^.resulttype:=p^.left^.resulttype; + if codegenerror then + exit; + if is_constintnode(p^.left) then + begin + t:=genordinalconstnode(-p^.left^.value,s32bitdef); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + { nasm can not cope with negativ reals !! } + if is_constrealnode(p^.left) +{$ifdef i386} + and not(aktoutputformat in [as_i386_nasmcoff,as_i386_nasmelf,as_i386_nasmobj]) +{$endif i386} + then + begin + t:=genrealconstnode(-p^.left^.value_real,bestrealdef^); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + if (p^.left^.resulttype^.deftype=floatdef) then + begin + if pfloatdef(p^.left^.resulttype)^.typ=f32bit then + begin + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.registers32<1) then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end + else + p^.location.loc:=LOC_FPU; + end +{$ifdef SUPPORT_MMX} + else if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(p^.left^.resulttype) then + begin + if (p^.left^.location.loc<>LOC_MMXREGISTER) and + (p^.registersmmx<1) then + p^.registersmmx:=1; + { if saturation is on, p^.left^.resulttype isn't + "mmx able" (FK) + if (cs_mmx_saturation in aktlocalswitches^) and + (porddef(parraydef(p^.resulttype)^.definition)^.typ in + [s32bit,u32bit]) then + CGMessage(type_e_mismatch); + } + end +{$endif SUPPORT_MMX} + else if is_64bitint(p^.left^.resulttype) then + begin + firstpass(p^.left); + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + p^.registers32:=p^.left^.registers32; + if codegenerror then + exit; + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.registers32<2) then + p^.registers32:=2; + p^.location.loc:=LOC_REGISTER; + p^.resulttype:=p^.left^.resulttype; + end + else if (p^.left^.resulttype^.deftype=orddef) then + begin + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + p^.registers32:=p^.left^.registers32; + if codegenerror then + exit; + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.registers32<1) then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + p^.resulttype:=p^.left^.resulttype; + end + else + begin + if assigned(overloaded_operators[_minus]) then + minusdef:=overloaded_operators[_minus]^.definition + else + minusdef:=nil; + while assigned(minusdef) do + begin + if is_equal(pparaitem(minusdef^.para^.first)^.paratype.def,p^.left^.resulttype) and + (pparaitem(minusdef^.para^.first)^.next=nil) then + begin + t:=gencallnode(overloaded_operators[_minus],nil); + t^.left:=gencallparanode(p^.left,nil); + putnode(p); + p:=t; + firstpass(p); + exit; + end; + minusdef:=minusdef^.nextoverloaded; + end; + CGMessage(type_e_mismatch); + end; + end; + + +{***************************************************************************** + FirstNot +*****************************************************************************} + + procedure firstnot(var p : ptree); + var + t : ptree; + notdef : pprocdef; + begin + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + + if (p^.left^.treetype=ordconstn) then + begin + if is_boolean(p^.left^.resulttype) then + t:=genordinalconstnode(byte(not(boolean(p^.left^.value))),p^.left^.resulttype) + else + t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + p^.resulttype:=p^.left^.resulttype; + p^.location.loc:=p^.left^.location.loc; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if is_boolean(p^.resulttype) then + begin + p^.registers32:=p^.left^.registers32; + if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + begin + p^.location.loc:=LOC_REGISTER; + if (p^.registers32<1) then + p^.registers32:=1; + end; + { before loading it into flags we need to load it into + a register thus 1 register is need PM } +{$ifdef i386} + if p^.left^.location.loc<>LOC_JUMP then + p^.location.loc:=LOC_FLAGS; +{$endif def i386} + end + else +{$ifdef SUPPORT_MMX} + if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(p^.left^.resulttype) then + begin + if (p^.left^.location.loc<>LOC_MMXREGISTER) and + (p^.registersmmx<1) then + p^.registersmmx:=1; + end + else +{$endif SUPPORT_MMX} + if is_64bitint(p^.left^.resulttype) then + begin + p^.registers32:=p^.left^.registers32; + if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + begin + p^.location.loc:=LOC_REGISTER; + if (p^.registers32<2) then + p^.registers32:=2; + end; + end + else if is_integer(p^.left^.resulttype) then + begin + p^.left:=gentypeconvnode(p^.left,s32bitdef); + firstpass(p^.left); + if codegenerror then + exit; + + p^.resulttype:=p^.left^.resulttype; + p^.registers32:=p^.left^.registers32; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.registers32<1) then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end + else + begin + if assigned(overloaded_operators[_op_not]) then + notdef:=overloaded_operators[_op_not]^.definition + else + notdef:=nil; + while assigned(notdef) do + begin + if is_equal(pparaitem(notdef^.para^.first)^.paratype.def,p^.left^.resulttype) and + (pparaitem(notdef^.para^.first)^.next=nil) then + begin + t:=gencallnode(overloaded_operators[_op_not],nil); + t^.left:=gencallparanode(p^.left,nil); + putnode(p); + p:=t; + firstpass(p); + exit; + end; + notdef:=notdef^.nextoverloaded; + end; + CGMessage(type_e_mismatch); + end; + + p^.registersfpu:=p^.left^.registersfpu; + end; + + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.31 2000/06/05 20:41:18 pierre + + support for NOT overloading + + unsupported overloaded operators generate errors + + Revision 1.30 2000/06/02 21:13:56 pierre + * use is_equal instead of direct def equality in unary minus overload + + Revision 1.29 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.28 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.27 2000/01/07 01:14:46 peter + * updated copyright to 2000 + + Revision 1.26 1999/12/11 18:53:31 jonas + * fixed type conversions of results of operations with cardinals + (between -dcardinalmulfix) + + Revision 1.25 1999/11/30 10:40:58 peter + + ttype, tsymlist + + Revision 1.24 1999/11/26 13:51:29 pierre + * fix for overloading of shr shl mod and div + + Revision 1.23 1999/11/18 15:34:50 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.22 1999/11/06 14:34:30 peter + * truncated log to 20 revs + + Revision 1.21 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.20 1999/08/23 23:37:01 pierre + * firstnot register counting error corrected + + Revision 1.19 1999/08/04 13:03:15 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.18 1999/08/04 00:23:43 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.17 1999/08/03 22:03:34 peter + * moved bitmask constants to sets + * some other type/const renamings + +} \ No newline at end of file diff --git a/befpc/compiler/tcmem.pas b/befpc/compiler/tcmem.pas new file mode 100644 index 0000000..1de786a --- /dev/null +++ b/befpc/compiler/tcmem.pas @@ -0,0 +1,737 @@ +{ + $Id: tcmem.pas,v 1.1.1.1 2001-07-23 17:17:18 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for memory related nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcmem; +interface + + uses + tree; + + procedure firstloadvmt(var p : ptree); + procedure firsthnew(var p : ptree); + procedure firstnew(var p : ptree); + procedure firsthdispose(var p : ptree); + procedure firstsimplenewdispose(var p : ptree); + procedure firstaddr(var p : ptree); + procedure firstdoubleaddr(var p : ptree); + procedure firstderef(var p : ptree); + procedure firstsubscript(var p : ptree); + procedure firstvec(var p : ptree); + procedure firstself(var p : ptree); + procedure firstwith(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + htypechk,pass_1,cpubase +{$ifdef newcg} + ,cgbase +{$else newcg} + ,hcodegen +{$endif newcg} + ; +{***************************************************************************** + FirstLoadVMT +*****************************************************************************} + + procedure firstloadvmt(var p : ptree); + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + +{***************************************************************************** + FirstHNew +*****************************************************************************} + + procedure firsthnew(var p : ptree); + begin + end; + + +{***************************************************************************** + FirstNewN +*****************************************************************************} + + procedure firstnew(var p : ptree); + begin + { Standardeinleitung } + if assigned(p^.left) then + firstpass(p^.left); + + if codegenerror then + exit; + if assigned(p^.left) then + begin + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + end; + { result type is already set } + procinfo^.flags:=procinfo^.flags or pi_do_call; + if assigned(p^.left) then + p^.location.loc:=LOC_REGISTER + else + p^.location.loc:=LOC_REFERENCE; + end; + + +{***************************************************************************** + FirstDispose +*****************************************************************************} + + procedure firsthdispose(var p : ptree); + begin + firstpass(p^.left); + + if codegenerror then + exit; + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if p^.registers32<1 then + p^.registers32:=1; + { + if p^.left^.location.loc<>LOC_REFERENCE then + CGMessage(cg_e_illegal_expression); + } + if p^.left^.location.loc=LOC_CREGISTER then + inc(p^.registers32); + p^.location.loc:=LOC_REFERENCE; + p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def; + end; + + +{***************************************************************************** + FirstSimpleNewDispose +*****************************************************************************} + + procedure firstsimplenewdispose(var p : ptree); + begin + { this cannot be in a register !! } + make_not_regable(p^.left); + + firstpass(p^.left); + if codegenerror then + exit; + + { check the type } + if p^.left^.resulttype=nil then + p^.left^.resulttype:=generrordef; + if (p^.left^.resulttype^.deftype<>pointerdef) then + CGMessage1(type_e_pointer_type_expected,p^.left^.resulttype^.typename); + + if (p^.left^.location.loc<>LOC_REFERENCE) {and + (p^.left^.location.loc<>LOC_CREGISTER)} then + CGMessage(cg_e_illegal_expression); + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + p^.resulttype:=voiddef; + procinfo^.flags:=procinfo^.flags or pi_do_call; + end; + + +{***************************************************************************** + FirstAddr +*****************************************************************************} + + procedure firstaddr(var p : ptree); + var + hp : ptree; + hp2 : pparaitem; + hp3 : pabstractprocdef; + begin + make_not_regable(p^.left); + if not(assigned(p^.resulttype)) then + begin + { tp @procvar support (type of @procvar is a void pointer) + Note: we need to leave the addrn in the tree, + else we can't see the difference between @procvar and procvar. + we set the procvarload flag so a secondpass does nothing for + this node (PFV) } + if (m_tp_procvar in aktmodeswitches) then + begin + hp:=p^.left; + case hp^.treetype of + calln : + begin + { is it a procvar? } + hp:=hp^.right; + if assigned(hp) then + begin + { remove calln node } + putnode(p^.left); + p^.left:=hp; + firstpass(hp); + p^.procvarload:=true; + end; + end; + loadn, + subscriptn, + typeconvn, + vecn, + derefn : + begin + firstpass(hp); + if codegenerror then + exit; + if hp^.resulttype^.deftype=procvardef then + begin + p^.procvarload:=true; + end; + end; + end; + end; + if p^.procvarload then + begin + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=p^.left^.location.loc; + p^.resulttype:=voidpointerdef; + exit; + end; + + { proc 2 procvar ? } + if p^.left^.treetype=calln then + begin + { generate a methodcallnode or proccallnode } + { we shouldn't convert things like @tcollection.load } + if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable) and + not(assigned(p^.left^.methodpointer) and (p^.left^.methodpointer^.treetype=typen)) then + begin + hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc, + getcopy(p^.left^.methodpointer)); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end + else + hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc); + + { result is a procedure variable } + { No, to be TP compatible, you must return a pointer to + the procedure that is stored in the procvar.} + if not(m_tp_procvar in aktmodeswitches) then + begin + p^.resulttype:=new(pprocvardef,init); + + { it could also be a procvar, not only pprocsym ! } + if p^.left^.symtableprocentry^.typ=varsym then + hp3:=pabstractprocdef(pvarsym(p^.left^.symtableentry)^.vartype.def) + else + hp3:=pabstractprocdef(pprocsym(p^.left^.symtableprocentry)^.definition); + + pprocvardef(p^.resulttype)^.proctypeoption:=hp3^.proctypeoption; + pprocvardef(p^.resulttype)^.proccalloptions:=hp3^.proccalloptions; + pprocvardef(p^.resulttype)^.procoptions:=hp3^.procoptions; + pprocvardef(p^.resulttype)^.rettype:=hp3^.rettype; + pprocvardef(p^.resulttype)^.symtablelevel:=hp3^.symtablelevel; + + { method ? then set the methodpointer flag } + if (hp3^.owner^.symtabletype=objectsymtable) and + (pobjectdef(hp3^.owner^.defowner)^.is_class) then +{$ifdef INCLUDEOK} + include(pprocvardef(p^.resulttype)^.procoptions,po_methodpointer); +{$else} + pprocvardef(p^.resulttype)^.procoptions:=pprocvardef(p^.resulttype)^.procoptions+[po_methodpointer]; +{$endif} + { we need to process the parameters reverse so they are inserted + in the correct right2left order (PFV) } + hp2:=pparaitem(hp3^.para^.last); + while assigned(hp2) do + begin + pprocvardef(p^.resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp); + hp2:=pparaitem(hp2^.previous); + end; + end + else + p^.resulttype:=voidpointerdef; + + disposetree(p^.left); + p^.left:=hp; + end + else + begin + firstpass(p^.left); + { what are we getting the address from an absolute sym? } + hp:=p^.left; + while assigned(hp) and (hp^.treetype in [vecn,derefn,subscriptn]) do + hp:=hp^.left; + if assigned(hp) and (hp^.treetype=loadn) and + ((hp^.symtableentry^.typ=absolutesym) and + pabsolutesym(hp^.symtableentry)^.absseg) then + begin + if not(cs_typed_addresses in aktlocalswitches) then + p^.resulttype:=voidfarpointerdef + else + p^.resulttype:=new(ppointerdef,initfardef(p^.left^.resulttype)); + end + else + begin + if not(cs_typed_addresses in aktlocalswitches) then + p^.resulttype:=voidpointerdef + else + p^.resulttype:=new(ppointerdef,initdef(p^.left^.resulttype)); + end; + end; + end; + firstpass(p^.left); + { this is like the function addr } + inc(parsing_para_level); + set_varstate(p^.left,false); + dec(parsing_para_level); + if codegenerror then + exit; + + { don't allow constants } + if is_constnode(p^.left) then + begin + aktfilepos:=p^.left^.fileinfo; + CGMessage(type_e_no_addr_of_constant); + end + else + begin + { we should allow loc_mem for @string } + if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then + begin + aktfilepos:=p^.left^.fileinfo; + CGMessage(cg_e_illegal_expression); + end; + end; + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if p^.registers32<1 then + p^.registers32:=1; + { is this right for object of methods ?? } + p^.location.loc:=LOC_REGISTER; + end; + + +{***************************************************************************** + FirstDoubleAddr +*****************************************************************************} + + procedure firstdoubleaddr(var p : ptree); + begin + make_not_regable(p^.left); + firstpass(p^.left); + inc(parsing_para_level); + set_varstate(p^.left,false); + dec(parsing_para_level); + if p^.resulttype=nil then + p^.resulttype:=voidpointerdef; + if codegenerror then + exit; + + if (p^.left^.resulttype^.deftype)<>procvardef then + CGMessage(cg_e_illegal_expression); + + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_illegal_expression); + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + +{***************************************************************************** + FirstDeRef +*****************************************************************************} + + procedure firstderef(var p : ptree); + begin + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + begin + p^.resulttype:=generrordef; + exit; + end; + + p^.registers32:=max(p^.left^.registers32,1); + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + + if p^.left^.resulttype^.deftype<>pointerdef then + CGMessage(cg_e_invalid_qualifier); + + p^.resulttype:=ppointerdef(p^.left^.resulttype)^.pointertype.def; + p^.location.loc:=LOC_REFERENCE; + end; + + +{***************************************************************************** + FirstSubScript +*****************************************************************************} + + procedure firstsubscript(var p : ptree); + begin + firstpass(p^.left); + if codegenerror then + begin + p^.resulttype:=generrordef; + exit; + end; + p^.resulttype:=p^.vs^.vartype.def; + + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + { classes must be dereferenced implicit } + if (p^.left^.resulttype^.deftype=objectdef) and + pobjectdef(p^.left^.resulttype)^.is_class then + begin + if p^.registers32=0 then + p^.registers32:=1; + p^.location.loc:=LOC_REFERENCE; + end + else + begin + if (p^.left^.location.loc<>LOC_MEM) and + (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_illegal_expression); + set_location(p^.location,p^.left^.location); + end; + end; + + +{***************************************************************************** + FirstVec +*****************************************************************************} + + procedure firstvec(var p : ptree); + var + harr : pdef; + ct : tconverttype; +{$ifdef consteval} + tcsym : ptypedconstsym; +{$endif} + begin + firstpass(p^.left); + firstpass(p^.right); + if codegenerror then + exit; + + { range check only for arrays } + if (p^.left^.resulttype^.deftype=arraydef) then + begin + if (isconvertable(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def, + ct,ordconstn,false)=0) and + not(is_equal(p^.right^.resulttype,parraydef(p^.left^.resulttype)^.rangetype.def)) then + CGMessage(type_e_mismatch); + end; + { Never convert a boolean or a char !} + { maybe type conversion } + if (p^.right^.resulttype^.deftype<>enumdef) and + not(is_char(p^.right^.resulttype)) and + not(is_boolean(p^.right^.resulttype)) then + begin + p^.right:=gentypeconvnode(p^.right,s32bitdef); + firstpass(p^.right); + if codegenerror then + exit; + end; + + { are we accessing a pointer[], then convert the pointer to + an array first } + if (p^.left^.resulttype^.deftype=pointerdef) then + begin + { convert pointer to array } + harr:=new(parraydef,init(0,$7fffffff,s32bitdef)); + parraydef(harr)^.elementtype.def:=ppointerdef(p^.left^.resulttype)^.pointertype.def; + p^.left:=gentypeconvnode(p^.left,harr); + firstpass(p^.left); + if codegenerror then + exit; + p^.resulttype:=parraydef(harr)^.elementtype.def + end; + + { determine return type } + if not assigned(p^.resulttype) then + if p^.left^.resulttype^.deftype=arraydef then + p^.resulttype:=parraydef(p^.left^.resulttype)^.elementtype.def + else if p^.left^.resulttype^.deftype=stringdef then + begin + { indexed access to strings } + case pstringdef(p^.left^.resulttype)^.string_typ of + { + st_widestring : p^.resulttype:=cwchardef; + } + st_ansistring : p^.resulttype:=cchardef; + st_longstring : p^.resulttype:=cchardef; + st_shortstring : p^.resulttype:=cchardef; + end; + end + else + CGMessage(type_e_mismatch); + { the register calculation is easy if a const index is used } + if p^.right^.treetype=ordconstn then + begin +{$ifdef consteval} + { constant evaluation } + if (p^.left^.treetype=loadn) and + (p^.left^.symtableentry^.typ=typedconstsym) then + begin + tcsym:=ptypedconstsym(p^.left^.symtableentry); + if tcsym^.defintion^.typ=stringdef then + begin + + end; + end; +{$endif} + p^.registers32:=p^.left^.registers32; + + { for ansi/wide strings, we need at least one register } + if is_ansistring(p^.left^.resulttype) or + is_widestring(p^.left^.resulttype) then + p^.registers32:=max(p^.registers32,1); + end + else + begin + { this rules are suboptimal, but they should give } + { good results } + p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); + + { for ansi/wide strings, we need at least one register } + if is_ansistring(p^.left^.resulttype) or + is_widestring(p^.left^.resulttype) then + p^.registers32:=max(p^.registers32,1); + + { need we an extra register when doing the restore ? } + if (p^.left^.registers32<=p^.right^.registers32) and + { only if the node needs less than 3 registers } + { two for the right node and one for the } + { left address } + (p^.registers32<3) then + inc(p^.registers32); + + { need we an extra register for the index ? } + if (p^.right^.location.loc<>LOC_REGISTER) + { only if the right node doesn't need a register } + and (p^.right^.registers32<1) then + inc(p^.registers32); + + { not correct, but what works better ? + if p^.left^.registers32>0 then + p^.registers32:=max(p^.registers32,2) + else + min. one register + p^.registers32:=max(p^.registers32,1); + } + end; + p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); +{$ifdef SUPPORT_MMX} + p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); +{$endif SUPPORT_MMX} + if p^.left^.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then + p^.location.loc:=LOC_REFERENCE + else + p^.location.loc:=LOC_MEM; + end; + + +{***************************************************************************** + FirstSelf +*****************************************************************************} + + procedure firstself(var p : ptree); + begin + if (p^.resulttype^.deftype=classrefdef) or + ((p^.resulttype^.deftype=objectdef) + and pobjectdef(p^.resulttype)^.is_class + ) then + p^.location.loc:=LOC_CREGISTER + else + p^.location.loc:=LOC_REFERENCE; + end; + + +{***************************************************************************** + FirstWithN +*****************************************************************************} + + procedure firstwith(var p : ptree); + var + symtable : pwithsymtable; + i : longint; + begin + if assigned(p^.left) and assigned(p^.right) then + begin + firstpass(p^.left); + { is this correct ? At least after is like if used + set_varstate(p^.left,false); + already done in _with_statment } + p^.left^.varstateset:=false; + set_varstate(p^.left,true); + if codegenerror then + exit; + symtable:=p^.withsymtable; + for i:=1 to p^.tablecount do + begin + if (p^.left^.treetype=loadn) and + (p^.left^.symtable=aktprocsym^.definition^.localst) then + symtable^.direct_with:=true; + symtable^.withnode:=p; + symtable:=pwithsymtable(symtable^.next); + end; + firstpass(p^.right); + if codegenerror then + exit; + + left_right_max(p); + p^.resulttype:=voiddef; + end + else + begin + { optimization } + disposetree(p); + p:=nil; + end; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.45 2000/04/08 09:30:01 peter + * fixed pointer->array conversion when resulttype was already set + + Revision 1.44 2000/03/23 16:29:32 jonas + * real fix for web bug882 + + Revision 1.43 2000/03/22 15:41:10 jonas + * fixed webbug 882 + + Revision 1.42 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.41 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.40 2000/01/10 16:38:43 pierre + * suppress wrong warning for with vars + + Revision 1.39 2000/01/10 00:42:44 pierre + * fix for bug 776 + + Revision 1.38 2000/01/07 09:36:24 pierre + * With argument is set as used to avoid unnecessary warnings + + Revision 1.37 2000/01/07 01:14:46 peter + * updated copyright to 2000 + + Revision 1.36 1999/11/30 10:40:58 peter + + ttype, tsymlist + + Revision 1.35 1999/11/29 22:36:48 florian + * problem with taking the address of abstract procedures fixed + + Revision 1.34 1999/11/18 15:34:51 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.33 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.32 1999/11/06 14:34:30 peter + * truncated log to 20 revs + + Revision 1.31 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.30 1999/10/13 10:40:55 peter + * subscript support for tp_procvar + + Revision 1.29 1999/09/27 23:45:02 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.28 1999/09/17 17:14:12 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.27 1999/09/11 11:10:39 florian + * fix of my previous commit, make cycle was broken + + Revision 1.26 1999/09/11 09:08:34 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.25 1999/08/23 23:34:15 pierre + * one more register needed if hnewn with CREGISTER + + Revision 1.24 1999/08/05 16:53:25 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + + Revision 1.23 1999/08/04 00:23:44 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.22 1999/08/03 22:03:35 peter + * moved bitmask constants to sets + * some other type/const renamings + +} diff --git a/befpc/compiler/tcset.pas b/befpc/compiler/tcset.pas new file mode 100644 index 0000000..578bc7f --- /dev/null +++ b/befpc/compiler/tcset.pas @@ -0,0 +1,357 @@ +{ + $Id: tcset.pas,v 1.1.1.1 2001-07-23 17:17:18 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for set/case nodes + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tcset; +interface + + uses + tree; + + procedure firstsetelement(var p : ptree); + procedure firstin(var p : ptree); + procedure firstrange(var p : ptree); + procedure firstcase(var p : ptree); + + +implementation + + uses + globtype,systems, + cobjects,verbose,globals, + symconst,symtable,aasm,types, + htypechk,pass_1, + tccnv,cpubase +{$ifdef newcg} + ,cgbase + ,tgcpu +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$ifdef m68k} + ,tgen68k +{$endif} +{$endif newcg} + ; + +{***************************************************************************** + FirstSetElement +*****************************************************************************} + + procedure firstsetelement(var p : ptree); + begin + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + + if assigned(p^.right) then + begin + firstpass(p^.right); + if codegenerror then + exit; + end; + + calcregisters(p,0,0,0); + p^.resulttype:=p^.left^.resulttype; + set_location(p^.location,p^.left^.location); + end; + + +{***************************************************************************** + FirstIn +*****************************************************************************} + + procedure firstin(var p : ptree); + type + byteset = set of byte; + var + t : ptree; + pst : pconstset; + + function createsetconst(psd : psetdef) : pconstset; + var + pcs : pconstset; + pes : penumsym; + i : longint; + begin + new(pcs); + case psd^.elementtype.def^.deftype of + enumdef : + begin + pes:=penumdef(psd^.elementtype.def)^.firstenum; + while assigned(pes) do + begin + pcs^[pes^.value div 8]:=pcs^[pes^.value div 8] or (1 shl (pes^.value mod 8)); + pes:=pes^.nextenum; + end; + end; + orddef : + begin + for i:=porddef(psd^.elementtype.def)^.low to porddef(psd^.elementtype.def)^.high do + begin + pcs^[i div 8]:=pcs^[i div 8] or (1 shl (i mod 8)); + end; + end; + end; + createsetconst:=pcs; + end; + + begin + p^.location.loc:=LOC_FLAGS; + p^.resulttype:=booldef; + + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + { Convert array constructor first to set } + if is_array_constructor(p^.right^.resulttype) then + begin + arrayconstructor_to_set(p^.right); + firstpass(p^.right); + if codegenerror then + exit; + end; + + { if p^.right is a typen then the def + is in typenodetype PM } + if p^.right^.treetype=typen then + p^.right^.resulttype:=p^.right^.typenodetype; + + if p^.right^.resulttype^.deftype<>setdef then + CGMessage(sym_e_set_expected); + if codegenerror then + exit; + + if (p^.right^.treetype=typen) then + begin + { we need to create a setconstn } + pst:=createsetconst(psetdef(p^.right^.typenodetype)); + t:=gensetconstnode(pst,psetdef(p^.right^.typenodetype)); + dispose(pst); + putnode(p^.right); + p^.right:=t; + end; + + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + + { empty set then return false } + if not assigned(psetdef(p^.right^.resulttype)^.elementtype.def) then + begin + t:=genordinalconstnode(0,booldef); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + + { type conversion/check } + p^.left:=gentypeconvnode(p^.left,psetdef(p^.right^.resulttype)^.elementtype.def); + firstpass(p^.left); + if codegenerror then + exit; + + { constant evaulation } + if (p^.left^.treetype=ordconstn) and (p^.right^.treetype=setconstn) then + begin + t:=genordinalconstnode(byte(p^.left^.value in byteset(p^.right^.value_set^)),booldef); + disposetree(p); + firstpass(t); + p:=t; + exit; + end; + + left_right_max(p); + { this is not allways true due to optimization } + { but if we don't set this we get problems with optimizing self code } + if psetdef(p^.right^.resulttype)^.settype<>smallset then + procinfo^.flags:=procinfo^.flags or pi_do_call + else + begin + { a smallset needs maybe an misc. register } + if (p^.left^.treetype<>ordconstn) and + not(p^.right^.location.loc in [LOC_CREGISTER,LOC_REGISTER]) and + (p^.right^.registers32<1) then + inc(p^.registers32); + end; + end; + + +{***************************************************************************** + FirstRange +*****************************************************************************} + + procedure firstrange(var p : ptree); + var + ct : tconverttype; + begin + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + { both types must be compatible } + if not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) and + (isconvertable(p^.left^.resulttype,p^.right^.resulttype,ct,ordconstn,false)=0) then + CGMessage(type_e_mismatch); + { Check if only when its a constant set } + if (p^.left^.treetype=ordconstn) and (p^.right^.treetype=ordconstn) then + begin + { upper limit must be greater or equal than lower limit } + { not if u32bit } + if (p^.left^.value>p^.right^.value) and + (( p^.left^.value<0) or (p^.right^.value>=0)) then + CGMessage(cg_e_upper_lower_than_lower); + end; + left_right_max(p); + p^.resulttype:=p^.left^.resulttype; + set_location(p^.location,p^.left^.location); + end; + + +{***************************************************************************** + FirstCase +*****************************************************************************} + + procedure firstcase(var p : ptree); + var + old_t_times : longint; + hp : ptree; + begin + { evalutes the case expression } +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif SUPPORT_MMX} + + { walk through all instructions } + + { estimates the repeat of each instruction } + old_t_times:=t_times; + if not(cs_littlesize in aktglobalswitches) then + begin + t_times:=t_times div case_count_labels(p^.nodes); + if t_times<1 then + t_times:=1; + end; + { first case } + hp:=p^.right; + while assigned(hp) do + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(hp^.right); + + { searchs max registers } + if hp^.right^.registers32>p^.registers32 then + p^.registers32:=hp^.right^.registers32; + if hp^.right^.registersfpu>p^.registersfpu then + p^.registersfpu:=hp^.right^.registersfpu; +{$ifdef SUPPORT_MMX} + if hp^.right^.registersmmx>p^.registersmmx then + p^.registersmmx:=hp^.right^.registersmmx; +{$endif SUPPORT_MMX} + + hp:=hp^.left; + end; + + { may be handle else tree } + if assigned(p^.elseblock) then + begin +{$ifdef newcg} + tg.cleartempgen; +{$else newcg} + cleartempgen; +{$endif newcg} + firstpass(p^.elseblock); + if codegenerror then + exit; + if p^.registers320 then + size:=size+(4-(size mod 4)); + { First check the tmpfreelist } + if assigned(tempfreelist) then + begin + { Check for a slot with the same size first } + hprev:=nil; + hp:=tempfreelist; + while assigned(hp) do + begin +{$ifdef EXTDEBUG} + if hp^.temptype<>tt_free then + Comment(V_Warning,'Temp in freelist is not set to tt_free'); +{$endif} + if hp^.size>=size then + begin + { Slot is the same size, then leave immediatly } + if hp^.size=size then + begin + bestprev:=hprev; + bestslot:=hp; + bestsize:=size; + break; + end + else + begin + if (bestsize=0) or (hp^.size 0 (PM) } + istemp:=((ref.base=procinfo^.framepointer) and +{$ifndef alpha} + (ref.index=R_NO) and +{$endif} + (ref.offsetallowtype then + begin + exit; + end; + exprasmlist^.concat(new(paitempalloc,dealloc(hp^.pos,hp^.size))); + { set this block to free } + hp^.temptype:=tt_free; + { Update tempfreelist } + if assigned(hprevfree) then + begin + { Connect with previous? } + if assigned(hprev) and (hprev^.temptype=tt_free) then + begin + inc(hprev^.size,hp^.size); + hprev^.next:=hp^.next; + dispose(hp); + hp:=hprev; + end + else + hprevfree^.nextfree:=hp; + end + else + begin + hp^.nextfree:=tempfreelist; + tempfreelist:=hp; + end; + { Next block free ? Yes, then concat } + hnext:=hp^.next; + if assigned(hnext) and (hnext^.temptype=tt_free) then + begin + inc(hp^.size,hnext^.size); + hp^.nextfree:=hnext^.nextfree; + hp^.next:=hnext^.next; + dispose(hnext); + end; + exit; + end; + if (hp^.temptype=tt_free) then + hprevfree:=hp; + hprev:=hp; + hp:=hp^.next; + end; + ungettemp:=tt_none; + end; + + + procedure ungetpersistanttemp(pos : longint); + begin +{$ifdef EXTDEBUG} + if ungettemp(pos,tt_persistant)<>tt_persistant then + Comment(V_Warning,'temp managment problem : ungetpersistanttemp()'+ + ' at pos '+tostr(pos)+ ' not found !'); +{$else} + ungettemp(pos,tt_persistant); +{$endif} + end; + + + procedure ungetiftemp(const ref : treference); +{$ifdef EXTDEBUG} + var + tt : ttemptype; +{$endif} + begin + if istemp(ref) then + begin + { first check if ansistring } + if ungetiftempansi(ref) then + exit; +{$ifndef EXTDEBUG} + ungettemp(ref.offset,tt_normal); +{$else} + tt:=ungettemp(ref.offset,tt_normal); + if tt=tt_persistant then + Comment(V_Debug,'temp at pos '+tostr(ref.offset)+ ' not released because persistant!'); + if tt=tt_none then + Comment(V_Warning,'temp not found for release at offset '+tostr(ref.offset)); +{$endif} + end; + end; + + + procedure inittemps; + begin + tempfreelist:=nil; + templist:=nil; + end; + +begin + InitTemps; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/05/23 13:55:27 pierre + Use a multiple of 4 to substract from stack pointer for locals and temps + + Revision 1.42 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.41 2000/01/07 01:14:47 peter + * updated copyright to 2000 + + Revision 1.40 1999/12/19 23:53:14 pierre + * problem with persistant temp fixed + + Revision 1.39 1999/12/01 12:42:33 peter + * fixed bug 698 + * removed some notes about unused vars + + Revision 1.38 1999/11/06 14:34:31 peter + * truncated log to 20 revs + + Revision 1.37 1999/09/27 23:45:02 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.36 1999/09/26 13:26:08 florian + * exception patch of Romio nevertheless the excpetion handling + needs some corections regarding register saving + * gettempansistring is again a procedure + + Revision 1.35 1999/09/16 11:34:59 pierre + * typo correction + + Revision 1.34 1999/08/04 00:23:46 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.33 1999/08/02 00:34:06 michael + * alpha has no index + +} \ No newline at end of file diff --git a/befpc/compiler/tgen68k.pas b/befpc/compiler/tgen68k.pas new file mode 100644 index 0000000..a1b4c2a --- /dev/null +++ b/befpc/compiler/tgen68k.pas @@ -0,0 +1,340 @@ +{ + $Id: tgen68k.pas,v 1.1.1.1 2001-07-23 17:17:19 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Carl Eric Codere + + This unit handles the temporary variables stuff for m68k + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tgen68k; + + interface + + uses + cobjects,globals,tree,hcodegen,verbose,files,aasm,cpubase; + + type + tregisterset = set of tregister; + tpushed = array[R_D0..R_A6] of boolean; + + const + { D2 to D5 usable as scratch registers } + usablereg32 : byte = 4; + { A2 to A4 usable as address registers } + usableaddress: byte = 3; + { FP2 to FP7 usable as FPU registers } + usablefloatreg : byte = 6; + + function getregister32 : tregister; + procedure ungetregister32(r : tregister); + { return a free 32-bit address register } + function getaddressreg: tregister; + + procedure ungetregister(r : tregister); + + procedure cleartempgen; + + function getfloatreg: tregister; + { returns a free floating point register } + { used in real, fpu mode, otherwise we } + { must use standard register allocation } + + procedure del_reference(const ref : treference); + procedure del_locref(const location : tlocation); + + + { pushs and restores registers } + procedure pushusedregisters(var pushed : tpushed;b : word); + procedure popusedregisters(const pushed : tpushed); + + procedure clearregistercount; + procedure resetusableregisters; + + var + unused,usableregs : tregisterset; + c_usableregs : longint; + + usedinproc : word; + + { count, how much a register must be pushed if it is used as register } + { variable } + reg_pushes : array[R_D0..R_A6] of longint; + is_reg_var : array[R_D0..R_A6] of boolean; + + implementation + + + function getusableaddr: byte; + { Since address registers are different then data registers } + { we check the unused register list to determine the number } + { of address registers which are available. } + var + i: byte; + Begin + i:=0; + if R_A2 in unused then + Inc(i); + if R_A3 in unused then + Inc(i); + if R_A4 in unused then + Inc(i); + getusableaddr:=i; + end; + + procedure pushusedregisters(var pushed : tpushed;b : word); + + var + r : tregister; + + begin + { the following registers can be pushed } + { D0, D1, D2, D3, D4, D5, D6, D7, A0 } + { A1, A2, A3, A4 } + for r:=R_D2 to R_A4 do + begin + pushed[r]:=false; + { if the register is used by the calling subroutine } + if ((b and ($800 shr word(r)))<>0) then + begin + { and is present in use } + if not(r in unused) then + begin + { then save it } + { then save it on the stack } + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,r,R_SPPUSH))); + { here was a big problem !!!!!} + { you cannot do that for a register that is + globally assigned to a var + this also means that you must push it much more + often, but there must be a better way + maybe by putting the value back to the stack !! } + if not(is_reg_var[r]) then + unused:=unused+[r]; + pushed[r]:=true; + end; + end; + end; + end; + + procedure popusedregisters(const pushed : tpushed); + + var + r : tregister; + + begin + for r:=R_A4 downto R_D2 do + if pushed[r] then + begin + exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_SPPULL,r))); + unused:=unused-[r]; + end; + end; + + procedure ungetregister(r : tregister); + + begin + ungetregister32(r) + end; + + + procedure del_reference(const ref : treference); + + begin + if ref.isintvalue then + exit; + ungetregister(ref.base); + ungetregister32(ref.index); + end; + + procedure del_locref(const location : tlocation); + + begin + if (location.loc<>loc_mem) and (location.loc<>loc_reference) then + exit; + if location.reference.isintvalue then + exit; + ungetregister(location.reference.base); + ungetregister32(location.reference.index); + end; + + procedure ungetregister32(r : tregister); + + begin + if r in [R_D2,R_D3,R_D4,R_D5,R_D7] then + begin + unused:=unused+[r]; + inc(usablereg32); + end + else + if r in [R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7] then + begin + unused:=unused+[r]; + inc(usablefloatreg); + end + else + if r in [R_A2,R_A3,R_A4] then + begin + unused:=unused+[r]; + inc(usableaddress); + end; + { other registers are RESERVED and should not be freed } + end; + + + function getfloatreg: tregister; + { returns a free floating point register } + { used in real, fpu mode, otherwise we } + { must use standard register allocation } + var + i:tregister; + begin + dec(usablefloatreg); + if usablefloatreg = 0 then + Message(cg_f_internal_error_in_getfloatreg); + for i:=R_FP2 to R_FP7 do + begin + if i in unused then + begin + unused := unused-[i]; + getfloatreg := i; + exit; + end; + end; + { if we are here, then there was an allocation failure } + Message(cg_f_internal_error_in_getfloatreg); + end; + + + function getaddressreg: tregister; + + begin + dec(usableaddress); + if R_A2 in unused then + begin + unused:=unused-[R_A2]; + usedinproc:=usedinproc or ($800 shr word(R_A2)); + getaddressreg:=R_A2; + end + else + if R_A3 in unused then + begin + unused:=unused-[R_A3]; + usedinproc:=usedinproc or ($800 shr word(R_A3)); + getaddressreg:=R_A3; + end + else + if R_A4 in unused then + begin + unused:=unused-[R_A4]; + usedinproc:=usedinproc or ($800 shr word(R_A4)); + getaddressreg:=R_A4; + end + else + begin + internalerror(10); + end; + + end; + + function getregister32 : tregister; + begin + dec(usablereg32); + if R_D2 in unused then + begin + unused:=unused-[R_D2]; + usedinproc:=usedinproc or ($800 shr word(R_D2)); + getregister32:=R_D2; + end + else if R_D3 in unused then + begin + unused:=unused-[R_D3]; + usedinproc:=usedinproc or ($800 shr word(R_D3)); + getregister32:=R_D3; + end + else if R_D4 in unused then + begin + unused:=unused-[R_D4]; + usedinproc:=usedinproc or ($800 shr word(R_D4)); + getregister32:=R_D4; + end + else if R_D5 in unused then + begin + unused:=unused-[R_D5]; + usedinproc:=usedinproc or ($800 shr word(R_D5)); + getregister32:=R_D5; + end + else if R_D7 in unused then + begin + unused:=unused-[R_D7]; + usedinproc:=usedinproc or ($800 shr word(R_D7)); + getregister32:=R_D7; + end + else + begin + internalerror(10); + end; + end; + + procedure cleartempgen; + + begin + unused:=usableregs; + usablereg32:=c_usableregs; + usableaddress:=getusableaddr; + end; + + + procedure clearregistercount; + var + regi : tregister; + begin + for regi:=R_D0 to R_A6 do + begin + reg_pushes[regi]:=0; + is_reg_var[regi]:=false; + end; + end; + + + + procedure resetusableregisters; + begin + usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4, + R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7]; + c_usableregs:=4; + usableaddress:=3; + usablefloatreg:=6; + end; + + + + +begin + resetusableregisters; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.6 2000/01/07 01:14:47 peter + * updated copyright to 2000 + + Revision 1.5 1999/09/16 23:05:57 florian + * m68k compiler is again compilable (only gas writer, no assembler reader) + +} diff --git a/befpc/compiler/tgeni386.pas b/befpc/compiler/tgeni386.pas new file mode 100644 index 0000000..eb21724 --- /dev/null +++ b/befpc/compiler/tgeni386.pas @@ -0,0 +1,712 @@ +{ + $Id: tgeni386.pas,v 1.1.1.1 2001-07-23 17:17:19 memson Exp $ + Copyright (C) 1998-2000 by Florian Klaempfl + + This unit handles the temporary variables stuff for i386 + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit tgeni386; + + interface + + uses + cobjects,globals,tree,hcodegen,verbose,files,aasm, + cpubase,cpuasm + ; + + type + tregisterset = set of tregister; + + tpushed = array[R_EAX..R_MM6] of boolean; + tsaved = array[R_EAX..R_MM6] of longint; + + const + usablereg32 : byte = 4; + + { this value is used in tsaved, if the register isn't saved } + reg_not_saved = $7fffffff; +{$ifdef SUPPORT_MMX} + usableregmmx : byte = 8; +{$endif SUPPORT_MMX} + + var + { tries to hold the amount of times which the current tree is processed } + t_times : longint; + +{$ifdef TEMPREGDEBUG} + procedure testregisters32; +{$endif TEMPREGDEBUG} + function getregister32 : tregister; + procedure ungetregister32(r : tregister); + { tries to allocate the passed register, if possible } + function getexplicitregister32(r : tregister) : tregister; +{$ifdef SUPPORT_MMX} + function getregistermmx : tregister; + procedure ungetregistermmx(r : tregister); +{$endif SUPPORT_MMX} + + procedure ungetregister(r : tregister); + + procedure cleartempgen; + procedure del_reference(const ref : treference); + procedure del_locref(const location : tlocation); + procedure del_location(const l : tlocation); + + { pushs and restores registers } + procedure pushusedregisters(var pushed : tpushed;b : byte); + procedure popusedregisters(const pushed : tpushed); + + { saves and restores used registers to temp. values } + procedure saveusedregisters(var saved : tsaved;b : byte); + procedure restoreusedregisters(const saved : tsaved); + + { increments the push count of all registers in b} + procedure incrementregisterpushed(b : byte); + + procedure clearregistercount; + procedure resetusableregisters; + + { corrects the fpu stack register by ofs } + function correct_fpuregister(r : tregister;ofs : byte) : tregister; + + var + unused,usableregs : tregisterset; + c_usableregs : longint; + + { uses only 1 byte while a set uses in FPC 32 bytes } + usedinproc : byte; + + fpuvaroffset : byte; + + { count, how much a register must be pushed if it is used as register } + { variable } +{$ifdef SUPPORT_MMX} + reg_pushes : array[R_EAX..R_MM6] of longint; + is_reg_var : array[R_EAX..R_MM6] of boolean; +{$ifdef TEMPREGDEBUG} + reg_user : array[R_EAX..R_MM6] of ptree; + reg_releaser : array[R_EAX..R_MM6] of ptree; +{$endif TEMPREGDEBUG} +{$else SUPPORT_MMX} + reg_pushes : array[R_EAX..R_EDI] of longint; + is_reg_var : array[R_EAX..R_EDI] of boolean; +{$ifdef TEMPREGDEBUG} + reg_user : array[R_EAX..R_EDI] of ptree; + reg_releaser : array[R_EAX..R_EDI] of ptree; +{$endif TEMPREGDEBUG} +{$endif SUPPORT_MMX} + + +implementation + + uses + globtype,temp_gen; + + procedure incrementregisterpushed(b : byte); + + var + regi : tregister; + + begin + for regi:=R_EAX to R_EDI do + begin + if (b and ($80 shr word(regi)))<>0 then + inc(reg_pushes[regi],t_times*2); + end; + end; + + procedure pushusedregisters(var pushed : tpushed;b : byte); + + var + r : tregister; +{$ifdef SUPPORT_MMX} + hr : preference; +{$endif} + begin + usedinproc:=usedinproc or b; + for r:=R_EAX to R_EBX do + begin + pushed[r]:=false; + { if the register is used by the calling subroutine } + if ((b and ($80 shr byte(r)))<>0) then + begin + { and is present in use } + if not(r in unused) then + begin + { then save it } + exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,r))); + + { here was a big problem !!!!!} + { you cannot do that for a register that is + globally assigned to a var + this also means that you must push it much more + often, but there must be a better way + maybe by putting the value back to the stack !! } + if not(is_reg_var[r]) then + begin + unused:=unused+[r]; +{$ifdef TEMPREGDEBUG} + inc(usablereg32); +{$endif TEMPREGDEBUG} + end; + pushed[r]:=true; + end; + end; + end; +{$ifdef SUPPORT_MMX} + for r:=R_MM0 to R_MM6 do + begin + pushed[r]:=false; + { if the mmx register is in use, save it } + if not(r in unused) then + begin + exprasmlist^.concat(new(paicpu,op_const_reg( + A_SUB,S_L,8,R_ESP))); + new(hr); + reset_reference(hr^); + hr^.base:=R_ESP; + exprasmlist^.concat(new(paicpu,op_reg_ref( + A_MOVQ,S_NO,r,hr))); + if not(is_reg_var[r]) then + begin + unused:=unused+[r]; +{$ifdef TEMPREGDEBUG} + inc(usableregmmx); +{$endif TEMPREGDEBUG} + end; + pushed[r]:=true; + end; + end; +{$endif SUPPORT_MMX} +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + + procedure saveusedregisters(var saved : tsaved;b : byte); + + var + r : tregister; + hr : treference; + + begin + usedinproc:=usedinproc or b; + for r:=R_EAX to R_EBX do + begin + saved[r]:=reg_not_saved; + { if the register is used by the calling subroutine } + if ((b and ($80 shr byte(r)))<>0) then + begin + { and is present in use } + if not(r in unused) then + begin + { then save it } + gettempofsizereference(4,hr); + saved[r]:=hr.offset; + exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,r,newreference(hr)))); + { here was a big problem !!!!!} + { you cannot do that for a register that is + globally assigned to a var + this also means that you must push it much more + often, but there must be a better way + maybe by putting the value back to the stack !! } + if not(is_reg_var[r]) then + begin + unused:=unused+[r]; +{$ifdef TEMPREGDEBUG} + inc(usablereg32); +{$endif TEMPREGDEBUG} + end; + end; + end; + end; +{$ifdef SUPPORT_MMX} + for r:=R_MM0 to R_MM6 do + begin + saved[r]:=reg_not_saved; + { if the mmx register is in use, save it } + if not(r in unused) then + begin + gettempofsizereference(8,hr); + exprasmlist^.concat(new(paicpu,op_reg_ref( + A_MOVQ,S_NO,r,newreference(hr)))); + if not(is_reg_var[r]) then + begin + unused:=unused+[r]; +{$ifdef TEMPREGDEBUG} + inc(usableregmmx); +{$endif TEMPREGDEBUG} + end; + saved[r]:=hr.offset; + end; + end; +{$endif SUPPORT_MMX} +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + + procedure popusedregisters(const pushed : tpushed); + + var + r : tregister; +{$ifdef SUPPORT_MMX} + hr : preference; +{$endif SUPPORT_MMX} + begin + { restore in reverse order: } +{$ifdef SUPPORT_MMX} + for r:=R_MM6 downto R_MM0 do + begin + if pushed[r] then + begin + new(hr); + reset_reference(hr^); + hr^.base:=R_ESP; + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_MOVQ,S_NO,hr,r))); + exprasmlist^.concat(new(paicpu,op_const_reg( + A_ADD,S_L,8,R_ESP))); + unused:=unused-[r]; +{$ifdef TEMPREGDEBUG} + dec(usableregmmx); +{$endif TEMPREGDEBUG} + end; + end; +{$endif SUPPORT_MMX} + for r:=R_EBX downto R_EAX do + if pushed[r] then + begin + exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,r))); +{$ifdef TEMPREGDEBUG} + if not (r in unused) then + { internalerror(10) + in cg386cal we always restore regs + that appear as used + due to a unused tmep storage PM } + else + dec(usablereg32); +{$endif TEMPREGDEBUG} + unused:=unused-[r]; + end; +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + + procedure restoreusedregisters(const saved : tsaved); + var + r : tregister; + hr : treference; + + begin + { restore in reverse order: } +{$ifdef SUPPORT_MMX} + for r:=R_MM6 downto R_MM0 do + begin + if saved[r]<>reg_not_saved then + begin + reset_reference(hr); + hr.base:=frame_pointer; + hr.offset:=saved[r]; + exprasmlist^.concat(new(paicpu,op_ref_reg( + A_MOVQ,S_NO,newreference(hr),r))); + unused:=unused-[r]; +{$ifdef TEMPREGDEBUG} + dec(usableregmmx); +{$endif TEMPREGDEBUG} + ungetiftemp(hr); + end; + end; +{$endif SUPPORT_MMX} + for r:=R_EBX downto R_EAX do + if saved[r]<>reg_not_saved then + begin + reset_reference(hr); + hr.base:=frame_pointer; + hr.offset:=saved[r]; + exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,newreference(hr),r))); +{$ifdef TEMPREGDEBUG} + if not (r in unused) then + internalerror(10) + else + dec(usablereg32); +{$endif TEMPREGDEBUG} + unused:=unused-[r]; + ungetiftemp(hr); + end; +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + + procedure ungetregister(r : tregister); + + begin + if r in [R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI] then + ungetregister32(r) + else if r in [R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI] then + ungetregister32(reg16toreg32(r)) + else if r in [R_AL,R_BL,R_CL,R_DL] then + ungetregister32(reg8toreg32(r)) +{$ifdef SUPPORT_MMX} + else if r in [R_MM0..R_MM6] then + ungetregistermmx(r) +{$endif SUPPORT_MMX} + else internalerror(18); + end; + + procedure ungetregister32(r : tregister); + + begin +{$ifndef noAllocEdi} + if (r = R_EDI) or + ((not assigned(procinfo^._class)) and (r = R_ESI)) then + begin + exprasmlist^.concat(new(pairegalloc,dealloc(r))); + exit; + end; +{$endif noAllocEdi} + if cs_regalloc in aktglobalswitches then + begin + { takes much time } + if not(r in usableregs) then + exit; + unused:=unused+[r]; + inc(usablereg32); + end + else + begin + if not(r in [R_EAX,R_EBX,R_ECX,R_EDX]) then + exit; +{$ifdef TEMPREGDEBUG} + if (r in unused) then +{$ifdef EXTTEMPREGDEBUG} + begin + Comment(V_Debug,'register freed twice '+reg2str(r)); + testregisters32; + exit; + end +{$else EXTTEMPREGDEBUG} + exit +{$endif EXTTEMPREGDEBUG} + else +{$endif TEMPREGDEBUG} + inc(usablereg32); + unused:=unused+[r]; +{$ifdef TEMPREGDEBUG} + reg_releaser[r]:=curptree^; +{$endif TEMPREGDEBUG} + end; + exprasmlist^.concat(new(pairegalloc,dealloc(r))); +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + +{$ifdef SUPPORT_MMX} + function getregistermmx : tregister; + + var + r : tregister; + + begin + dec(usableregmmx); + for r:=R_MM0 to R_MM6 do + if r in unused then + begin + unused:=unused-[r]; + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + getregistermmx:=r; + exit; + end; + internalerror(10); + end; + + procedure ungetregistermmx(r : tregister); + + begin + if cs_regalloc in aktglobalswitches then + begin + { takes much time } + if not(r in usableregs) then + exit; + unused:=unused+[r]; + inc(usableregmmx); + end + else + begin + unused:=unused+[r]; + inc(usableregmmx); + end; + end; +{$endif SUPPORT_MMX} + + procedure del_reference(const ref : treference); + + begin + if ref.is_immediate then + exit; + ungetregister32(ref.base); + ungetregister32(ref.index); + end; + + + procedure del_locref(const location : tlocation); + begin + if (location.loc<>loc_mem) and (location.loc<>loc_reference) then + exit; + if location.reference.is_immediate then + exit; + ungetregister32(location.reference.base); + ungetregister32(location.reference.index); + end; + + + procedure del_location(const l : tlocation); + begin + case l.loc of + LOC_REGISTER : + ungetregister(l.register); + LOC_MEM,LOC_REFERENCE : + del_reference(l.reference); + end; + end; + + +{$ifdef TEMPREGDEBUG} + procedure testregisters32; + var test : byte; + begin + test:=0; + if R_EAX in unused then + inc(test); + if R_EBX in unused then + inc(test); + if R_ECX in unused then + inc(test); + if R_EDX in unused then + inc(test); + if test<>usablereg32 then + internalerror(10); + end; +{$endif TEMPREGDEBUG} + + function getregister32 : tregister; + begin + if usablereg32=0 then + internalerror(10); + dec(usablereg32); +{$ifdef TEMPREGDEBUG} + if curptree^^.usableregs-usablereg32>curptree^^.registers32 then + internalerror(10); +{$endif TEMPREGDEBUG} +{$ifdef EXTTEMPREGDEBUG} + if curptree^^.usableregs-usablereg32>curptree^^.reallyusedregs then + curptree^^.reallyusedregs:=curptree^^.usableregs-usablereg32; +{$endif EXTTEMPREGDEBUG} + if R_EAX in unused then + begin + unused:=unused-[R_EAX]; + usedinproc:=usedinproc or ($80 shr byte(R_EAX)); + getregister32:=R_EAX; +{$ifdef TEMPREGDEBUG} + reg_user[R_EAX]:=curptree^; +{$endif TEMPREGDEBUG} + exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); + end + else if R_EDX in unused then + begin + unused:=unused-[R_EDX]; + usedinproc:=usedinproc or ($80 shr byte(R_EDX)); + getregister32:=R_EDX; +{$ifdef TEMPREGDEBUG} + reg_user[R_EDX]:=curptree^; +{$endif TEMPREGDEBUG} + exprasmlist^.concat(new(pairegalloc,alloc(R_EDX))); + end + else if R_EBX in unused then + begin + unused:=unused-[R_EBX]; + usedinproc:=usedinproc or ($80 shr byte(R_EBX)); + getregister32:=R_EBX; +{$ifdef TEMPREGDEBUG} + reg_user[R_EBX]:=curptree^; +{$endif TEMPREGDEBUG} + exprasmlist^.concat(new(pairegalloc,alloc(R_EBX))); + end + else if R_ECX in unused then + begin + unused:=unused-[R_ECX]; + usedinproc:=usedinproc or ($80 shr byte(R_ECX)); + getregister32:=R_ECX; +{$ifdef TEMPREGDEBUG} + reg_user[R_ECX]:=curptree^; +{$endif TEMPREGDEBUG} + exprasmlist^.concat(new(pairegalloc,alloc(R_ECX))); + end + else internalerror(10); +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end; + + function getexplicitregister32(r : tregister) : tregister; + + begin +{$ifndef noAllocEdi} + if r in [R_ESI,R_EDI] then + begin + exprasmlist^.concat(new(pairegalloc,alloc(r))); + getexplicitregister32 := r; + exit; + end; +{$endif noAllocEdi} + if r in unused then + begin + dec(usablereg32); +{$ifdef TEMPREGDEBUG} + if curptree^^.usableregs-usablereg32>curptree^^.registers32 then + internalerror(10); + reg_user[r]:=curptree^; +{$endif TEMPREGDEBUG} + unused:=unused-[r]; + usedinproc:=usedinproc or ($80 shr byte(r)); + exprasmlist^.concat(new(pairegalloc,alloc(r))); + getexplicitregister32:=r; +{$ifdef TEMPREGDEBUG} + testregisters32; +{$endif TEMPREGDEBUG} + end + else + getexplicitregister32:=getregister32; + end; + + procedure cleartempgen; + + begin + unused:=usableregs; + usablereg32:=c_usableregs; + {fpuvaroffset:=0; + this must only be resetted at each procedure + compilation start PM } + end; + + + procedure clearregistercount; + var + regi : tregister; + begin +{$ifdef SUPPORT_MMX} + for regi:=R_EAX to R_MM6 do + begin + reg_pushes[regi]:=0; + is_reg_var[regi]:=false; + end; +{$else SUPPORT_MMX} + for regi:=R_EAX to R_EDI do + begin + reg_pushes[regi]:=0; + is_reg_var[regi]:=false; + end; +{$endif SUPPORT_MMX} + end; + + function correct_fpuregister(r : tregister;ofs : byte) : tregister; + + begin + correct_fpuregister:=tregister(longint(r)+ofs); + end; + + procedure resetusableregisters; + begin +{$ifdef SUPPORT_MMX} + usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX,R_MM0..R_MM6]; + c_usableregs:=4; + usableregmmx:=8; +{$else} + usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX]; + c_usableregs:=4; +{$endif SUPPORT_MMX} + fpuvaroffset:=0; + end; + +begin + resetusableregisters; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.42 2000/04/02 18:30:12 florian + * fixed another problem with readln(); + * the register allocator takes now care of necessary pushes/pops for + readln/writeln + + Revision 1.41 2000/02/10 11:27:18 jonas + * esi is never deallocated anymore in methods + + Revision 1.40 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.39 2000/01/21 12:17:42 jonas + * regallocation fixes + + Revision 1.38 2000/01/09 12:35:02 jonas + * changed edi allocation to use getexplicitregister32/ungetregister + (adapted tgeni386 a bit for this) and enabled it by default + * fixed very big and stupid bug of mine in cg386mat that broke the + include() code (and make cycle :( ) if you compiled without + -dnewoptimizations + + Revision 1.37 2000/01/07 01:14:47 peter + * updated copyright to 2000 + + Revision 1.36 1999/11/06 14:34:31 peter + * truncated log to 20 revs + + Revision 1.35 1999/09/27 23:45:02 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.34 1999/08/27 10:38:32 pierre + + EXTTEMPREGDEBUG code added + + Revision 1.33 1999/08/25 12:00:06 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.32 1999/08/23 23:25:58 pierre + + TEMPREGDEBUG code, test of register allocation + if a tree uses more than registers32 regs then + internalerror(10) is issued + + EXTTEMPREGDEBUG will also give internalerror(10) if + a same register is freed twice (happens in several part + of current compiler like addn for strings and sets) + + Revision 1.31 1999/08/10 12:47:55 pierre + * fpuvaroffset problems solved + + Revision 1.30 1999/08/04 13:45:32 florian + + floating point register variables !! + * pairegalloc is now generated for register variables + + Revision 1.29 1999/08/04 00:23:48 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.28 1999/08/02 17:17:11 florian + * small changes for the new code generator + +} \ No newline at end of file diff --git a/befpc/compiler/todo.txt b/befpc/compiler/todo.txt new file mode 100644 index 0000000..b16c871 --- /dev/null +++ b/befpc/compiler/todo.txt @@ -0,0 +1,106 @@ +$Id: todo.txt,v 1.1.1.1 2001-07-23 17:17:19 memson Exp $ +This list contains tasks which should be done til version 1.0. +Don't hesitate to insert jobs :) +Don't insert bugs there, for this purpose is the bugs directory. + +Please indent task which are done 8 spaces and add the +compiler version and your short cut. + +* OPOM (Object Pascal Object Modell) + - virtual constructors ................................... 0.99.6 (FK) + * properties + - save the def and not the sym which + does read/write access ................................. 0.99.6 (FK) + - indexed properties ..................................... 0.99.6 (FK) + - default properties ..................................... 0.99.6 (FK) + - save array for overriding + - stored qualifier ...................................... 0.99.11 (FK) + - read/write from/to unit file ........................... 0.99.6 (FK) + - call of destructor helper routine ..................... 0.99.11 (FK) + - message qualifier ..................................... 0.99.11 (FK) + - correct handling of constructor result type ............ 0.99.6 (FK) + - rtti ................................................... 0.99.8 (FK) + - published .............................................. 0.99.8 (FK) + - dynamic methods + - correct handling of access specifiers .................. 0.99.7 (FK) + - interface +* rtti + - generation ........................................... 0.99.7 (FK) + - use when copying etc. ................................ 0.99.7 (FK) + - new/dispose should look for rtti'ed data ............. 0.99.8 (FK) + - enumeration names ................................... 0.99.11 (FK) + - methodpointers + - change booleans into enumerations +* AnsiString + - operators ........................................... 0.99.11 (FK) + - indexed access ...................................... 0.99.11 (FK) + - type conversions .................................... 0.99.11 (FK) +* LongString and WideString +* MMX support by the compiler + - unary minus .......................................... 0.99.1 (FK) + - proper handling of fixed type ........................ 0.99.1 (FK) + - array access + - binary operators ..................................... 0.99.1 (FK) + - mul operator ......................................... 0.99.1 (FK) + * special functions + - lo function + - pack/unpack function + - div by 2^n + - function results + - shift operators + - andn optimization + - muladdn optimization + - comparisations + - KNI + - 3DNow +* Delphi 4 support + - overloaded directive + - default parameters + - dynamic arrays + - 64 bit int +* QWord + - constants + - case + - for + - inc/dec + - read + - write ................................................. 0.99.13 (FK) + - str ................................................... 0.99.13 (FK) + - val + - range checking + - type cast QWord -> real + - lo/hi testing ......................................... 0.99.13 (FK) + - overflow checking test ................................ 0.99.13 (FK) +* Misc + - array of const as subroutine parameter ................ 0.99.9 (PFV) + - open array with call by value ......................... 0.99.6 (FK) + - subrange types of enumerations ........................ 0.99.7 (PFV) + - code generation for exceptions ........................ 0.99.7 (FK) + - assertation ........................................... 0.99.9 (PFV) + - add abstract virtual method runtime error (210) ....... 0.99.1 (FK) + - add debug info $D switch .............................. 0.99.1 (FK) + - add strict var strings check $V switch ................ 0.99.1 (FK) + - make dec/inc internal.................................. 0.99.6 (PFV) + - make length internal................................... 0.99.7 (PFV) + - range checking for open arrays......................... 0.99.11 (PFV) + - method pointers (procedure of object) ................. 0.99.11 (FK) + - open strings, $P....................................... 0.99.10 (PFV) + - include/exclude........................................ 0.99.10 (PM) +- fix all bugs of the bug directory +- sysutils unit for go32v2 (exceptions!) + - initialisation/finalization for units ................. 0.99.11 (PFV) +- fixed data type +- add alignment $A switch +- $B + +Future versions +--------------- +1.1 + - full MT support in rtl + - synchronized keyword + - interfaces + - lineinfo in the executable which can be showed instead + of addresses +2.0 + - new code generator + - complete inline support diff --git a/befpc/compiler/tokendat.pas b/befpc/compiler/tokendat.pas new file mode 100644 index 0000000..54ec37a --- /dev/null +++ b/befpc/compiler/tokendat.pas @@ -0,0 +1,81 @@ +{ + $Id: tokendat.pas,v 1.1.1.1 2001-07-23 17:17:19 memson Exp $ + Copyright (c) 1998-2000 by Daniel Mantione, Peter Vreman + Members of the Free Pascal development team + + This little program generates a file of tokendata + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +program tokendat; + +{$ifdef FPC} + {$FATAL Use tp 7 to compile, FPC can't be used because the records are written different.} +{$else} + {$ifndef TP} + -- You need to define -dTP and -dI386 + {$endif} + {$ifndef I386} + -- You need to define -dTP and -dI386 + {$endif} +{$endif} + +uses tokens; + +{Header is designed both to identify the file and to display a nice + message when you use the type command on it. + +Explanation: + +#8 String length is also displayed. A backspace erases it. +#13#10 Needed to display dos prompt on next line. +#26 End of file. Causes type to stop reading the file. +} + +const + headerstr:string[length(tokheader)]=tokheader; +var + f:file; + a:longint; +begin + new(tokenidx); + create_tokenidx; + assign(f,'tokens.dat'); + rewrite(f,1); + {Write header...} + blockwrite(f,headerstr,sizeof(headerstr)); + {Write size of tokeninfo.} + a:=sizeof(arraytokeninfo); + blockwrite(f,a,sizeof(a)); + {Write tokeninfo.} + blockwrite(f,arraytokeninfo,sizeof(arraytokeninfo)); + {Write tokenindex.} + blockwrite(f,tokenidx^,sizeof(tokenidx^)); + close(f); + dispose(tokenidx); +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/01/07 01:14:47 peter + * updated copyright to 2000 + + Revision 1.4 1999/09/08 16:02:03 peter + * tokendat compiles for tp + * tokens.dat supplied by default + +} + diff --git a/befpc/compiler/tokens.dat b/befpc/compiler/tokens.dat new file mode 100644 index 0000000..36cc8e6 --- /dev/null +++ b/befpc/compiler/tokens.dat @@ -0,0 +1 @@ +&Free Pascal Compiler -- Token data diff --git a/befpc/compiler/tokens.pas b/befpc/compiler/tokens.pas new file mode 100644 index 0000000..318cf92 --- /dev/null +++ b/befpc/compiler/tokens.pas @@ -0,0 +1,583 @@ +{ + $Id: tokens.pas,v 1.1.1.1 2001-07-23 17:17:20 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller + + Tokens used by the compiler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + **************************************************************************** +} +unit tokens; +interface + +uses + globtype; + +const + tokenidlen=14; + tokheader=#8'Free Pascal Compiler -- Token data'#13#10#26; + +type + ttoken=(NOTOKEN, + { operators, which can also be overloaded } + _PLUS, + _MINUS, + _STAR, + _SLASH, + _EQUAL, + _GT, + _LT, + _GTE, + _LTE, + _SYMDIF, + _STARSTAR, + _OP_AS, + _OP_IN, + _OP_IS, + _OP_OR, + _OP_AND, + _OP_DIV, + _OP_MOD, + _OP_NOT, + _OP_SHL, + _OP_SHR, + _OP_XOR, + _ASSIGNMENT, + { special chars } + _CARET, + _UNEQUAL, + _LECKKLAMMER, + _RECKKLAMMER, + _POINT, + _COMMA, + _LKLAMMER, + _RKLAMMER, + _COLON, + _SEMICOLON, + _KLAMMERAFFE, + _POINTPOINT, + _DOUBLEADDR, + _EOF, + _ID, + _NOID, + _REALNUMBER, + _INTCONST, + _CSTRING, + _CCHAR, + { C like operators } + _PLUSASN, + _MINUSASN, + _ANDASN, + _ORASN, + _STARASN, + _SLASHASN, + _MODASN, + _DIVASN, + _NOTASN, + _XORASN, + { Normal words } + _AS, + _AT, + _DO, + _IF, + _IN, + _IS, + _OF, + _ON, + _OR, + _TO, + _AND, + _ASM, + _DIV, + _END, + _FAR, + _FOR, + _MOD, + _NEW, + _NIL, + _NOT, + _SET, + _SHL, + _SHR, + _TRY, + _VAR, + _XOR, + _CASE, + _CVAR, + _ELSE, + _EXIT, + _FAIL, + _FILE, + _GOTO, + _NAME, + _NEAR, + _READ, + _SELF, + _THEN, + _TRUE, + _TYPE, + _UNIT, + _USES, + _WITH, + _ALIAS, + _ARRAY, + _BEGIN, + _BREAK, + _CDECL, + _CLASS, + _CONST, + _FALSE, + _INDEX, + _LABEL, + _RAISE, + _UNTIL, + _WHILE, + _WRITE, + _DOWNTO, + _EXCEPT, + _EXPORT, + _INLINE, + _OBJECT, + _PACKED, + _PASCAL, + _PUBLIC, + _RECORD, + _REPEAT, + _RESULT, + _STATIC, + _STORED, + _STRING, + _SYSTEM, + _ASMNAME, + _DEFAULT, + _DISPOSE, + _DYNAMIC, + _EXPORTS, + _FINALLY, + _FORWARD, + _IOCHECK, + _LIBRARY, + _MESSAGE, + _PRIVATE, + _PROGRAM, + _STDCALL, + _SYSCALL, + _VIRTUAL, + _ABSOLUTE, + _ABSTRACT, + _CONTINUE, + _CPPCLASS, + _EXTERNAL, + _FUNCTION, + _OPERATOR, + _OVERLOAD, + _OVERRIDE, + _POPSTACK, + _PROPERTY, + _REGISTER, + _RESIDENT, + _SAFECALL, + _ASSEMBLER, + _INHERITED, + _INTERFACE, + _INTERRUPT, + _NODEFAULT, + _OTHERWISE, + _PROCEDURE, + _PROTECTED, + _PUBLISHED, + _THREADVAR, + _DESTRUCTOR, + _INTERNPROC, + _OPENSTRING, + _CONSTRUCTOR, + _INTERNCONST, + _REINTRODUCE, + _SHORTSTRING, + _FINALIZATION, + _SAVEREGISTERS, + _IMPLEMENTATION, + _INITIALIZATION, + _RESOURCESTRING + ); + + tokenrec=record + str : string[tokenidlen]; + special : boolean; + keyword : tmodeswitch; + op : ttoken; + encoded : longint; + end; + + ttokenarray=array[ttoken] of tokenrec; + ptokenarray=^ttokenarray; + + tokenidxrec=record + first,last : ttoken; + end; + + ptokenidx=^ttokenidx; + ttokenidx=array[2..tokenidlen,'A'..'Z'] of tokenidxrec; + +const + arraytokeninfo : ttokenarray =( + (str:'' ;special:true ;keyword:m_none;op:NOTOKEN), + { Operators which can be overloaded } + (str:'+' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'-' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'*' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'/' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'>' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'<' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'>=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'<=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'><' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'**' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'as' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'in' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'is' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'or' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'and' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'div' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'mod' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'not' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'shl' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'shr' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'xor' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:':=' ;special:true ;keyword:m_none;op:NOTOKEN), + { Special chars } + (str:'^' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'<>' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'[' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:']' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'.' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:',' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'(' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:')' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:':' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:';' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'@' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'..' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'@@' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'end of file' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'identifier' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'non identifier';special:true ;keyword:m_none;op:NOTOKEN), + (str:'const real' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'ordinal const' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'const string' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'const char' ;special:true ;keyword:m_none;op:NOTOKEN), + { C like operators } + (str:'+=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'-=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'&=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'|=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'*=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'/=' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'' ;special:true ;keyword:m_none;op:NOTOKEN), + (str:'' ;special:true ;keyword:m_none;op:NOTOKEN), + { Normal words } + (str:'AS' ;special:false;keyword:m_class;op:_OP_AS), + (str:'AT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'DO' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'IF' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'IN' ;special:false;keyword:m_all;op:_OP_IN), + (str:'IS' ;special:false;keyword:m_class;op:_OP_IS), + (str:'OF' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'ON' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'OR' ;special:false;keyword:m_all;op:_OP_OR), + (str:'TO' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'AND' ;special:false;keyword:m_all;op:_OP_AND), + (str:'ASM' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'DIV' ;special:false;keyword:m_all;op:_OP_DIV), + (str:'END' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'FAR' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'FOR' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'MOD' ;special:false;keyword:m_all;op:_OP_MOD), + (str:'NEW' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'NIL' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'NOT' ;special:false;keyword:m_all;op:_OP_NOT), + (str:'SET' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'SHL' ;special:false;keyword:m_all;op:_OP_SHL), + (str:'SHR' ;special:false;keyword:m_all;op:_OP_SHR), + (str:'TRY' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'VAR' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'XOR' ;special:false;keyword:m_all;op:_OP_XOR), + (str:'CASE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'CVAR' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ELSE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'EXIT' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'FAIL' ;special:false;keyword:m_none;op:NOTOKEN), { only set within constructors PM } + (str:'FILE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'GOTO' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'NAME' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'NEAR' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'READ' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'SELF' ;special:false;keyword:m_none;op:NOTOKEN), {set inside methods only PM } + (str:'THEN' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'TRUE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'TYPE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'UNIT' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'USES' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'WITH' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'ALIAS' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ARRAY' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'BEGIN' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'BREAK' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'CDECL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'CLASS' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'CONST' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'FALSE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'INDEX' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'LABEL' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'RAISE' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'UNTIL' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'WHILE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'WRITE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'DOWNTO' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'EXCEPT' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'EXPORT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'INLINE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'OBJECT' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'PACKED' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'PASCAL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'PUBLIC' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'RECORD' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'REPEAT' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'RESULT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'STATIC' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'STORED' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'STRING' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'SYSTEM' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ASMNAME' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'DEFAULT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'DISPOSE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'DYNAMIC' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'EXPORTS' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'FINALLY' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'FORWARD' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'IOCHECK' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'LIBRARY' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'MESSAGE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'PRIVATE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'PROGRAM' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'STDCALL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'SYSCALL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'VIRTUAL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ABSOLUTE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ABSTRACT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'CONTINUE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'CPPCLASS' ;special:false;keyword:m_fpc;op:NOTOKEN), + (str:'EXTERNAL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'FUNCTION' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'OPERATOR' ;special:false;keyword:m_fpc;op:NOTOKEN), + (str:'OVERLOAD' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'OVERRIDE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'POPSTACK' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'PROPERTY' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'REGISTER' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'RESIDENT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'SAFECALL' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'ASSEMBLER' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'INHERITED' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'INTERFACE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'INTERRUPT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'NODEFAULT' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'OTHERWISE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'PROCEDURE' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'PROTECTED' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'PUBLISHED' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'THREADVAR' ;special:false;keyword:m_class;op:NOTOKEN), + (str:'DESTRUCTOR' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'INTERNPROC' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'OPENSTRING' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'CONSTRUCTOR' ;special:false;keyword:m_all;op:NOTOKEN), + (str:'INTERNCONST' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'REINTRODUCE' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'SHORTSTRING' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'FINALIZATION' ;special:false;keyword:m_initfinal;op:NOTOKEN), + (str:'SAVEREGISTERS' ;special:false;keyword:m_none;op:NOTOKEN), + (str:'IMPLEMENTATION';special:false;keyword:m_all;op:NOTOKEN), + (str:'INITIALIZATION';special:false;keyword:m_initfinal;op:NOTOKEN), + (str:'RESOURCESTRING';special:false;keyword:m_class;op:NOTOKEN) + ); + +var + tokeninfo:ptokenarray; + tokenidx:ptokenidx; + +procedure inittokens; +procedure donetokens; +procedure create_tokenidx; + +implementation + +{$ifdef TP} +uses + dos; +{$endif} + +procedure create_tokenidx; +{ create an index with the first and last token for every possible token + length, so a search only will be done in that small part } +var + t : ttoken; +begin + fillchar(tokenidx^,sizeof(tokenidx^),0); + for t:=low(ttoken) to high(ttoken) do + begin + if not arraytokeninfo[t].special then + begin + if ord(tokenidx^[length(arraytokeninfo[t].str),arraytokeninfo[t].str[1]].first)=0 then + tokenidx^[length(arraytokeninfo[t].str),arraytokeninfo[t].str[1]].first:=t; + tokenidx^[length(arraytokeninfo[t].str),arraytokeninfo[t].str[1]].last:=t; + end; + end; +end; + +procedure inittokens; +{$ifdef TP} +var + f:file; + n : namestr; + d : dirstr; + e : extstr; + header:string; + a:longint; +{$endif TP} +begin +{$ifdef TP} + fsplit(paramstr(0),d,n,e); + { when debugging d=''!!!! FK } + if d='' then + assign(f,'tokens.dat') + else + assign(f,d+'tokens.dat'); + {$I-} + reset(f,1); + {We are not sure that the msg file is loaded!} + if ioresult<>0 then + begin + { Very nice indeed !!! PM } + writeln('Fatal: File tokens.dat not found.'); + close(f); + halt(3); + end; + blockread(f,header,1); + blockread(f,header[1],length(header)); + blockread(f,a,sizeof(a)); + if (ioresult<>0) or + (header<>tokheader) or (a<>sizeof(ttokenarray)) then + begin + writeln('Fatal: File tokens.dat corrupt.'); + close(f); + halt(3); + end; + new(tokeninfo); + blockread(f,tokeninfo^,sizeof(ttokenarray)); + new(tokenidx); + blockread(f,tokenidx^,sizeof(tokenidx^)); + close(f); +{$I+} + if (ioresult<>0) then + begin + writeln('Fatal: File tokens.dat corrupt.'); + halt(3); + end; +{$else not TP} + tokeninfo:=@arraytokeninfo; + new(tokenidx); + create_tokenidx; +{$endif not TP} +end; + + +procedure donetokens; +begin +{$ifdef TP} + dispose(tokeninfo); +{$else TP} + tokeninfo:=nil; +{$endif TP} + dispose(tokenidx); +end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.24 2000/06/18 18:12:40 peter + * support overload keyword + + Revision 1.23 2000/06/05 20:41:18 pierre + + support for NOT overloading + + unsupported overloaded operators generate errors + + Revision 1.22 2000/03/19 14:56:39 florian + * bug 873 fixed + * some cleanup in objectdec + + Revision 1.21 2000/02/12 23:53:18 carl + * bugfixes in tokens using TP conditional + + Revision 1.20 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.19 2000/01/07 01:14:48 peter + * updated copyright to 2000 + + Revision 1.18 1999/11/15 17:53:00 pierre + + one field added for ttoken record for operator + linking the id to the corresponding operator token that + can now now all be overloaded + * overloaded operators are resetted to nil in InitSymtable + (bug when trying to compile a uint that overloads operators twice) + + Revision 1.17 1999/09/21 20:53:23 florian + * fixed 1/s problem from mailing list + + Revision 1.16 1999/09/17 09:17:49 peter + * removed uses globals + + Revision 1.15 1999/09/16 13:41:37 peter + * better error checking + + Revision 1.14 1999/09/08 16:02:04 peter + * tokendat compiles for tp + * tokens.dat supplied by default + + Revision 1.13 1999/09/03 08:37:34 pierre + * tokens.dat only used for TP, and also removed from + compiler dependencies + + Revision 1.12 1999/09/02 18:47:49 daniel + * Could not compile with TP, some arrays moved to heap + * NOAG386BIN default for TP + * AG386* files were not compatible with TP, fixed. + + Revision 1.11 1999/08/04 13:03:17 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.10 1999/08/03 22:03:39 peter + * moved bitmask constants to sets + * some other type/const renamings + + Revision 1.9 1999/07/22 09:38:01 florian + + resourcestring implemented + + start of longstring support + +} \ No newline at end of file diff --git a/befpc/compiler/tpexcept.pas b/befpc/compiler/tpexcept.pas new file mode 100644 index 0000000..3517269 --- /dev/null +++ b/befpc/compiler/tpexcept.pas @@ -0,0 +1,406 @@ +{ + $Id: tpexcept.pas,v 1.1.1.1 2001-07-23 17:17:20 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + SetJmp and LongJmp implementation for recovery handling of the + compiler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} +unit tpexcept; +interface + +{$ifndef LINUX} + {$S-} +{$endif} +{$ifdef Delphi} +{$undef TP} +{$endif Delphi} + +type + jmp_buf = record +{$ifdef TP} + _ax,_bx,_cx,_dx,_si,_di,_bp,_sp,_ip,flags : word; + _cs,_ds,_es,_ss : word; +{$else} + {$ifdef Delphi} { must preserve: ebx, esi, edi, ebp, esp, eip only } + _ebx,_esi,_edi,_ebp,_esp,_eip : longint; + {$else} + eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint; + cs,ds,es,fs,gs,ss : word; + {$endif Delphi} +{$endif TP} + end; + + pjmp_buf = ^jmp_buf; + +{$ifdef TP} + function setjmp(var rec : jmp_buf) : integer; + procedure longjmp(const rec : jmp_buf;return_value : integer); +{$else} + function setjmp(var rec : jmp_buf) : longint; + {$ifdef Delphi}stdcall;{$endif} + procedure longjmp(const rec : jmp_buf;return_value : longint); + {$ifdef Delphi}stdcall;{$endif} +{$endif TP} + + const + recoverpospointer : pjmp_buf = nil; + longjump_used : boolean = false; + +implementation + + +{***************************************************************************** + Exception Helpers +*****************************************************************************} + +{$ifdef TP} + + function setjmp(var rec : jmp_buf) : integer; + begin + asm + push di + push es + les di,rec + mov es:[di].jmp_buf._ax,ax + mov es:[di].jmp_buf._bx,bx + mov es:[di].jmp_buf._cx,cx + mov es:[di].jmp_buf._dx,dx + mov es:[di].jmp_buf._si,si + + { load di } + mov ax,[bp-4] + + { ... and store it } + mov es:[di].jmp_buf._di,ax + + { load es } + mov ax,[bp-6] + + { ... and store it } + mov es:[di].jmp_buf._es,ax + + { bp ... } + mov ax,[bp] + mov es:[di].jmp_buf._bp,ax + + { sp ... } + mov ax,bp + add ax,10 + mov es:[di].jmp_buf._sp,ax + + { the return address } + mov ax,[bp+2] + mov es:[di].jmp_buf._ip,ax + mov ax,[bp+4] + mov es:[di].jmp_buf._cs,ax + + { flags ... } + pushf + pop word ptr es:[di].jmp_buf.flags + + mov es:[di].jmp_buf._ds,ds + mov es:[di].jmp_buf._ss,ss + + { restore es:di } + pop es + pop di + + { we come from the initial call } + xor ax,ax + leave + retf 4 + end; + end; + + procedure longjmp(const rec : jmp_buf;return_value : integer); + begin + asm + + { this is the address of rec } + lds di,rec + + { save return value } + mov ax,return_value + mov ds:[di].jmp_buf._ax,ax + + { restore compiler shit } + pop bp + + { restore some registers } + mov bx,ds:[di].jmp_buf._bx + mov cx,ds:[di].jmp_buf._cx + mov dx,ds:[di].jmp_buf._dx + mov bp,ds:[di].jmp_buf._bp + + { create a stack frame for the return } + mov es,ds:[di].jmp_buf._ss + mov si,ds:[di].jmp_buf._sp + + sub si,12 + + { store ds } + mov ax,ds:[di].jmp_buf._ds + mov es:[si],ax + + { store di } + mov ax,ds:[di].jmp_buf._di + mov es:[si+2],ax + + { store si } + mov ax,ds:[di].jmp_buf._si + mov es:[si+4],ax + + { store flags } + mov ax,ds:[di].jmp_buf.flags + mov es:[si+6],ax + + { store ip } + mov ax,ds:[di].jmp_buf._ip + mov es:[si+8],ax + + { store cs } + mov ax,ds:[di].jmp_buf._cs + mov es:[si+10],ax + + { load stack } + mov ax,es + mov ss,ax + mov sp,si + + { load return value } + mov ax,ds:[di].jmp_buf._ax + + { load old ES } + mov es,ds:[di].jmp_buf._es + + pop ds + pop di + pop si + + popf + retf + end; + end; + +{$else} +{$ifdef Delphi} + + {$STACKFRAMES ON} + function setjmp(var rec : jmp_buf) : longint; assembler; + { [ebp+12]: [ebp+8]:@rec, [ebp+4]:eip', [ebp+0]:ebp' } + asm // free: eax, ecx, edx + { push ebp; mov ebp,esp } + mov edx,rec + mov [edx].jmp_buf._ebx,ebx { ebx } + mov [edx].jmp_buf._esi,esi { esi } + mov [edx].jmp_buf._edi,edi { edi } + mov eax,[ebp] { ebp (caller stack frame) } + mov [edx].jmp_buf._ebp,eax + lea eax,[ebp+12] { esp [12]: [8]:@rec, [4]:eip, [0]:ebp } + mov [edx].jmp_buf._esp,eax + mov eax,[ebp+4] + mov [edx].jmp_buf._eip,eax + xor eax,eax + { leave } + { ret 4 } + end; + + procedure longjmp(const rec : jmp_buf; return_value : longint);assembler; + { [ebp+12]: return_value [ebp+8]:@rec, [ebp+4]:eip', [ebp+0]:ebp' } + asm + { push ebp, mov ebp,esp } + mov edx,rec + mov ecx,return_value + mov ebx,[edx].jmp_buf._ebx { ebx } + mov esi,[edx].jmp_buf._esi { esi } + mov edi,[edx].jmp_buf._edi { edi } + mov ebp,[edx].jmp_buf._ebp { ebp } + mov esp,[edx].jmp_buf._esp { esp } + mov eax,[edx].jmp_buf._eip { eip } + push eax + mov eax,ecx + ret 0 + end; + +{$else Delphi} + +{$asmmode ATT} + + function setjmp(var rec : jmp_buf) : longint; + begin + asm + pushl %edi + movl rec,%edi + movl %eax,(%edi) + movl %ebx,4(%edi) + movl %ecx,8(%edi) + movl %edx,12(%edi) + movl %esi,16(%edi) + + { load edi } + movl -4(%ebp),%eax + + { ... and store it } + movl %eax,20(%edi) + + { ebp ... } + movl (%ebp),%eax + movl %eax,24(%edi) + + { esp ... } + leal 12(%ebp),%eax + movl %eax,28(%edi) + + { the return address } + movl 4(%ebp),%eax + movl %eax,32(%edi) + + { flags ... } + pushfl + popl 36(%edi) + + { !!!!! the segment registers, not yet needed } + { you need them if the exception comes from + an interrupt or a seg_move } + movw %cs,40(%edi) + movw %ds,42(%edi) + movw %es,44(%edi) + movw %fs,46(%edi) + movw %gs,48(%edi) + movw %ss,50(%edi) + + { restore EDI } + pop %edi + + { we come from the initial call } + xorl %eax,%eax + + leave + ret $4 + end; + end; + + + procedure longjmp(const rec : jmp_buf;return_value : longint); + begin + asm + { restore compiler shit } + popl %ebp + { this is the address of rec } + movl 4(%esp),%edi + + { save return value } + movl 8(%esp),%eax + movl %eax,0(%edi) + + { !!!!! load segment registers } + movw 46(%edi),%fs + movw 48(%edi),%gs + + { ... and some other registers } + movl 4(%edi),%ebx + movl 8(%edi),%ecx + movl 12(%edi),%edx + movl 24(%edi),%ebp + + { !!!!! movw 50(%edi),%es } + movl 28(%edi),%esi + + { create a stack frame for the return } + subl $16,%esi + + { + movzwl 42(%edi),%eax + !!!!! es + movl %eax,(%esi) + } + + { edi } + movl 20(%edi),%eax + { !!!!! es } + movl %eax,(%esi) + + { esi } + movl 16(%edi),%eax + { !!!!! es } + movl %eax,4(%esi) + + { eip } + movl 32(%edi),%eax + { !!!!! es } + movl %eax,12(%esi) + + { !!!!! cs + movl 40(%edi),%eax + es + movl %eax,16(%esi) + } + + { load and store flags } + movl 36(%edi),%eax + { !!!!! + es + } + movl %eax,8(%esi) + + { load return value } + movl 0(%edi),%eax + + { load old ES + !!!!! movw 44(%edi),%es + } + + { load stack + !!!!! movw 50(%edi),%ss } + movl %esi,%esp + + { !!!! + popl %ds + } + popl %edi + popl %esi + + popfl + ret + end; + end; +{$endif Delphi} +{$endif TP} + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/05/11 09:36:22 pierre + * Delphi implementation by Kovacs Attila Zoltan + + Revision 1.12 2000/02/24 18:41:39 peter + * removed warnings/notes + + Revision 1.11 2000/02/11 23:59:35 jonas + + $asmmode att for people with -Rintel in their ppc386.cfg + + Revision 1.10 2000/02/09 13:23:08 peter + * log truncated + + Revision 1.9 2000/01/07 01:14:48 peter + * updated copyright to 2000 + + Revision 1.8 1999/08/18 11:35:59 pierre + * esp loading corrected + +} diff --git a/befpc/compiler/tree.pas b/befpc/compiler/tree.pas new file mode 100644 index 0000000..ed11426 --- /dev/null +++ b/befpc/compiler/tree.pas @@ -0,0 +1,2251 @@ +{ + $Id: tree.pas,v 1.1.1.1 2001-07-23 17:17:21 memson Exp $ + Copyright (c) 1998-2000 by Florian Klaempfl + + This units exports some routines to manage the parse tree + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{$ifdef tp} + {$E+,N+} +{$endif} +unit tree; + + interface + + uses + globtype,cobjects + {$IFDEF NEWST} + ,objects,symtable,symbols,defs + {$ELSE} + ,symconst,symtable + {$ENDIF NEWST} + ,aasm,cpubase; + + type + pconstset = ^tconstset; + tconstset = array[0..31] of byte; + + ttreetyp = ( + addn, {Represents the + operator.} + muln, {Represents the * operator.} + subn, {Represents the - operator.} + divn, {Represents the div operator.} + symdifn, {Represents the >< operator.} + modn, {Represents the mod operator.} + assignn, {Represents an assignment.} + loadn, {Represents the use of a variabele.} + rangen, {Represents a range (i.e. 0..9).} + ltn, {Represents the < operator.} + lten, {Represents the <= operator.} + gtn, {Represents the > operator.} + gten, {Represents the >= operator.} + equaln, {Represents the = operator.} + unequaln, {Represents the <> operator.} + inn, {Represents the in operator.} + orn, {Represents the or operator.} + xorn, {Represents the xor operator.} + shrn, {Represents the shr operator.} + shln, {Represents the shl operator.} + slashn, {Represents the / operator.} + andn, {Represents the and operator.} + subscriptn, {??? Field in a record/object?} + derefn, {Dereferences a pointer.} + addrn, {Represents the @ operator.} + doubleaddrn, {Represents the @@ operator.} + ordconstn, {Represents an ordinal value.} + typeconvn, {Represents type-conversion/typecast.} + calln, {Represents a call node.} + callparan, {Represents a parameter.} + realconstn, {Represents a real value.} + fixconstn, {Represents a fixed value.} + unaryminusn, {Represents a sign change (i.e. -2).} + asmn, {Represents an assembler node } + vecn, {Represents array indexing.} + pointerconstn, + stringconstn, {Represents a string constant.} + funcretn, {Represents the function result var.} + selfn, {Represents the self parameter.} + notn, {Represents the not operator.} + inlinen, {Internal procedures (i.e. writeln).} + niln, {Represents the nil pointer.} + errorn, {This part of the tree could not be + parsed because of a compiler error.} + typen, {A type name. Used for i.e. typeof(obj).} + hnewn, {The new operation, constructor call.} + hdisposen, {The dispose operation with destructor call.} + newn, {The new operation, constructor call.} + simpledisposen, {The dispose operation.} + setelementn, {A set element(s) (i.e. [a,b] and also [a..b]).} + setconstn, {A set constant (i.e. [1,2]).} + blockn, {A block of statements.} + statementn, {One statement in a block of nodes.} + loopn, { used in genloopnode, must be converted } + ifn, {An if statement.} + breakn, {A break statement.} + continuen, {A continue statement.} + repeatn, {A repeat until block.} + whilen, {A while do statement.} + forn, {A for loop.} + exitn, {An exit statement.} + withn, {A with statement.} + casen, {A case statement.} + labeln, {A label.} + goton, {A goto statement.} + simplenewn, {The new operation.} + tryexceptn, {A try except block.} + raisen, {A raise statement.} + switchesn, {??? Currently unused...} + tryfinallyn, {A try finally statement.} + onn, { for an on statement in exception code } + isn, {Represents the is operator.} + asn, {Represents the as typecast.} + caretn, {Represents the ^ operator.} + failn, {Represents the fail statement.} + starstarn, {Represents the ** operator exponentiation } + procinlinen, {Procedures that can be inlined } + arrayconstructn, {Construction node for [...] parsing} + arrayconstructrangen, {Range element to allow sets in array construction tree} + { added for optimizations where we cannot suppress } + nothingn, + loadvmtn + ); + + tconverttype = ( + tc_equal, + tc_not_possible, + tc_string_2_string, + tc_char_2_string, + tc_pchar_2_string, + tc_cchar_2_pchar, + tc_cstring_2_pchar, + tc_ansistring_2_pchar, + tc_string_2_chararray, + tc_chararray_2_string, + tc_array_2_pointer, + tc_pointer_2_array, + tc_int_2_int, + tc_int_2_bool, + tc_bool_2_bool, + tc_bool_2_int, + tc_real_2_real, + tc_int_2_real, + tc_int_2_fix, + tc_real_2_fix, + tc_fix_2_real, + tc_proc_2_procvar, + tc_arrayconstructor_2_set, + tc_load_smallset, + tc_cord_2_pointer + ); + + { allows to determine which elementes are to be replaced } + tdisposetyp = (dt_nothing,dt_leftright,dt_left,dt_leftrighthigh, + dt_mbleft,dt_typeconv,dt_inlinen,dt_leftrightmethod, + dt_mbleft_and_method,dt_loop,dt_case,dt_with,dt_onn, + dt_leftrightframe); + + { different assignment types } + + tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash); + + pcaserecord = ^tcaserecord; + tcaserecord = record + + { range } + _low,_high : longint; + + { only used by gentreejmp } + _at : pasmlabel; + + { label of instruction } + statement : pasmlabel; + + { is this the first of an case entry, needed to release statement + label (PFV) } + firstlabel : boolean; + + { left and right tree node } + less,greater : pcaserecord; + end; + + ptree = ^ttree; + ttree = record + error : boolean; + disposetyp : tdisposetyp; + { is true, if the right and left operand are swaped } + swaped : boolean; + { do we need to parse childs to set var state } + varstateset : boolean; + { the location of the result of this node } + location : tlocation; + + { the number of registers needed to evalute the node } + registers32,registersfpu : longint; { must be longint !!!! } +{$ifdef SUPPORT_MMX} + registersmmx : longint; +{$endif SUPPORT_MMX} + left,right : ptree; + resulttype : pdef; + fileinfo : tfileposinfo; + localswitches : tlocalswitches; + isproperty : boolean; +{$ifdef extdebug} + firstpasscount : longint; +{$endif extdebug} +{$ifdef TEMPREGDEBUG} + usableregs : longint; +{$endif TEMPREGDEBUG} +{$ifdef EXTTEMPREGDEBUG} + reallyusedregs : longint; +{$endif EXTTEMPREGDEBUG} +{$ifdef TEMPS_NOT_PUSH} + temp_offset : longint; +{$endif TEMPS_NOT_PUSH} + case treetype : ttreetyp of + addn : (use_strconcat : boolean;string_typ : tstringtype); + callparan : (is_colon_para : boolean;exact_match_found, + convlevel1found,convlevel2found:boolean;hightree:ptree); + assignn : (assigntyp : tassigntyp;concat_string : boolean); + loadn : (symtableentry : psym;symtable : psymtable; + is_absolute,is_first : boolean); + calln : (symtableprocentry : pprocsym; + symtableproc : psymtable;procdefinition : pabstractprocdef; + methodpointer : ptree; + no_check,unit_specific, + return_value_used,static_call : boolean); + addrn : (procvarload:boolean); + ordconstn : (value : longint); + realconstn : (value_real : bestreal;lab_real : pasmlabel); + fixconstn : (value_fix: longint); + funcretn : (funcretprocinfo : pointer; + {$IFDEF NEWST} + retsym:Psym; + {$ELSE} + rettype : ttype; + {$ENDIF} + is_first_funcret : boolean); + subscriptn : (vs : pvarsym); + raisen : (frametree : ptree); + vecn : (memindex,memseg:boolean;callunique : boolean); + stringconstn : (value_str : pchar;length : longint; lab_str : pasmlabel;stringtype : tstringtype); + typeconvn : (convtyp : tconverttype;explizit : boolean); + typen : (typenodetype : pdef;typenodesym:ptypesym); + inlinen : (inlinenumber : byte;inlineconst:boolean); + procinlinen : (inlinetree:ptree;inlineprocsym:pprocsym;retoffset,para_offset,para_size : longint); + setconstn : (value_set : pconstset;lab_set:pasmlabel); + loopn : (t1,t2 : ptree;backward : boolean); + asmn : (p_asm : paasmoutput;object_preserved : boolean); + casen : (nodes : pcaserecord;elseblock : ptree); + labeln,goton : (labelnr : pasmlabel;exceptionblock : ptree;labsym : plabelsym); + {$IFDEF NEWST} + withn : (withsymtables:Pcollection; + withreference:preference; + islocal:boolean); + {$ELSE} + withn : (withsymtable : pwithsymtable; + tablecount : longint; + withreference:preference; + islocal:boolean); + {$ENDIF NEWST} + onn : (exceptsymtable : psymtable;excepttype : pobjectdef); + arrayconstructn : (cargs,cargswap,forcevaria,novariaallowed: boolean;constructdef:pdef); + end; + + function gennode(t : ttreetyp;l,r : ptree) : ptree; + function genlabelnode(t : ttreetyp;nr : pasmlabel) : ptree; + function genloadnode(v : pvarsym;st : psymtable) : ptree; + function genloadcallnode(v: pprocsym;st: psymtable): ptree; + function genloadmethodcallnode(v: pprocsym;st: psymtable; mp:ptree): ptree; + function gensinglenode(t : ttreetyp;l : ptree) : ptree; + function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree; + function genordinalconstnode(v : longint;def : pdef) : ptree; + function genpointerconstnode(v : longint;def : pdef) : ptree; + function genfixconstnode(v : longint;def : pdef) : ptree; + function gentypeconvnode(node : ptree;t : pdef) : ptree; + function gentypenode(t : pdef;sym:ptypesym) : ptree; + function gencallparanode(expr,next : ptree) : ptree; + function genrealconstnode(v : bestreal;def : pdef) : ptree; + function gencallnode(v : pprocsym;st : psymtable) : ptree; + function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree; + + { allow pchar or string for defining a pchar node } + function genstringconstnode(const s : string;st:tstringtype) : ptree; + { length is required for ansistrings } + function genpcharconstnode(s : pchar;length : longint) : ptree; + { helper routine for conststring node } + function getpcharcopy(p : ptree) : pchar; + + function genzeronode(t : ttreetyp) : ptree; + function geninlinenode(number : byte;is_const:boolean;l : ptree) : ptree; + function genprocinlinenode(callp,code : ptree) : ptree; + function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree; + function genenumnode(v : penumsym) : ptree; + function genselfnode(_class : pdef) : ptree; + function gensetconstnode(s : pconstset;settype : psetdef) : ptree; + function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree; + function genasmnode(p_asm : paasmoutput) : ptree; + function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree; +{$IFDEF NEWST} + function genwithnode(symtables:Pcollection;l,r : ptree) : ptree; +{$ELSE} + function genwithnode(symtable:pwithsymtable;l,r : ptree;count : longint) : ptree; +{$ENDIF NEWST} + + function getcopy(p : ptree) : ptree; + + function equal_trees(t1,t2 : ptree) : boolean; +{$ifdef newoptimizations2} + { checks if t1 is loaded more than once in t2 and its sub-trees } + function multiple_uses(t1,t2: ptree): boolean; +{$endif newoptimizations2} + + procedure swaptree(p:Ptree); + procedure disposetree(p : ptree); + procedure putnode(p : ptree); + function getnode : ptree; + procedure clear_location(var loc : tlocation); + procedure set_location(var destloc,sourceloc : tlocation); + procedure swap_location(var destloc,sourceloc : tlocation); + procedure set_file_line(from,_to : ptree); + procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo); +{$ifdef extdebug} + procedure compare_trees(oldp,p : ptree); + const + maxfirstpasscount : longint = 0; +{$endif extdebug} + + { sets the callunique flag, if the node is a vecn, } + { takes care of type casts etc. } + procedure set_unique(p : ptree); + + { sets funcret_is_valid to true, if p contains a funcref node } + procedure set_funcret_is_valid(p : ptree); + + { + type + tvarstaterequire = (vsr_can_be_undefined,vsr_must_be_valid, + vsr_is_used_after,vsr_must_be_valid_and_is_used_after); } + + { sets varsym varstate field correctly } + procedure set_varstate(p : ptree;must_be_valid : boolean); + + { gibt den ordinalen Werten der Node zurueck oder falls sie } + { keinen ordinalen Wert hat, wird ein Fehler erzeugt } + function get_ordinal_value(p : ptree) : longint; + + function is_constnode(p : ptree) : boolean; + { true, if p is a pointer to a const int value } + function is_constintnode(p : ptree) : boolean; + function is_constboolnode(p : ptree) : boolean; + function is_constrealnode(p : ptree) : boolean; + function is_constcharnode(p : ptree) : boolean; + function is_constresourcestringnode(p : ptree) : boolean; + + function str_length(p : ptree) : longint; + function is_emptyset(p : ptree):boolean; + + { counts the labels } + function case_count_labels(root : pcaserecord) : longint; + { searches the highest label } + function case_get_max(root : pcaserecord) : longint; + { searches the lowest label } + function case_get_min(root : pcaserecord) : longint; + + type + pptree = ^ptree; + +{$ifdef TEMPREGDEBUG} + const + curptree : pptree = nil; +{$endif TEMPREGDEBUG} + +{$I innr.inc} + +{$ifdef newcg} +{$I nodeh.inc} +{$endif newcg} + implementation + + uses + systems, + globals,verbose,files,types, +{$ifdef newcg} + cgbase +{$else newcg} + hcodegen +{$endif newcg} +{$IFDEF NEWST} + ,symtablt +{$ENDIF} + ; + + function getnode : ptree; + + var + hp : ptree; + + begin + new(hp); + { makes error tracking easier } + fillchar(hp^,sizeof(ttree),0); + { reset } + hp^.location.loc:=LOC_INVALID; + { save local info } + hp^.fileinfo:=aktfilepos; + hp^.localswitches:=aktlocalswitches; + getnode:=hp; + end; + + + procedure putnode(p : ptree); + begin + { clean up the contents of a node } + case p^.treetype of + asmn : if assigned(p^.p_asm) then + dispose(p^.p_asm,done); + stringconstn : begin + ansistringdispose(p^.value_str,p^.length); + end; + setconstn : begin + if assigned(p^.value_set) then + dispose(p^.value_set); + end; + end; +{$ifdef extdebug} + if p^.firstpasscount>maxfirstpasscount then + maxfirstpasscount:=p^.firstpasscount; +{$endif extdebug} + dispose(p); + end; + + function getcopy(p : ptree) : ptree; + + var + hp : ptree; + + begin + if not assigned(p) then + begin + getcopy:=nil; + exit; + end; + hp:=getnode; + hp^:=p^; + case p^.disposetyp of + dt_leftright : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + if assigned(p^.right) then + hp^.right:=getcopy(p^.right); + end; + dt_leftrighthigh : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + if assigned(p^.right) then + hp^.right:=getcopy(p^.right); + if assigned(p^.hightree) then + hp^.hightree:=getcopy(p^.hightree); + end; + dt_leftrightframe : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + if assigned(p^.right) then + hp^.right:=getcopy(p^.right); + if assigned(p^.frametree) then + hp^.frametree:=getcopy(p^.frametree); + end; + dt_leftrightmethod : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + if assigned(p^.right) then + hp^.right:=getcopy(p^.right); + if assigned(p^.methodpointer) then + hp^.methodpointer:=getcopy(p^.methodpointer); + end; + dt_nothing : ; + dt_left : + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + dt_mbleft : + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + dt_mbleft_and_method : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + hp^.methodpointer:=getcopy(p^.methodpointer); + end; + dt_loop : + begin + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + if assigned(p^.right) then + hp^.right:=getcopy(p^.right); + if assigned(p^.t1) then + hp^.t1:=getcopy(p^.t1); + if assigned(p^.t2) then + hp^.t2:=getcopy(p^.t2); + end; + dt_typeconv : hp^.left:=getcopy(p^.left); + dt_inlinen : + if assigned(p^.left) then + hp^.left:=getcopy(p^.left); + else internalerror(11); + end; + { now check treetype } + case p^.treetype of + stringconstn : begin + hp^.value_str:=getpcharcopy(p); + hp^.length:=p^.length; + end; + setconstn : begin + new(hp^.value_set); + hp^.value_set:=p^.value_set; + end; + end; + getcopy:=hp; + end; + + procedure deletecaselabels(p : pcaserecord); + + begin + if assigned(p^.greater) then + deletecaselabels(p^.greater); + if assigned(p^.less) then + deletecaselabels(p^.less); + dispose(p); + end; + + procedure swaptree(p:Ptree); + + var swapp:Ptree; + + begin + swapp:=p^.right; + p^.right:=p^.left; + p^.left:=swapp; + p^.swaped:=not(p^.swaped); + end; + + + procedure disposetree(p : ptree); + + var + symt : psymtable; + i : longint; + + begin + if not(assigned(p)) then + exit; + if not(p^.treetype in [addn..loadvmtn]) then + internalerror(26219); + case p^.disposetyp of + dt_leftright : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + end; + dt_leftrighthigh : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.hightree) then + disposetree(p^.hightree); + end; + dt_leftrightframe : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.frametree) then + disposetree(p^.frametree); + end; + dt_leftrightmethod : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.methodpointer) then + disposetree(p^.methodpointer); + end; + dt_case : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.nodes) then + deletecaselabels(p^.nodes); + if assigned(p^.elseblock) then + disposetree(p^.elseblock); + end; + dt_nothing : ; + dt_left : + if assigned(p^.left) then + disposetree(p^.left); + dt_mbleft : + if assigned(p^.left) then + disposetree(p^.left); + dt_mbleft_and_method : + begin + if assigned(p^.left) then disposetree(p^.left); + disposetree(p^.methodpointer); + end; + dt_typeconv : disposetree(p^.left); + dt_inlinen : + if assigned(p^.left) then + disposetree(p^.left); + dt_loop : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.t1) then + disposetree(p^.t1); + if assigned(p^.t2) then + disposetree(p^.t2); + end; + dt_onn: + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + if assigned(p^.exceptsymtable) then + dispose(p^.exceptsymtable,done); + end; + dt_with : + begin + if assigned(p^.left) then + disposetree(p^.left); + if assigned(p^.right) then + disposetree(p^.right); + {$IFDEF NEWST} + dispose(p^.withsymtables,done); + {$ELSE} + symt:=p^.withsymtable; + for i:=1 to p^.tablecount do + begin + if assigned(symt) then + begin + p^.withsymtable:=pwithsymtable(symt^.next); + dispose(symt,done); + end; + symt:=p^.withsymtable; + end; + {$ENDIF NEWST} + end; + else internalerror(12); + end; + putnode(p); + end; + + procedure set_file_line(from,_to : ptree); + + begin + if assigned(from) then + _to^.fileinfo:=from^.fileinfo; + end; + + procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo); + begin + p^.fileinfo:=filepos; + end; + +{$IFDEF NEWST} + function genwithnode(symtables:Pcollection;l,r : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_with; + p^.treetype:=withn; + p^.left:=l; + p^.right:=r; + p^.registers32:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + p^.withsymtables:=symtables; + p^.withreference:=nil; + p^.islocal:=false; + set_file_line(l,p); + genwithnode:=p; + end; +{$ELSE} + function genwithnode(symtable : pwithsymtable;l,r : ptree;count : longint) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_with; + p^.treetype:=withn; + p^.left:=l; + p^.right:=r; + p^.registers32:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + p^.withsymtable:=symtable; + p^.tablecount:=count; + p^.withreference:=nil; + p^.islocal:=false; + set_file_line(l,p); + genwithnode:=p; + end; +{$ENDIF NEWST} + + function genfixconstnode(v : longint;def : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=fixconstn; + p^.registers32:=0; + { p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=def; + p^.value:=v; + genfixconstnode:=p; + end; + + function gencallparanode(expr,next : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_leftrighthigh; + p^.treetype:=callparan; + p^.left:=expr; + p^.right:=next; + p^.registers32:=0; + { p^.registers16:=0; + p^.registers8:=0; } +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.registersfpu:=0; + p^.resulttype:=nil; + p^.exact_match_found:=false; + p^.convlevel1found:=false; + p^.convlevel2found:=false; + p^.is_colon_para:=false; + p^.hightree:=nil; + set_file_line(expr,p); + gencallparanode:=p; + end; + + function gennode(t : ttreetyp;l,r : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_leftright; + p^.treetype:=t; + p^.left:=l; + p^.right:=r; + p^.registers32:=0; + { p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + gennode:=p; + end; + + function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_case; + p^.treetype:=casen; + p^.left:=l; + p^.right:=r; + p^.nodes:=nodes; + p^.registers32:=0; + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + set_file_line(l,p); + gencasenode:=p; + end; + + function genloopnode(t : ttreetyp;l,r,n1 : ptree;back : boolean) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_loop; + p^.treetype:=t; + p^.left:=l; + p^.right:=r; + p^.t1:=n1; + p^.t2:=nil; + p^.registers32:=0; + p^.backward:=back; + { p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + set_file_line(l,p); + genloopnode:=p; + end; + + function genordinalconstnode(v : longint;def : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=ordconstn; + p^.registers32:=0; + { p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=def; + p^.value:=v; + {$IFDEF NEWST} + if typeof(p^.resulttype^)=typeof(Torddef) then + testrange(p^.resulttype,p^.value); + {$ELSE NEWST} + if p^.resulttype^.deftype=orddef then + testrange(p^.resulttype,p^.value); + {$ENDIF} + genordinalconstnode:=p; + end; + + function genpointerconstnode(v : longint;def : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=pointerconstn; + p^.registers32:=0; + { p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=def; + p^.value:=v; + genpointerconstnode:=p; + end; + + function genenumnode(v : penumsym) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=ordconstn; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=v^.definition; + p^.value:=v^.value; + testrange(p^.resulttype,p^.value); + genenumnode:=p; + end; + + + function genrealconstnode(v : bestreal;def : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=realconstn; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=def; + p^.value_real:=v; + p^.lab_real:=nil; + genrealconstnode:=p; + end; + + + function genstringconstnode(const s : string;st:tstringtype) : ptree; + + var + p : ptree; + l : longint; + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=stringconstn; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + l:=length(s); + p^.length:=l; + { stringdup write even past a #0 } + getmem(p^.value_str,l+1); + move(s[1],p^.value_str^,l); + p^.value_str[l]:=#0; + p^.lab_str:=nil; + if st=st_default then + begin + if cs_ansistrings in aktlocalswitches then + p^.stringtype:=st_ansistring + else + p^.stringtype:=st_shortstring; + end + else + p^.stringtype:=st; + case p^.stringtype of + st_shortstring : + p^.resulttype:=cshortstringdef; + st_ansistring : + p^.resulttype:=cansistringdef; + else + internalerror(44990099); + end; + genstringconstnode:=p; + end; + + function getpcharcopy(p : ptree) : pchar; + var + pc : pchar; + begin + pc:=nil; + getmem(pc,p^.length+1); + if pc=nil then + Message(general_f_no_memory_left); + move(p^.value_str^,pc^,p^.length+1); + getpcharcopy:=pc; + end; + + + function genpcharconstnode(s : pchar;length : longint) : ptree; + var + p : ptree; + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=stringconstn; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.length:=length; + if (cs_ansistrings in aktlocalswitches) or + (length>255) then + begin + p^.stringtype:=st_ansistring; + p^.resulttype:=cansistringdef; + end + else + begin + p^.stringtype:=st_shortstring; + p^.resulttype:=cshortstringdef; + end; + p^.value_str:=s; + p^.lab_str:=nil; + genpcharconstnode:=p; + end; + + + function gensinglenode(t : ttreetyp;l : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_left; + p^.treetype:=t; + p^.left:=l; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + gensinglenode:=p; + end; + + function genasmnode(p_asm : paasmoutput) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=asmn; + p^.registers32:=4; + p^.p_asm:=p_asm; + p^.object_preserved:=false; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=8; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=8; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + genasmnode:=p; + end; + + function genloadnode(v : pvarsym;st : psymtable) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=loadn; + {$IFDEF NEWST} + p^.resulttype:=v^.definition; + {$ELSE} + p^.resulttype:=v^.vartype.def; + {$ENDIF NEWST} + p^.symtableentry:=v; + p^.symtable:=st; + p^.is_first := False; + { method pointer load nodes can use the left subtree } + p^.disposetyp:=dt_left; + p^.left:=nil; + genloadnode:=p; + end; + + function genloadcallnode(v: pprocsym;st: psymtable): ptree; + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=loadn; + p^.left:=nil; + {$IFDEF NEWST} + p^.resulttype:=nil; {We don't know which overloaded procedure is + wanted...} + {$ELSE} + p^.resulttype:=v^.definition; + {$ENDIF} + p^.symtableentry:=v; + p^.symtable:=st; + p^.is_first := False; + p^.disposetyp:=dt_nothing; + genloadcallnode:=p; + end; + + function genloadmethodcallnode(v: pprocsym;st: psymtable; mp:ptree): ptree; + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=loadn; + p^.left:=nil; + {$IFDEF NEWST} + p^.resulttype:=nil; {We don't know which overloaded procedure is + wanted...} + {$ELSE} + p^.resulttype:=v^.definition; + {$ENDIF} + p^.symtableentry:=v; + p^.symtable:=st; + p^.is_first := False; + p^.disposetyp:=dt_left; + p^.left:=mp; + genloadmethodcallnode:=p; + end; + + + function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=loadn; + p^.left:=nil; + {$IFDEF NEWST} + p^.resulttype:=sym^.definition; + {$ELSE} + p^.resulttype:=sym^.typedconsttype.def; + {$ENDIF NEWST} + p^.symtableentry:=sym; + p^.symtable:=st; + p^.disposetyp:=dt_nothing; + gentypedconstloadnode:=p; + end; + + function gentypeconvnode(node : ptree;t : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_typeconv; + p^.treetype:=typeconvn; + p^.left:=node; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.convtyp:=tc_equal; + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=t; + p^.explizit:=false; + set_file_line(node,p); + gentypeconvnode:=p; + end; + + function gentypenode(t : pdef;sym:ptypesym) : ptree; + var + p : ptree; + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=typen; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=generrordef; + p^.typenodetype:=t; + p^.typenodesym:=sym; + gentypenode:=p; + end; + + function gencallnode(v : pprocsym;st : psymtable) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=calln; + p^.symtableprocentry:=v; + p^.symtableproc:=st; + p^.unit_specific:=false; + p^.no_check:=false; + p^.return_value_used:=true; + p^.disposetyp := dt_leftrightmethod; + p^.methodpointer:=nil; + p^.left:=nil; + p^.right:=nil; + p^.procdefinition:=nil; + gencallnode:=p; + end; + + function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.treetype:=calln; + p^.return_value_used:=true; + p^.symtableprocentry:=v; + p^.symtableproc:=st; + p^.disposetyp:=dt_leftrightmethod; + p^.left:=nil; + p^.right:=nil; + p^.methodpointer:=mp; + p^.procdefinition:=nil; + genmethodcallnode:=p; + end; + + function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_left; + p^.treetype:=subscriptn; + p^.left:=l; + p^.registers32:=0; + p^.vs:=varsym; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + gensubscriptnode:=p; + end; + + function genzeronode(t : ttreetyp) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=t; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + genzeronode:=p; + end; + + function genlabelnode(t : ttreetyp;nr : pasmlabel) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=t; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + { for security } + { nr^.is_used:=true;} + p^.labelnr:=nr; + p^.exceptionblock:=nil; + genlabelnode:=p; + end; + + function genselfnode(_class : pdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=selfn; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=_class; + genselfnode:=p; + end; + + function geninlinenode(number : byte;is_const:boolean;l : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_inlinen; + p^.treetype:=inlinen; + p^.left:=l; + p^.inlinenumber:=number; + p^.inlineconst:=is_const; + p^.registers32:=0; +{ p^.registers16:=0; + p^.registers8:=0; } + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=nil; + geninlinenode:=p; + end; + + + { uses the callnode to create the new procinline node } + function genprocinlinenode(callp,code : ptree) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=procinlinen; + p^.inlineprocsym:=callp^.symtableprocentry; + p^.retoffset:=-4; { less dangerous as zero (PM) } + p^.para_offset:=0; + {$IFDEF NEWST} + {Fixme!!} + internalerror($00022801); + {$ELSE} + p^.para_size:=p^.inlineprocsym^.definition^.para_size(target_os.stackalignment); + if ret_in_param(p^.inlineprocsym^.definition^.rettype.def) then + p^.para_size:=p^.para_size+target_os.size_of_pointer; + {$ENDIF NEWST} + { copy args } + p^.inlinetree:=code; + p^.registers32:=code^.registers32; + p^.registersfpu:=code^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + {$IFDEF NEWST} + {Fixme!!} + {$ELSE} + p^.resulttype:=p^.inlineprocsym^.definition^.rettype.def; + {$ENDIF NEWST} + genprocinlinenode:=p; + end; + + function gensetconstnode(s : pconstset;settype : psetdef) : ptree; + + var + p : ptree; + + begin + p:=getnode; + p^.disposetyp:=dt_nothing; + p^.treetype:=setconstn; + p^.registers32:=0; + p^.registersfpu:=0; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=0; +{$endif SUPPORT_MMX} + p^.resulttype:=settype; + p^.left:=nil; + new(p^.value_set); + p^.value_set^:=s^; + gensetconstnode:=p; + end; + +{$ifdef extdebug} + procedure compare_trees(oldp,p : ptree); + + var + error_found : boolean; + + begin + if oldp^.resulttype<>p^.resulttype then + begin + error_found:=true; + if is_equal(oldp^.resulttype,p^.resulttype) then + comment(v_debug,'resulttype fields are different but equal') + else + comment(v_warning,'resulttype fields are really different'); + end; + if oldp^.treetype<>p^.treetype then + begin + comment(v_warning,'treetype field different'); + error_found:=true; + end + else + comment(v_debug,' treetype '+tostr(longint(oldp^.treetype))); + if oldp^.error<>p^.error then + begin + comment(v_warning,'error field different'); + error_found:=true; + end; + if oldp^.disposetyp<>p^.disposetyp then + begin + comment(v_warning,'disposetyp field different'); + error_found:=true; + end; + { is true, if the right and left operand are swaped } + if oldp^.swaped<>p^.swaped then + begin + comment(v_warning,'swaped field different'); + error_found:=true; + end; + + { the location of the result of this node } + if oldp^.location.loc<>p^.location.loc then + begin + comment(v_warning,'location.loc field different'); + error_found:=true; + end; + + { the number of registers needed to evalute the node } + if oldp^.registers32<>p^.registers32 then + begin + comment(v_warning,'registers32 field different'); + comment(v_warning,' old '+tostr(oldp^.registers32)+'<> new '+tostr(p^.registers32)); + error_found:=true; + end; + if oldp^.registersfpu<>p^.registersfpu then + begin + comment(v_warning,'registersfpu field different'); + error_found:=true; + end; +{$ifdef SUPPORT_MMX} + if oldp^.registersmmx<>p^.registersmmx then + begin + comment(v_warning,'registersmmx field different'); + error_found:=true; + end; +{$endif SUPPORT_MMX} + if oldp^.left<>p^.left then + begin + comment(v_warning,'left field different'); + error_found:=true; + end; + if oldp^.right<>p^.right then + begin + comment(v_warning,'right field different'); + error_found:=true; + end; + if oldp^.fileinfo.line<>p^.fileinfo.line then + begin + comment(v_warning,'fileinfo.line field different'); + error_found:=true; + end; + if oldp^.fileinfo.column<>p^.fileinfo.column then + begin + comment(v_warning,'fileinfo.column field different'); + error_found:=true; + end; + if oldp^.fileinfo.fileindex<>p^.fileinfo.fileindex then + begin + comment(v_warning,'fileinfo.fileindex field different'); + error_found:=true; + end; + if oldp^.localswitches<>p^.localswitches then + begin + comment(v_warning,'localswitches field different'); + error_found:=true; + end; +{$ifdef extdebug} + if oldp^.firstpasscount<>p^.firstpasscount then + begin + comment(v_warning,'firstpasscount field different'); + error_found:=true; + end; +{$endif extdebug} + if oldp^.treetype=p^.treetype then + case oldp^.treetype of + addn : + begin + if oldp^.use_strconcat<>p^.use_strconcat then + begin + comment(v_warning,'use_strconcat field different'); + error_found:=true; + end; + if oldp^.string_typ<>p^.string_typ then + begin + comment(v_warning,'stringtyp field different'); + error_found:=true; + end; + end; + callparan : + {(is_colon_para : boolean;exact_match_found : boolean);} + begin + if oldp^.is_colon_para<>p^.is_colon_para then + begin + comment(v_warning,'use_strconcat field different'); + error_found:=true; + end; + if oldp^.exact_match_found<>p^.exact_match_found then + begin + comment(v_warning,'exact_match_found field different'); + error_found:=true; + end; + end; + assignn : + {(assigntyp : tassigntyp;concat_string : boolean);} + begin + if oldp^.assigntyp<>p^.assigntyp then + begin + comment(v_warning,'assigntyp field different'); + error_found:=true; + end; + if oldp^.concat_string<>p^.concat_string then + begin + comment(v_warning,'concat_string field different'); + error_found:=true; + end; + end; + loadn : + {(symtableentry : psym;symtable : psymtable; + is_absolute,is_first : boolean);} + begin + if oldp^.symtableentry<>p^.symtableentry then + begin + comment(v_warning,'symtableentry field different'); + error_found:=true; + end; + if oldp^.symtable<>p^.symtable then + begin + comment(v_warning,'symtable field different'); + error_found:=true; + end; + if oldp^.is_absolute<>p^.is_absolute then + begin + comment(v_warning,'is_absolute field different'); + error_found:=true; + end; + if oldp^.is_first<>p^.is_first then + begin + comment(v_warning,'is_first field different'); + error_found:=true; + end; + end; + calln : + {(symtableprocentry : pprocsym; + symtableproc : psymtable;procdefinition : pprocdef; + methodpointer : ptree; + no_check,unit_specific : boolean);} + begin + if oldp^.symtableprocentry<>p^.symtableprocentry then + begin + comment(v_warning,'symtableprocentry field different'); + error_found:=true; + end; + if oldp^.symtableproc<>p^.symtableproc then + begin + comment(v_warning,'symtableproc field different'); + error_found:=true; + end; + if oldp^.procdefinition<>p^.procdefinition then + begin + comment(v_warning,'procdefinition field different'); + error_found:=true; + end; + if oldp^.methodpointer<>p^.methodpointer then + begin + comment(v_warning,'methodpointer field different'); + error_found:=true; + end; + if oldp^.no_check<>p^.no_check then + begin + comment(v_warning,'no_check field different'); + error_found:=true; + end; + if oldp^.unit_specific<>p^.unit_specific then + begin + error_found:=true; + comment(v_warning,'unit_specific field different'); + end; + end; + ordconstn : + begin + if oldp^.value<>p^.value then + begin + comment(v_warning,'value field different'); + error_found:=true; + end; + end; + realconstn : + begin + if oldp^.value_real<>p^.value_real then + begin + comment(v_warning,'valued field different'); + error_found:=true; + end; + if oldp^.lab_real<>p^.lab_real then + begin + comment(v_warning,'labnumber field different'); + error_found:=true; + end; + { if oldp^.realtyp<>p^.realtyp then + begin + comment(v_warning,'realtyp field different'); + error_found:=true; + end; } + end; + end; + if not error_found then + comment(v_warning,'did not find difference in trees'); + + end; +{$endif extdebug} + + function equal_trees(t1,t2 : ptree) : boolean; + + begin + if t1^.treetype=t2^.treetype then + begin + case t1^.treetype of + addn, + muln, + equaln, + orn, + xorn, + andn, + unequaln: + begin + equal_trees:=(equal_trees(t1^.left,t2^.left) and + equal_trees(t1^.right,t2^.right)) or + (equal_trees(t1^.right,t2^.left) and + equal_trees(t1^.left,t2^.right)); + end; + subn, + divn, + modn, + assignn, + ltn, + lten, + gtn, + gten, + inn, + shrn, + shln, + slashn, + rangen: + begin + equal_trees:=(equal_trees(t1^.left,t2^.left) and + equal_trees(t1^.right,t2^.right)); + end; + unaryminusn, + notn, + derefn, + addrn: + begin + equal_trees:=(equal_trees(t1^.left,t2^.left)); + end; + loadn: + begin + equal_trees:=(t1^.symtableentry=t2^.symtableentry) + { not necessary + and (t1^.symtable=t2^.symtable)}; + end; + { + + subscriptn, + ordconstn,typeconvn,calln,callparan, + realconstn,asmn,vecn, + stringconstn,funcretn,selfn, + inlinen,niln,errorn, + typen,hnewn,hdisposen,newn, + disposen,setelen,setconstrn + } + else equal_trees:=false; + end; + end + else + equal_trees:=false; + end; + +{$ifdef newoptimizations2} + function multiple_uses(t1,t2: ptree): boolean; + var nr: longint; + + procedure check_tree(t: ptree); + begin + inc(nr,ord(equal_trees(t1,t))); + if (nr < 2) and assigned(t^.left) then + check_tree(t^.left); + if (nr < 2) and assigned(t^.right) then + check_tree(t^.right); + end; + + begin + nr := 0; + check_tree(t2); + multiple_uses := nr > 1; + end; +{$endif newoptimizations2} + + procedure set_unique(p : ptree); + + begin + if assigned(p) then + begin + case p^.treetype of + vecn: + p^.callunique:=true; + typeconvn,subscriptn,derefn: + set_unique(p^.left); + end; + end; + end; + + procedure set_funcret_is_valid(p : ptree); + + begin + if assigned(p) then + begin + case p^.treetype of + funcretn: + begin + if p^.is_first_funcret then + pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned; + end; + vecn,typeconvn,subscriptn{,derefn}: + set_funcret_is_valid(p^.left); + end; + end; + end; + + procedure set_varstate(p : ptree;must_be_valid : boolean); + + begin + if not assigned(p) then + exit + else + begin + if p^.varstateset then + exit; + case p^.treetype of + typeconvn : + if p^.convtyp in + [ + tc_cchar_2_pchar, + tc_cstring_2_pchar, + tc_array_2_pointer + ] then + set_varstate(p^.left,false) + else if p^.convtyp in + [ + tc_pchar_2_string, + tc_pointer_2_array + ] then + set_varstate(p^.left,true) + else + set_varstate(p^.left,must_be_valid); + subscriptn : + set_varstate(p^.left,must_be_valid); + vecn: + begin + {$IFDEF NEWST} + if (typeof(p^.left^.resulttype^)=typeof(Tstringdef)) or + (typeof(p^.left^.resulttype^)=typeof(Tarraydef)) then + set_varstate(p^.left,must_be_valid) + else + set_varstate(p^.left,true); + {$ELSE} + if (p^.left^.resulttype^.deftype in [stringdef,arraydef]) then + set_varstate(p^.left,must_be_valid) + else + set_varstate(p^.left,true); + {$ENDIF NEWST} + set_varstate(p^.right,true); + end; + { do not parse calln } + calln : ; + callparan: + begin + set_varstate(p^.left,must_be_valid); + set_varstate(p^.right,must_be_valid); + end; + loadn : + {$IFDEF NEWST} + if (typeof(p^.symtableentry^)=typeof(Tvarsym)) or + (typeof(p^.symtableentry^)=typeof(Tparamsym)) then + begin + if must_be_valid and p^.is_first then + begin + if (pvarsym(p^.symtableentry)^.state=vs_declared_and_first_found) or + (pvarsym(p^.symtableentry)^.state=vs_set_but_first_not_passed) then + if (assigned(pvarsym(p^.symtableentry)^.owner) and + assigned(aktprocsym) and + (pvarsym(p^.symtableentry)^.owner= + Pcontainingsymtable(aktprocdef^.localst))) then + begin + if typeof(p^.symtable^)=typeof(Tprocsymtable) then + CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name) + else + CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name); + end; + end; + if (p^.is_first) then + begin + if pvarsym(p^.symtableentry)^.state=vs_declared_and_first_found then + { this can only happen at left of an assignment, no ? PM } + if (parsing_para_level=0) and not must_be_valid then + pvarsym(p^.symtableentry)^.state:=vs_assigned + else + pvarsym(p^.symtableentry)^.state:=vs_used; + if pvarsym(p^.symtableentry)^.state=vs_set_but_first_not_passed then + pvarsym(p^.symtableentry)^.state:=vs_used; + p^.is_first:=false; + end + else + begin + if (pvarsym(p^.symtableentry)^.state=vs_assigned) and + (must_be_valid or (parsing_para_level>0) or + (typeof(p^.resulttype^)=typeof(Tprocvardef))) then + pvarsym(p^.symtableentry)^.state:=vs_used; + if (pvarsym(p^.symtableentry)^.state=vs_declared_and_first_found) and + (must_be_valid or (parsing_para_level>0) or + (typeof(p^.resulttype^)=typeof(Tprocvardef))) then + pvarsym(p^.symtableentry)^.state:=vs_set_but_first_not_passed; + end; + end; + {$ELSE} + if (p^.symtableentry^.typ=varsym) then + begin + if must_be_valid and p^.is_first then + begin + if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) or + (pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed) then + if (assigned(pvarsym(p^.symtableentry)^.owner) and + assigned(aktprocsym) and + (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then + begin + if p^.symtable^.symtabletype=localsymtable then + CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name) + else + CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name); + end; + end; + if (p^.is_first) then + begin + if pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found then + { this can only happen at left of an assignment, no ? PM } + if (parsing_para_level=0) and not must_be_valid then + pvarsym(p^.symtableentry)^.varstate:=vs_assigned + else + pvarsym(p^.symtableentry)^.varstate:=vs_used; + if pvarsym(p^.symtableentry)^.varstate=vs_set_but_first_not_passed then + pvarsym(p^.symtableentry)^.varstate:=vs_used; + p^.is_first:=false; + end + else + begin + if (pvarsym(p^.symtableentry)^.varstate=vs_assigned) and + (must_be_valid or (parsing_para_level>0) or + (p^.resulttype^.deftype=procvardef)) then + pvarsym(p^.symtableentry)^.varstate:=vs_used; + if (pvarsym(p^.symtableentry)^.varstate=vs_declared_and_first_found) and + (must_be_valid or (parsing_para_level>0) or + (p^.resulttype^.deftype=procvardef)) then + pvarsym(p^.symtableentry)^.varstate:=vs_set_but_first_not_passed; + end; + end; + {$ENDIF NEWST} + funcretn: + begin + { no claim if setting higher return value_str } + if must_be_valid and + (procinfo=pprocinfo(p^.funcretprocinfo)) and + ((procinfo^.funcret_state=vs_declared) or + ((p^.is_first_funcret) and + (procinfo^.funcret_state=vs_declared_and_first_found))) then + begin + CGMessage(sym_w_function_result_not_set); + { avoid multiple warnings } + procinfo^.funcret_state:=vs_assigned; + end; + if p^.is_first_funcret and not must_be_valid then + pprocinfo(p^.funcretprocinfo)^.funcret_state:=vs_assigned; + end; + else + begin + {internalerror(565656);} + end; + end;{case } + p^.varstateset:=true; + end; + end; + + procedure clear_location(var loc : tlocation); + + begin + loc.loc:=LOC_INVALID; + end; + + {This is needed if you want to be able to delete the string with the nodes !!} + procedure set_location(var destloc,sourceloc : tlocation); + + begin + destloc:= sourceloc; + end; + + procedure swap_location(var destloc,sourceloc : tlocation); + + var + swapl : tlocation; + + begin + swapl := destloc; + destloc := sourceloc; + sourceloc := swapl; + end; + + + function get_ordinal_value(p : ptree) : longint; + begin + if p^.treetype=ordconstn then + get_ordinal_value:=p^.value + else + begin + Message(type_e_ordinal_expr_expected); + get_ordinal_value:=0; + end; + end; + + + function is_constnode(p : ptree) : boolean; + begin + is_constnode:=(p^.treetype in [ordconstn,realconstn,stringconstn,fixconstn,setconstn]); + end; + + + function is_constintnode(p : ptree) : boolean; + begin + is_constintnode:=(p^.treetype=ordconstn) and is_integer(p^.resulttype); + end; + + + function is_constcharnode(p : ptree) : boolean; + + begin + is_constcharnode:=(p^.treetype=ordconstn) and is_char(p^.resulttype); + end; + + function is_constrealnode(p : ptree) : boolean; + + begin + is_constrealnode:=(p^.treetype=realconstn); + end; + + function is_constboolnode(p : ptree) : boolean; + + begin + is_constboolnode:=(p^.treetype=ordconstn) and is_boolean(p^.resulttype); + end; + + + function is_constresourcestringnode(p : ptree) : boolean; + begin + is_constresourcestringnode:=(p^.treetype=loadn) and + (p^.symtableentry^.typ=constsym) and + (pconstsym(p^.symtableentry)^.consttyp=constresourcestring); + end; + + + function str_length(p : ptree) : longint; + + begin + str_length:=p^.length; + end; + + + function is_emptyset(p : ptree):boolean; + { + return true if set s is empty + } + var + i : longint; + begin + i:=0; + if p^.treetype=setconstn then + begin + while (i<32) and (p^.value_set^[i]=0) do + inc(i); + end; + is_emptyset:=(i=32); + end; + + +{***************************************************************************** + Case Helpers +*****************************************************************************} + + function case_count_labels(root : pcaserecord) : longint; + var + _l : longint; + + procedure count(p : pcaserecord); + begin + inc(_l); + if assigned(p^.less) then + count(p^.less); + if assigned(p^.greater) then + count(p^.greater); + end; + + begin + _l:=0; + count(root); + case_count_labels:=_l; + end; + + + function case_get_max(root : pcaserecord) : longint; + var + hp : pcaserecord; + begin + hp:=root; + while assigned(hp^.greater) do + hp:=hp^.greater; + case_get_max:=hp^._high; + end; + + + function case_get_min(root : pcaserecord) : longint; + var + hp : pcaserecord; + begin + hp:=root; + while assigned(hp^.less) do + hp:=hp^.less; + case_get_min:=hp^._low; + end; + +{$ifdef newcg} +{$I node.inc} +{$endif newcg} +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.122 2000/06/29 13:49:39 jonas + * fixed copy/paste bugs in getcopy + + Revision 1.121 2000/06/06 20:24:07 pierre + Generate a warning if function result is a pointer and result^:=x; is used + + Revision 1.120 2000/05/17 17:10:06 peter + * add support for loading of typed const strings with resourcestrings, + made the loading also a bit more generic + + Revision 1.119 2000/04/25 14:43:37 jonas + - disabled "string_var := string_var + ... " and "string_var + char_var" + optimizations (were only active with -dnewoptimizations) because of + several internal issues + + Revision 1.118 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.117 2000/04/08 16:22:11 jonas + * fixed concat_string optimization and enabled it when + -dnewoptimizations is used + + Revision 1.116 2000/03/01 15:36:12 florian + * some new stuff for the new cg + + Revision 1.115 2000/03/01 11:43:55 daniel + * Some more work on the new symtable. + + Symtable stack unit 'symstack' added. + + Revision 1.114 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.113 2000/02/20 20:49:46 florian + * newcg is compiling + * fixed the dup id problem reported by Paul Y. + + Revision 1.112 2000/02/17 14:53:43 florian + * some updates for the newcg + + Revision 1.111 2000/02/09 13:23:09 peter + * log truncated + + Revision 1.110 2000/01/26 12:02:30 peter + * abstractprocdef.para_size needs alignment parameter + * secondcallparan gets para_alignment size instead of dword_align + + Revision 1.109 2000/01/09 23:16:07 peter + * added st_default stringtype + * genstringconstnode extended with stringtype parameter using st_default + will do the old behaviour + + Revision 1.108 2000/01/07 01:14:48 peter + * updated copyright to 2000 + + Revision 1.107 2000/01/06 01:10:33 pierre + * fixes for set_varstate on conversions + + Revision 1.106 1999/12/22 01:01:52 peter + - removed freelabel() + * added undefined label detection in internal assembler, this prevents + a lot of ld crashes and wrong .o files + * .o files aren't written anymore if errors have occured + * inlining of assembler labels is now correct + + Revision 1.105 1999/12/14 09:58:42 florian + + compiler checks now if a goto leaves an exception block + + Revision 1.104 1999/11/30 10:40:59 peter + + ttype, tsymlist + + Revision 1.103 1999/11/18 15:34:51 pierre + * Notes/Hints for local syms changed to + Set_varstate function + + Revision 1.102 1999/11/17 17:05:07 pierre + * Notes/hints changes + + Revision 1.101 1999/11/06 14:34:31 peter + * truncated log to 20 revs + + Revision 1.100 1999/10/22 14:37:31 peter + * error when properties are passed to var parameters + + Revision 1.99 1999/09/27 23:45:03 peter + * procinfo is now a pointer + * support for result setting in sub procedure + + Revision 1.98 1999/09/26 21:30:22 peter + + constant pointer support which can happend with typecasting like + const p=pointer(1) + * better procvar parsing in typed consts + + Revision 1.97 1999/09/17 17:14:13 peter + * @procvar fixes for tp mode + * @:= gives now an error + + Revision 1.96 1999/09/16 11:34:59 pierre + * typo correction + + Revision 1.95 1999/09/10 18:48:11 florian + * some bug fixes (e.g. must_be_valid and procinfo^.funcret_is_valid) + * most things for stored properties fixed + + Revision 1.94 1999/09/07 07:52:20 peter + * > < >= <= support for boolean + * boolean constants are now calculated like integer constants + + Revision 1.93 1999/08/27 10:38:31 pierre + + EXTTEMPREGDEBUG code added + + Revision 1.92 1999/08/26 21:10:08 peter + * better error recovery for case + + Revision 1.91 1999/08/23 23:26:00 pierre + + TEMPREGDEBUG code, test of register allocation + if a tree uses more than registers32 regs then + internalerror(10) is issued + + EXTTEMPREGDEBUG will also give internalerror(10) if + a same register is freed twice (happens in several part + of current compiler like addn for strings and sets) + +} diff --git a/befpc/compiler/types.pas b/befpc/compiler/types.pas new file mode 100644 index 0000000..334c7b8 --- /dev/null +++ b/befpc/compiler/types.pas @@ -0,0 +1,1187 @@ +{ + $Id: types.pas,v 1.1.1.1 2001-07-23 17:17:23 memson Exp $ + Copyright (C) 1998-2000 by Florian Klaempfl + + This unit provides some help routines for type handling + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit types; +interface + + uses + cobjects,symtable + {$IFDEF NEWST} + ,defs + {$ENDIF NEWST}; + + type + tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit, + mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle); + + const + { true if we must never copy this parameter } + never_copy_const_param : boolean = false; + +{***************************************************************************** + Basic type functions + *****************************************************************************} + + { returns true, if def defines an ordinal type } + function is_ordinal(def : pdef) : boolean; + + { returns the min. value of the type } + function get_min_value(def : pdef) : longint; + + { returns true, if def defines an ordinal type } + function is_integer(def : pdef) : boolean; + + { true if p is a boolean } + function is_boolean(def : pdef) : boolean; + + { true if p is a char } + function is_char(def : pdef) : boolean; + + { true if p is a void} + function is_void(def : pdef) : boolean; + + { true if p is a smallset def } + function is_smallset(p : pdef) : boolean; + + { returns true, if def defines a signed data type (only for ordinal types) } + function is_signed(def : pdef) : boolean; + +{***************************************************************************** + Array helper functions + *****************************************************************************} + + { true, if p points to a zero based (non special like open or + dynamic array def, mainly this is used to see if the array + is convertable to a pointer } + function is_zero_based_array(p : pdef) : boolean; + + { true if p points to an open array def } + function is_open_array(p : pdef) : boolean; + + { true, if p points to an array of const def } + function is_array_constructor(p : pdef) : boolean; + + { true, if p points to a variant array } + function is_variant_array(p : pdef) : boolean; + + { true, if p points to an array of const } + function is_array_of_const(p : pdef) : boolean; + + { true, if p points any kind of special array } + function is_special_array(p : pdef) : boolean; + + { true if p is a char array def } + function is_chararray(p : pdef) : boolean; + +{***************************************************************************** + String helper functions + *****************************************************************************} + + { true if p points to an open string def } + function is_open_string(p : pdef) : boolean; + + { true if p is an ansi string def } + function is_ansistring(p : pdef) : boolean; + + { true if p is a long string def } + function is_longstring(p : pdef) : boolean; + + { true if p is a wide string def } + function is_widestring(p : pdef) : boolean; + + { true if p is a short string def } + function is_shortstring(p : pdef) : boolean; + + { true if p is a pchar def } + function is_pchar(p : pdef) : boolean; + + { true if p is a voidpointer def } + function is_voidpointer(p : pdef) : boolean; + + { returns true, if def uses FPU } + function is_fpu(def : pdef) : boolean; + + { true if the return value is in EAX } + function ret_in_acc(def : pdef) : boolean; + + { true if uses a parameter as return value } + function ret_in_param(def : pdef) : boolean; + + { true, if def is a 64 bit int type } + function is_64bitint(def : pdef) : boolean; + + function push_high_param(def : pdef) : boolean; + + { true if a parameter is too large to copy and only the address is pushed } + function push_addr_param(def : pdef) : boolean; + + { true, if def1 and def2 are semantical the same } + function is_equal(def1,def2 : pdef) : boolean; + + { checks for type compatibility (subgroups of type) } + { used for case statements... probably missing stuff } + { to use on other types } + function is_subequal(def1, def2: pdef): boolean; + + { same as is_equal, but with error message if failed } + function CheckTypes(def1,def2 : pdef) : boolean; + + { true, if two parameter lists are equal } + { if acp is cp_none, all have to match exactly } + { if acp is cp_value_equal_const call by value } + { and call by const parameter are assumed as } + { equal } + { if acp is cp_all the var const or nothing are considered equal } + type + compare_type = ( cp_none, cp_value_equal_const, cp_all); + + function equal_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean; + + + { true if a type can be allowed for another one + in a func var } + function convertable_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean; + + { true if a function can be assigned to a procvar } + function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean; + + { if l isn't in the range of def a range check error is generated and + the value is placed within the range } + procedure testrange(def : pdef;var l : longint); + + { returns the range of def } + procedure getrange(def : pdef;var l : longint;var h : longint); + + { some type helper routines for MMX support } + function is_mmx_able_array(p : pdef) : boolean; + + { returns the mmx type } + function mmx_type(p : pdef) : tmmxtype; + + { returns true, if sym needs an entry in the proplist of a class rtti } + function needs_prop_entry(sym : psym) : boolean; + + { returns true, if p contains data which needs init/final code } + function needs_init_final(p : psymtable) : boolean; + +implementation + + uses + strings,globtype,globals,htypechk, + tree,verbose,symconst; + + var + b_needs_init_final : boolean; + + procedure _needs_init_final(p : pnamedindexobject);{$ifndef FPC}far;{$endif} + + + begin + if (psym(p)^.typ=varsym) and + assigned(pvarsym(p)^.vartype.def) and + not((pvarsym(p)^.vartype.def^.deftype=objectdef) and + pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and + pvarsym(p)^.vartype.def^.needs_inittable then + b_needs_init_final:=true; + end; + + { returns true, if p contains data which needs init/final code } + function needs_init_final(p : psymtable) : boolean; + + begin + b_needs_init_final:=false; + p^.foreach({$ifndef TP}@{$endif}_needs_init_final); + needs_init_final:=b_needs_init_final; + end; + + function needs_prop_entry(sym : psym) : boolean; + + begin + needs_prop_entry:=(sp_published in psym(sym)^.symoptions) and + (sym^.typ in [propertysym,varsym]); + end; + + { compare_type = ( cp_none, cp_value_equal_const, cp_all); } + + function equal_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean; + var + def1,def2 : pparaitem; + begin + def1:=pparaitem(paralist1^.first); + def2:=pparaitem(paralist2^.first); + while (assigned(def1)) and (assigned(def2)) do + begin + case acp of + cp_value_equal_const : + begin + if not(is_equal(def1^.paratype.def,def2^.paratype.def)) or + ((def1^.paratyp<>def2^.paratyp) and + ((def1^.paratyp=vs_var) or + (def1^.paratyp=vs_var) + ) + ) then + begin + equal_paras:=false; + exit; + end; + end; + cp_all : + begin + if not(is_equal(def1^.paratype.def,def2^.paratype.def)) or + (def1^.paratyp<>def2^.paratyp) then + begin + equal_paras:=false; + exit; + end; + end; + cp_none : + begin + if not(is_equal(def1^.paratype.def,def2^.paratype.def)) then + begin + equal_paras:=false; + exit; + end; + end; + end; + def1:=pparaitem(def1^.next); + def2:=pparaitem(def2^.next); + end; + if (def1=nil) and (def2=nil) then + equal_paras:=true + else + equal_paras:=false; + end; + + function convertable_paras(paralist1,paralist2 : plinkedlist;acp : compare_type) : boolean; + var + def1,def2 : pparaitem; + doconv : tconverttype; + begin + def1:=pparaitem(paralist1^.first); + def2:=pparaitem(paralist2^.first); + while (assigned(def1)) and (assigned(def2)) do + begin + case acp of + cp_value_equal_const : + begin + if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or + ((def1^.paratyp<>def2^.paratyp) and + ((def1^.paratyp=vs_var) or + (def1^.paratyp=vs_var) + ) + ) then + begin + convertable_paras:=false; + exit; + end; + end; + cp_all : + begin + if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or + (def1^.paratyp<>def2^.paratyp) then + begin + convertable_paras:=false; + exit; + end; + end; + cp_none : + begin + if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) then + begin + convertable_paras:=false; + exit; + end; + end; + end; + def1:=pparaitem(def1^.next); + def2:=pparaitem(def2^.next); + end; + if (def1=nil) and (def2=nil) then + convertable_paras:=true + else + convertable_paras:=false; + end; + + + { true if a function can be assigned to a procvar } + function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean; + const + po_comp = po_compatibility_options-[po_methodpointer,po_classmethod]; + var + ismethod : boolean; + begin + proc_to_procvar_equal:=false; + if not(assigned(def1)) or not(assigned(def2)) then + exit; + { check for method pointer } + ismethod:=assigned(def1^.owner) and + (def1^.owner^.symtabletype=objectsymtable); + { I think methods of objects are also not compatible } + { with procedure variables! (FK) + and + assigned(def1^.owner^.defowner) and + (pobjectdef(def1^.owner^.defowner)^.is_class); } + if (ismethod and not (po_methodpointer in def2^.procoptions)) or + (not(ismethod) and (po_methodpointer in def2^.procoptions)) then + begin + Message(type_e_no_method_and_procedure_not_compatible); + exit; + end; + { check return value and para's and options, methodpointer is already checked + parameters may also be convertable } + if is_equal(def1^.rettype.def,def2^.rettype.def) and + (equal_paras(def1^.para,def2^.para,cp_all) or + convertable_paras(def1^.para,def2^.para,cp_all)) and + ((po_comp * def1^.procoptions)= (po_comp * def2^.procoptions)) then + proc_to_procvar_equal:=true + else + proc_to_procvar_equal:=false; + end; + + + { returns true, if def uses FPU } + function is_fpu(def : pdef) : boolean; + begin + is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit); + end; + + + { true if p is an ordinal } + function is_ordinal(def : pdef) : boolean; + var + dt : tbasetype; + begin + case def^.deftype of + orddef : + begin + dt:=porddef(def)^.typ; + is_ordinal:=dt in [uchar, + u8bit,u16bit,u32bit,u64bit, + s8bit,s16bit,s32bit,s64bit, + bool8bit,bool16bit,bool32bit]; + end; + enumdef : + is_ordinal:=true; + else + is_ordinal:=false; + end; + end; + + + { returns the min. value of the type } + function get_min_value(def : pdef) : longint; + begin + case def^.deftype of + orddef: + get_min_value:=porddef(def)^.low; + enumdef: + get_min_value:=penumdef(def)^.min; + else + get_min_value:=0; + end; + end; + + + { true if p is an integer } + function is_integer(def : pdef) : boolean; + begin + is_integer:=(def^.deftype=orddef) and + (porddef(def)^.typ in [uauto,u8bit,u16bit,u32bit,u64bit, + s8bit,s16bit,s32bit,s64bit]); + end; + + + { true if p is a boolean } + function is_boolean(def : pdef) : boolean; + begin + is_boolean:=(def^.deftype=orddef) and + (porddef(def)^.typ in [bool8bit,bool16bit,bool32bit]); + end; + + + { true if p is a void } + function is_void(def : pdef) : boolean; + begin + is_void:=(def^.deftype=orddef) and + (porddef(def)^.typ=uvoid); + end; + + + { true if p is a char } + function is_char(def : pdef) : boolean; + begin + is_char:=(def^.deftype=orddef) and + (porddef(def)^.typ=uchar); + end; + + + { true if p is signed (integer) } + function is_signed(def : pdef) : boolean; + var + dt : tbasetype; + begin + case def^.deftype of + orddef : + begin + dt:=porddef(def)^.typ; + is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]); + end; + enumdef : + is_signed:=false; + else + is_signed:=false; + end; + end; + + + { true, if p points to an open array def } + function is_open_string(p : pdef) : boolean; + begin + is_open_string:=(p^.deftype=stringdef) and + (pstringdef(p)^.string_typ=st_shortstring) and + (pstringdef(p)^.len=0); + end; + + + { true, if p points to a zero based array def } + function is_zero_based_array(p : pdef) : boolean; + begin + is_zero_based_array:=(p^.deftype=arraydef) and + (parraydef(p)^.lowrange=0) and + not(is_special_array(p)); + end; + + { true, if p points to an open array def } + function is_open_array(p : pdef) : boolean; + begin + { check for s32bitdef is needed, because for u32bit the high + range is also -1 ! (PFV) } + is_open_array:=(p^.deftype=arraydef) and + (parraydef(p)^.rangetype.def=pdef(s32bitdef)) and + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=-1) and + not(parraydef(p)^.IsConstructor) and + not(parraydef(p)^.IsVariant) and + not(parraydef(p)^.IsArrayOfConst); + + end; + + { true, if p points to an array of const def } + function is_array_constructor(p : pdef) : boolean; + begin + is_array_constructor:=(p^.deftype=arraydef) and + (parraydef(p)^.IsConstructor); + end; + + { true, if p points to a variant array } + function is_variant_array(p : pdef) : boolean; + begin + is_variant_array:=(p^.deftype=arraydef) and + (parraydef(p)^.IsVariant); + end; + + { true, if p points to an array of const } + function is_array_of_const(p : pdef) : boolean; + begin + is_array_of_const:=(p^.deftype=arraydef) and + (parraydef(p)^.IsArrayOfConst); + end; + + { true, if p points to a special array } + function is_special_array(p : pdef) : boolean; + begin + is_special_array:=(p^.deftype=arraydef) and + ((parraydef(p)^.IsVariant) or + (parraydef(p)^.IsArrayOfConst) or + (parraydef(p)^.IsConstructor) or + is_open_array(p) + ); + end; + + { true if p is an ansi string def } + function is_ansistring(p : pdef) : boolean; + begin + is_ansistring:=(p^.deftype=stringdef) and + (pstringdef(p)^.string_typ=st_ansistring); + end; + + + { true if p is an long string def } + function is_longstring(p : pdef) : boolean; + begin + is_longstring:=(p^.deftype=stringdef) and + (pstringdef(p)^.string_typ=st_longstring); + end; + + + { true if p is an wide string def } + function is_widestring(p : pdef) : boolean; + begin + is_widestring:=(p^.deftype=stringdef) and + (pstringdef(p)^.string_typ=st_widestring); + end; + + + { true if p is an short string def } + function is_shortstring(p : pdef) : boolean; + begin + is_shortstring:=(p^.deftype=stringdef) and + (pstringdef(p)^.string_typ=st_shortstring); + end; + + { true if p is a char array def } + function is_chararray(p : pdef) : boolean; + begin + is_chararray:=(p^.deftype=arraydef) and + is_equal(parraydef(p)^.elementtype.def,cchardef) and + not(is_special_array(p)); + end; + + + { true if p is a pchar def } + function is_pchar(p : pdef) : boolean; + begin + is_pchar:=(p^.deftype=pointerdef) and + is_equal(Ppointerdef(p)^.pointertype.def,cchardef); + end; + + + { true if p is a voidpointer def } + function is_voidpointer(p : pdef) : boolean; + begin + is_voidpointer:=(p^.deftype=pointerdef) and + is_equal(Ppointerdef(p)^.pointertype.def,voiddef); + end; + + + { true if p is a smallset def } + function is_smallset(p : pdef) : boolean; + begin + is_smallset:=(p^.deftype=setdef) and + (psetdef(p)^.settype=smallset); + end; + + + { true if the return value is in accumulator (EAX for i386), D0 for 68k } + function ret_in_acc(def : pdef) : boolean; + begin + ret_in_acc:=(def^.deftype in [orddef,pointerdef,enumdef,classrefdef]) or + ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or + ((def^.deftype=procvardef) and not(po_methodpointer in pprocvardef(def)^.procoptions)) or + ((def^.deftype=objectdef) and pobjectdef(def)^.is_class) or + ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset)) or + ((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit)); + end; + + + { true, if def is a 64 bit int type } + function is_64bitint(def : pdef) : boolean; + begin + is_64bitint:=(def^.deftype=orddef) and (porddef(def)^.typ in [u64bit,s64bit]) + end; + + + { true if uses a parameter as return value } + function ret_in_param(def : pdef) : boolean; + begin + ret_in_param:=(def^.deftype in [arraydef,recorddef]) or + ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or + ((def^.deftype=procvardef) and (po_methodpointer in pprocvardef(def)^.procoptions)) or + ((def^.deftype=objectdef) and not(pobjectdef(def)^.is_class)) or + ((def^.deftype=setdef) and (psetdef(def)^.settype<>smallset)); + end; + + + function push_high_param(def : pdef) : boolean; + begin + push_high_param:=is_open_array(def) or + is_open_string(def) or + is_array_of_const(def); + end; + + + { true if a parameter is too large to copy and only the address is pushed } + function push_addr_param(def : pdef) : boolean; + begin + push_addr_param:=false; + if never_copy_const_param then + push_addr_param:=true + else + begin + case def^.deftype of + formaldef : + push_addr_param:=true; + recorddef : + push_addr_param:=(def^.size>4); + arraydef : + push_addr_param:=((Parraydef(def)^.highrange>Parraydef(def)^.lowrange) and (def^.size>4)) or + is_open_array(def) or + is_array_of_const(def) or + is_array_constructor(def); + objectdef : + push_addr_param:=not(pobjectdef(def)^.is_class); + stringdef : + push_addr_param:=pstringdef(def)^.string_typ in [st_shortstring,st_longstring]; + procvardef : + push_addr_param:=(po_methodpointer in pprocvardef(def)^.procoptions); + setdef : + push_addr_param:=(psetdef(def)^.settype<>smallset); + end; + end; + end; + + { test if l is in the range of def, outputs error if out of range } + procedure testrange(def : pdef;var l : longint); + var + lv,hv: longint; + + begin + { for 64 bit types we need only to check if it is less than } + { zero, if def is a qword node } + if is_64bitint(def) then + begin + if (l<0) and (porddef(def)^.typ=u64bit) then + begin + l:=0; + if (cs_check_range in aktlocalswitches) then + Message(parser_e_range_check_error) + else + Message(parser_w_range_check_error); + end; + end + else + begin + getrange(def,lv,hv); + if (def^.deftype=orddef) and + (porddef(def)^.typ=u32bit) then + begin + if lv<=hv then + begin + if (lhv) then + begin + if (cs_check_range in aktlocalswitches) then + Message(parser_e_range_check_error) + else + Message(parser_w_range_check_error); + end; + end + else + { this happens with the wrap around problem } + { if lv is positive and hv is over $7ffffff } + { so it seems negative } + begin + if ((l>=0) and (lhv)) then + begin + if (cs_check_range in aktlocalswitches) then + Message(parser_e_range_check_error) + else + Message(parser_w_range_check_error); + end; + end; + end + else if (lhv) then + begin + if (def^.deftype=enumdef) or + (cs_check_range in aktlocalswitches) then + Message(parser_e_range_check_error) + else + Message(parser_w_range_check_error); + { Fix the value to fit in the allocated space for this type of variable } + case def^.size of + 1: l := l and $ff; + 2: l := l and $ffff; + end +{ l:=lv+(l mod (hv-lv+1));} + end; + end; + end; + + + { return the range from def in l and h } + procedure getrange(def : pdef;var l : longint;var h : longint); + begin + case def^.deftype of + orddef : + begin + l:=porddef(def)^.low; + h:=porddef(def)^.high; + end; + enumdef : + begin + l:=penumdef(def)^.min; + h:=penumdef(def)^.max; + end; + arraydef : + begin + l:=parraydef(def)^.lowrange; + h:=parraydef(def)^.highrange; + end; + else + internalerror(987); + end; + end; + + + function mmx_type(p : pdef) : tmmxtype; + begin + mmx_type:=mmxno; + if is_mmx_able_array(p) then + begin + if parraydef(p)^.elementtype.def^.deftype=floatdef then + case pfloatdef(parraydef(p)^.elementtype.def)^.typ of + s32real: + mmx_type:=mmxsingle; + f16bit: + mmx_type:=mmxfixed16 + end + else + case porddef(parraydef(p)^.elementtype.def)^.typ of + u8bit: + mmx_type:=mmxu8bit; + s8bit: + mmx_type:=mmxs8bit; + u16bit: + mmx_type:=mmxu16bit; + s16bit: + mmx_type:=mmxs16bit; + u32bit: + mmx_type:=mmxu32bit; + s32bit: + mmx_type:=mmxs32bit; + end; + end; + end; + + + function is_mmx_able_array(p : pdef) : boolean; + begin +{$ifdef SUPPORT_MMX} + if (cs_mmx_saturation in aktlocalswitches) then + begin + is_mmx_able_array:=(p^.deftype=arraydef) and + not(is_special_array(p)) and + ( + ( + (parraydef(p)^.elementtype.def^.deftype=orddef) and + ( + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=1) and + (porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit]) + ) + or + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=3) and + (porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit]) + ) + ) + ) + or + ( + ( + (parraydef(p)^.elementtype.def^.deftype=floatdef) and + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=3) and + (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f16bit) + ) or + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=1) and + (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real) + ) + ) + ) + ); + end + else + begin + is_mmx_able_array:=(p^.deftype=arraydef) and + ( + ( + (parraydef(p)^.elementtype.def^.deftype=orddef) and + ( + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=1) and + (porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit]) + ) + or + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=3) and + (porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit]) + ) + or + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=7) and + (porddef(parraydef(p)^.elementtype.def)^.typ in [u8bit,s8bit]) + ) + ) + ) + or + ( + (parraydef(p)^.elementtype.def^.deftype=floatdef) and + ( + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=3) and + (pfloatdef(parraydef(p)^.elementtype.def)^.typ=f32bit) + ) + or + ( + (parraydef(p)^.lowrange=0) and + (parraydef(p)^.highrange=1) and + (pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real) + ) + ) + ) + ); + end; +{$else SUPPORT_MMX} + is_mmx_able_array:=false; +{$endif SUPPORT_MMX} + end; + + + function is_equal(def1,def2 : pdef) : boolean; + var + b : boolean; + hd : pdef; + begin + { both types must exists } + if not (assigned(def1) and assigned(def2)) then + begin + is_equal:=false; + exit; + end; + + { be sure, that if there is a stringdef, that this is def1 } + if def2^.deftype=stringdef then + begin + hd:=def1; + def1:=def2; + def2:=hd; + end; + b:=false; + + { both point to the same definition ? } + if def1=def2 then + b:=true + else + { pointer with an equal definition are equal } + if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then + begin + { here a problem detected in tabsolutesym } + { the types can be forward type !! } + if assigned(def1^.typesym) and (ppointerdef(def1)^.pointertype.def^.deftype=forwarddef) then + b:=(def1^.typesym=def2^.typesym) + else + b:=ppointerdef(def1)^.pointertype.def=ppointerdef(def2)^.pointertype.def; + end + else + { ordinals are equal only when the ordinal type is equal } + if (def1^.deftype=orddef) and (def2^.deftype=orddef) then + begin + case porddef(def1)^.typ of + u8bit,u16bit,u32bit, + s8bit,s16bit,s32bit: + b:=((porddef(def1)^.typ=porddef(def2)^.typ) and + (porddef(def1)^.low=porddef(def2)^.low) and + (porddef(def1)^.high=porddef(def2)^.high)); + uvoid,uchar, + bool8bit,bool16bit,bool32bit: + b:=(porddef(def1)^.typ=porddef(def2)^.typ); + end; + end + else + if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then + b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ + else + { strings with the same length are equal } + if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and + (pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then + begin + b:=not(is_shortstring(def1)) or + (pstringdef(def1)^.len=pstringdef(def2)^.len); + end + else + if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then + b:=true + { file types with the same file element type are equal } + { this is a problem for assign !! } + { changed to allow if one is untyped } + { all typed files are equal to the special } + { typed file that has voiddef as elemnt type } + { but must NOT match for text file !!! } + else + if (def1^.deftype=filedef) and (def2^.deftype=filedef) then + b:=(pfiledef(def1)^.filetyp=pfiledef(def2)^.filetyp) and + (( + ((pfiledef(def1)^.typedfiletype.def=nil) and + (pfiledef(def2)^.typedfiletype.def=nil)) or + ( + (pfiledef(def1)^.typedfiletype.def<>nil) and + (pfiledef(def2)^.typedfiletype.def<>nil) and + is_equal(pfiledef(def1)^.typedfiletype.def,pfiledef(def2)^.typedfiletype.def) + ) or + ( (pfiledef(def1)^.typedfiletype.def=pdef(voiddef)) or + (pfiledef(def2)^.typedfiletype.def=pdef(voiddef)) + ))) + { sets with the same element type are equal } + else + if (def1^.deftype=setdef) and (def2^.deftype=setdef) then + begin + if assigned(psetdef(def1)^.elementtype.def) and + assigned(psetdef(def2)^.elementtype.def) then + b:=(psetdef(def1)^.elementtype.def^.deftype=psetdef(def2)^.elementtype.def^.deftype) + else + b:=true; + end + else + if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then + begin + { poassembler isn't important for compatibility } + { if a method is assigned to a methodpointer } + { is checked before } + b:=(pprocvardef(def1)^.proctypeoption=pprocvardef(def2)^.proctypeoption) and + (pprocvardef(def1)^.proccalloptions=pprocvardef(def2)^.proccalloptions) and + ((pprocvardef(def1)^.procoptions * po_compatibility_options)= + (pprocvardef(def2)^.procoptions * po_compatibility_options)) and + is_equal(pprocvardef(def1)^.rettype.def,pprocvardef(def2)^.rettype.def) and + equal_paras(pprocvardef(def1)^.para,pprocvardef(def2)^.para,cp_all); + end + else + if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) then + begin + if is_open_array(def1) or is_open_array(def2) or + is_array_of_const(def1) or is_array_of_const(def2) then + begin + if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then + b:=true + else + b:=is_equal(parraydef(def1)^.elementtype.def,parraydef(def2)^.elementtype.def); + end + else + begin + b:=not(m_tp in aktmodeswitches) and + not(m_delphi in aktmodeswitches) and + (parraydef(def1)^.lowrange=parraydef(def2)^.lowrange) and + (parraydef(def1)^.highrange=parraydef(def2)^.highrange) and + is_equal(parraydef(def1)^.elementtype.def,parraydef(def2)^.elementtype.def) and + is_equal(parraydef(def1)^.rangetype.def,parraydef(def2)^.rangetype.def); + end; + end + else + if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then + begin + { similar to pointerdef: } + if assigned(def1^.typesym) and (pclassrefdef(def1)^.pointertype.def^.deftype=forwarddef) then + b:=(def1^.typesym=def2^.typesym) + else + b:=is_equal(pclassrefdef(def1)^.pointertype.def,pclassrefdef(def2)^.pointertype.def); + end; + is_equal:=b; + end; + + + function is_subequal(def1, def2: pdef): boolean; + + var + basedef1,basedef2 : penumdef; + + Begin + is_subequal := false; + if assigned(def1) and assigned(def2) then + Begin + if (def1^.deftype = orddef) and (def2^.deftype = orddef) then + Begin + { see p.47 of Turbo Pascal 7.01 manual for the separation of types } + { range checking for case statements is done with testrange } + case porddef(def1)^.typ of + u8bit,u16bit,u32bit, + s8bit,s16bit,s32bit : + is_subequal:=(porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]); + bool8bit,bool16bit,bool32bit : + is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]); + uchar : + is_subequal:=(porddef(def2)^.typ=uchar); + end; + end + else + Begin + { I assume that both enumerations are equal when the first } + { pointers are equal. } + + { I changed this to assume that the enums are equal } + { if the basedefs are equal (FK) } + if (def1^.deftype=enumdef) and (def2^.deftype=enumdef) then + Begin + { get both basedefs } + basedef1:=penumdef(def1); + while assigned(basedef1^.basedef) do + basedef1:=basedef1^.basedef; + basedef2:=penumdef(def2); + while assigned(basedef2^.basedef) do + basedef2:=basedef2^.basedef; + is_subequal:=basedef1=basedef2; + { + if penumdef(def1)^.firstenum = penumdef(def2)^.firstenum then + is_subequal := TRUE; + } + end; + end; + end; { endif assigned ... } + end; + + function CheckTypes(def1,def2 : pdef) : boolean; + + var + s1,s2 : string; + + begin + if not is_equal(def1,def2) then + begin + { Crash prevention } + if (not assigned(def1)) or (not assigned(def2)) then + Message(type_e_mismatch) + else + begin + s1:=def1^.typename; + s2:=def2^.typename; + if (s1<>'') and (s2<>'') then + Message2(type_e_not_equal_types,def1^.typename,def2^.typename) + else + Message(type_e_mismatch); + end; + CheckTypes:=false; + end + else + CheckTypes:=true; + end; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.102 2000/06/30 22:12:26 peter + * fix for bug 988 + + Revision 1.101 2000/06/20 12:47:53 pierre + * equal_paras and convertable_paras changed by transforming third parameter + into an enum with three possible values: + cp_none, cp_value_equal_const and cp_all. + + Revision 1.100 2000/05/28 15:22:54 florian + * fixed a problem with subrange enumerations in case statements + + Revision 1.99 2000/03/01 15:36:12 florian + * some new stuff for the new cg + + Revision 1.98 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.97 2000/02/09 13:23:09 peter + * log truncated + + Revision 1.96 2000/02/01 09:44:03 peter + * is_voidpointer + + Revision 1.95 2000/01/07 01:14:49 peter + * updated copyright to 2000 + + Revision 1.94 2000/01/04 16:35:58 jonas + * when range checking is off, constants that are out of bound are no longer + truncated to their max/min legal value but left alone (jsut an "and" is done to + make sure they fit in the allocated space if necessary) + + Revision 1.93 1999/12/31 14:26:28 peter + * fixed crash with empty array constructors + + Revision 1.92 1999/11/30 10:40:59 peter + + ttype, tsymlist + + Revision 1.91 1999/11/06 14:34:31 peter + * truncated log to 20 revs + + Revision 1.90 1999/10/26 12:30:46 peter + * const parameter is now checked + * better and generic check if a node can be used for assigning + * export fixes + * procvar equal works now (it never had worked at least from 0.99.8) + * defcoll changed to linkedlist with pparaitem so it can easily be + walked both directions + + Revision 1.89 1999/10/01 10:04:07 peter + * fixed is_equal for proc -> procvar which didn't check the + callconvention and type anymore since the splitting of procoptions + + Revision 1.88 1999/10/01 08:02:51 peter + * forward type declaration rewritten + + Revision 1.87 1999/09/15 22:09:27 florian + + rtti is now automatically generated for published classes, i.e. + they are handled like an implicit property + + Revision 1.86 1999/09/11 09:08:35 florian + * fixed bug 596 + * fixed some problems with procedure variables and procedures of object, + especially in TP mode. Procedure of object doesn't apply only to classes, + it is also allowed for objects !! + + Revision 1.85 1999/08/13 21:27:08 peter + * more fixes for push_addr + + Revision 1.84 1999/08/13 15:38:23 peter + * fixed push_addr_param for records < 4, the array high 0 then + rewrite(status.redirfile); + {$I+} + status.use_redir:=(ioresult=0); + if status.use_redir then + begin + redirexitsave:=exitproc; + exitproc:=@DoneRedirectFile; + end; +end; + + +function SetVerbosity(const s:string):boolean; +var + m : Longint; + i : Integer; + inverse : boolean; + c : char; +begin + Setverbosity:=false; + val(s,m,i); + if (i=0) and (s<>'') then + status.verbosity:=m + else + begin + i:=1; + while i<=length(s) do + begin + c:=upcase(s[i]); + inverse:=false; + { on/off ? } + if (ilastmoduleidx) or + (aktfilepos.fileindex<>lastfileidx)) then + begin + { update status record } + status.currentmodule:=current_module^.modulename^; + status.currentsource:=current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex); + status.currentsourcepath:=current_module^.sourcefiles^.get_file_path(aktfilepos.fileindex); + { update lastfileidx only if name known PM } + if status.currentsource<>'' then + lastfileidx:=aktfilepos.fileindex + else + lastfileidx:=0; + lastmoduleidx:=current_module^.unit_index; + end; +end; + + +procedure stop; +begin +{$ifndef TP} + do_stop(); +{$else} + do_stop; +{$endif} +end; + + +procedure ShowStatus; +begin + UpdateStatus; +{$ifndef TP} + if do_status() then + stop; +{$else} + if do_status then + stop; +{$endif} +end; + + +function ErrorCount:longint; +begin + ErrorCount:=status.errorcount; +end; + + +procedure SetErrorFlags(const s:string); +var + code : integer; + i,j,l : longint; +begin +{ empty string means error count = 1 for backward compatibility (PFV) } + if s='' then + begin + status.maxerrorcount:=1; + exit; + end; + i:=0; + while (i0 then + l:=1; + status.maxerrorcount:=l; + i:=j; + end; + 'w','W' : + status.errorwarning:=true; + 'n','N' : + status.errornote:=true; + 'h','H' : + status.errorhint:=true; + end; + end; +end; + + +procedure GenerateError; +begin + inc(status.errorcount); +end; + + +procedure internalerror(i : longint); +begin + UpdateStatus; + do_internalerror(i); + inc(status.errorcount); + stop; +end; + + +procedure Comment(l:longint;s:string); +var + dostop : boolean; +begin + dostop:=((l and V_Fatal)<>0); + if ((l and V_Error)<>0) or + (status.errorwarning and ((l and V_Warning)<>0)) or + (status.errornote and ((l and V_Note)<>0)) or + (status.errorhint and ((l and V_Hint)<>0)) then + inc(status.errorcount); +{ Create status info } + UpdateStatus; +{ Fix replacements } + DefaultReplacements(s); +{ show comment } + if do_comment(l,s) or dostop then + stop; + if (status.errorcount>=status.maxerrorcount) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(status.errorcount)); + status.skip_error:=true; + stop; + end; +end; + + +Procedure Msg2Comment(s:string); +var + idx,i,v : longint; + dostop : boolean; +begin +{Reset} + dostop:=false; + v:=0; +{Parse options} + idx:=pos('_',s); + if idx=0 then + v:=V_Normal + else + if (idx >= 1) And (idx <= 5) then + begin + for i:=1 to idx do + begin + case upcase(s[i]) of + 'F' : + begin + v:=v or V_Fatal; + inc(status.errorcount); + dostop:=true; + end; + 'E' : + begin + v:=v or V_Error; + inc(status.errorcount); + end; + 'O' : + v:=v or V_Normal; + 'W': + begin + v:=v or V_Warning; + if status.errorwarning then + inc(status.errorcount); + end; + 'N' : + begin + v:=v or V_Note; + if status.errornote then + inc(status.errorcount); + end; + 'H' : + begin + v:=v or V_Hint; + if status.errorhint then + inc(status.errorcount); + end; + 'I' : + v:=v or V_Info; + 'L' : + v:=v or V_Status; + 'U' : + v:=v or V_Used; + 'T' : + v:=v or V_Tried; + 'M' : + v:=v or V_Macro; + 'P' : + v:=v or V_Procedure; + 'C' : + v:=v or V_Conditional; + 'D' : + v:=v or V_Debug; + 'B' : + v:=v or V_Declarations; + 'X' : + v:=v or V_Executable; + 'Z' : + v:=v or V_Assem; + 'S' : + dostop:=true; + '_' : ; + end; + end; + end; + Delete(s,1,idx); +{ fix status } + UpdateStatus; +{ Fix replacements } + DefaultReplacements(s); +{ show comment } + if do_comment(v,s) or dostop then + stop; + if (status.errorcount>=status.maxerrorcount) and not status.skip_error then + begin + Message1(unit_f_errors_in_unit,tostr(status.errorcount)); + status.skip_error:=true; + stop; + end; +end; + + +function MessagePchar(w:longint):pchar; +begin + MessagePchar:=msg^.GetPchar(w) +end; + + +procedure Message(w:longint); +begin + Msg2Comment(msg^.Get(w)); +end; + + +procedure Message1(w:longint;const s1:string); +begin + Msg2Comment(msg^.Get1(w,s1)); +end; + + +procedure Message2(w:longint;const s1,s2:string); +begin + Msg2Comment(msg^.Get2(w,s1,s2)); +end; + + +procedure Message3(w:longint;const s1,s2,s3:string); +begin + Msg2Comment(msg^.Get3(w,s1,s2,s3)); +end; + + +procedure MessagePos(const pos:tfileposinfo;w:longint); +var + oldpos : tfileposinfo; +begin + oldpos:=aktfilepos; + aktfilepos:=pos; + Msg2Comment(msg^.Get(w)); + aktfilepos:=oldpos; +end; + + +procedure MessagePos1(const pos:tfileposinfo;w:longint;const s1:string); +var + oldpos : tfileposinfo; +begin + oldpos:=aktfilepos; + aktfilepos:=pos; + Msg2Comment(msg^.Get1(w,s1)); + aktfilepos:=oldpos; +end; + + +procedure MessagePos2(const pos:tfileposinfo;w:longint;const s1,s2:string); +var + oldpos : tfileposinfo; +begin + oldpos:=aktfilepos; + aktfilepos:=pos; + Msg2Comment(msg^.Get2(w,s1,s2)); + aktfilepos:=oldpos; +end; + + +procedure MessagePos3(const pos:tfileposinfo;w:longint;const s1,s2,s3:string); +var + oldpos : tfileposinfo; +begin + oldpos:=aktfilepos; + aktfilepos:=pos; + Msg2Comment(msg^.Get3(w,s1,s2,s3)); + aktfilepos:=oldpos; +end; + + +procedure InitVerbose; +begin +{ Init } + msg:=new(pmessage,Init(20,msgidxmax)); + if msg=nil then + begin + writeln('Fatal: MsgIdx Wrong'); + halt(3); + end; +{$ifndef EXTERN_MSG} + msg^.LoadIntern(@msgtxt,msgtxtsize); +{$else} + LoadMsgFile(exepath+'errore.msg'); +{$endif} + FillChar(Status,sizeof(TCompilerStatus),0); + status.verbosity:=V_Default; + Status.MaxErrorCount:=50; +end; + + +procedure DoneVerbose; +begin + if assigned(msg) then + begin + dispose(msg,Done); + msg:=nil; + end; +end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.55 2000/06/30 20:23:38 peter + * new message files layout with msg numbers (but still no code to + show the number on the screen) + + Revision 1.54 2000/05/23 20:32:48 peter + * removed dup msgcrcvalue + + Revision 1.53 2000/05/15 14:05:40 pierre + Declare MsgCrcValue with cond EXTERN_MSG + + Revision 1.52 2000/05/10 19:20:23 pierre + * Use integer third arg for val in SetErrorFlags + to allow compilation with Delphi + reported by Kovacs Attila Zoltan + + Revision 1.51 2000/05/10 13:40:19 peter + * -Se option extended to increase errorcount for + warning,notes or hints + + Revision 1.50 2000/04/01 10:46:29 hajny + * logfile appended if exists + + Revision 1.49 2000/03/12 08:24:45 daniel + * Made check for message file TP compilable. + + Revision 1.48 2000/03/01 22:29:18 peter + * message files are check for amount of msgs found. If not correct a + line is written to stdout and switched to internal messages + + Revision 1.47 2000/03/01 21:45:42 peter + * lowercase .INC -> .inc + + Revision 1.46 2000/02/28 17:23:57 daniel + * Current work of symtable integration committed. The symtable can be + activated by defining 'newst', but doesn't compile yet. Changes in type + checking and oop are completed. What is left is to write a new + symtablestack and adapt the parser to use it. + + Revision 1.45 2000/02/09 13:23:09 peter + * log truncated + + Revision 1.44 2000/01/07 01:14:49 peter + * updated copyright to 2000 + + Revision 1.43 1999/11/06 14:34:32 peter + * truncated log to 20 revs + + Revision 1.42 1999/08/05 16:53:28 peter + * V_Fatal=1, all other V_ are also increased + * Check for local procedure when assigning procvar + * fixed comment parsing because directives + * oldtp mode directives better supported + * added some messages to errore.msg + +} \ No newline at end of file diff --git a/befpc/compiler/version.pas b/befpc/compiler/version.pas new file mode 100644 index 0000000..6964d3e --- /dev/null +++ b/befpc/compiler/version.pas @@ -0,0 +1,137 @@ +{ + $Id: version.pas,v 1.1.1.1 2001-07-23 17:17:25 memson Exp $ + Copyright (C) 1998-2000 by Florian Klaempfl + + Version/target constants + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit version; +interface + + const + { word version for ppu file } + wordversion = (1 shl 14)+0; + + { version string } + + version_nr = '1'; + release_nr = '00'; + patch_nr = '0'; +{$ifdef newcg} + minorpatch = ' NCG'; +{$else newcg} + {$ifdef newoptimizations} + minorpatch = ' OPT'; + {$else} + minorpatch = ''; + {$endif} +{$endif newcg} + + { date string } +{$ifdef FPC} + date_string = {$I %DATE%}; +{$else} + date_string = 'N/A'; +{$endif} + + { target cpu string } +{$ifdef i386} + target_cpu_string = 'i386'; +{$endif} +{$ifdef m68k} + target_cpu_string = 'm68k'; +{$endif} +{$ifdef alpha} + target_cpu_string = 'alpha'; +{$endif} +{$ifdef powerpc} + target_cpu_string = 'powerpc'; +{$endif} + + { source cpu string } +{$ifdef cpu86} + source_cpu_string = 'i386'; +{$endif} +{$ifdef cpu68} + source_cpu_string = 'm68k'; +{$endif} + +function version_string:string; +function full_version_string:string; + + +implementation + +function version_string:string; +begin + if patch_nr='0' then + version_string := version_nr+'.'+release_nr + else + version_string := version_nr+'.'+release_nr+'.'+patch_nr; +end; + + +function full_version_string:string; +begin + if patch_nr='0' then + full_version_string := version_nr+'.'+release_nr+minorpatch + else + full_version_string := version_nr+'.'+release_nr+'.'+patch_nr+minorpatch; +end; + + +begin +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/07/10 09:17:27 pierre + * fix wordversion + + Revision 1.19 2000/07/09 09:34:50 peter + * version_string is now a function so it returns 1.00 instead of 1.00.0 + + Revision 1.18 2000/07/06 20:08:46 peter + * version 1.00.0 so the snapshots can test with this version number + for a few days + + Revision 1.17 2000/03/21 21:35:27 peter + * add OPT for optimizing compiler + + Revision 1.16 2000/02/09 13:23:09 peter + * log truncated + + Revision 1.15 2000/01/28 20:47:26 michael + + Changed patch number to 15 + + Revision 1.14 2000/01/14 13:05:54 peter + * version 0.99.14 + + Revision 1.13 2000/01/07 01:14:49 peter + * updated copyright to 2000 + + Revision 1.12 1999/08/04 13:03:18 jonas + * all tokens now start with an underscore + * PowerPC compiles!! + + Revision 1.11 1999/08/02 17:17:12 florian + * small changes for the new code generator + + Revision 1.10 1999/08/01 23:36:42 florian + * some changes to compile the new code generator + +} \ No newline at end of file diff --git a/befpc/rtl/beos/0build.sh b/befpc/rtl/beos/0build.sh new file mode 100644 index 0000000..1646546 --- /dev/null +++ b/befpc/rtl/beos/0build.sh @@ -0,0 +1,6 @@ +fpc -vi -Fi../inc -Fi../i386 -FE. -di386 -TBEOS -Us -Sg sysbeos.pp +fpc -vi -Fi../inc -Fi../i386 -FE. -di386 -TBEOS beos.pp +fpc -vi -Fi../inc -Fi../i386 -FE. -di386 -TBEOS dos.pp +fpc -vi -Fi../inc -Fi../i386 -FE. -di386 -TBEOS ../inc/strings.pp +fpc -vi -Fi../inc -Fi../i386 -FE. -di386 -TBEOS ../inc/objects.pp + diff --git a/befpc/rtl/beos/beos.pp b/befpc/rtl/beos/beos.pp new file mode 100644 index 0000000..a5ffa5a --- /dev/null +++ b/befpc/rtl/beos/beos.pp @@ -0,0 +1,439 @@ +unit beos; + +interface + +type + Stat = packed record + dev:longint; {"device" that this file resides on} + ino:int64; {this file's inode #, unique per device} + mode:dword; {mode bits (rwx for user, group, etc)} + nlink:longint; {number of hard links to this file} + uid:dword; {user id of the owner of this file} + gid:dword; {group id of the owner of this file} + size:int64; {size of this file (in bytes)} + rdev:longint; {device type (not used)} + blksize:longint; {preferref block size for i/o} + atime:longint; {last access time} + mtime:longint; {last modification time} + ctime:longint; {last change time, not creation time} + crtime:longint; {creation time} + end; + PStat=^Stat; + TStat=Stat; + + ComStr = String[255]; + PathStr = String[255]; + DirStr = String[255]; + NameStr = String[255]; + ExtStr = String[255]; + +function FStat(Path:String;Var Info:stat):Boolean; +function FStat(var f:File;Var Info:stat):Boolean; +function GetEnv(P: string): pchar; + +function FExpand(Const Path: PathStr):PathStr; +function FSearch(const path:pathstr;dirlist:string):pathstr; +procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr); +function Dirname(Const path:pathstr):pathstr; +function Basename(Const path:pathstr;Const suf:pathstr):pathstr; +function FNMatch(const Pattern,Name:string):Boolean; +{function StringToPPChar(Var S:STring):ppchar;} + +function PExists(path:string):boolean; +function FExists(path:string):boolean; + +Function Shell(const Command:String):Longint; + +implementation + +uses strings; + +{$i filerec.inc} +{$i textrec.inc} + +function sys_stat (a:longint;path:pchar;info:pstat;n:longint):longint; cdecl; external name 'sys_stat'; + +function FStat(Path:String;Var Info:stat):Boolean; +{ + Get all information on a file, and return it in Info. +} +var tmp:string; +var p:pchar; +begin + tmp:=path+#0; + p:=@tmp[1]; + FStat:=(sys_stat($FF000000,p,@Info,0)=0); +end; + +function FStat(var f:File;Var Info:stat):Boolean; +{ + Get all information on a file, and return it in Info. +} +begin + FStat:=(sys_stat($FF000000,PChar(@FileRec(f).Name),@Info,0)=0); +end; + + + +Function GetEnv(P:string):Pchar; +{ + Searches the environment for a string with name p and + returns a pchar to it's value. + A pchar is used to accomodate for strings of length > 255 +} +var + ep : ppchar; + found : boolean; +Begin + p:=p+'='; {Else HOST will also find HOSTNAME, etc} + ep:=envp; + found:=false; + if ep<>nil then + begin + while (not found) and (ep^<>nil) do + begin + if strlcomp(@p[1],(ep^),length(p))=0 then + found:=true + else + inc(ep); + end; + end; + if found then + getenv:=ep^+length(p) + else + getenv:=nil; +{ writeln ('GETENV (',P,') =',getenv);} +end; + + + +Function StringToPPChar(Var S:String; Var nr:longint):ppchar; +{ + Create a PPChar to structure of pchars which are the arguments specified + in the string S. Especially usefull for creating an ArgV for Exec-calls +} +var + Buf : ^char; + p : ppchar; +begin + s:=s+#0; + buf:=@s[1]; + nr:=0; + while(buf^<>#0) do + begin + while (buf^ in [' ',#8,#10]) do + inc(buf); + inc(nr); + while not (buf^ in [' ',#0,#8,#10]) do + inc(buf); + end; + getmem(p,nr*4); + StringToPPChar:=p; + if p=nil then + begin +{ LinuxError:=sys_enomem;} + exit; + end; + buf:=@s[1]; + while (buf^<>#0) do + begin + while (buf^ in [' ',#8,#10]) do + begin + buf^:=#0; + inc(buf); + end; + p^:=buf; + inc(p); + p^:=nil; + while not (buf^ in [' ',#0,#8,#10]) do + inc(buf); + end; +end; + + + +Function FExpand(Const Path:PathStr):PathStr; +var + temp : pathstr; + i,j : longint; + p : pchar; +Begin +{Remove eventual drive - doesn't exist in Linux} + if path[2]=':' then + i:=3 + else + i:=1; + temp:=''; +{Replace ~/ with $HOME} + if (path[i]='~') and ((i+1>length(path)) or (path[i+1]='/')) then + begin + p:=getenv('HOME'); + if not (p=nil) then + Insert(StrPas(p),temp,i); + i:=1; + temp:=temp+Copy(Path,2,255); + end; +{Do we have an absolute path ? No - prefix the current dir} + if temp='' then + begin + if path[i]<>'/' then + begin + {$I-} + getdir(0,temp); + {$I+} + if ioresult<>0 then; + end + else + inc(i); + temp:=temp+'/'+copy(path,i,length(path)-i+1)+'/'; + end; +{First remove all references to '/./'} + while pos('/./',temp)<>0 do + delete(temp,pos('/./',temp),2); +{Now remove also all references to '/../' + of course previous dirs..} + repeat + i:=pos('/../',temp); + {Find the pos of the previous dir} + if i>1 then + begin + j:=i-1; + while (j>1) and (temp[j]<>'/') do + dec (j);{temp[1] is always '/'} + delete(temp,j,i-j+3); + end + else + if i=1 then {i=1, so we have temp='/../something', just delete '/../'} + delete(temp,1,3); + until i=0; + { Remove ending /.. } + i:=pos('/..',temp); + if (i<>0) and (i =length(temp)-2) then + begin + j:=i-1; + while (j>1) and (temp[j]<>'/') do + dec (j); + delete (temp,j,i-j+3); + end; + { if last character is / then remove it - dir is also a file :-) } + if (length(temp)>0) and (temp[length(temp)]='/') then + dec(byte(temp[0])); + fexpand:=temp; +End; + + + +Function FSearch(const path:pathstr;dirlist:string):pathstr; +{ + Searches for a file 'path' in the list of direcories in 'dirlist'. + returns an empty string if not found. Wildcards are NOT allowed. + If dirlist is empty, it is set to '.' +} +Var + NewDir : PathStr; + p1 : Longint; + Info : Stat; +Begin +{Replace ':' with ';'} + for p1:=1to length(dirlist) do + if dirlist[p1]=':' then + dirlist[p1]:=';'; +{Check for WildCards} + If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then + FSearch:='' {No wildcards allowed in these things.} + Else + Begin + Dirlist:='.;'+dirlist;{Make sure current dir is first to be searched.} + Repeat + p1:=Pos(';',DirList); + If p1=0 Then + p1:=255; + NewDir:=Copy(DirList,1,P1 - 1); + if NewDir[Length(NewDir)]<>'/' then + NewDir:=NewDir+'/'; + NewDir:=NewDir+Path; + Delete(DirList,1,p1); + if FStat(NewDir,Info) then + Begin + If Pos('./',NewDir)=1 Then + Delete(NewDir,1,2); + {DOS strips off an initial .\} + End + Else + NewDir:=''; + Until (DirList='') or (Length(NewDir) > 0); + FSearch:=NewDir; + End; +End; + + + +Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr); +Var + DotPos,SlashPos,i : longint; +Begin + SlashPos:=0; + DotPos:=256; + i:=Length(Path); + While (i>0) and (SlashPos=0) Do + Begin + If (DotPos=256) and (Path[i]='.') Then + DotPos:=i; + If (Path[i]='/') Then + SlashPos:=i; + Dec(i); + End; + Ext:=Copy(Path,DotPos,255); + Dir:=Copy(Path,1,SlashPos); + Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1); +End; + + + +Function Dirname(Const path:pathstr):pathstr; +{ + This function returns the directory part of a complete path. + Unless the directory is root '/', The last character is not + a slash. +} +var + Dir : PathStr; + Name : NameStr; + Ext : ExtStr; +begin + FSplit(Path,Dir,Name,Ext); + if length(Dir)>1 then + Delete(Dir,length(Dir),1); + DirName:=Dir; +end; + + + +Function Basename(Const path:pathstr;Const suf:pathstr):pathstr; +{ + This function returns the filename part of a complete path. If suf is + supplied, it is cut off the filename. +} +var + Dir : PathStr; + Name : NameStr; + Ext : ExtStr; +begin + FSplit(Path,Dir,Name,Ext); + if Suf<>Ext then + Name:=Name+Ext; + BaseName:=Name; +end; + + + +Function FNMatch(const Pattern,Name:string):Boolean; +Var + LenPat,LenName : longint; + + Function DoFNMatch(i,j:longint):Boolean; + Var + Found : boolean; + Begin + Found:=true; + While Found and (i<=LenPat) Do + Begin + Case Pattern[i] of + '?' : Found:=(j<=LenName); + '*' : Begin + {find the next character in pattern, different of ? and *} + while Found and (ipattern[i]) do + inc (j); + if (j=LenName); + end + else + j:=LenName;{we can stop} + end; + else {not a wildcard character in pattern} + Found:=(j<=LenName) and (pattern[i]=name[j]); + end; + inc(i); + inc(j); + end; + DoFnMatch:=Found and (j>LenName); + end; + +Begin {start FNMatch} + LenPat:=Length(Pattern); + LenName:=Length(Name); + FNMatch:=DoFNMatch(1,1); +End; + + +function PExists(path:string):boolean; +begin + PExists:=FExists(path); +end; + +function FExists(path:string):boolean; +var l:longint; + info:stat; +begin + FExists:=Fstat(path,info); +end; + +function sys_load_image(a:longint; argp:ppchar; envp:ppchar):longint; cdecl; external name 'sys_load_image'; +function sys_wait_for_thread (th:longint; var exitcode:longint):longint; cdecl; external name 'sys_wait_for_thread'; + +Function Shell(const Command:String):Longint; +var s:string; + argv:ppchar; + argc:longint; + th:longint; +begin + s:=Command; + argv:=StringToPPChar(s,argc); + th:=0; +{ writeln ('argc = ',argc); + while argv[th]<>Nil do begin + writeln ('argv[',th,'] = ',argv[th]); + th:=th+1; + end; +} + th:=sys_load_image(argc,argv,system.envp); + if th<0 then begin + shell:=0; + exit; + end; + sys_wait_for_thread(th,Shell); +end; + + + +end. diff --git a/befpc/rtl/beos/dos.pp b/befpc/rtl/beos/dos.pp new file mode 100644 index 0000000..e63b691 --- /dev/null +++ b/befpc/rtl/beos/dos.pp @@ -0,0 +1,695 @@ +{ + $Id: dos.pp,v 1.1.1.1 2001-07-23 17:17:26 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Dos unit for BP7 compatible RTL + + 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 dos; +interface + +uses beos; + +const + FileNameLen=255; + +type + ComStr = String[FileNameLen]; + PathStr = String[FileNameLen]; + DirStr = String[FileNameLen]; + NameStr = String[FileNameLen]; + ExtStr = String[FileNameLen]; + + +Const + LFNSUPPORT=True; + + {Bitmasks for CPU Flags} + fcarry = $0001; + fparity = $0004; + fauxiliary = $0010; + fzero = $0040; + fsign = $0080; + foverflow = $0800; + + {Bitmasks for file attribute} + readonly = $01; + hidden = $02; + sysfile = $04; + volumeid = $08; + directory = $10; + archive = $20; + anyfile = $3F; + + {File Status} + fmclosed = $D7B0; + fminput = $D7B1; + fmoutput = $D7B2; + fminout = $D7B3; + + + S_IFMT = $F000; { type of file } + S_IFLNK = $A000; { symbolic link } + S_IFREG = $8000; { regular } + S_IFBLK = $6000; { block special } + S_IFDIR = $4000; { directory } + S_IFCHR = $2000; { character special } + S_IFIFO = $1000; { fifo } + +{ + filerec.inc contains the definition of the filerec. + textrec.inc contains the definition of the textrec. + It is in a separate file to make it available in other units without + having to use the DOS unit for it. +} +{$i filerec.inc} +{$i textrec.inc} + + DateTime = packed record + Year, + Month, + Day, + Hour, + Min, + Sec : word; + End; + + searchrec = record + fd : longint; + path : string; + fname : string; + attr : byte; + time : longint; + size : longint; + name : string[255]; + end; + + +Var + DosError : integer; + +{Info/Date/Time} +Procedure GetDate(var year, month, mday, wday: word); +procedure GetTime(var hour,min,sec,msec,usec:word); +procedure GetTime(var hour,min,sec,sec100:word); +procedure GetTime(Var Hour,Min,Sec:Word); + +Procedure UnpackTime(p: longint; var t: datetime); +Procedure PackTime(var t: datetime; var p: longint); + +{Exec} +Procedure Exec(const path: pathstr; const comline: comstr); +Function DosExitCode: word; + + +{Disk} +Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec); +Procedure FindNext(var f: searchRec); +Procedure FindClose(var f: searchRec); + +{File} +{Procedure GetFAttr(var f:File; var attr: word);} +procedure GetFTime(var f:File; var time: longint); +procedure GetFTime(f:string; var time: longint); +Procedure SetFTime(var f:File; time : longint); +Function FSearch(path: pathstr; dirlist: string): pathstr; +Function FExpand(const path: pathstr): pathstr; +Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr); + + + + +{Environment} +{Function EnvCount: longint; +Function EnvStr(index: integer): string;} + +{Misc} +{Procedure SetFAttr(var f; attr: word); +Procedure SetFTime(var f; time: longint); +Procedure GetVerify(var verify: boolean); +Procedure SetVerify(verify: boolean);} + +{Do Nothing Functions} +Procedure SwapVectors; +{Procedure GetIntVec(intno: byte; var vector: pointer); +Procedure SetIntVec(intno: byte; vector: pointer); +Procedure Keep(exitcode: word);} +function GetEnv(EnvVar: String): String; + + +Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word); + + +implementation + +uses strings; + + +procedure GetFTime(var f:file; var time: longint); +var info:stat; + t:longint; + dt:DateTime; +begin + if not FStat(F,Info) then begin + t:=0; + doserror:=3; + exit; + end else t:=info.ctime; + EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); + packtime(dt,time); +end; + +procedure GetFTime(f:string; var time: longint); +var info:stat; + t:longint; + dt:DateTime; +begin + if not FStat(F,Info) then begin + t:=0; + doserror:=3; + exit; + end else t:=info.ctime; + EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); + packtime(dt,time); +end; + + +type utimbuf=record actime,modtime:longint; end; +{function _utime (path:pchar;var buf:utimbuf):longint; cdecl; external name 'utime';} + +Procedure setftime(var f:file; time : longint); +var buf:utimbuf; +begin +{ buf.actime:=time; + buf.modtime:=time;} +{ writeln ('SetFTime ',PChar(@FileRec(f).Name),' := ',time);} +{ if _utime(PChar(@FileRec(f).Name),buf)<>0 then doserror:=3;} +end; + + +{****************************************************************************** + --- Info / Date / Time --- +******************************************************************************} + + +procedure getdate(var year,month,mday,wday : word); +begin +end; + +function sys_time:longint; cdecl; external name 'sys_time'; + + +procedure GetTime(var hour,min,sec,msec,usec:word); +{ + Gets the current time, adjusted to local time +} +var + year,day,month:Word; + t : longint; +begin + t:=sys_time; + EpochToLocal(t,year,month,day,hour,min,sec); + msec:=0; + usec:=0; +end; + +procedure GetTime(var hour,min,sec,sec100:word); +{ Gets the current time, adjusted to local time } +var usec : word; +begin + gettime(hour,min,sec,sec100,usec); + sec100:=sec100 div 10; +end; + +procedure GetTime(Var Hour,Min,Sec:Word); +{ + Gets the current time, adjusted to local time + } + var + msec,usec : Word; + Begin + gettime(hour,min,sec,msec,usec); +end; + + + +Procedure packtime(var t : datetime;var p : longint); +Begin + p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25); +End; + + +Procedure unpacktime(p : longint;var t : datetime); +Begin + with t do + begin + sec:=(p and 31) shl 1; + min:=(p shr 5) and 63; + hour:=(p shr 11) and 31; + day:=(p shr 16) and 31; + month:=(p shr 21) and 15; + year:=(p shr 25)+1980; + end; +End; + + +{****************************************************************************** + --- Exec --- +******************************************************************************} + + +Procedure Exec(const path: pathstr; const comline: comstr); +var p:string; +begin + p:=path+' '+comline; + doserror:=beos.shell(p); +end; + +Function DosExitCode: word; +begin + dosexitcode:=doserror; +end; + + + + +{****************************************************************************** + --- File --- +******************************************************************************} + +Procedure FSplit(Path: PathStr; Var Dir: DirStr; Var Name: NameStr;Var Ext: ExtStr); + +Begin + beos.FSplit(Path,Dir,Name,Ext); +End; + +Function FExpand(Const Path: PathStr): PathStr; +Begin + FExpand:=beos.FExpand(Path); +End; + +Function FSearch(path : pathstr;dirlist : string) : pathstr; +Var info:stat; +Begin +if (length(Path)>0) and (path[1]='/') and FStat(path,info) then + FSearch:=path + else + FSearch:=beos.FSearch(path,dirlist); +End; + + + +{****************************************************************************** + --- Findfirst FindNext --- +******************************************************************************} + +{procedure dossearchrec2searchrec(var f : searchrec); +var + len : longint; +begin + len:=StrLen(@f.Name); + Move(f.Name[0],f.Name[1],Len); + f.Name[0]:=chr(len); +end;} + +type dirent = packed record + d_dev:longint; + d_pdev:longint; + d_ino:int64; + d_pino:int64; + d_reclen:word; + d_name:array[0..255] of char; +end; + +function sys_opendir (a:dword;path:pchar;b:longint):longint; cdecl; external name 'sys_opendir'; +function sys_readdir (fd:longint;var de:dirent;a:longint;b:byte):longint; cdecl; external name 'sys_readdir'; + +procedure findnext(var f : searchRec); +var len:longint; + ent:dirent; + info:stat; + dt:DateTime; +begin + if sys_readdir(f.fd,ent,$11C,1)=0 then begin + doserror:=3; + exit; + end; +{ writeln ('NAME: ',pchar(@ent.d_name[0]));} + + len:=StrLen(@ent.d_name); + Move(ent.d_name,f.name[1],len); + f.name[0]:=chr(len); +{ writeln ('NAME: "',f.path+f.name,'"');} + + if not FStat(f.path+f.name,info) then begin + writeln ('NOT FOUND'); + doserror:=3; + exit; + end; + writeln ('OK'); + + f.size:=info.size; + + f.attr:=0; + if (info.mode and S_IFMT)=S_IFDIR then f.attr:=directory; + + EpochToLocal(info.mtime,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); + packtime(dt,f.time); + doserror:=0; + +end; + + +procedure findfirst(const path : pathstr;attr : word;var f : searchRec); +var tmp:string; + p:pchar; + info:stat; + ext:string; +begin + tmp:=path; + if tmp='' then tmp:='.'; + + if FStat(tmp,info) then begin + if ((info.mode and S_IFMT)=S_IFDIR) and (tmp[length(tmp)]<>'/') then tmp:=tmp+'/'; + end; + + FSplit (tmp,f.path,f.fname,ext); +{ f.path:=FExpand(f.path);} + f.fname:=f.fname+ext; + if length(f.fname)=0 then f.fname:='*'; + + tmp:=tmp+#0; + f.fd:=sys_opendir ($FF000000,@tmp[1],0); + writeln ('F.PATH=',f.path,' ; ',f.fname); + findnext(f); +end; + +Procedure FindClose(Var f: SearchRec); +begin + DosError:=0; +end; + + +procedure swapvectors; +begin +{ no beos equivalent } + DosError:=0; +end; + + + +{****************************************************************************** + --- Environment --- +******************************************************************************} + +function envcount : longint; +var + hp : ppchar; +begin + hp:=envp; + envcount:=0; + while assigned(hp^) do + begin + inc(envcount); + hp:=hp+4; + end; +end; + + +function envstr(index : integer) : string; +begin + if (index<=0) or (index>envcount) then + begin + envstr:=''; + exit; + end; + envstr:=strpas(ppchar(envp+4*(index-1))^); +end; + + +{****************************************************************************** + --- Not Supported --- +******************************************************************************} + +Procedure keep(exitcode : word); +Begin +End; + +Procedure getintvec(intno : byte;var vector : pointer); +Begin +End; + +Procedure setintvec(intno : byte;vector : pointer); +Begin +End; + + + + +{****************************************************************************** + Date and Time related calls +******************************************************************************} + +Const +{Date Translation} + C1970=2440588; + D0 = 1461; + D1 = 146097; + D2 =1721119; + +Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word); +Var + YYear,XYear,Temp,TempMonth : LongInt; +Begin + Temp:=((JulianDN-D2) shl 2)-1; + JulianDN:=Temp Div D1; + XYear:=(Temp Mod D1) or 3; + YYear:=(XYear Div D0); + Temp:=((((XYear mod D0)+4) shr 2)*5)-3; + Day:=((Temp Mod 153)+5) Div 5; + TempMonth:=Temp Div 153; + If TempMonth>=10 Then + Begin + inc(YYear); + dec(TempMonth,12); + End; + inc(TempMonth,3); + Month := TempMonth; + Year:=YYear+(JulianDN*100); +end; + + +Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word); +{ Transforms Epoch time into local time (hour, minute,seconds) } +Var + DateNum: LongInt; +Begin + Datenum:=(Epoch Div 86400) + c1970; + JulianToGregorian(DateNum,Year,Month,day); + Epoch:=Epoch Mod 86400; + Hour:=Epoch Div 3600; + Epoch:=Epoch Mod 3600; + Minute:=Epoch Div 60; + Second:=Epoch Mod 60; +End; + + +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/01/07 16:41:29 daniel + * copyright 2000 + + Revision 1.4 2000/01/07 16:32:23 daniel + * copyright 2000 added + + Revision 1.3 1999/01/22 16:22:09 pierre + * Daniel removal of findclose reverted + + Revision 1.2 1999/01/22 10:07:02 daniel + - Findclose removed: This is TP incompatible!! + + Revision 1.1 1998/12/21 13:07:02 peter + * use -FE + + Revision 1.19 1998/11/23 13:53:59 peter + * more fexpand fixes from marco van de voort + + Revision 1.18 1998/11/23 12:48:02 peter + * fexpand('o:') fixed to return o:\ (from the mailinglist) + + Revision 1.17 1998/11/22 09:33:21 florian + * fexpand bug (temp. strings were too shoort) fixed, was reported + by Marco van de Voort + + Revision 1.16 1998/11/17 09:37:41 pierre + * explicit conversion from word dosreg.ax to integer doserror + + Revision 1.15 1998/11/01 20:27:18 peter + * fixed some doserror settings + + Revision 1.14 1998/10/22 15:05:28 pierre + * fsplit adapted to long filenames + + Revision 1.13 1998/09/16 16:47:24 peter + * merged fixes + + Revision 1.11.2.2 1998/09/16 16:16:04 peter + * go32v1 compiles again + + Revision 1.12 1998/09/11 12:46:44 pierre + * range check problem with LFN attr removed + + Revision 1.11.2.1 1998/09/11 12:38:41 pierre + * conversion from LFN attr to Dos attr did not respect range checking + + Revision 1.11 1998/08/28 10:45:58 peter + * fixed path buffer in findfirst + + Revision 1.10 1998/08/27 10:30:48 pierre + * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !) + I renamed tb_selector to tb_segment because + it is a real mode segment as opposed to + a protected mode selector + Fixed it for go32v1 (remove the $E0000000 offset !) + + Revision 1.9 1998/08/26 10:04:01 peter + * new lfn check from mailinglist + * renamed win95 -> LFNSupport + + tb_selector, tb_offset for easier access to transferbuffer + + Revision 1.8 1998/08/16 20:39:49 peter + + LFN Support + + Revision 1.7 1998/08/16 09:12:13 michael + Corrected fexpand behaviour. + + Revision 1.6 1998/08/05 21:01:50 michael + applied bugfix from maillist to fsearch + + Revision 1.5 1998/05/31 14:18:13 peter + * force att or direct assembling + * cleanup of some files + + Revision 1.4 1998/05/22 00:39:22 peter + * go32v1, go32v2 recompiles with the new objects + * remake3 works again with go32v2 + - removed some "optimizes" from daniel which were wrong + + Revision 1.3 1998/05/21 19:30:47 peter + * objects compiles for linux + + assign(pchar), assign(char), rename(pchar), rename(char) + * fixed read_text_as_array + + read_text_as_pchar which was not yet in the rtl +} + + + +Function StringToPPChar(Var S:STring):ppchar; +{ + Create a PPChar to structure of pchars which are the arguments specified + in the string S. Especially usefull for creating an ArgV for Exec-calls +} +var + nr : longint; + Buf : ^char; + p : ppchar; +begin + s:=s+#0; + buf:=@s[1]; + nr:=0; + while(buf^<>#0) do + begin + while (buf^ in [' ',#8,#10]) do + inc(buf); + inc(nr); + while not (buf^ in [' ',#0,#8,#10]) do + inc(buf); + end; + getmem(p,nr*4); + StringToPPChar:=p; + if p=nil then + begin +{ LinuxError:=sys_enomem;} + exit; + end; + buf:=@s[1]; + while (buf^<>#0) do + begin + while (buf^ in [' ',#8,#10]) do + begin + buf^:=#0; + inc(buf); + end; + p^:=buf; + inc(p); + p^:=nil; + while not (buf^ in [' ',#0,#8,#10]) do + inc(buf); + end; +end; + + + +Function Dirname(Const path:pathstr):pathstr; +{ + This function returns the directory part of a complete path. + Unless the directory is root '/', The last character is not + a slash. +} +var + Dir : PathStr; + Name : NameStr; + Ext : ExtStr; +begin + FSplit(Path,Dir,Name,Ext); + if length(Dir)>1 then + Delete(Dir,length(Dir),1); + DirName:=Dir; +end; + + + +Function Basename(Const path:pathstr;Const suf:pathstr):pathstr; +{ + This function returns the filename part of a complete path. If suf is + supplied, it is cut off the filename. +} +var + Dir : PathStr; + Name : NameStr; + Ext : ExtStr; +begin + FSplit(Path,Dir,Name,Ext); + if Suf<>Ext then + Name:=Name+Ext; + BaseName:=Name; +end; + + +function GetEnv(EnvVar: String): String; +var p:pchar; +begin + p:=beos.GetEnv(EnvVar); + if p=nil then + GetEnv:='' + else + GetEnv:=StrPas(p); +end; + + +end. + + + + + + + diff --git a/befpc/rtl/beos/i386/cprt0.s b/befpc/rtl/beos/i386/cprt0.s new file mode 100644 index 0000000..65228dc --- /dev/null +++ b/befpc/rtl/beos/i386/cprt0.s @@ -0,0 +1,210 @@ + .file "cprt0.s" +.data + .align 4 +default_environ: + .long 0 +.text +.globl _start + .type _start,@function +_start: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %ebx + call .L6 +.L6: + popl %ebx + addl $_GLOBAL_OFFSET_TABLE_+[.-.L6],%ebx + movl argv_save@GOT(%ebx),%eax + movl 12(%ebp),%edi + movl %edi,(%eax) + movl environ@GOT(%ebx),%eax + movl 16(%ebp),%esi + movl %esi,(%eax) + test %esi,%esi + jnz .L4 + movl environ@GOT(%ebx),%eax + movl %ebx,%ecx + addl $default_environ@GOTOFF,%ecx + movl %ecx,%edx + movl %edx,(%eax) +.L4: +/* movl %fs:0x4,%eax this doesn't work on BeOS 4.0, let's use find_thread instead */ + pushl $0x0 + call find_thread + movl __main_thread_id@GOT(%ebx),%edx + movl %eax,(%edx) + pushl %esi + pushl %edi + movl 8(%ebp),%eax + pushl %eax + call _init_c_library_ + call _call_init_routines_ + movl 8(%ebp),%eax + movl %eax,U_SYSBEOS_ARGC + movl %edi,U_SYSBEOS_ARGV + movl %esi,U_SYSBEOS_ENVP + xorl %ebp,%ebp + call PASCALMAIN + +.globl _haltproc +.type _haltproc,@function +_haltproc: + call _thread_do_exit_notification + xorl %ebx,%ebx + movw U_SYSBEOS_EXITCODE,%bx + pushl %ebx + call exit + + +/* int sys_open (int=0xFF000000, char * name, int mode, int=0, int close_on_exec=0); */ +.globl sys_open +.type sys_open,@function +sys_open: +xorl %eax,%eax +int $0x25 +ret + +/* int sys_close (int handle) */ +.globl sys_close +.type sys_close,@function +sys_close: +mov $0x01,%eax +int $0x25 +ret + +/* int sys_read (int handle, void * buffer, int length) */ +.globl sys_read +.type sys_read,@function +sys_read: +movl $0x02,%eax +int $0x25 +ret + +/* int sys_write (int handle, void * buffer, int length) */ +.globl sys_write +.type sys_write,@function +sys_write: +movl $0x3,%eax +int $0x25 +ret + +/* int sys_lseek (int handle, long long pos, int whence) */ +.globl sys_lseek +.type sys_lseek,@function +sys_lseek: +movl $0x5,%eax +int $0x25 +ret + +/* int sys_time(void) */ +.globl sys_time +.type sys_time,@function +sys_time: +movl $0x7,%eax +int $0x25 +ret + +/* int sys_resize_area */ +.globl sys_resize_area +.type sys_resize_area,@function +sys_resize_area: +movl $0x8,%eax +int $0x25 +ret + +/* int sys_opendir (0xFF000000, chra * name, 0) */ +.globl sys_opendir +.type sys_opendir,@function +sys_opendir: +movl $0xC,%eax +int $0x25 +ret + + +/* int sys_create_area */ +.globl sys_create_area +.type sys_create_area,@function +sys_create_area: +movl $0x14,%eax +int $0x25 +ret + +/* int sys_readdir (int handle, void * dirent, 0x11C, 0x01000000) */ +.globl sys_readdir +.type sys_readdir,@function +sys_readdir: +movl $0x1C,%eax +int $0x25 +ret + +/* int sys_mkdir (char=0xFF, char * name, int mode) */ +.globl sys_mkdir +.type sys_mkdir,@function +sys_mkdir: +movl $0x1E,%eax +int $0x25 +ret + +/* int sys_wait_for_thread */ +.globl sys_wait_for_thread +.type sys_wait_for_thread,@function +sys_wait_for_thread: +movl $0x22,%eax +int $0x25 +ret + +/* int sys_rename (int=0xFF000000, char * name, int=0xFF000000, char * newname) */ +.globl sys_rename +.type sys_rename,@function +sys_rename: +movl $0x26,%eax +int $0x25 +ret + +/* int sys_unlink (int=0xFF000000, char * name) */ +.globl sys_unlink +.type sys_unlink,@function +sys_unlink: +movl $0x27,%eax +int $0x25 +ret + +/* int sys_stat (int=0xFF000000, char * name, struct stat * s, int=0) */ +.globl sys_stat +.type sys_stat,@function +sys_stat: +movl $0x30,%eax +int $0x25 +ret + +/* int sys_load_image */ +.globl sys_load_image +.type sys_load_image,@function +sys_load_image: +movl $0x34,%eax +int $0x25 +ret + +/* void sys_exit (int exitcode) */ +.globl sys_exit +.type sys_exit,@function +sys_exit: +movl $0x3F,%eax +int $0x25 + +/* void sys_chdir (char 0xFF, char * name) */ +.globl sys_chdir +.type sys_chdir,@function +sys_chdir: +movl $0x57,%eax +int $0x25 +ret + +/* void sys_rmdir (char 0xFF, char * name) */ +.globl sys_rmdir +.type sys_rmdir,@function +sys_rmdir: +movl $0x60,%eax +int $0x25 +ret diff --git a/befpc/rtl/beos/i386/dllprt.cpp b/befpc/rtl/beos/i386/dllprt.cpp new file mode 100644 index 0000000..dd4444a --- /dev/null +++ b/befpc/rtl/beos/i386/dllprt.cpp @@ -0,0 +1,39 @@ +#include + +class FPC_DLL +{ + public: + FPC_DLL(); +// ~FPC_DLL(); +}; + +static FPC_DLL fpc_dll(); + +//FPC_DLL::~FPC_DLL() +//{ +// printf ("main thread ended."); +//} + + +extern "C" void PASCALMAIN(void); +extern int U_SYSBEOS_ARGC; +extern void * U_SYSBEOS_ARGV; +extern void * U_SYSBEOS_ENVP; + +static char * _argv[] = {"dll",0}; +static char * _envp[] = {0}; + +extern "C" void BEGIN() +{ + printf ("init\n"); + U_SYSBEOS_ARGC=0; + U_SYSBEOS_ARGV = (void *)_argv; + U_SYSBEOS_ENVP = (void *)_envp; + PASCALMAIN(); +} + +FPC_DLL::FPC_DLL() +{ + BEGIN(); +} + diff --git a/befpc/rtl/beos/i386/dllprt.s b/befpc/rtl/beos/i386/dllprt.s new file mode 100644 index 0000000..40fef3a --- /dev/null +++ b/befpc/rtl/beos/i386/dllprt.s @@ -0,0 +1,170 @@ + .file "dllprt.cpp" +.text + .p2align 2 +.globl _._7FPC_DLL + .type _._7FPC_DLL,@function +_._7FPC_DLL: +.LFB1: + pushl %ebp +.LCFI0: + movl %esp,%ebp +.LCFI1: + pushl %esi +.LCFI2: + pushl %ebx +.LCFI3: + call .L7 +.L7: + popl %ebx + addl $_GLOBAL_OFFSET_TABLE_+[.-.L7],%ebx + movl 8(%ebp),%esi +.L3: + movl 12(%ebp),%eax + andl $1,%eax + testl %eax,%eax + je .L5 + pushl %esi +.LCFI4: + call __builtin_delete@PLT + addl $4,%esp + jmp .L5 + .p2align 4,,7 +.L4: +.L5: +.L2: + leal -8(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret +.LFE1: +.Lfe1: + .size _._7FPC_DLL,.Lfe1-_._7FPC_DLL +.section .rodata +.LC0: + .string "dll" +.data + .align 4 + .type _argv,@object + .size _argv,8 +_argv: + .long .LC0 + .long 0 + .align 4 + .type _envp,@object + .size _envp,4 +_envp: + .long 0 +.text + .p2align 2 +.globl __7FPC_DLL + .type __7FPC_DLL,@function +__7FPC_DLL: +.LFB2: + pushl %ebp +.LCFI5: + movl %esp,%ebp +.LCFI6: + pushl %ebx +.LCFI7: + call .L11 +.L11: + popl %ebx + addl $_GLOBAL_OFFSET_TABLE_+[.-.L11],%ebx + movl U_SYSBEOS_ARGC@GOT(%ebx),%eax + movl $0,(%eax) + movl U_SYSBEOS_ARGV@GOT(%ebx),%eax + movl %ebx,%ecx + addl $_argv@GOTOFF,%ecx + movl %ecx,%edx + movl %edx,(%eax) + movl U_SYSBEOS_ENVP@GOT(%ebx),%eax + movl %ebx,%ecx + addl $_envp@GOTOFF,%ecx + movl %ecx,%edx + movl %edx,(%eax) + call PASCALMAIN__Fv@PLT +.L9: + movl 8(%ebp),%eax + jmp .L8 +.L8: + movl -4(%ebp),%ebx + movl %ebp,%esp + popl %ebp + ret +.LFE2: +.Lfe2: + .size __7FPC_DLL,.Lfe2-__7FPC_DLL + +.section .eh_frame,"aw",@progbits +__FRAME_BEGIN__: + .4byte .LLCIE1 +.LSCIE1: + .4byte 0x0 + .byte 0x1 + .byte 0x0 + .byte 0x1 + .byte 0x7c + .byte 0x8 + .byte 0xc + .byte 0x4 + .byte 0x4 + .byte 0x88 + .byte 0x1 + .align 4 +.LECIE1: + .set .LLCIE1,.LECIE1-.LSCIE1 + .4byte .LLFDE1 +.LSFDE1: + .4byte .LSFDE1-__FRAME_BEGIN__ + .4byte .LFB1 + .4byte .LFE1-.LFB1 + .byte 0x4 + .4byte .LCFI0-.LFB1 + .byte 0xe + .byte 0x8 + .byte 0x85 + .byte 0x2 + .byte 0x4 + .4byte .LCFI1-.LCFI0 + .byte 0xd + .byte 0x5 + .byte 0x4 + .4byte .LCFI2-.LCFI1 + .byte 0x86 + .byte 0x3 + .byte 0x4 + .4byte .LCFI3-.LCFI2 + .byte 0x83 + .byte 0x4 + .byte 0x4 + .4byte .LCFI4-.LCFI3 + .byte 0x2e + .byte 0x4 + .align 4 +.LEFDE1: + .set .LLFDE1,.LEFDE1-.LSFDE1 + .4byte .LLFDE3 +.LSFDE3: + .4byte .LSFDE3-__FRAME_BEGIN__ + .4byte .LFB2 + .4byte .LFE2-.LFB2 + .byte 0x4 + .4byte .LCFI5-.LFB2 + .byte 0xe + .byte 0x8 + .byte 0x85 + .byte 0x2 + .byte 0x4 + .4byte .LCFI6-.LCFI5 + .byte 0xd + .byte 0x5 + .byte 0x4 + .4byte .LCFI7-.LCFI6 + .byte 0x83 + .byte 0x3 + .align 4 +.LEFDE3: + .set .LLFDE3,.LEFDE3-.LSFDE3 + .ident "GCC: (GNU) 2.9-beos-991026" diff --git a/befpc/rtl/beos/i386/func.s b/befpc/rtl/beos/i386/func.s new file mode 100644 index 0000000..9c466ca --- /dev/null +++ b/befpc/rtl/beos/i386/func.s @@ -0,0 +1,161 @@ + .file "func.s" +.text + +.globl _haltproc +.type _haltproc,@function +_haltproc: + xorl %ebx,%ebx + movw U_SYSBEOS_EXITCODE,%bx + pushl %ebx + call sys_exit + +/* int sys_open (int=0xFF000000, char * name, int mode, int=0, int close_on_exec=0); */ +.globl sys_open +.type sys_open,@function +sys_open: +xorl %eax,%eax +int $0x25 +ret + +/* int sys_close (int handle) */ +.globl sys_close +.type sys_close,@function +sys_close: +mov $0x01,%eax +int $0x25 +ret + +/* int sys_read (int handle, void * buffer, int length) */ +.globl sys_read +.type sys_read,@function +sys_read: +movl $0x02,%eax +int $0x25 +ret + +/* int sys_write (int handle, void * buffer, int length) */ +.globl sys_write +.type sys_write,@function +sys_write: +movl $0x3,%eax +int $0x25 +ret + +/* int sys_lseek (int handle, long long pos, int whence) */ +.globl sys_lseek +.type sys_lseek,@function +sys_lseek: +movl $0x5,%eax +int $0x25 +ret + +/* int sys_time(void) */ +.globl sys_time +.type sys_time,@function +sys_time: +movl $0x7,%eax +int $0x25 +ret + +/* int sys_resize_area */ +.globl sys_resize_area +.type sys_resize_area,@function +sys_resize_area: +movl $0x8,%eax +int $0x25 +ret + +/* int sys_opendir (0xFF000000, chra * name, 0) */ +.globl sys_opendir +.type sys_opendir,@function +sys_opendir: +movl $0xC,%eax +int $0x25 +ret + +/* int sys_create_area */ +.globl sys_create_area +.type sys_create_area,@function +sys_create_area: +movl $0x14,%eax +int $0x25 +ret + +/* int sys_readdir (int handle, void * dirent, 0x11C, 0x01000000) */ +.globl sys_readdir +.type sys_readdir,@function +sys_readdir: +movl $0x1C,%eax +int $0x25 +ret + +/* int sys_mkdir (char=0xFF, char * name, int mode) */ +.globl sys_mkdir +.type sys_mkdir,@function +sys_mkdir: +movl $0x1E,%eax +int $0x25 +ret + +/* int sys_wait_for_thread */ +.globl sys_wait_for_thread +.type sys_wait_for_thread,@function +sys_wait_for_thread: +movl $0x22,%eax +int $0x25 +ret + +/* int sys_rename (int=0xFF000000, char * name, int=0xFF000000, char * newname) */ +.globl sys_rename +.type sys_rename,@function +sys_rename: +movl $0x26,%eax +int $0x25 +ret + +/* int sys_unlink (int=0xFF000000, char * name) */ +.globl sys_unlink +.type sys_unlink,@function +sys_unlink: +movl $0x27,%eax +int $0x25 +ret + +/* int sys_stat (int=0xFF000000, char * name, struct stat * s, int=0) */ +.globl sys_stat +.type sys_stat,@function +sys_stat: +movl $0x30,%eax +int $0x25 +ret + +/* int sys_load_image */ +.globl sys_load_image +.type sys_load_image,@function +sys_load_image: +movl $0x34,%eax +int $0x25 +ret + +/* void sys_exit (int exitcode) */ +.globl sys_exit +.type sys_exit,@function +sys_exit: +movl $0x3F,%eax +int $0x25 + +/* void sys_chdir (char 0xFF, char * name) */ +.globl sys_chdir +.type sys_chdir,@function +sys_chdir: +movl $0x57,%eax +int $0x25 +ret + +/* void sys_rmdir (char 0xFF, char * name) */ +.globl sys_rmdir +.type sys_rmdir,@function +sys_rmdir: +movl $0x60,%eax +int $0x25 +ret diff --git a/befpc/rtl/beos/i386/prt0.s b/befpc/rtl/beos/i386/prt0.s new file mode 100644 index 0000000..2c3e883 --- /dev/null +++ b/befpc/rtl/beos/i386/prt0.s @@ -0,0 +1,174 @@ + .file "prt0.c" +.text +.globl start + .type start,@function +start: + pushl %ebp + movl %esp,%ebp + movl 16(%ebp),%ecx + movl 12(%ebp),%ebx + movl 8(%ebp),%eax + movl %eax,U_SYSBEOS_ARGC + movl %ebx,U_SYSBEOS_ARGV + movl %ecx,U_SYSBEOS_ENVP + xorl %ebp,%ebp + call PASCALMAIN + +.globl _haltproc +.type _haltproc,@function +_haltproc: + xorl %ebx,%ebx + movw U_SYSBEOS_EXITCODE,%bx + pushl %ebx + call sys_exit + +/* int sys_open (int=0xFF000000, char * name, int mode, int=0, int close_on_exec=0); */ +.globl sys_open +.type sys_open,@function +sys_open: +xorl %eax,%eax +int $0x25 +ret + +/* int sys_close (int handle) */ +.globl sys_close +.type sys_close,@function +sys_close: +mov $0x01,%eax +int $0x25 +ret + +/* int sys_read (int handle, void * buffer, int length) */ +.globl sys_read +.type sys_read,@function +sys_read: +movl $0x02,%eax +int $0x25 +ret + +/* int sys_write (int handle, void * buffer, int length) */ +.globl sys_write +.type sys_write,@function +sys_write: +movl $0x3,%eax +int $0x25 +ret + +/* int sys_lseek (int handle, long long pos, int whence) */ +.globl sys_lseek +.type sys_lseek,@function +sys_lseek: +movl $0x5,%eax +int $0x25 +ret + +/* int sys_time(void) */ +.globl sys_time +.type sys_time,@function +sys_time: +movl $0x7,%eax +int $0x25 +ret + +/* int sys_resize_area */ +.globl sys_resize_area +.type sys_resize_area,@function +sys_resize_area: +movl $0x8,%eax +int $0x25 +ret + +/* int sys_opendir (0xFF000000, chra * name, 0) */ +.globl sys_opendir +.type sys_opendir,@function +sys_opendir: +movl $0xC,%eax +int $0x25 +ret + +/* int sys_create_area */ +.globl sys_create_area +.type sys_create_area,@function +sys_create_area: +movl $0x14,%eax +int $0x25 +ret + +/* int sys_readdir (int handle, void * dirent, 0x11C, 0x01000000) */ +.globl sys_readdir +.type sys_readdir,@function +sys_readdir: +movl $0x1C,%eax +int $0x25 +ret + +/* int sys_mkdir (char=0xFF, char * name, int mode) */ +.globl sys_mkdir +.type sys_mkdir,@function +sys_mkdir: +movl $0x1E,%eax +int $0x25 +ret + +/* int sys_wait_for_thread */ +.globl sys_wait_for_thread +.type sys_wait_for_thread,@function +sys_wait_for_thread: +movl $0x22,%eax +int $0x25 +ret + +/* int sys_rename (int=0xFF000000, char * name, int=0xFF000000, char * newname) */ +.globl sys_rename +.type sys_rename,@function +sys_rename: +movl $0x26,%eax +int $0x25 +ret + +/* int sys_unlink (int=0xFF000000, char * name) */ +.globl sys_unlink +.type sys_unlink,@function +sys_unlink: +movl $0x27,%eax +int $0x25 +ret + +/* int sys_stat (int=0xFF000000, char * name, struct stat * s, int=0) */ +.globl sys_stat +.type sys_stat,@function +sys_stat: +movl $0x30,%eax +int $0x25 +ret + +/* int sys_load_image */ +.globl sys_load_image +.type sys_load_image,@function +sys_load_image: +movl $0x34,%eax +int $0x25 +ret + +/* void sys_exit (int exitcode) */ +.globl sys_exit +.type sys_exit,@function +sys_exit: +movl $0x3F,%eax +int $0x25 + +/* void sys_chdir (char 0xFF, char * name) */ +.globl sys_chdir +.type sys_chdir,@function +sys_chdir: +movl $0x57,%eax +int $0x25 +ret + +/* void sys_rmdir (char 0xFF, char * name) */ +.globl sys_rmdir +.type sys_rmdir,@function +sys_rmdir: +movl $0x60,%eax +int $0x25 +ret diff --git a/befpc/rtl/beos/sysbeos.pp b/befpc/rtl/beos/sysbeos.pp new file mode 100644 index 0000000..d639eb9 --- /dev/null +++ b/befpc/rtl/beos/sysbeos.pp @@ -0,0 +1,514 @@ +{ + $Id: sysbeos.pp,v 1.1.1.1 2001-07-23 17:17:26 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + This is a prototype file to show all function that need to be implemented + for a new operating system (provided the processor specific + function are already implemented !) + + 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. + + **********************************************************************} +{ no stack check in system } + +{$DEFINE SHORT_LINEBREAK} +{$S-} +unit SysBeos; + +interface + +{ include system-independent routine headers } + +{$I systemh.inc} + +{ include heap support headers } + +{$I heaph.inc} + +var + argc : longint; + argv : ppchar; + envp : ppchar; + +var + UnusedHandle:longint; + StdInputHandle:longint; + StdOutputHandle:longint; + StdErrorHandle:longint; + +implementation + +{$I sysfiles.inc} + +function sys_unlink (a:longint;name:pchar):longint; cdecl; external name 'sys_unlink'; +function sys_rename (a:longint;p1:pchar;b:longint;p2:pchar):longint; cdecl; external name 'sys_rename'; +function sys_create_area (name:pchar; var start:longint; a,b,c,d:longint):longint; cdecl; external name 'sys_create_area'; +function sys_resize_area (handle:longint; size:longint):longint; cdecl; external name 'sys_resize_area'; +function sys_mkdir (a:longint; name:pchar; mode:longint):longint; cdecl; external name 'sys_mkdir'; +function sys_chdir (a:longint; name:pchar):longint; cdecl; external name 'sys_chdir'; +function sys_rmdir (a:longint; name:pchar):longint; cdecl; external name 'sys_rmdir'; + +{$I system.inc} + + +{***************************************************************************** + System Dependent Exit code +*****************************************************************************} +procedure prthaltproc;external name '_haltproc'; + +procedure system_exit; +begin + asm + jmp prthaltproc + end; +End; + +{***************************************************************************** + Stack check code +*****************************************************************************} +procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK']; +{ + called when trying to get local stack if the compiler directive $S + is set this function must preserve esi !!!! because esi is set by + the calling proc for methods it must preserve all registers !! + + With a 2048 byte safe area used to write to StdIo without crossing + the stack boundary +} +begin +end; + +{***************************************************************************** + ParamStr/Randomize +*****************************************************************************} + +{ number of args } +function paramcount : longint; +begin + paramcount := argc - 1; +end; + +{ argument number l } +function paramstr(l : longint) : string; +begin + if (l>=0) and (l+1<=argc) then + paramstr:=strpas(argv[l]) + else + paramstr:=''; +end; + +{ set randseed to a new pseudo random value } +procedure randomize; +begin + {regs.realeax:=$2c00; + sysrealintr($21,regs); + hl:=regs.realedx and $ffff; + randseed:=hl*$10000+ (regs.realecx and $ffff);} + randseed:=0; +end; + +{***************************************************************************** + Heap Management +*****************************************************************************} + +var myheapstart:longint; + myheapsize:longint; + myheaprealsize:longint; + heap_handle:longint; + zero:longint; + +{ first address of heap } +function getheapstart:pointer; +begin + getheapstart:=pointer(myheapstart); +end; + +{ current length of heap } +function getheapsize:longint; +begin + getheapsize:=myheapsize; +end; + +{ function to allocate size bytes more for the program } +{ must return the first address of new data space or -1 if fail } +function Sbrk(size : longint):longint; +var newsize,newrealsize:longint; +begin + if (myheapsize+size)<=myheaprealsize then begin + Sbrk:=myheapstart+myheapsize; + myheapsize:=myheapsize+size; + exit; + end; + newsize:=myheapsize+size; + newrealsize:=(newsize and $FFFFF000)+$1000; + if sys_resize_area(heap_handle,newrealsize)=0 then begin + Sbrk:=myheapstart+myheapsize; + myheapsize:=newsize; + myheaprealsize:=newrealsize; + exit; + end; + Sbrk:=-1; +end; + + +{ include standard heap management } +{$I heap.inc} + + +{**************************************************************************** + Low level File Routines + All these functions can set InOutRes on errors + ****************************************************************************} + + + +{ close a file from the handle value } +procedure do_close(handle : longint); +begin +{ writeln ('CLOSE ',handle);} + if handle<=2 then exit; + InOutRes:=sys_close(handle); +end; + + +procedure do_erase(p : pchar); +begin + if sys_unlink($FF000000,p)<>0 then InOutRes:=1 + else InOutRes:=0; +end; + +procedure do_rename(p1,p2 : pchar); +begin + InOutRes:=sys_rename($FF000000,p1,$FF000000,p2); +end; + +function do_write(h,addr,len : longint) : longint; +begin +{ if h>0 then begin + sys_write ('WRITE handle=%d ',h); + printf ('addr=%x ',addr); + printf ('len=%d',len); + printf ('%c',10); + end;} + do_write:=sys_write (h,pointer(addr),len,zero); + if (do_write<0) then begin + InOutRes:=do_write; + do_write:=0; + end else InOutRes:=0; +end; + +function do_read(h,addr,len : longint) : longint; +begin +{ if h>2 then begin + printf ('READ handle=%d ',h); + printf ('addr=%x ',addr); + printf ('len=%d',len); + end;} + do_read:=sys_read (h,pointer(addr),len,zero); + if (do_read<0) then begin + InOutRes:=do_read; + do_read:=0; + end else InOutRes:=0; +end; + +function do_filepos(handle : longint) : longint; +begin + do_filepos:=sys_lseek(handle,0,1); {1=SEEK_CUR} + if (do_filepos<0) then begin + InOutRes:=do_filepos; + do_filepos:=0; + end else InOutRes:=0; +end; + +procedure do_seek(handle,pos : longint); +var s:longint; +begin + InOutRes:=sys_lseek(handle,pos,0); + if InOutRes>0 then InOutRes:=0; +end; + +function do_seekend(handle:longint):longint; +begin + do_seekend:=sys_lseek (handle,0,2); {2=SEEK_END} + if do_seekend<0 then begin + InOutRes:=do_seekend; + do_seekend:=0; + end else InOutRes:=0; +end; + +function do_filesize(handle : longint) : longint; +var cur:longint; +begin + cur:=sys_lseek (handle,0,1); {1=SEEK_CUR} + if cur<0 then begin + InOutRes:=cur; + do_filesize:=0; + exit; + end; + do_filesize:=sys_lseek (handle,0,2); {2=SEEK_END} + if do_filesize<0 then begin + InOutRes:=do_filesize; + do_filesize:=0; + exit; + end; + cur:=sys_lseek (handle,cur,0); {0=SEEK_POS} + if cur<0 then begin + InOutRes:=cur; + do_filesize:=0; + exit; + end; +end; + +{ truncate at a given position } +procedure do_truncate (handle,pos:longint); +begin + InOutRes:=1; +end; + +procedure do_open(var f;p:pchar;flags:longint); +{ + filerec and textrec have both handle and mode as the first items so + they could use the same routine for opening/creating. + when (flags and $100) the file will be append + when (flags and $1000) the file will be truncate/rewritten + when (flags and $10000) there is no check for close (needed for textfiles) +} +var m:longint; + mode,h:longint; +begin +{ printf ('OPEN %d ',longint(f)); + printf (' %s',longint(p)); + printf (' %x',flags);} + + m:=0; + case (flags and $3) of + $0: begin m:=m or O_RDONLY; mode:=fminput; end; + $1: begin m:=m or O_WRONLY; mode:=fmoutput;end; + $2: begin m:=m or O_RDWR; mode:=fminout; end; + end; + + if (flags and $100)<>0 then m:=m or O_APPEND; + if (flags and $1000)<>0 then m:=m or O_TRUNC or O_CREAT; + +{ if (flags and $10000)<>0 then m:=m or O_TEXT else m:=m or O_BINARY;} + + h:=sys_open($FF000000,p,m,0,0); + + if h<0 then InOutRes:=h + else InOutRes:=0; + + if InOutRes=0 then begin + FileRec(f).handle:=h; + FileRec(f).mode:=mode; + end; +end; + +function do_isdevice(handle:longint):boolean; +begin + do_isdevice:=false; + InOutRes:=0; +end; + + +{***************************************************************************** + UnTyped File Handling +*****************************************************************************} + +{$i file.inc} + +{***************************************************************************** + Typed File Handling +*****************************************************************************} + +{$i typefile.inc} + +{***************************************************************************** + Text File Handling +*****************************************************************************} + +{ should we consider #26 as the end of a file ? } +{?? $DEFINE EOF_CTRLZ} + +{$i text.inc} + +{***************************************************************************** + Directory Handling +*****************************************************************************} +procedure mkdir(const s : string);[IOCheck]; +var t:string; +begin + t:=s+#0; + InOutRes:=sys_mkdir ($FF000000,@t[1],493); +end; + +procedure rmdir(const s : string);[IOCheck]; +var t:string; +begin + t:=s+#0; + InOutRes:=sys_rmdir ($FF000000,@t[1]); +end; + +procedure chdir(const s : string);[IOCheck]; +var t:string; +begin + t:=s+#0; + InOutRes:=sys_chdir ($FF000000,@t[1]); +end; + +{***************************************************************************** + getdir procedure +*****************************************************************************} +type dirent = packed record + d_dev:longint; + d_pdev:longint; + d_ino:int64; + d_pino:int64; + d_reclen:word; + d_name:array[0..255] of char; + end; + + stat = packed record + dev:longint; {"device" that this file resides on} + ino:int64; {this file's inode #, unique per device} + mode:dword; {mode bits (rwx for user, group, etc)} + nlink:longint; {number of hard links to this file} + uid:dword; {user id of the owner of this file} + gid:dword; {group id of the owner of this file} + size:int64; {size of this file (in bytes)} + rdev:longint; {device type (not used)} + blksize:longint; {preferref block size for i/o} + atime:longint; {last access time} + mtime:longint; {last modification time} + ctime:longint; {last change time, not creation time} + crtime:longint; {creation time} + end; + pstat = ^stat; + +function sys_stat (a:longint;path:pchar;info:pstat;n:longint):longint; cdecl; external name 'sys_stat'; + +function FStat(Path:String;Var Info:stat):Boolean; +{ + Get all information on a file, and return it in Info. +} +var tmp:string; +var p:pchar; +begin + tmp:=path+#0; + p:=@tmp[1]; + FStat:=(sys_stat($FF000000,p,@Info,0)=0); +end; + + +function sys_opendir (a:dword;path:pchar;b:longint):longint; cdecl; external name 'sys_opendir'; +function sys_readdir (fd:longint;var de:dirent;a:longint;b:byte):longint; cdecl; external name 'sys_readdir'; + +function parentdir(fd:longint;dev:longint;ino:int64;var err:longint):string; +var len:longint; + ent:dirent; + info:stat; + name:string; +begin + err:=0; + parentdir:=''; + if sys_readdir(fd,ent,$11C,1)=0 then begin + err:=1; + exit; + end; + + len:=StrLen(@ent.d_name); + Move(ent.d_name,name[1],len); + name[0]:=chr(len); +{ writeln ('NAME: "',name,'" = ',ent.d_dev,',',ent.d_ino);} + if (dev=ent.d_dev) and (ino=ent.d_ino) then begin + err:=0; + parentdir:='/'+name; + exit; + end; + + err:=0; +end; + + +function getdir2:string; +var tmp:string; + p:pchar; + info:stat; + info2:stat; + ext:string; + fd:longint; + name:string; + cur:string; + res:string; + err:longint; +begin + res:=''; + cur:=''; + + repeat + + FStat(cur+'.',info); + FStat(cur+'..',info2); +{ writeln ('"." = ',info.dev,',',info.ino);} + if ((info.dev=info2.dev) and (info.ino=info2.ino)) then begin + if res='' then getdir2:='/' else getdir2:=res; + exit; + end; + + tmp:=cur+'..'+#0; + fd:=sys_opendir ($FF000000,@tmp[1],0); + repeat + name:=parentdir(fd,info.dev,info.ino,err); + until (err<>0) or (name<>''); + if err<>0 then begin + getdir2:=''; + exit; + end; + res:=name+res; +{ writeln(res);} + cur:=cur+'../'; + until false; +end; + +procedure getdir(drivenr : byte;var dir : shortstring); +var s:string; + r:longint; +begin + drivenr:=0; + dir:=getdir2; +end; + + +{***************************************************************************** + SystemUnit Initialization +*****************************************************************************} + +begin +{ Setup heap } + zero:=0; + myheapsize:=$2000; + myheaprealsize:=$2000; + myheapstart:=0; + heap_handle:=sys_create_area('fpcheap',myheapstart,0,myheaprealsize,0,3); + if heap_handle>0 then begin + InitHeap; + end else system_exit; + +{ Setup IO } + StdInputHandle:=0; + StdOutputHandle:=1; + StdErrorHandle:=2; + + OpenStdIO(Input,fmInput,StdInputHandle); + OpenStdIO(Output,fmOutput,StdOutputHandle); + OpenStdIO(StdOut,fmOutput,StdOutputHandle); + OpenStdIO(StdErr,fmOutput,StdErrorHandle); + +{ Reset IO Error } + InOutRes:=0; +end. diff --git a/befpc/rtl/beos/sysfiles.inc b/befpc/rtl/beos/sysfiles.inc new file mode 100644 index 0000000..74626ee --- /dev/null +++ b/befpc/rtl/beos/sysfiles.inc @@ -0,0 +1,18 @@ + +const O_RDONLY=0; +const O_WRONLY=1; +const O_RDWR=2; +const O_CREAT = $200; +const O_TRUNC = $400; +const O_APPEND = $800; +{const O_TEXT = $4000; +const O_BINARY = $8000;} + + +function sys_open (a:longint;name:pchar;access:longint;b:longint;c:longint):longint; cdecl; external name 'sys_open'; +function sys_close (handle:longint):longint; cdecl; external name 'sys_close'; +function sys_read (handle:longint;buffer:pointer;len:longint;var a:longint):longint; cdecl; external name 'sys_read'; +function sys_write (handle:longint;buffer:pointer;len:longint;var a:longint):longint; cdecl; external name 'sys_write'; +function sys_lseek (handle:longint;pos:int64;whence:longint): int64; cdecl; external name 'sys_lseek'; + + \ No newline at end of file diff --git a/befpc/rtl/beos/systemh.inc b/befpc/rtl/beos/systemh.inc new file mode 100644 index 0000000..001dc36 --- /dev/null +++ b/befpc/rtl/beos/systemh.inc @@ -0,0 +1,539 @@ +{ + $Id: systemh.inc,v 1.1.1.1 2001-07-23 17:17:26 memson Exp $ + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This File contains the OS independent declarations of the system unit + + 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. + + **********************************************************************} + +{ + Supported conditionnals: + ------------------------ + RTLLITE Create a somewhat smaller RTL +} + +{**************************************************************************** + Needed switches +****************************************************************************} + +{$I-,Q-,H-,R-,V-} +{$mode objfpc} + +{ don't use FPU registervariables on the i386 } +{$ifdef i386} + {$maxfpuregisters 0} +{$endif i386} + +{ needed for insert,delete,readln } +{$P+} + +{ Stack check gives a note under linux } +{$ifndef linux} + {$S-} +{$endif} + +{**************************************************************************** + Global Types and Constants +****************************************************************************} + +Type + shortint = -128..127; + SmallInt = -32768..32767; + Longint = $80000000..$7fffffff; { $8000000 creates a longint overfow !! } + byte = 0..255; + Word = 0..65535; + dword = cardinal; + longword = cardinal; + +{ at least declare Turbo Pascal real types } +{$ifdef i386} + StrLenInt = LongInt; + + {$define DEFAULT_EXTENDED} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + {$define SUPPORT_EXTENDED} + {$define SUPPORT_COMP} + + { define SUPPORT_FIXED} + + ValSInt = Longint; + ValUInt = Cardinal; + ValReal = Extended; +{$endif} + +{$ifdef m68k} + StrLenInt = Longint; + + ValSInt = Longint; + ValUInt = Cardinal; + ValReal = Real; + + {$define SUPPORT_SINGLE} +{$endif} + +{ Zero - terminated strings } + PChar = ^Char; + PPChar = ^PChar; +{ Delphi types } + TAnsiChar = Char; + AnsiChar = TAnsiChar; + PAnsiChar = PChar; + PQWord = ^QWord; + PInt64 = ^Int64; + +{$ifdef HASWIDECHAR} + PWideChar = ^WideChar; +{$endif HASWIDECHAR} + +{ procedure type } + TProcedure = Procedure; + +const +{ Maximum value of the biggest signed and unsigned integer type available} + MaxSIntValue = High(ValSInt); + MaxUIntValue = High(ValUInt); + +{ max. values for longint and int} + maxLongint = $7fffffff; + maxSmallint = 32767; + +{ Integer type definition } +type + Integer = smallint; +const + maxint = maxsmallint; + +{ Compatibility With TP } +const +{$ifdef i386} + Test8086 : byte = 2; { Always i386 or newer } + Test8087 : byte = 3; { Always 387 or newer. Emulated if needed. } + { code to use comps in int64mul and div code is commented out! (JM) } + FPUInt64 : boolean = false; { set this to false if you don't want that } + { the fpu does int64*int64 and } + { int64 div int64, if the * is overflow } + { checked, it is done in software } +{$endif i386} +{$ifdef m68k} + Test68000 : byte = 0; { Must be determined at startup for both } + Test68881 : byte = 0; +{$endif} + +{ max level in dumping on error } + Max_Frame_Dump : Word = 8; + +{ Exit Procedure handling consts and types } + ExitProc : pointer = nil; + Erroraddr: pointer = nil; + Errorcode: Word = 0; + +{ file input modes } + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + fmAppend = $D7B4; + Filemode : byte = 2; + CmdLine : PChar = nil; + +var +{ Standard In- and Output } + Output, + Input, + StdOut, + StdErr : Text; + ExitCode, + InOutRes : Word; + StackBottom, + LowestStack, + RandSeed : Cardinal; +{ Delphi compatible } + IsLibrary,IsMultiThreaded,IsConsole : boolean; + + +{**************************************************************************** + Processor specific routines +****************************************************************************} + +Procedure Move(const source;var dest;count:Longint); +Procedure FillChar(Var x;count:Longint;Value:Boolean); +Procedure FillChar(Var x;count:Longint;Value:Char); +Procedure FillChar(Var x;count:Longint;Value:Byte); +{$ifndef RTLLITE} +procedure FillByte(var x;count:longint;value:byte); +Procedure FillWord(Var x;count:Longint;Value:Word); +procedure FillDWord(var x;count:longint;value:DWord); +function IndexChar(var buf;len:longint;b:char):longint; +function IndexByte(var buf;len:longint;b:byte):longint; +function Indexword(var buf;len:longint;b:word):longint; +function IndexDWord(var buf;len:longint;b:DWord):longint; +function CompareChar(var buf1,buf2;len:longint):longint; +function CompareByte(var buf1,buf2;len:longint):longint; +function CompareWord(var buf1,buf2;len:longint):longint; +function CompareDWord(var buf1,buf2;len:longint):longint; +procedure MoveChar0(var buf1,buf2;len:longint); +function IndexChar0(var buf;len:longint;b:char):longint; +function CompareChar0(var buf1,buf2;len:longint):longint; +{$endif} + + +{**************************************************************************** + Math Routines +****************************************************************************} + +{$ifndef RTLLITE} +Function lo(w:Word):byte; +Function lo(l:Longint):Word; +Function lo(l:DWord):Word; +Function lo(i:Integer):byte; +Function lo(B: Byte):Byte; +Function hi(w:Word):byte; +Function hi(i:Integer):byte; +Function hi(l:Longint):Word; +Function hi(b : Byte) : Byte; +Function hi(l: DWord): Word; +Function Swap (X:Word):Word; +Function Swap (X:Integer):Integer; +Function Swap (X:Cardinal):Cardinal; +Function Swap (X:LongInt):LongInt; +{$ifdef INT64} +Function lo(q : QWord) : DWord; +Function lo(i : Int64) : DWord; +Function hi(q : QWord) : DWord; +Function hi(i : Int64) : DWord; +Function Swap (X:QWord):QWord; +Function Swap (X:Int64):Int64; +{$endif} +{$endif RTLLITE} + +Function Random(l:cardinal):cardinal; +{$ifndef cardinalmulfixed} +Function Random(l:longint):longint; +{$endif cardinalmulfixed} +Function Random: extended; +Procedure Randomize; + +Function abs(l:Longint):Longint; +Function sqr(l:Longint):Longint; +Function odd(l:Longint):Boolean; + +{ float math routines } +{$I mathh.inc} + +{**************************************************************************** + Addr/Pointer Handling +****************************************************************************} + +{$ifndef RTLLITE} +Function ptr(sel,off:Longint):pointer; +Function Cseg:Word; +Function Dseg:Word; +Function Sseg:Word; +{$endif RTLLITE} + +{**************************************************************************** + PChar and String Handling +****************************************************************************} + +function strpas(p:pchar):shortstring; +function strlen(p:pchar):longint; + +{ Shortstring functions } +Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring; +Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt); +Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt); +Procedure Insert(source:Char;Var s:shortstring;index:StrLenInt); +Function Pos(const substr:shortstring;const s:shortstring):StrLenInt; +Function Pos(C:Char;const s:shortstring):StrLenInt; +Procedure SetLength(var s:shortstring;len:StrLenInt); +Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint); +Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint); +Function Length(s:string):byte; +Function upCase(const s:shortstring):shortstring; +{$ifndef RTLLITE} +Function lowerCase(const s:shortstring):shortstring; +{$endif} +Function Space(b:byte):shortstring; +{$ifndef RTLLITE} +Function hexStr(Val:Longint;cnt:byte):shortstring; +Function binStr(Val:Longint;cnt:byte):shortstring; +{$endif RTLLITE} + +{ Char functions } +Function Chr(b:byte):Char; +Function upCase(c:Char):Char; +{$ifndef RTLLITE} +Function lowerCase(c:Char):Char; +{$endif RTLLITE} +function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring; +function pos(const substr : shortstring;c:char): StrLenInt; +function length(c:char):byte; + + +{**************************************************************************** + AnsiString Handling +****************************************************************************} + +Procedure SetLength (Var S : AnsiString; l : Longint); +Procedure UniqueString (Var S : AnsiString); +Function Length (Const S : AnsiString) : Longint; +Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString; +Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint; +Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint); +Procedure Delete (Var S : AnsiString; Index,Size: Longint); +Function StringOfChar(c : char;l : longint) : AnsiString; + + +{**************************************************************************** + Untyped File Management +****************************************************************************} + +Procedure Assign(Var f:File;const Name:string); +Procedure Assign(Var f:File;p:pchar); +Procedure Assign(Var f:File;c:char); +Procedure Rewrite(Var f:File;l:Longint); +Procedure Rewrite(Var f:File); +Procedure Reset(Var f:File;l:Longint); +Procedure Reset(Var f:File); +Procedure Close(Var f:File); +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint;Var Result:Longint); +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;Var Result:Word); +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;Var Result:Integer); +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint); +Procedure BlockRead(Var f:File;Var Buf;count:Longint;Var Result:Longint); +Procedure BlockRead(Var f:File;Var Buf;count:Word;Var Result:Word); +Procedure BlockRead(Var f:File;Var Buf;count:Word;Var Result:Integer); +Procedure BlockRead(Var f:File;Var Buf;count:Longint); +Function FilePos(Var f:File):Longint; +Function FileSize(Var f:File):Longint; +Procedure Seek(Var f:File;Pos:Longint); +Function EOF(Var f:File):Boolean; +Procedure Erase(Var f:File); +Procedure Rename(Var f:File;const s:string); +Procedure Rename(Var f:File;p:pchar); +Procedure Rename(Var f:File;c:char); +Procedure Truncate (Var F:File); + + +{**************************************************************************** + Typed File Management +****************************************************************************} + +Procedure Assign(Var f:TypedFile;const Name:string); +Procedure Assign(Var f:TypedFile;p:pchar); +Procedure Assign(Var f:TypedFile;c:char); +Procedure Rewrite(Var f:TypedFile); +Procedure Reset(Var f:TypedFile); + + +{**************************************************************************** + Text File Management +****************************************************************************} + +Procedure Assign(Var t:Text;const s:string); +Procedure Assign(Var t:Text;p:pchar); +Procedure Assign(Var t:Text;c:char); +Procedure Close(Var t:Text); +Procedure Rewrite(Var t:Text); +Procedure Reset(Var t:Text); +Procedure Append(Var t:Text); +Procedure Flush(Var t:Text); +Procedure Erase(Var t:Text); +Procedure Rename(Var t:Text;const s:string); +Procedure Rename(Var t:Text;p:pchar); +Procedure Rename(Var t:Text;c:char); +Function EOF(Var t:Text):Boolean; +Function EOF:Boolean; +Function EOLn(Var t:Text):Boolean; +Function EOLn:Boolean; +Function SeekEOLn (Var t:Text):Boolean; +Function SeekEOF (Var t:Text):Boolean; +Function SeekEOLn:Boolean; +Function SeekEOF:Boolean; +Procedure SetTextBuf(Var f:Text; Var Buf); +Procedure SetTextBuf(Var f:Text; Var Buf; Size:Longint); + + +{**************************************************************************** + Directory Management +****************************************************************************} + +Procedure chdir(const s:string); +Procedure mkdir(const s:string); +Procedure rmdir(const s:string); +Procedure getdir(drivenr:byte;Var dir:shortstring); +Procedure getdir(drivenr:byte;Var dir:ansistring); + + +{***************************************************************************** + Miscelleaous +*****************************************************************************} + +{ os independent calls to allow backtraces } +function get_frame:longint; +function get_caller_addr(framebp:longint):longint; +function get_caller_frame(framebp:longint):longint; + +Function IOResult:Word; +Function Sptr:Longint; + + +{***************************************************************************** + Init / Exit / ExitProc +*****************************************************************************} + +Function Paramcount:Longint; +Function ParamStr(l:Longint):string; +{$ifndef RTLLITE} +Procedure Dump_Stack(var f : text;bp:Longint); +{$endif RTLLITE} +Procedure RunError(w:Word); +Procedure RunError; +Procedure halt(errnum:byte); +{$ifndef RTLLITE} +Procedure AddExitProc(Proc:TProcedure); +{$endif RTLLITE} +Procedure halt; + + +{***************************************************************************** + Abstract/Assert/Error Handling +*****************************************************************************} + +procedure AbstractError; +Function SysBackTraceStr(Addr: Longint): ShortString; +Procedure SysAssert(Const Msg,FName:ShortString;LineNo,ErrorAddr:Longint); + +{ Error handlers } +Type + TBackTraceStrFunc = Function (Addr: Longint): ShortString; + TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer); + TAbstractErrorProc = Procedure; + TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno,erroraddr:longint); + + + +const + BackTraceStrFunc : TBackTraceStrFunc = @SysBackTraceStr; + ErrorProc : TErrorProc = nil; + AbstractErrorProc : TAbstractErrorProc = nil; + AssertErrorProc : TAssertErrorProc = @SysAssert; + + +{***************************************************************************** + SetJmp/LongJmp +*****************************************************************************} + +{$i setjumph.inc} + + +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$i objpash.inc} + +{ + $Log: not supported by cvs2svn $ + Revision 1.87 2000/07/07 19:22:27 pierre + * correct last commit error + + Revision 1.86 2000/07/07 18:23:41 marco + * Changed move (var source;var dest) to move (const source;var dest) + + Revision 1.85 2000/06/22 18:41:25 peter + * moved islibrary,isconsole,ismulithread to systemh as they are + os independent + + Revision 1.84 2000/06/22 18:05:56 michael + + Modifications for exception support in sysutils. Mainly added + RaiseList function. + + Revision 1.83 2000/06/11 07:02:30 peter + * UniqueAnsiString -> UniqueString for Delphi compatibility + + Revision 1.82 2000/05/14 18:46:54 florian + * TVarRec with In64/QWord stuff extended + + Revision 1.81 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.80 2000/03/26 11:36:28 jonas + + $maxfpuregisters 0 for i386 in systemh (to avoid requiring too much + empty FPU registers for sysstem routines + * fixed bug in str_real when using :x:0 + * str_real now doesn't call exp() anymore at runtime, so it should + require less free FPU registers now (and be slightly faster) + + Revision 1.79 2000/03/14 10:20:18 michael + + Added constants and types for Delphi compatibility + + Revision 1.78 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.77 2000/02/06 17:19:22 peter + * lineinfo unit added which uses stabs to get lineinfo for backtraces + + Revision 1.76 2000/01/21 15:32:07 jonas + * set FPUInt64 to false for i386, because comp mul and div code for int64 is + commented out in int64.inc + + Revision 1.75 2000/01/10 09:54:30 peter + * primitives added + + Revision 1.74 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.73 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.72 1999/12/20 11:20:14 peter + + smallint, maxsmallint + * integer is redefined as smallint + + Revision 1.71 1999/12/18 14:55:05 florian + * very basic widestring support + + Revision 1.70 1999/12/12 13:29:34 jonas + * remove "random(longint): longint" if cardinalmulfixed is defined + + Revision 1.69 1999/12/01 12:37:13 jonas + + function random(longint): longint + + Revision 1.68 1999/11/25 13:34:57 michael + + Added Ansistring setstring call + + Revision 1.67 1999/11/20 12:48:09 jonas + * reinstated old random generator, but modified it so the integer + one now has a much longer period + + Revision 1.66 1999/11/09 20:14:12 daniel + * Committed new random generator. + + Revision 1.65 1999/11/06 14:35:39 peter + * truncated log + + Revision 1.64 1999/10/27 14:19:10 florian + + StringOfChar + + Revision 1.63 1999/10/26 12:31:00 peter + * *errorproc are not procvars instead of pointers which allows better + error checking for the parameters (shortstring<->ansistring) + + Revision 1.62 1999/08/19 11:16:13 peter + * settextbuf size is now longint + +} \ No newline at end of file diff --git a/befpc/rtl/beos/toport/objinc.inc b/befpc/rtl/beos/toport/objinc.inc new file mode 100644 index 0000000..86f071a --- /dev/null +++ b/befpc/rtl/beos/toport/objinc.inc @@ -0,0 +1,96 @@ +{ For linux we 'steal' the following from system unit, this way + we don't need to change the system unit interface. } + +Var errno : Longint; + +{$i sysnr.inc} +{$i errno.inc} +{$i sysconst.inc} +{$i systypes.inc} +{$i syscalls.inc} + +FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle; + +Var LinuxMode : longint; + +BEGIN + LinuxMode:=0; + if Mode=stCreate then + Begin + LinuxMode:=Open_Creat; + LinuxMode:=LinuxMode or Open_RdWr; + end + else + Begin + Case (Mode and 3) of + 0 : LinuxMode:=LinuxMode or Open_RdOnly; + 1 : LinuxMode:=LinuxMode or Open_WrOnly; + 2 : LinuxMode:=LinuxMode or Open_RdWr; + end; + end; + FileOpen:=SYS_Open (pchar(@FileName[0]),LinuxMode,438 {666 octal}); + If FileOpen=-1 then FileOpen:=0; + DosStreamError:=Errno; +END; + +FUNCTION FileRead (Handle: THandle; Var BufferArea; BufferLength: Sw_Word; +Var BytesMoved: Sw_Word): Word; +BEGIN + BytesMoved:=Sys_read (Handle,Pchar(@BufferArea),BufferLength); + DosStreamError:=Errno; + FileRead:=Errno; +END; + +FUNCTION FileWrite (Handle: THandle; Var BufferArea; BufferLength: Sw_Word; +Var BytesMoved: Sw_Word): Word; +BEGIN + BytesMoved:=Sys_Write (Handle,Pchar(@BufferArea),BufferLength); + FileWrite:=Errno; + DosStreamError:=Errno; +END; + +FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word; +VAR NewPos: LongInt): Word; + +BEGIN + NewPos:=Sys_LSeek (Handle,Pos,MoveType); + SetFilePos:=Errno; +END; + +FUNCTION FileClose (Handle: THandle): Word; +BEGIN + Sys_Close (Handle); + DosStreamError:=Errno; + FileClose := Errno; +END; + +FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word; + +{$IFNDEF BSD} +Var sr : syscallregs; +{$ENDIF} +{$IFDEF DOSSETFILE1} + Actual, Buf: LongInt; +{$ENDIF} + +BEGIN + {$IFDEF BSD} + Do_Syscall(Syscall_Nr_ftruncate,handle,filesize,0); {0 -> offset =64 bit} + {$ELSE} + sr.reg2:=Handle; + sr.reg3:=FileSize; + Syscall(syscall_nr_fTruncate,sr); + {$ENDIF} + If Errno=0 then + SetFileSize:=0 + else + SetFileSize:=103; +{$IFDEF DOSSETFILE1} + If (Actual = FileSize) Then Begin { No position error } + Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file } + If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error } + SetFileSize := 103; { File truncate error } + End Else SetFileSize := 103; { File truncate error } +{$ENDIF} +END; + diff --git a/befpc/rtl/i386/cpu.pp b/befpc/rtl/i386/cpu.pp new file mode 100644 index 0000000..15c54ea --- /dev/null +++ b/befpc/rtl/i386/cpu.pp @@ -0,0 +1,84 @@ +{ + $Id: cpu.pp,v 1.1.1.1 2001-07-23 17:17:27 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + + This unit contains some routines to get informations about the + processor + + 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 cpu; + interface + + { returns true, if the processor supports the cpuid instruction } + function cpuid_support : boolean; + + { returns true, if floating point is done by an emulator } + function floating_point_emulation : boolean; + + { returns the contents of the cr0 register } + function cr0 : longint; + + + implementation + +{$ASMMODE INTEL} + + + function cpuid_support : boolean;assembler; + { + Check if the ID-flag can be changed, if changed then CpuID is supported. + Tested under go32v1 and Linux on c6x86 with CpuID enabled and disabled (PFV) + } + asm + pushf + pushf + pop eax + mov ebx,eax + xor eax,200000h + push eax + popf + pushf + pop eax + popf + and eax,200000h + and ebx,200000h + cmp eax,ebx + setnz al + end; + + + function cr0 : longint;assembler; + asm + DB 0Fh,20h,0C0h + { mov eax,cr0 + special registers are not allowed in the assembler + parsers } + end; + + + function floating_point_emulation : boolean; + begin + {!!!! I don't know currently the position of the EM flag } + { $4 after Ralf Brown's list } + floating_point_emulation:=(cr0 and $4)<>0; + end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.6 2000/01/07 16:41:32 daniel + * copyright 2000 + +} diff --git a/befpc/rtl/i386/i386.inc b/befpc/rtl/i386/i386.inc new file mode 100644 index 0000000..1dbbe6e --- /dev/null +++ b/befpc/rtl/i386/i386.inc @@ -0,0 +1,1243 @@ +{ + $Id: i386.inc,v 1.1.1.1 2001-07-23 17:17:28 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Processor dependent implementation for the system unit for + intel i386+ + + 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. + + **********************************************************************} + +{$asmmode ATT} + + +{**************************************************************************** + Primitives +****************************************************************************} + +{$define FPC_SYSTEM_HAS_MOVE} +procedure Move(const source;var dest;count:longint);assembler; +asm + movl dest,%edi + movl source,%esi + movl %edi,%eax + movl count,%ebx +{ Check for back or forward } + sub %esi,%eax + jz .LMoveEnd { Do nothing when source=dest } + jc .LFMove { Do forward, dest no cmp} + rep + cmpsl + je .LCmpbyte2 { All equal? then to the left over bytes} + movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise} + subl %eax,%esi + subl %eax,%edi +.LCmpbyte2: + movl %eax,%ecx {bytes still to (re)scan} + orl %eax,%eax {prevent disaster in case %eax=0} + rep + cmpsb +.LCmpbyte3: + movzbl -1(%esi),%ecx + movzbl -1(%edi),%eax // Compare failing (or equal) position + subl %ecx,%eax +.LCmpbyteExit: +end ['ECX','EAX','ESI','EDI']; + + + +{$define FPC_SYSTEM_HAS_COMPAREWORD} +function CompareWord(var buf1,buf2;len:longint):longint; assembler; +asm + cld + movl len,%eax + movl buf2,%esi { Load params} + movl buf1,%edi + testl %eax,%eax {We address -2(%esi), so we have to deal with len=0} + je .LCmpwordExit + cmpl $5,%eax {<5 (3 bytes align + 4 bytes cmpsl = 4 words} + jl .LCmpword2 { not worth aligning and go through all trouble} + movl (%edi),%ebx // Compare alignment bytes. + cmpl (%esi),%ebx + jne .LCmpword2 // Aligning will go wrong already. Max 2 words will be scanned Branch NOW + shll $1,%eax {Convert word count to bytes} + movl %edi,%edx { Align comparing is already done, so simply add} + negl %edx { calc bytes to align -%edi and 3} + andl $3,%edx + addl %edx,%esi { Skip max 3 bytes alignment} + addl %edx,%edi + subl %edx,%eax { Subtract from number of bytes to go} + movl %eax,%ecx { Make copy of bytes to go} + andl $3,%eax { Calc remainder (mod 4) } + andl $1,%edx { %edx is 1 if array not 2-aligned, 0 otherwise} + shrl $2,%ecx { divide bytes to go by 4, DWords to go} + orl %ecx,%ecx { Sets zero flag if ecx=0 -> no cmp} + rep { Compare entire DWords} + cmpsl + je .LCmpword2a { All equal? then to the left over bytes} + movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise} + subl %eax,%esi { Go back one DWord} + subl %eax,%edi + incl %eax {if not odd then this does nothing, else it makes + sure that adding %edx increases from 2 to 3 words} +.LCmpword2a: + subl %edx,%esi { Subtract alignment} + subl %edx,%edi + addl %edx,%eax + shrl $1,%eax +.LCmpword2: + movl %eax,%ecx {words still to (re)scan} + orl %eax,%eax {prevent disaster in case %eax=0} + rep + cmpsw +.LCmpword3: + movzwl -2(%esi),%ecx + movzwl -2(%edi),%eax // Compare failing (or equal) position + subl %ecx,%eax // calculate end result. +.LCmpwordExit: +end ['EBX','EDX','ECX','EAX','ESI','EDI']; + + +{$define FPC_SYSTEM_HAS_COMPAREDWORD} +function CompareDWord(var buf1,buf2;len:longint):longint; assembler; +asm + cld + movl len,%eax + movl buf2,%esi { Load params} + movl buf1,%edi + testl %eax,%eax {We address -2(%esi), so we have to deal with len=0} + je .LCmpDwordExit + cmpl $3,%eax {<3 (3 bytes align + 4 bytes cmpsl) = 2 DWords} + jl .LCmpDword2 { not worth aligning and go through all trouble} + movl (%edi),%ebx // Compare alignment bytes. + cmpl (%esi),%ebx + jne .LCmpDword2 // Aligning will go wrong already. Max 2 words will be scanned Branch NOW + shll $2,%eax {Convert word count to bytes} + movl %edi,%edx { Align comparing is already done, so simply add} + negl %edx { calc bytes to align -%edi and 3} + andl $3,%edx + addl %edx,%esi { Skip max 3 bytes alignment} + addl %edx,%edi + subl %edx,%eax { Subtract from number of bytes to go} + movl %eax,%ecx { Make copy of bytes to go} + andl $3,%eax { Calc remainder (mod 4) } + shrl $2,%ecx { divide bytes to go by 4, DWords to go} + orl %ecx,%ecx { Sets zero flag if ecx=0 -> no cmp} + rep { Compare entire DWords} + cmpsl + je .LCmpDword2a { All equal? then to the left over bytes} + movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise} + subl %eax,%esi { Go back one DWord} + subl %eax,%edi + addl $3,%eax {if align<>0 this causes repcount to be 2} +.LCmpDword2a: + subl %edx,%esi { Subtract alignment} + subl %edx,%edi + addl %edx,%eax + shrl $2,%eax +.LCmpDword2: + movl %eax,%ecx {words still to (re)scan} + orl %eax,%eax {prevent disaster in case %eax=0} + rep + cmpsl +.LCmpDword3: + movzwl -4(%esi),%ecx + movzwl -4(%edi),%eax // Compare failing (or equal) position + subl %ecx,%eax // calculate end result. +.LCmpDwordExit: +end ['EBX','EDX','ECX','EAX','ESI','EDI']; + + +{$define FPC_SYSTEM_HAS_INDEXCHAR0} +function IndexChar0(var buf;len:longint;b:Char):longint; assembler; +asm +// Can't use scasb, or will have to do it twice, think this +// is faster for small "len" + movl Buf,%esi // Load address + movl len,%edx // load maximal searchdistance + movzbl b,%ebx // Load searchpattern + testl %edx,%edx + je .LFound + xorl %ecx,%ecx // zero index in Buf + xorl %eax,%eax // To make DWord compares possible +.LLoop: + movb (%esi),%al // Load byte + cmpb %al,%bl + je .LFound // byte the same? + incl %ecx + incl %esi + cmpl %edx,%ecx // Maximal distance reached? + je .LNotFound + testl %eax,%eax // Nullchar = end of search? + jne .LLoop +.LNotFound: + movl $-1,%ecx // Not found return -1 +.LFound: + movl %ecx,%eax +end['EAX','EBX','ECX','EDX','ESI']; + + +{**************************************************************************** + Object Helpers +****************************************************************************} + +{$define FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR} +procedure int_help_constructor;assembler; [public,alias:'FPC_HELP_CONSTRUCTOR']; +asm +{ Entry without preamble, since we need the ESP of the constructor + Stack (relative to %ebp): + 12 Self + 8 VMT-Address + 4 main programm-Addr + 0 %ebp + edi contains the vmt position +} + { eax isn't touched anywhere, so it doesn't have to reloaded } + movl 8(%ebp),%eax + { initialise self ? } + orl %esi,%esi + jne .LHC_4 + { get memory, but save register first temporary variable } + subl $4,%esp + movl %esp,%esi + { Save Register} + pushal + { Memory size } + pushl (%eax) + pushl %esi + call AsmGetMem + movl $-1,8(%ebp) + popal + { Memory position to %esi } + movl (%esi),%esi + addl $4,%esp + { If no memory available : fail() } + orl %esi,%esi + jz .LHC_5 + { init self for the constructor } + movl %esi,12(%ebp) + jmp .LHC_6 + { Why was the VMT reset to zero here ???? + I need it fail to know if I should + zero the VMT field in static objects PM } +.LHC_4: + { movl $0,8(%ebp) } +.LHC_6: + { is there a VMT address ? } + orl %eax,%eax + jnz .LHC_7 + { In case the constructor doesn't do anything, the Zero-Flag } + { can't be put, because this calls Fail() } + incl %eax + ret +.LHC_7: + { set zero inside the object } + pushal + cld + movl (%eax),%ecx + movl %esi,%edi + xorl %eax,%eax + shrl $1,%ecx + jnc .LHCFill1 + stosb +.LHCFill1: + shrl $1,%ecx + jnc .LHCFill2 + stosw +.LHCFill2: + rep + stosl + popal + { set the VMT address for the new created object } + { the offset is in %edi since the calling and has not been changed !! } + movl %eax,(%esi,%edi,1) + orl %eax,%eax +.LHC_5: +end; + + +{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL} +procedure int_help_fail;assembler;[public,alias:'FPC_HELP_FAIL']; +{ should be called with a object that needs to be + freed if VMT field is at -1 + %edi contains VMT offset in object again } +asm + orl %esi,%esi + je .LHF_1 + cmpl $-1,8(%ebp) + je .LHF_2 + { reset vmt field to zero for static instances } + cmpl $0,8(%ebp) + je .LHF_3 + { main constructor, we can zero the VMT field now } + movl $0,(%esi,%edi,1) +.LHF_3: + { we zero esi to indicate failure } + xorl %esi,%esi + jmp .LHF_1 +.LHF_2: + { get vmt address in eax } + movl (%esi,%edi,1),%eax + movl %esi,12(%ebp) + { push object position } + leal 12(%ebp),%eax + pushl %eax + call AsmFreeMem + { set both object places to zero } + xorl %esi,%esi + movl %esi,12(%ebp) +.LHF_1: +end; + + +{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR} +procedure int_help_destructor;assembler;[public,alias:'FPC_HELP_DESTRUCTOR']; +asm +{ Stack (relative to %ebp): + 12 Self + 8 VMT-Address + 4 Main program-Addr + 0 %ebp + edi contains the vmt position +} + pushal + { Should the object be resolved ? } + movl 8(%ebp),%eax + orl %eax,%eax + jz .LHD_3 + { Yes, get size from SELF! } + movl 12(%ebp),%eax + { get VMT-pointer (from Self) to %ebx } + { the offset is in %edi since the calling and has not been changed !! } + movl (%eax,%edi,1),%ebx + { I think for precaution } + { that we should clear the VMT here } + movl $0,(%eax,%edi,1) + { temporary Variable } + subl $4,%esp + movl %esp,%edi + { SELF } + movl %eax,(%edi) + pushl %edi + call AsmFreeMem + addl $4,%esp +.LHD_3: + popal +end; + + +{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS} +procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS']; +asm + { to be sure in the future, we save also edit } + pushl %edi + { create class ? } + movl 8(%ebp),%edi + { if we test eax later without calling newinstance } + { it must have a value <>0 } + movl $1,%eax + orl %edi,%edi + jz .LNEW_CLASS1 + { save registers !! } + pushl %ebx + pushl %ecx + pushl %edx + { esi contains the vmt } + pushl %esi + { call newinstance (class method!) } +{$ifdef NEWVMTOFFSET} + call *52{vmtNewInstance}(%esi) +{$else} + call *16(%esi) +{$endif} + popl %edx + popl %ecx + popl %ebx + { newinstance returns a pointer to the new created } + { instance in eax } + { load esi and insert self } + movl %eax,%esi +.LNEW_CLASS1: + movl %esi,8(%ebp) + orl %eax,%eax + popl %edi +end; + + +{$define FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS} +procedure int_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS']; +asm + { to be sure in the future, we save also edit } + pushl %edi + { destroy class ? } + movl 12(%ebp),%edi + orl %edi,%edi + jz .LDISPOSE_CLASS1 + { no inherited call } + movl (%esi),%edi + { save registers !! } + pushl %eax + pushl %ebx + pushl %ecx + pushl %edx + { push self } + pushl %esi + { call freeinstance } +{$ifdef NEWVMTOFFSET} + call *56{vmtFreeInstance}(%edi) +{$else} + call *20(%edi) +{$endif} + popl %edx + popl %ecx + popl %ebx + popl %eax +.LDISPOSE_CLASS1: + popl %edi +end; + +{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL_CLASS} +procedure int_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS']; +{ a non zero class must allways be disposed + VMT is allways at pos 0 } +asm + orl %esi,%esi + je .LHFC_1 + call INT_DISPOSE_CLASS + { set both object places to zero } + xorl %esi,%esi + movl %esi,8(%ebp) +.LHFC_1: +end; + + + +{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT} + +{$ifdef SYSTEMDEBUG} +{ we want the stack for debugging !! PM } +procedure int_check_object(obj : pointer);[public,alias:'FPC_CHECK_OBJECT']; +begin +{$else not SYSTEMDEBUG} +procedure int_check_object;assembler;[public,alias:'FPC_CHECK_OBJECT']; +{$endif not SYSTEMDEBUG} +asm + pushl %edi +{$ifdef SYSTEMDEBUG} + movl obj,%edi +{$else not SYSTEMDEBUG} + movl 8(%esp),%edi +{$endif not SYSTEMDEBUG} + pushl %eax + { Here we must check if the VMT pointer is nil before } + { accessing it... } + orl %edi,%edi + jz .Lco_re + movl (%edi),%eax + addl 4(%edi),%eax + jz .Lco_ok +.Lco_re: + pushl $210 + call HandleError +.Lco_ok: + popl %eax + popl %edi + { the adress is pushed : it needs to be removed from stack !! PM } +{$ifdef SYSTEMDEBUG} +end;{ of asm } +end; +{$else SYSTEMDEBUG} + ret $4 +end; +{$endif not SYSTEMDEBUG} + + +{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT} +procedure int_check_object_ext;assembler;[public,alias:'FPC_CHECK_OBJECT_EXT']; +{ checks for a correct vmt pointer } +{ deeper check to see if the current object is } +{ really related to the true } +asm + pushl %ebp + movl %esp,%ebp + pushl %edi + movl 8(%ebp),%edi + pushl %ebx + movl 12(%ebp),%ebx + pushl %eax + { Here we must check if the VMT pointer is nil before } + { accessing it... } +.Lcoext_obj: + orl %edi,%edi + jz .Lcoext_re + movl (%edi),%eax + addl 4(%edi),%eax + jnz .Lcoext_re + cmpl %edi,%ebx + je .Lcoext_ok +.Lcoext_vmt: + movl 8(%edi),%eax + cmpl %ebx,%eax + je .Lcoext_ok + movl %eax,%edi + jmp .Lcoext_obj +.Lcoext_re: + pushl $220 + call HandleError +.Lcoext_ok: + popl %eax + popl %ebx + popl %edi + { the adress and vmt were pushed : it needs to be removed from stack !! PM } + popl %ebp + ret $8 +end; + + +{**************************************************************************** + String +****************************************************************************} + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} +procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; +{ + this procedure must save all modified registers except EDI and ESI !!! +} +begin + asm + pushl %eax + pushl %ecx + cld + movl dstr,%edi + movl sstr,%esi + xorl %eax,%eax + movl len,%ecx + lodsb + cmpl %ecx,%eax + jbe .LStrCopy1 + movl %ecx,%eax +.LStrCopy1: + stosb + cmpl $7,%eax + jl .LStrCopy2 + movl %edi,%ecx { Align on 32bits } + negl %ecx + andl $3,%ecx + subl %ecx,%eax + rep + movsb + movl %eax,%ecx + andl $3,%eax + shrl $2,%ecx + rep + movsl +.LStrCopy2: + movl %eax,%ecx + rep + movsb + popl %ecx + popl %eax + end ['ESI','EDI']; +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} +procedure int_strconcat(s1,s2:pointer); + [public,alias:'FPC_SHORTSTR_CONCAT']; +begin + asm + movl s2,%edi + movl s1,%esi + movl %edi,%ebx + movzbl (%edi),%ecx + xor %eax,%eax + lea 1(%edi,%ecx),%edi + negl %ecx + addl $0x0ff,%ecx + lodsb + cmpl %ecx,%eax + jbe .LStrConcat1 + movl %ecx,%eax +.LStrConcat1: + addb %al,(%ebx) + cmpl $7,%eax + jl .LStrConcat2 + movl %edi,%ecx { Align on 32bits } + negl %ecx + andl $3,%ecx + subl %ecx,%eax + rep + movsb + movl %eax,%ecx + andl $3,%eax + shrl $2,%ecx + rep + movsl +.LStrConcat2: + movl %eax,%ecx + rep + movsb + end ['EBX','ECX','EAX','ESI','EDI']; +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} +procedure int_strcmp(dstr,sstr:pointer);[public,alias:'FPC_SHORTSTR_COMPARE']; +begin + asm + cld + xorl %ebx,%ebx + xorl %eax,%eax + movl sstr,%esi + movl dstr,%edi + movb (%esi),%al + movb (%edi),%bl + movl %eax,%edx + incl %esi + incl %edi + cmpl %ebx,%eax + jbe .LStrCmp1 + movl %ebx,%eax +.LStrCmp1: + cmpl $7,%eax + jl .LStrCmp2 + movl %edi,%ecx { Align on 32bits } + negl %ecx + andl $3,%ecx + subl %ecx,%eax + orl %ecx,%ecx + rep + cmpsb + jne .LStrCmp3 + movl %eax,%ecx + andl $3,%eax + shrl $2,%ecx + orl %ecx,%ecx + rep + cmpsl + je .LStrCmp2 + movl $4,%eax + sub %eax,%esi + sub %eax,%edi +.LStrCmp2: + movl %eax,%ecx + orl %eax,%eax + rep + cmpsb + jne .LStrCmp3 + cmp %ebx,%edx +.LStrCmp3: + end ['EDX','ECX','EBX','EAX','ESI','EDI']; +end; + + +{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} +function strpas(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; +begin + asm + cld + movl p,%edi + movl $0xff,%ecx + orl %edi,%edi + jnz .LStrPasNotNil + decl %ecx + jmp .LStrPasNil +.LStrPasNotNil: + xorl %eax,%eax + movl %edi,%esi + repne + scasb +.LStrPasNil: + movl %ecx,%eax + movl __RESULT,%edi + notb %al + decl %eax + stosb + cmpl $7,%eax + jl .LStrPas2 + movl %edi,%ecx { Align on 32bits } + negl %ecx + andl $3,%ecx + subl %ecx,%eax + rep + movsb + movl %eax,%ecx + andl $3,%eax + shrl $2,%ecx + rep + movsl +.LStrPas2: + movl %eax,%ecx + rep + movsb + end ['ECX','EAX','ESI','EDI']; +end; + + +{$define FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} +function strchararray(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; +begin + asm + cld + movl p,%esi + movl l,%ecx + orl %esi,%esi + jnz .LStrCharArrayNotNil + movl $0,%ecx +.LStrCharArrayNotNil: + movl %ecx,%eax + movl __RESULT,%edi + stosb + cmpl $7,%eax + jl .LStrCharArray2 + movl %edi,%ecx { Align on 32bits } + negl %ecx + andl $3,%ecx + subl %ecx,%eax + rep + movsb + movl %eax,%ecx + andl $3,%eax + shrl $2,%ecx + rep + movsl +.LStrCharArray2: + movl %eax,%ecx + rep + movsb + end ['ECX','EAX','ESI','EDI']; +end; + + +{$define FPC_SYSTEM_HAS_STRLEN} +function strlen(p:pchar):longint;assembler; +asm + movl p,%edi + movl $0xffffffff,%ecx + xorl %eax,%eax + cld + repne + scasb + movl $0xfffffffe,%eax + subl %ecx,%eax +end ['EDI','ECX','EAX']; + + +{**************************************************************************** + Caller/StackFrame Helpers +****************************************************************************} + +{$define FPC_SYSTEM_HAS_GET_FRAME} +function get_frame:longint;assembler; +asm + movl %ebp,%eax +end ['EAX']; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} +function get_caller_addr(framebp:longint):longint;assembler; +asm + movl framebp,%eax + orl %eax,%eax + jz .Lg_a_null + movl 4(%eax),%eax +.Lg_a_null: +end ['EAX']; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} +function get_caller_frame(framebp:longint):longint;assembler; +asm + movl framebp,%eax + orl %eax,%eax + jz .Lgnf_null + movl (%eax),%eax +.Lgnf_null: +end ['EAX']; + + +{**************************************************************************** + Math +****************************************************************************} + +{$define FPC_SYSTEM_HAS_ABS_LONGINT} +function abs(l:longint):longint; assembler;[internconst:in_const_abs]; +asm + movl l,%eax + cltd + xorl %edx,%eax + subl %edx,%eax +end ['EAX','EDX']; + + +{$define FPC_SYSTEM_HAS_ODD_LONGINT} +function odd(l:longint):boolean;assembler;[internconst:in_const_odd]; +asm + movl l,%eax + andl $1,%eax + setnz %al +end ['EAX']; + + +{$define FPC_SYSTEM_HAS_SQR_LONGINT} +function sqr(l:longint):longint;assembler;[internconst:in_const_sqr]; +asm + mov l,%eax + imull %eax,%eax +end ['EAX']; + + +{$define FPC_SYSTEM_HAS_SPTR} +Function Sptr : Longint;assembler; +asm + movl %esp,%eax +end; + + +{**************************************************************************** + Str() +****************************************************************************} + +{$define FPC_SYSTEM_HAS_INT_STR_LONGINT} +procedure int_str(l : longint;var s : string); +var + buffer : array[0..11] of byte; +begin + { Workaround: } + if l=$80000000 then + begin + s:='-2147483648'; + exit; + end; + asm + movl l,%eax // load Integer + movl s,%edi // Load String address + xorl %ecx,%ecx // String length=0 + xorl %ebx,%ebx // Buffer length=0 + movl $0x0a,%esi // load 10 as dividing constant. + orl %eax,%eax // Sign ? + jns .LM2 + neg %eax + movb $0x2d,1(%edi) // put '-' in String + incl %ecx +.LM2: + cltd + idivl %esi + addb $0x30,%dl // convert Rest to ASCII. + movb %dl,-12(%ebp,%ebx) + incl %ebx + cmpl $0,%eax + jnz .LM2 + { copy String } +.LM3: + movb -13(%ebp,%ebx),%al // -13 because EBX is decreased only later + movb %al,1(%edi,%ecx) + incl %ecx + decl %ebx + jnz .LM3 + movb %cl,(%edi) // Copy String length + end; +end; + + +{$define FPC_SYSTEM_HAS_INT_STR_CARDINAL} +procedure int_str(c : cardinal;var s : string); +var + buffer : array[0..14] of byte; +begin + asm + movl c,%eax // load CARDINAL + movl s,%edi // Load String address + xorl %ecx,%ecx // String length=0 + xorl %ebx,%ebx // Buffer length=0 + movl $0x0a,%esi // load 10 as dividing constant. +.LM4: + xorl %edx,%edx + divl %esi + addb $0x30,%dl // convert Rest to ASCII. + movb %dl,-12(%ebp,%ebx) + incl %ebx + cmpl $0,%eax + jnz .LM4 + { now copy the string } +.LM5: + movb -13(%ebp,%ebx),%al // -13 because EBX is decreased only later + movb %al,1(%edi,%ecx) + incl %ecx + decl %ebx + jnz .LM5 + movb %cl,(%edi) // Copy String length + end; +end; + + +{**************************************************************************** + Bounds Check +****************************************************************************} + +{$define FPC_SYSTEM_HAS_FPC_BOUNDCHECK} + +{$ifdef SYSTEMDEBUG} +{ we want the stack for debugging !! PM } +procedure int_boundcheck;[public,alias: 'FPC_BOUNDCHECK']; +begin +{$else not SYSTEMDEBUG} +procedure int_boundcheck;assembler;[public,alias: 'FPC_BOUNDCHECK']; +var dummy_to_force_stackframe_generation_for_trace: Longint; +{$endif not SYSTEMDEBUG} +{ + called with: + %ecx - value + %edi - pointer to the ranges +} +asm + cmpl (%edi),%ecx + jl .Lbc_err + cmpl 4(%edi),%ecx + jle .Lbc_ok +.Lbc_err: + pushl %ebp + pushl $201 + call HandleErrorFrame +.Lbc_ok: +end; +{$ifdef SYSTEMDEBUG} +end; +{$endif def SYSTEMDEBUG} + + +{$ifndef HASSAVEREGISTERS} + +{**************************************************************************** + IoCheck +****************************************************************************} +{$define FPC_SYSTEM_HAS_FPC_IOCHECK} + +procedure int_iocheck(addr : longint);[public,alias:'FPC_IOCHECK']; +var + l : longint; +begin + asm + pushal + end; + if InOutRes<>0 then + begin + l:=InOutRes; + InOutRes:=0; + HandleErrorFrame(l,get_frame); + end; + asm + popal + end; +end; + +{$endif not HASSAVEREGISTERS} + +{ + $Log: not supported by cvs2svn $ + Revision 1.75 2000/07/08 09:09:35 jonas + - removed fpc_strconcat_len for -dnewoptimizations since it's not + used anymore (because the strconcat optimizations have been + disabled quite a while ago) + + Revision 1.74 2000/07/07 18:23:41 marco + * Changed move (var source;var dest) to move (const source;var dest) + + Revision 1.73 2000/05/09 06:21:58 pierre + * fix ingnored assembler error in IndexDWord + + Revision 1.72 2000/04/23 09:26:51 jonas + + FPC_SHORTSTR_CONCAT_LEN (temporary, for -dnewoptimizations) + + Revision 1.71 2000/04/10 09:47:15 jonas + + added destroyed registers list for move procedure (it doesn't destroy + edx) + + Revision 1.70 2000/04/06 08:39:22 florian + * the bounds check error gets now a correct stack frame + + Revision 1.69 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.68 2000/01/13 13:06:03 jonas + * fixed warning + + Revision 1.67 2000/01/11 21:11:04 marco + * Changed some direct asm params to real params + + Revision 1.66 2000/01/10 09:54:30 peter + * primitives added + + Revision 1.65 2000/01/07 16:41:32 daniel + * copyright 2000 + + Revision 1.64 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.63 1999/12/21 11:48:09 pierre + * typo error if previous commit + + Revision 1.62 1999/12/21 11:13:34 pierre + + FPC_CHARARRAY_TO_SHORTSTRING added + + Revision 1.61 1999/12/11 18:59:44 jonas + * faster abs() function (no jump anymore) + + Revision 1.60 1999/11/20 12:48:09 jonas + * reinstated old random generator, but modified it so the integer + one now has a much longer period + + Revision 1.59 1999/11/09 20:14:12 daniel + * Committed new random generator. + + Revision 1.58 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.57 1999/10/08 14:40:54 pierre + * fix for FPC_HELP_FAIL_CLASS + + Revision 1.56 1999/10/05 20:50:06 pierre + + code for fail for class + + Revision 1.55 1999/09/17 17:14:11 peter + + new heap manager supporting delphi freemem(pointer) + + Revision 1.54 1999/09/15 13:04:04 jonas + * added dummy local var to boundcheck to force stackframe generation + + Revision 1.53 1999/08/19 12:50:08 pierre + * changes for fail support + + Revision 1.52 1999/08/18 10:43:31 pierre + + VMT reset to -1 if getmem called, neede for fail + + Revision 1.51 1999/08/09 22:20:02 peter + * classes vmt changed to only positive addresses + * sharedlib creation is working + + Revision 1.50 1999/08/05 23:45:12 peter + * saveregister is now working and used for assert and iocheck (which has + been moved to system.inc because it's now system independent) + +} diff --git a/befpc/rtl/i386/makefile.cpu b/befpc/rtl/i386/makefile.cpu new file mode 100644 index 0000000..d24d317 --- /dev/null +++ b/befpc/rtl/i386/makefile.cpu @@ -0,0 +1,7 @@ +# +# Here we set processor dependent include file names. +# + +CPUNAMES=i386 math set rttip setjump setjumph +CPUINCNAMES=$(addsuffix .inc,$(CPUNAMES)) + diff --git a/befpc/rtl/i386/math.inc b/befpc/rtl/i386/math.inc new file mode 100644 index 0000000..9564215 --- /dev/null +++ b/befpc/rtl/i386/math.inc @@ -0,0 +1,411 @@ +{ + $Id: math.inc,v 1.1.1.1 2001-07-23 17:17:28 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Implementation of mathamatical Routines (only for real) + + 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. + + **********************************************************************} + + +{**************************************************************************** + EXTENDED data type routines + ****************************************************************************} + +{$ifdef hasinternmath} + function pi : extended;[internproc:in_pi]; + function abs(d : extended) : extended;[internproc:in_abs_extended]; + function sqr(d : extended) : extended;[internproc:in_sqr_extended]; + function sqrt(d : extended) : extended;[internproc:in_sqrt_extended]; + function arctan(d : extended) : extended;[internproc:in_arctan_extended]; + function ln(d : extended) : extended;[internproc:in_ln_extended]; + function sin(d : extended) : extended;[internproc:in_sin_extended]; + function cos(d : extended) : extended;[internproc:in_cos_extended]; +{$else hasinternmath} + function pi : extended;assembler;[internconst:in_const_pi]; + asm + fldpi + end []; + + + function abs(d : extended) : extended;assembler;[internconst:in_const_abs]; + asm + fldt d + fabs + end []; + + + function sqr(d : extended) : extended;assembler;[internconst:in_const_sqr]; + asm + fldt d + fldt d + fmulp %st(1) + end []; + + + function sqrt(d : extended) : extended;assembler;[internconst:in_const_sqrt]; + asm + fldt d + fsqrt + end []; + + + function arctan(d : extended) : extended;assembler;[internconst:in_const_arctan]; + asm + fldt d + fld1 + fpatan + end []; + + function cos(d : extended) : extended;assembler;[internconst:in_const_cos]; + asm + fldt d + fcos + fstsw + sahf + jnp .LCOS1 + fstp %st(0) + fldt .LCOS0 + jmp .LCOS1 + .data + .LCOS0: + .long 0xffffffff + .long 0xffffffff + .long 0xffffffff + .text + .LCOS1: + end ['EAX']; + + function ln(d : extended) : extended;assembler;[internconst:in_const_ln]; + asm + fldln2 + fldt d + fyl2x + end []; + + + function sin(d : extended) : extended;assembler;[internconst:in_const_sin]; + asm + fldt d + fsin + fstsw + sahf + jnp .LSIN1 + fstp %st(0) + fldt .LSIN0 + jmp .LSIN1 + .data + .LSIN0: + .long 0xffffffff + .long 0xffffffff + .long 0xffffffff + .text + .LSIN1: + end ['EAX']; + + +{$endif hasinternmath} + + function exp(d : extended) : extended;assembler;[internconst:in_const_exp]; + asm + // comes from DJ GPP + fldt d + fldl2e + fmulp %st(1) + fstcw .LCW1 + fstcw .LCW2 + andw $0xf3ff,.LCW2 + orw $0x0400,.LCW2 + fldcw .LCW2 + fld %st(0) + frndint + fldcw .LCW1 + fxch %st(1) + fsub %st(1),%st + f2xm1 + fld1 + faddp %st(1) + fscale + fstp %st(1) + jmp .LCW3 + // store some help data in the data segment + .data + .LCW1: + .word 0 + .LCW2: + .word 0 + .text + .LCW3: + end; + + + function frac(d : extended) : extended;assembler;[internconst:in_const_frac]; + asm + subl $16,%esp + fnstcw -4(%ebp) + fwait + movw -4(%ebp),%cx + orw $0x0c3f,%cx + movw %cx,-8(%ebp) + fldcw -8(%ebp) + fwait + fldt d + frndint + fldt d + fsub %st(1) + fstp %st(1) + fclex + fldcw -4(%ebp) + end ['ECX']; + + + function int(d : extended) : extended;assembler;[internconst:in_const_int]; + asm + subl $16,%esp + fnstcw -4(%ebp) + fwait + movw -4(%ebp),%cx + orw $0x0c3f,%cx + movw %cx,-8(%ebp) + fldcw -8(%ebp) + fwait + fldt d + frndint + fclex + fldcw -4(%ebp) + end ['ECX']; + + + function trunc(d : extended) : longint;assembler;[internconst:in_const_trunc]; + asm + subl $16,%esp + fnstcw -4(%ebp) + fwait + movw -4(%ebp),%cx + orw $0x0c3f,%cx + movw %cx,-8(%ebp) + fldcw -8(%ebp) + fwait + fldt d + fistpl -8(%ebp) + movl -8(%ebp),%eax + fldcw -4(%ebp) + end ['EAX','ECX']; + + + function round(d : extended) : longint;assembler;[internconst:in_const_round]; + asm + subl $8,%esp + fnstcw -4(%ebp) + fwait + movw $0x1372,-8(%ebp) + fldcw -8(%ebp) + fwait + fldt d + fistpl -8(%ebp) + movl -8(%ebp),%eax + fldcw -4(%ebp) + end ['EAX','ECX']; + + + function power(bas,expo : extended) : extended; + begin + if bas=0 then + begin + if expo<>0 then + power:=0.0 + else + HandleError(207); + end + else if expo=0 then + power:=1 + else + { bas < 0 is not allowed } + if bas<0 then + handleerror(207) + else + power:=exp(ln(bas)*expo); + end; + + +{**************************************************************************** + Longint data type routines + ****************************************************************************} + + function power(bas,expo : longint) : longint; + begin + if bas=0 then + begin + if expo<>0 then + power:=0 + else + HandleError(207); + end + else if expo=0 then + power:=1 + else + begin + if bas<0 then + begin + if odd(expo) then + power:=-round(exp(ln(-bas)*expo)) + else + power:=round(exp(ln(-bas)*expo)); + end + else + power:=round(exp(ln(bas)*expo)); + end; + end; + + +{**************************************************************************** + Fixed data type routines + ****************************************************************************} + +{$ifdef HASFIXED} { Not yet allowed } + + function sqrt(d : fixed) : fixed; + + begin + asm + movl d,%eax + movl %eax,%ebx + movl %eax,%ecx + jecxz .L_kl + xorl %esi,%esi + .L_it: + xorl %edx,%edx + idivl %ebx + addl %ebx,%eax + shrl $1,%eax + subl %eax,%esi + cmpl $1,%esi + jbe .L_kl + movl %eax,%esi + movl %eax,%ebx + movl %ecx,%eax + jmp .L_it + .L_kl: + shl $8,%eax + leave + ret $4 + end; + end; + + + function int(d : fixed) : fixed; + {*****************************************************************} + { Returns the integral part of d } + {*****************************************************************} + begin + int:=d and $ffff0000; { keep only upper bits } + end; + + + function trunc(d : fixed) : longint; + {*****************************************************************} + { Returns the Truncated integral part of d } + {*****************************************************************} + begin + trunc:=longint(integer(d shr 16)); { keep only upper 16 bits } + end; + + function frac(d : fixed) : fixed; + {*****************************************************************} + { Returns the Fractional part of d } + {*****************************************************************} + begin + frac:=d AND $ffff; { keep only decimal parts - lower 16 bits } + end; + + function abs(d : fixed) : fixed; + {*****************************************************************} + { Returns the Absolute value of d } + {*****************************************************************} + begin + asm + movl d,%eax + rol $16,%eax { Swap high & low word.} + {Absolute value: Invert all bits and increment when <0 .} + cwd { When ax<0, dx contains $ffff} + xorw %dx,%ax { Inverts all bits when dx=$ffff.} + subw %dx,%ax { Increments when dx=$ffff.} + rol $16,%eax { Swap high & low word.} + leave + ret $4 + end; + end; + + + function sqr(d : fixed) : fixed; + {*****************************************************************} + { Returns the Absolute squared value of d } + {*****************************************************************} + begin + {16-bit precision needed, not 32 =)} + sqr := d*d; +{ sqr := (d SHR 8 * d) SHR 8; } + end; + + + function Round(x: fixed): longint; + {*****************************************************************} + { Returns the Rounded value of d as a longint } + {*****************************************************************} + var + lowf:integer; + highf:integer; + begin + lowf:=x and $ffff; { keep decimal part ... } + highf :=integer(x shr 16); + if lowf > 5 then + highf:=highf+1 + else + if lowf = 5 then + begin + { here we must check the sign ... } + { if greater or equal to zero, then } + { greater value will be found by adding } + { one... } + if highf >= 0 then + Highf:=Highf+1; + end; + Round:= longint(highf); + end; + +{$endif HASFIXED} + +{ + $Log: not supported by cvs2svn $ + Revision 1.23 2000/05/02 10:37:50 pierre + * 0**n where n<>0 is 0; 0**0 generates RTE 207 + + Revision 1.22 2000/04/07 21:29:00 pierre + changed to get nasm to compile system + + Revision 1.21 2000/02/15 14:37:36 florian + * disabled FIXED data type per default + + Revision 1.20 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.19 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.18 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.17 1999/10/06 17:44:43 peter + * fixed power(int,int) with negative base + * power(ext,ext) with negative base gives rte 207 + + Revision 1.16 1999/09/15 20:24:11 florian + * some math functions are now coded inline by the compiler +} \ No newline at end of file diff --git a/befpc/rtl/i386/mmx.pp b/befpc/rtl/i386/mmx.pp new file mode 100644 index 0000000..34f7ae0 --- /dev/null +++ b/befpc/rtl/i386/mmx.pp @@ -0,0 +1,140 @@ +{ + $Id: mmx.pp,v 1.1.1.1 2001-07-23 17:17:28 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + 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. + + **********************************************************************} +{ This unit contains some helpful stuff to deal with the mmx extensions } +unit mmx; + + interface + + type + tmmxshortint = array[0..7] of shortint; + tmmxbyte = array[0..7] of byte; + tmmxword = array[0..3] of word; + tmmxinteger = array[0..3] of integer; +{$ifdef HASFIXED} + tmmxfixed = array[0..3] of fixed16; +{$endif HASFIXED} + tmmxlongint = array[0..1] of longint; + tmmxcardinal = array[0..1] of cardinal; + { for the AMD 3D } + tmmxsingle = array[0..1] of single; + + pmmxshortint = ^tmmxshortint; + pmmxbyte = ^tmmxbyte; + pmmxword = ^tmmxword; + pmmxinteger = ^tmmxinteger; +{$ifdef HASFIXED} + pmmxfixed = ^tmmxfixed; +{$endif HASFIXED} + pmmxlongint = ^tmmxlongint; + pmmxcardinal = ^tmmxcardinal; + { for the AMD 3D } + pmmxsingle = ^tmmxsingle; + + const + is_mmx_cpu : boolean = false; + is_amd_3d_cpu : boolean = false; + + { sets all floating point registers to empty + (use this after mmx usage) + } + procedure emms; + + implementation + + uses + cpu; + + {$ASMMODE ATT} + + { returns true, if the processor supports the mmx instructions } + function mmx_support : boolean; + + var + _edx : longint; + + begin + if cpuid_support then + begin + asm + movl $1,%eax + cpuid + movl %edx,_edx + end; + mmx_support:=(_edx and $800000)<>0; + end + else + { a cpu with without cpuid instruction supports never mmx } + mmx_support:=false; + end; + + function amd_3d_support : boolean; + + var + _edx : longint; + + begin + if cpuid_support then + begin + asm + movl $0x80000001,%eax + cpuid + movl %edx,_edx + end; + amd_3d_support:=(_edx and $80000000)<>0; + end + else + { a cpu with without cpuid instruction supports never mmx } + amd_3d_support:=false; + end; + + procedure emms;assembler; + + asm + emms + end; + + var + oldexitproc : pointer; + + procedure mmxexitproc; + + begin + exitproc:=oldexitproc; + emms; + end; + +begin + if mmx_support then + begin + is_mmx_cpu:=true; + { the exit code sets the fpu stack to empty } + oldexitproc:=exitproc; + exitproc:=@mmxexitproc; + is_amd_3d_cpu:=amd_3d_support; + end; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/15 14:37:36 florian + * disabled FIXED data type per default + + Revision 1.6 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.5 2000/01/07 16:41:33 daniel + * copyright 2000 + +} + diff --git a/befpc/rtl/i386/readme b/befpc/rtl/i386/readme new file mode 100644 index 0000000..489b69a --- /dev/null +++ b/befpc/rtl/i386/readme @@ -0,0 +1,17 @@ +This directory contains only RTL parts specific to the processor I386 family. + +(They are specific because they contain assembler instructions) + +Include files for system are : + heap.inc (heap handling) + set.inc (sets operations) + math.inc (mathematic operations using the coprocessor) + i386.inc (several functions/procedures containing assembler parts) + setjump.inc (setjmp/longjmp implementation for exceptions) + rttip.inc (rtti handling, for speed reasons) + +Units are : + strings.pp (written in assembler for speed) + cpu.pp (routines to access cpu info) + mmx.pp (special mmx routines) + \ No newline at end of file diff --git a/befpc/rtl/i386/rttip.inc b/befpc/rtl/i386/rttip.inc new file mode 100644 index 0000000..bb2eaf5 --- /dev/null +++ b/befpc/rtl/i386/rttip.inc @@ -0,0 +1,411 @@ +{ + $Id: rttip.inc,v 1.1.1.1 2001-07-23 17:17:28 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt + member of the Free Pascal development team + + 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. + + **********************************************************************} + +{ Run-Time type information routines - processor dependent part } + +Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias:'FPC_INITIALIZE'];assembler; +asm +// Save registers + push %eax + push %ebx + push %ecx + push %edx +// decide what type it is + movl TypeInfo,%ebx + movb (%ebx),%al +// This is MANIFESTLY wrong + subb $9,%al + jz .LDoAnsiStringInit + decb %al + jz .LDoAnsiStringInit + subb $2,%al + jz .LDoArrayInit + decb %al + jz .LDoRecordInit + subb $2,%al + jz .LDoClassInit + decb %al + jz .LDoObjectInit + decb %al + jz .LDoClassInit + jmp .LExitInitialize +.LDoObjectInit: +.LDoClassInit: +.LDoRecordInit: + incl %ebx + movzbl (%ebx),%eax +// Skip also recordsize. + addl $5,%eax + addl %eax,%ebx +// %ebx points to element count. Set in %edx + movl (%ebx),%edx + addl $4,%ebx +// %ebx points to First element in record +.LMyRecordInitLoop: + decl %edx + jl .LExitInitialize +// %ebx points to typeinfo pointer +// Push type + pushl (%ebx) + addl $4,%ebx +// %ebx points to offset in record. +// Us it to calculate data + movl Data,%eax + addl (%ebx),%eax + addl $4,%ebx +// push data + pushl %eax + call INITIALIZE + jmp .LMyRecordInitLoop +// Array handling +.LDoArrayInit: +// Skip array name !! + incl %ebx + movzbl (%ebx),%eax + incl %eax + addl %eax,%ebx +// %ebx points to size. Put size in ecx + movl (%ebx),%ecx + addl $4, %ebx +// %ebx points to count. Put count in %edx + movl (%ebx),%edx + addl $4, %ebx +// %ebx points to type. Put into ebx. +// Start treating elements. +.LMyArrayInitLoop: + decl %edx + jl .LExitInitialize +// push type + pushl (%ebx) +// calculate data + movl %ecx,%eax + imull %edx,%eax + addl Data,%eax +// push data + pushl %eax + call INITIALIZE + jmp .LMyArrayInitLoop +// AnsiString handling : +.LDoAnsiStringInit: + movl Data, %eax + movl $0,(%eax) +.LExitInitialize: + pop %edx + pop %ecx + pop %ebx + pop %eax +end; + + +Procedure Finalize (Data,TypeInfo: Pointer);[Public,Alias:'FPC_FINALIZE'];assembler; +asm + push %eax + push %ebx + push %ecx + push %edx +// decide what type it is + movl TypeInfo,%ebx + movb (%ebx),%al + subb $9,%al + jz .LDoAnsiStringFinal + decb %al + jz .LDoAnsiStringFinal + subb $2,%al + jz .LDoArrayFinal + decb %al + jz .LDoRecordFinal + subb $2,%al + jz .LDoClassFinal + decb %al + jz .LDoObjectFinal + decb %al + jz .LDoClassFinal + jmp .LExitFinalize +.LDoClassFinal: +.LDoObjectFinal: +.LDoRecordFinal: + incl %ebx + movzbl (%ebx),%eax +// Skip also recordsize. + addl $5,%eax + addl %eax,%ebx +// %ebx points to element count. Set in %edx + movl (%ebx),%edx + addl $4,%ebx +// %ebx points to First element in record +.LMyRecordFinalLoop: + decl %edx + jl .LExitFinalize +// %ebx points to typeinfo pointer +// Push type + pushl (%ebx) + addl $4,%ebx +// %ebx points to offset. +// Use to calculate data + movl Data,%eax + addl (%ebx),%eax + addl $4,%ebx +// push data + pushl %eax + call FINALIZE + jmp .LMyRecordFinalLoop +// Array handling +.LDoArrayFinal: +// Skip array name !! + incl %ebx + movzbl (%ebx),%eax + incl %eax + addl %eax,%ebx +// %ebx points to size. Put size in ecx + movl (%ebx),%ecx + addl $4, %ebx +// %ebx points to count. Put count in %edx + movl (%ebx),%edx + addl $4, %ebx +// %ebx points to type. Put into ebx. +// Start treating elements. +.LMyArrayFinalLoop: + decl %edx + jl .LExitFinalize +// push type + pushl (%ebx) +// calculate data + movl %ecx,%eax + imull %edx,%eax + addl Data,%eax +// push data + pushl %eax + call FINALIZE + jmp .LMyArrayFinalLoop +// AnsiString handling : +.LDoAnsiStringFinal: + pushl Data + call ANSISTR_DECR_REF +.LExitFinalize: + pop %edx + pop %ecx + pop %ebx + pop %eax +end; + + +Procedure Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF'];Assembler; +asm +// Save registers + push %eax + push %ebx + push %ecx + push %edx +// decide what type it is + movl TypeInfo,%ebx + movb (%ebx),%al + subb $9,%al + jz .LDoAnsiStringAddRef + decb %al + jz .LDoAnsiStringAddRef + subb $2,%al + jz .LDoArrayAddRef + decb %al + jz .LDoRecordAddRef + subb $2,%al + jz .LDoClassAddRef + decb %al + jz .LDoObjectAddRef + decb %al + jz .LDoClassAddRef + jmp .LExitAddRef +.LDoClassAddRef: +.LDoObjectAddRef: +.LDoRecordAddRef: + incl %ebx + movzbl (%ebx),%eax +// Skip also recordsize. + addl $5,%eax + addl %eax,%ebx +// %ebx points to element count. Set in %edx + movl (%ebx),%edx + addl $4,%ebx +// %ebx points to First element in record +.LMyRecordAddRefLoop: + decl %edx + jl .LExitAddRef +// Push type + pushl (%ebx) + addl $4,%ebx +// Calculate data + movl Data,%eax + addl (%ebx),%eax + addl $4,%ebx +// push data + pushl %eax + call ADDREF + jmp .LMyRecordAddRefLoop +// Array handling +.LDoArrayAddRef: +// Skip array name !! + incl %ebx + movzbl (%ebx),%eax + incl %eax + addl %eax,%ebx +// %ebx points to size. Put size in ecx + movl (%ebx),%ecx + addl $4, %ebx +// %ebx points to count. Put count in %edx + movl (%ebx),%edx + addl $4, %ebx +// %ebx points to type. Put into ebx. +// Start treating elements. +.LMyArrayAddRefLoop: + decl %edx + jl .LExitAddRef +// push type + pushl (%ebx) +// calculate data + movl %ecx,%eax + imull %edx,%eax + addl Data,%eax +// push data + pushl %eax + call ADDREF + jmp .LMyArrayAddRefLoop +// AnsiString handling : +.LDoAnsiStringAddRef: + pushl Data + call ANSISTR_INCR_REF +.LExitAddRef: + pop %edx + pop %ecx + pop %ebx + pop %eax +end; + + +Procedure DecRef (Data,TypeInfo : Pointer); [Public,alias : 'FPC_DECREF'];Assembler; +asm +// Save registers + push %eax + push %ebx + push %ecx + push %edx +// decide what type it is + movl TypeInfo,%ebx + movb (%ebx),%al + subb $9,%al + jz .LDoAnsiStringDecRef + decb %al + jz .LDoAnsiStringDecRef + subb $2,%al + jz .LDoArrayDecRef + decb %al + jz .LDoRecordDecRef + subb $2,%al + jz .LDoClassDecRef + decb %al + jz .LDoObjectDecRef + decb %al + jz .LDoClassDecRef + jmp .LExitDecRef +.LDoClassDecRef: +.LDoObjectDecRef: +.LDoRecordDecRef: + incl %ebx + movzbl (%ebx),%eax +// Skip also recordsize. + addl $5,%eax + addl %eax,%ebx +// %ebx points to element count. Set in %edx + movl (%ebx),%edx + addl $4,%ebx +// %ebx points to First element in record +.LMyRecordDecRefLoop: + decl %edx + jl .LExitDecRef +// Push type + pushl (%ebx) + addl $4,%ebx +// Calculate data + movl Data,%eax + addl (%ebx),%eax + addl $4,%ebx +// push data + pushl %eax + call DECREF + jmp .LMyRecordDecRefLoop +// Array handling +.LDoArrayDecRef: +// Skip array name !! + incl %ebx + movzbl (%ebx),%eax + incl %eax + addl %eax,%ebx +// %ebx points to size. Put size in ecx + movl (%ebx),%ecx + addl $4, %ebx +// %ebx points to count. Put count in %edx + movl (%ebx),%edx + addl $4, %ebx +// %ebx points to type. Put into ebx. +// Start treating elements. +.LMyArrayDecRefLoop: + decl %edx + jl .LExitDecRef +// push type + pushl (%ebx) +// calculate data + movl %ecx,%eax + imull %edx,%eax + addl Data,%eax +// push data + pushl %eax + call DECREF + jmp .LMyArrayDecRefLoop +// AnsiString handling : +.LDoAnsiStringDecRef: + movl Data,%eax + pushl %eax + call ANSISTR_DECR_REF +.LExitDecRef: + pop %edx + pop %ecx + pop %ebx + pop %eax +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.23 2000/06/07 08:55:30 jonas + * fixed web bug 983 (array name wasn't skipped in add/decref) + + Revision 1.22 2000/04/01 11:45:34 peter + * fixed addref/decref for records, the data/type was read in the + wrong order + + Revision 1.21 2000/02/18 15:23:01 florian + * fixed constants in rtti + * longjmp does now a finit + + Revision 1.20 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.19 2000/01/11 21:11:34 marco + * Direct params to internal assembler + + Revision 1.18 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.17 1999/07/31 22:27:28 michael + Object finalization data fixed + +} diff --git a/befpc/rtl/i386/set.inc b/befpc/rtl/i386/set.inc new file mode 100644 index 0000000..1981c69 --- /dev/null +++ b/befpc/rtl/i386/set.inc @@ -0,0 +1,440 @@ +{ + $Id: set.inc,v 1.1.1.1 2001-07-23 17:17:29 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Include file with set operations called by the compiler + + 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. + + **********************************************************************} + +procedure do_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL']; +{ + load a normal set p from a smallset l +} +asm + movl p,%edi + movl l,%eax + movl %eax,(%edi) + addl $4,%edi + movl $7,%ecx + xorl %eax,%eax + rep + stosl +end; + + +procedure do_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; +{ + create a new set in p from an element b +} +asm + pushl %eax + pushl %ecx + movl p,%edi + xorl %eax,%eax + movl $8,%ecx + rep + stosl + movb b,%al + movl p,%edi + movl %eax,%ecx + shrl $3,%eax + andl $7,%ecx + addl %eax,%edi + btsl %ecx,(%edi) + popl %ecx + popl %eax +end; + +procedure do_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE']; +{ + add the element b to the set pointed by p +} +asm + pushl %eax + movl p,%edi + movb b,%al + andl $0xf8,%eax + shrl $3,%eax + addl %eax,%edi + movb b,%al + andl $7,%eax + btsl %eax,(%edi) + popl %eax +end; + + +procedure do_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE']; +{ + suppresses the element b to the set pointed by p + used for exclude(set,element) +} +asm + pushl %eax + movl p,%edi + movb b,%al + andl $0xf8,%eax + shrl $3,%eax + addl %eax,%edi + movb b,%al + andl $7,%eax + btrl %eax,(%edi) + popl %eax +end; + + +procedure do_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE']; +{ + bad implementation, but it's very seldom used +} +asm + pushl %eax + movl p,%edi + xorl %eax,%eax + xorl %ecx,%ecx + movb h,%al + movb l,%cl +.LSET_SET_RANGE_LOOP: + cmpl %ecx,%eax + jl .LSET_SET_RANGE_EXIT + movl %eax,%ebx + movl %eax,%edx + andl $0xf8,%ebx + andl $7,%edx + shrl $3,%ebx + btsl %edx,(%edi,%ebx) + dec %eax + jmp .LSET_SET_RANGE_LOOP +.LSET_SET_RANGE_EXIT: + popl %eax +end; + + +procedure do_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE']; +{ + tests if the element b is in the set p the carryflag is set if it present +} +asm + pushl %eax + movl p,%edi + movb b,%al + andl $0xf8,%eax + shrl $3,%eax + addl %eax,%edi + movb b,%al + andl $7,%eax + btl %eax,(%edi) + popl %eax +end; + + + +procedure do_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS']; +{ + adds set1 and set2 into set dest +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl $8,%ecx + .LMADDSETS1: + lodsl + orl (%ebx),%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMADDSETS1 +end; + + + +procedure do_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS']; +{ + multiplies (takes common elements of) set1 and set2 result put in dest +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl $8,%ecx + .LMMULSETS1: + lodsl + andl (%ebx),%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMMULSETS1 +end; + + +procedure do_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS']; +{ + computes the diff from set1 to set2 result in dest +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl $8,%ecx + .LMSUBSETS1: + lodsl + movl (%ebx),%edx + notl %edx + andl %edx,%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMSUBSETS1 +end; + + +procedure do_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; +{ + computes the symetric diff from set1 to set2 result in dest +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl $8,%ecx + .LMSYMDIFSETS1: + lodsl + movl (%ebx),%edx + xorl %edx,%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMSYMDIFSETS1 +end; + + +procedure do_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS']; +{ + compares set1 and set2 zeroflag is set if they are equal +} +asm + movl set1,%esi + movl set2,%edi + movl $8,%ecx + .LMCOMPSETS1: + movl (%esi),%eax + movl (%edi),%edx + cmpl %edx,%eax + jne .LMCOMPSETEND + addl $4,%esi + addl $4,%edi + decl %ecx + jnz .LMCOMPSETS1 + { we are here only if the two sets are equal + we have zero flag set, and that what is expected } + .LMCOMPSETEND: +end; + +{$IfNDef NoSetInclusion} +procedure do_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; +{ + on exit, zero flag is set if set1 <= set2 (set2 contains set1) +} +asm + movl set1,%esi + movl set2,%edi + movl $8,%ecx + .LMCONTAINSSETS1: + movl (%esi),%eax + movl (%edi),%edx + andl %eax,%edx + cmpl %edx,%eax {set1 and set2 = set1?} + jne .LMCONTAINSSETEND + addl $4,%esi + addl $4,%edi + decl %ecx + jnz .LMCONTAINSSETS1 + { we are here only if set2 contains set1 + we have zero flag set, and that what is expected } + .LMCONTAINSSETEND: +end; +{$EndIf SetInclusion} + +{$ifdef LARGESETS} + +procedure do_set(p : pointer;b : word);assembler;[public,alias:'FPC_SET_SET_WORD']; +{ + sets the element b in set p works for sets larger than 256 elements + not yet use by the compiler so +} +asm + pushl %eax + movl p,%edi + movw b,%ax + andl $0xfff8,%eax + shrl $3,%eax + addl %eax,%edi + movb 12(%ebp),%al + andl $7,%eax + btsl %eax,(%edi) + popl %eax +end; + + +procedure do_in(p : pointer;b : word);assembler;[public,alias:'FPC_SET_IN_WORD']; +{ + tests if the element b is in the set p the carryflag is set if it present + works for sets larger than 256 elements +} +asm + pushl %eax + movl p,%edi + movw b,%ax + andl $0xfff8,%eax + shrl $3,%eax + addl %eax,%edi + movb 12(%ebp),%al + andl $7,%eax + btl %eax,(%edi) + popl %eax +end; + + +procedure add_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_ADD_SETS_SIZE']; +{ + adds set1 and set2 into set dest size is the number of bytes in the set +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl size,%ecx + .LMADDSETSIZES1: + lodsl + orl (%ebx),%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMADDSETSIZES1 +end; + + +procedure mul_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_MUL_SETS_SIZE']; +{ + multiplies (i.E. takes common elements of) set1 and set2 result put in + dest size is the number of bytes in the set +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl size,%ecx + .LMMULSETSIZES1: + lodsl + andl (%ebx),%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMMULSETSIZES1 +end; + + +procedure sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SUB_SETS_SIZE']; +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl size,%ecx + .LMSUBSETSIZES1: + lodsl + movl (%ebx),%edx + notl %edx + andl %edx,%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMSUBSETSIZES1 +end; + + +procedure sym_sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SYMDIF_SETS_SIZE']; +{ + computes the symetric diff from set1 to set2 result in dest +} +asm + movl set1,%esi + movl set2,%ebx + movl dest,%edi + movl size,%ecx + .LMSYMDIFSETSIZE1: + lodsl + movl (%ebx),%edx + xorl %edx,%eax + stosl + addl $4,%ebx + decl %ecx + jnz .LMSYMDIFSETSIZE1 +end; + + +procedure comp_sets(set1,set2 : pointer;size : longint);assembler;[public,alias:'FPC_SET_COMP_SETS_SIZE']; +asm + movl set1,%esi + movl set2,%edi + movl size,%ecx + .LMCOMPSETSIZES1: + lodsl + movl (%edi),%edx + cmpl %edx,%eax + jne .LMCOMPSETSIZEEND + addl $4,%edi + decl %ecx + jnz .LMCOMPSETSIZES1 + { we are here only if the two sets are equal + we have zero flag set, and that what is expected } + .LMCOMPSETSIZEEND: +end; + +{$IfNDef NoSetInclusion} +procedure contains_sets(set1,set2 : pointer; size: longint);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; +{ + on exit, zero flag is set if set1 <= set2 (set2 contains set1) +} +asm + movl set1,%esi + movl set2,%edi + movl size,%ecx + .LMCONTAINSSETS2: + movl (%esi),%eax + movl (%edi),%edx + andl %eax,%edx + cmpl %edx,%eax {set1 and set2 = set1?} + jne .LMCONTAINSSETEND2 + addl $4,%esi + addl $4,%edi + decl %ecx + jnz .LMCONTAINSSETS2 + { we are here only if set2 contains set1 + we have zero flag set, and that what is expected } + .LMCONTAINSSETEND2: +end; +{$EndIf NoSetInclusion} + + +{$endif LARGESET} + +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.12 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.11 2000/01/07 16:32:24 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/i386/setjump.inc b/befpc/rtl/i386/setjump.inc new file mode 100644 index 0000000..61e80b5 --- /dev/null +++ b/befpc/rtl/i386/setjump.inc @@ -0,0 +1,76 @@ +{ + $Id: setjump.inc,v 1.1.1.1 2001-07-23 17:17:29 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + SetJmp and LongJmp implementation for exception handling + + 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. + + **********************************************************************} + +Function SetJmp (Var S : Jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP']; +asm + movl 8(%ebp),%eax + movl %ebx,(%eax) + movl %esi,4(%eax) + movl %edi,8(%eax) + movl 4(%ebp),%edi + movl %edi,20(%eax) + movl (%ebp),%edi + movl %edi,12(%eax) + leal 12(%ebp),%edi + movl %edi,16(%eax) + movl 8(%eax),%edi + xorl %eax,%eax +end['EAX']; + + +Procedure longJmp (Var S : Jmp_buf; value : longint); assembler;[Public, alias : 'FPC_LONGJMP']; +asm + movl 8(%ebp),%ecx + movl 12(%ebp),%eax + movl (%ecx),%ebx + movl 4(%ecx),%esi + movl 8(%ecx),%edi + movl 12(%ecx),%ebp + movl 16(%ecx),%esp + // we should also clear the fpu + // fninit no must be done elsewhere PM + // or we should reset the control word also + jmp 20(%ecx) +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.13 2000/05/04 09:47:40 pierre + * Preserve all registers in SetJmp + * set EAX to value filed in LongJmp instead of only 0 or 1 + + Revision 1.12 2000/03/31 23:12:09 pierre + * remove fninit in longjump + + Revision 1.11 2000/02/18 16:16:13 florian + * we don't need to to finit twice ... + + Revision 1.10 2000/02/18 15:23:01 florian + * fixed constants in rtti + * longjmp does now a finit + + Revision 1.9 2000/02/09 22:12:54 florian + * longjump does now a finit + + Revision 1.8 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.7 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.6 1999/08/18 10:42:13 pierre + * loading of esp value corrected +} \ No newline at end of file diff --git a/befpc/rtl/i386/setjumph.inc b/befpc/rtl/i386/setjumph.inc new file mode 100644 index 0000000..9f3a8a4 --- /dev/null +++ b/befpc/rtl/i386/setjumph.inc @@ -0,0 +1,32 @@ +{ + $Id: setjumph.inc,v 1.1.1.1 2001-07-23 17:17:29 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1998 the Free Pascal development team + + SetJmp/Longjmp declarations + + 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. + + **********************************************************************} + +Type + jmp_buf = record + ebx,esi,edi : Longint; + bp,sp,pc : Pointer; + end; + PJmp_buf = ^jmp_buf; + +Function Setjmp (Var S : Jmp_buf) : longint; +Procedure longjmp (Var S : Jmp_buf; value : longint); + +{ + $Log: not supported by cvs2svn $ + Revision 1.3 2000/02/09 16:59:29 peter + * truncated log + +} diff --git a/befpc/rtl/i386/strings.inc b/befpc/rtl/i386/strings.inc new file mode 100644 index 0000000..bf3b0de --- /dev/null +++ b/befpc/rtl/i386/strings.inc @@ -0,0 +1,440 @@ +{ + $Id: strings.inc,v 1.1.1.1 2001-07-23 17:17:29 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Processor dependent part of strings.pp, that can be shared with + sysutils unit. + + 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. + + **********************************************************************} + +{$ASMMODE ATT} + +function strcopy(dest,source : pchar) : pchar;assembler; +asm + movl source,%edi + testl %edi,%edi + jz .LStrCopyDone + movl %edi,%ecx + andl $0x0fffffff8,%edi + movl source,%esi + subl %edi,%ecx + movl dest,%edi + jz .LStrCopyAligned +.LStrCopyAlignLoop: + movb (%esi),%al + incl %edi + incl %esi + testb %al,%al + movb %al,-1(%edi) + jz .LStrCopyDone + decl %ecx + jnz .LStrCopyAlignLoop + .balign 16 +.LStrCopyAligned: + movl (%esi),%eax + addl $4,%esi + testl $0x0ff,%eax + jz .LStrCopyByte + testl $0x0ff00,%eax + jz .LStrCopyWord + testl $0x0ff0000,%eax + jz .LStrCopy3Bytes + movl %eax,(%edi) + testl $0x0ff000000,%eax + jz .LStrCopyDone + addl $4,%edi + jmp .LStrCopyAligned +.LStrCopy3Bytes: + movw %ax,(%edi) + xorl %eax,%eax + addl $2,%edi + jmp .LStrCopyByte +.LStrCopyWord: + movw %ax,(%edi) + jmp .LStrCopyDone +.LStrCopyByte: + movb %al,(%edi) +.LStrCopyDone: + movl dest,%eax +end ['EAX','ECX','ESI','EDI']; + + +function strecopy(dest,source : pchar) : pchar;assembler; +asm + cld + movl source,%edi + movl $0xffffffff,%ecx + xorl %eax,%eax + repne + scasb + not %ecx + movl dest,%edi + movl source,%esi + movl %ecx,%eax + shrl $2,%ecx + rep + movsl + movl %eax,%ecx + andl $3,%ecx + rep + movsb + movl dest,%eax + decl %edi + movl %edi,%eax +end ['EAX','ECX','ESI','EDI']; + + +function strlcopy(dest,source : pchar;maxlen : longint) : pchar;assembler; +asm + movl source,%esi + movl maxlen,%ecx + movl dest,%edi + orl %ecx,%ecx + jz .LSTRLCOPY2 + cld +.LSTRLCOPY1: + lodsb + stosb + decl %ecx // Lower maximum + jz .LSTRLCOPY2 // 0 reached ends + orb %al,%al + jnz .LSTRLCOPY1 + jmp .LSTRLCOPY3 +.LSTRLCOPY2: + xorb %al,%al // If cutted + stosb // add a #0 +.LSTRLCOPY3: + movl dest,%eax +end ['EAX','ECX','ESI','EDI']; + + +function strlen(p : pchar) : longint;assembler; +asm + cld + xorl %eax,%eax + movl p,%edi + orl %edi,%edi + jz .LNil + movl $0xffffffff,%ecx + repne + scasb + movl $0xfffffffe,%eax + subl %ecx,%eax +.LNil: +end ['EDI','ECX','EAX']; + + +function strend(p : pchar) : pchar;assembler; +asm + cld + xorl %eax,%eax + movl p,%edi + orl %edi,%edi + jz .LStrEndNil + movl $0xffffffff,%ecx + xorl %eax,%eax + repne + scasb + movl %edi,%eax + decl %eax +.LStrEndNil: +end ['EDI','ECX','EAX']; + + +function strcomp(str1,str2 : pchar) : longint;assembler; +asm + movl str2,%edi + movl $0xffffffff,%ecx + cld + xorl %eax,%eax + repne + scasb + not %ecx + movl str2,%edi + movl str1,%esi + repe + cmpsb + movb -1(%esi),%al + movzbl -1(%edi),%ecx + subl %ecx,%eax +end ['EAX','ECX','ESI','EDI']; + + +function strlcomp(str1,str2 : pchar;l : longint) : longint;assembler; +asm + movl str2,%edi + movl $0xffffffff,%ecx + cld + xorl %eax,%eax + repne + scasb + not %ecx + cmpl l,%ecx + jl .LSTRLCOMP1 + movl l,%ecx +.LSTRLCOMP1: + movl str2,%edi + movl str1,%esi + repe + cmpsb + movb -1(%esi),%al + movzbl -1(%edi),%ecx + subl %ecx,%eax +end ['EAX','ECX','ESI','EDI']; + + +function stricomp(str1,str2 : pchar) : longint;assembler; +asm + movl str2,%edi + movl $0xffffffff,%ecx + cld + xorl %eax,%eax + repne + scasb + not %ecx + movl str2,%edi + movl str1,%esi +.LSTRICOMP2: + repe + cmpsb + jz .LSTRICOMP3 // If last reached then exit + movzbl -1(%esi),%eax + movzbl -1(%edi),%ebx + cmpb $97,%al + jb .LSTRICOMP1 + cmpb $122,%al + ja .LSTRICOMP1 + subb $0x20,%al +.LSTRICOMP1: + cmpb $97,%bl + jb .LSTRICOMP4 + cmpb $122,%bl + ja .LSTRICOMP4 + subb $0x20,%bl +.LSTRICOMP4: + subl %ebx,%eax + jz .LSTRICOMP2 // If still equal, compare again +.LSTRICOMP3: +end ['EAX','ECX','ESI','EDI']; + + +function strlicomp(str1,str2 : pchar;l : longint) : longint;assembler; +asm + movl str2,%edi + movl $0xffffffff,%ecx + cld + xorl %eax,%eax + repne + scasb + not %ecx + cmpl l,%ecx + jl .LSTRLICOMP5 + movl l,%ecx +.LSTRLICOMP5: + movl str2,%edi + movl str1,%esi +.LSTRLICOMP2: + repe + cmpsb + jz .LSTRLICOMP3 // If last reached, exit + movzbl -1(%esi),%eax + movzbl -1(%edi),%ebx + cmpb $97,%al + jb .LSTRLICOMP1 + cmpb $122,%al + ja .LSTRLICOMP1 + subb $0x20,%al +.LSTRLICOMP1: + cmpb $97,%bl + jb .LSTRLICOMP4 + cmpb $122,%bl + ja .LSTRLICOMP4 + subb $0x20,%bl +.LSTRLICOMP4: + subl %ebx,%eax + jz .LSTRLICOMP2 +.LSTRLICOMP3: +end ['EAX','ECX','ESI','EDI']; + + +function strscan(p : pchar;c : char) : pchar;assembler; +asm + movl p,%eax + xorl %ecx,%ecx + testl %eax,%eax + jz .LSTRSCAN +// align + movb c,%cl + movl %eax,%esi + andl $0xfffffff8,%eax + movl $0xff,%edx + movl p,%edi + subl %eax,%esi + jz .LSTRSCANLOOP + xorl %eax,%eax +.LSTRSCANALIGNLOOP: + movb (%edi),%al +// at .LSTRSCANFOUND, one is substracted from edi to calculate the position, +// so add 1 here already (not after .LSTRSCAN, because then the test/jz and +// cmp/je can't be paired) + incl %edi + testb %al,%al + jz .LSTRSCAN + cmpb %cl,%al + je .LSTRSCANFOUND + decl %esi + jnz .LSTRSCANALIGNLOOP + jmp .LSTRSCANLOOP + .balign 16 +.LSTRSCANLOOP: + movl (%edi),%eax + movl %eax,%esi +// first char + andl %edx,%eax +// end of string -> stop + jz .LSTRSCAN + shrl $8,%esi + cmpl %ecx,%eax + movl %esi,%eax + je .LSTRSCANFOUND1 +// second char + andl %edx,%eax + jz .LSTRSCAN + shrl $8,%esi + cmpl %ecx,%eax + movl %esi,%eax + je .LSTRSCANFOUND2 +// third char + andl %edx,%eax + jz .LSTRSCAN + shrl $8,%esi + cmpl %ecx,%eax + movl %esi,%eax + je .LSTRSCANFOUND3 +// fourth char +// all upper bits have already been cleared + testl %eax,%eax + jz .LSTRSCAN + addl $4,%edi + cmpl %ecx,%eax + je .LSTRSCANFOUND + jmp .LSTRSCANLOOP +.LSTRSCANFOUND3: + leal 2(%edi),%eax + jmp .LSTRSCAN +.LSTRSCANFOUND2: + leal 1(%edi),%eax + jmp .LSTRSCAN +.LSTRSCANFOUND1: + movl %edi,%eax + jmp .LSTRSCAN +.LSTRSCANFOUND: + leal -1(%edi),%eax +.LSTRSCAN: +end ['EAX','ECX','ESI','EDI','EDX']; + + +function strrscan(p : pchar;c : char) : pchar;assembler; +asm + xorl %eax,%eax + movl p,%edi + orl %edi,%edi + jz .LSTRRSCAN + movl $0xffffffff,%ecx + cld + xorb %al,%al + repne + scasb + not %ecx + movb c,%al + movl p,%edi + addl %ecx,%edi + decl %edi + std + repne + scasb + cld + movl $0,%eax + jnz .LSTRRSCAN + movl %edi,%eax + incl %eax +.LSTRRSCAN: +end ['EAX','ECX','EDI']; + + +function strupper(p : pchar) : pchar;assembler; +asm + movl p,%esi + orl %esi,%esi + jz .LStrUpperNil + movl %esi,%edi +.LSTRUPPER1: + lodsb + cmpb $97,%al + jb .LSTRUPPER3 + cmpb $122,%al + ja .LSTRUPPER3 + subb $0x20,%al +.LSTRUPPER3: + stosb + orb %al,%al + jnz .LSTRUPPER1 +.LStrUpperNil: + movl p,%eax +end ['EAX','ESI','EDI']; + + +function strlower(p : pchar) : pchar;assembler; +asm + movl p,%esi + orl %esi,%esi + jz .LStrLowerNil + movl %esi,%edi +.LSTRLOWER1: + lodsb + cmpb $65,%al + jb .LSTRLOWER3 + cmpb $90,%al + ja .LSTRLOWER3 + addb $0x20,%al +.LSTRLOWER3: + stosb + orb %al,%al + jnz .LSTRLOWER1 +.LStrLowerNil: + movl p,%eax +end ['EAX','ESI','EDI']; + +{ + $Log: not supported by cvs2svn $ + Revision 1.11 2000/06/23 11:13:56 jonas + * fixed bug in strscan :( + + Revision 1.10 2000/06/12 19:53:32 peter + * change .align to .balign + + Revision 1.9 2000/06/11 14:25:23 jonas + * much faster strcopy and strscan procedures + + Revision 1.8 2000/03/28 11:14:33 jonas + * added missing register that is destroyed by strecopy + + some destroyed register lists for procedures that didn't have one yet + + Revision 1.7 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.6 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.5 1999/12/18 23:08:33 florian + * bug 766 fixed + +} diff --git a/befpc/rtl/i386/stringss.inc b/befpc/rtl/i386/stringss.inc new file mode 100644 index 0000000..bac5f00 --- /dev/null +++ b/befpc/rtl/i386/stringss.inc @@ -0,0 +1,135 @@ +{ + $Id: stringss.inc,v 1.1.1.1 2001-07-23 17:17:29 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Processor dependent part of strings.pp, not shared with + sysutils unit. + + 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. + + **********************************************************************} + +function strpas(p : pchar) : string; +begin +asm + movl p,%esi + movl __RESULT,%edi + movl %esi,%edx + movl $1,%ecx + andl $0x0fffffff8,%esi + // skip length byte + incl %edi + subl %esi,%edx + jz .LStrPasAligned + movl p,%esi + // align source to multiple of 4 (not dest, because we can't read past + // the end of the source, since that may be past the end of the heap + // -> sigsegv!!) +.LStrPasAlignLoop: + movb (%esi),%al + incl %esi + testb %al,%al + jz .LStrPasDone + incl %edi + incb %cl + decb %dl + movb %al,-1(%edi) + jne .LStrPasAlignLoop + .balign 16 +.LStrPasAligned: + movl (%esi),%eax + addl $4,%esi + // this won't overwrite data since the result = 255 char string + // and we never process more than the first 255 chars of p + movl %eax,(%edi) + testl $0x0ff,%eax + jz .LStrPasDone + incl %ecx + testl $0x0ff00,%eax + jz .LStrPasDone + incl %ecx + testl $0x0ff0000,%eax + jz .LStrPasDone + incl %ecx + testl $0x0ff000000,%eax + jz .LStrPasDone + incl %ecx + addl $4,%edi + cmpl $252,%ecx + jbe .LStrPasAligned + testb %cl,%cl + jz .LStrPasDone + movl (%esi),%eax +.LStrPasEndLoop: + testb %al,%al + jz .LStrPasDone + movb %al,(%edi) + shrl $8,%eax + incl %edi + incb %cl + jnz .LStrPasEndLoop +.LStrPasDone: + movl __RESULT,%edi + addb $255,%cl + movb %cl,(%edi) +end ['EAX','ECX','EDX','ESI','EDI']; +end; + +function strpcopy(d : pchar;const s : string) : pchar;assembler; +asm + pushl %esi // Save ESI + cld + movl s,%esi // Load Source adress + movl d,%edi // load destination address + movzbl (%esi),%ecx // load length in ECX + incl %esi + rep + movsb + movb $0,(%edi) + movl d,%eax // return value to EAX + popl %esi +end ['EDI','EAX','ECX']; + +{ + $Log: not supported by cvs2svn $ + Revision 1.15 2000/07/01 10:52:12 jonas + * fixed reading past end-of-heap again (correctly this time I hope) + + Revision 1.14 2000/06/30 12:20:20 jonas + * strpas is again slightly slower, but won't crash anymore if a pchar + is passed to it that starts less than 4 bbytes from the heap end + + Revision 1.13 2000/06/12 19:53:32 peter + * change .align to .balign + + Revision 1.12 2000/06/12 13:17:56 jonas + * fixed typo :( + + Revision 1.11 2000/06/12 08:33:26 jonas + * new fixed and faster strpas (previous version only returned the first + 254 chars when the pchar was aligned on a 4 byte boundary and was >= + 255 chars) + + Revision 1.10 2000/03/28 11:14:33 jonas + * added missing register that is destroyed by strecopy + + some destroyed register lists for procedures that didn't have one yet + + Revision 1.9 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.8 2000/01/11 22:56:57 pierre + * wrong change for StrPas function corrected + + Revision 1.7 2000/01/11 21:12:15 marco + * direct params to internal asm. + + Revision 1.6 2000/01/07 16:41:33 daniel + * copyright 2000 + +} diff --git a/befpc/rtl/inc/astrings.inc b/befpc/rtl/inc/astrings.inc new file mode 100644 index 0000000..b9f1a39 --- /dev/null +++ b/befpc/rtl/inc/astrings.inc @@ -0,0 +1,685 @@ +{ + $Id: astrings.inc,v 1.1.1.1 2001-07-23 17:17:30 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team. + + This file implements AnsiStrings for FPC + + 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. + + **********************************************************************} + +{ This will release some functions for special shortstring support } +{ define EXTRAANSISHORT} + +{ + This file contains the implementation of the AnsiString type, + and all things that are needed for it. + AnsiString is defined as a 'silent' pchar : + a pchar that points to : + + @-12 : Longint for maximum size; + @-8 : Longint for size; + @-4 : Longint for reference count; + @ : String + Terminating #0; + Pchar(Ansistring) is a valid typecast. + So AS[i] is converted to the address @AS+i-1. + + Constants should be assigned a reference count of -1 + Meaning that they can't be disposed of. +} + +Type + PAnsiRec = ^TAnsiRec; + TAnsiRec = Packed Record + Maxlen, + len, + ref : Longint; + First : Char; + end; + +Const + AnsiRecLen = SizeOf(TAnsiRec); + FirstOff = SizeOf(TAnsiRec)-1; + + +{**************************************************************************** + Internal functions, not in interface. +****************************************************************************} + +{$ifdef AnsiStrDebug} +Procedure DumpAnsiRec(S : Pointer); +begin + If S=Nil then + Writeln ('String is nil') + Else + Begin + With PAnsiRec(S-Firstoff)^ do + begin + Write ('(Maxlen: ',maxlen); + Write (' Len:',len); + Writeln (' Ref: ',ref,')'); + end; + end; +end; +{$endif} + + +Function NewAnsiString(Len : Longint) : Pointer; +{ + Allocate a new AnsiString on the heap. + initialize it to zero length and reference count 1. +} +Var + P : Pointer; +begin + { Also add +1 for a terminating zero } + GetMem(P,Len+AnsiRecLen); + If P<>Nil then + begin + PAnsiRec(P)^.Maxlen:=Len; { Maximal length } + PAnsiRec(P)^.Len:=0; { Initial length } + PAnsiRec(P)^.Ref:=1; { Set reference count } + PAnsiRec(P)^.First:=#0; { Terminating #0 } + P:=P+FirstOff; { Points to string now } + end; + NewAnsiString:=P; +end; + + +Procedure DisposeAnsiString(Var S : Pointer); +{ + Deallocates a AnsiString From the heap. +} +begin + If S=Nil then + exit; + Dec (Longint(S),FirstOff); + FreeMem (S); + S:=Nil; +end; + + +Procedure AnsiStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_DECR_REF']; +{ + Decreases the ReferenceCount of a non constant ansistring; + If the reference count is zero, deallocate the string; +} +Type + plongint = ^longint; +Var + l : plongint; +Begin + { Zero string } + If S=Nil then exit; + { check for constant strings ...} + l:=@PANSIREC(S-FirstOff)^.Ref; + If l^<0 then exit; + Dec(l^); + If l^=0 then + { Ref count dropped to zero } + DisposeAnsiString (S); { Remove...} + { this pointer is not valid anymore, so set it to zero } + S:=nil; +end; + + +Procedure AnsiStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_INCR_REF']; +Begin + If S=Nil then + exit; + { Let's be paranoid : Constant string ??} + If PAnsiRec(S-FirstOff)^.Ref<0 then exit; + Inc(PAnsiRec(S-FirstOff)^.Ref); +end; + + +Procedure AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN']; +{ + Assigns S2 to S1 (S1:=S2), taking in account reference counts. +} +begin + If S2<>nil then + If PAnsiRec(S2-FirstOff)^.Ref>0 then + Inc(PAnsiRec(S2-FirstOff)^.ref); + { Decrease the reference count on the old S1 } + ansistr_decr_ref (S1); + { And finally, have S1 pointing to S2 (or its copy) } + S1:=S2; +end; + + +Procedure AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_ANSISTR_CONCAT']; +{ + Concatenates 2 AnsiStrings : S1+S2. + Result Goes to S3; +} +Var + Size,Location : Longint; +begin +{ create new result } + if S3<>nil then + AnsiStr_Decr_Ref(S3); +{ only assign if s1 or s2 is empty } + if (S1=Nil) then + AnsiStr_Assign(S3,S2) + else + if (S2=Nil) then + AnsiStr_Assign(S3,S1) + else + begin + Size:=PAnsiRec(S2-FirstOff)^.Len; + Location:=Length(AnsiString(S1)); + SetLength (AnsiString(S3),Size+Location); + Move (S1^,S3^,Location); + Move (S2^,(S3+location)^,Size+1); + end; +end; + + +{$ifdef EXTRAANSISHORT} +Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString); +{ + Concatenates a Ansi with a short string; : S2 + S2 +} +Var + Size,Location : Longint; +begin + Size:=Length(S2); + Location:=Length(S1); + If Size=0 then + exit; + { Setlength takes case of uniqueness + and alllocated memory. We need to use length, + to take into account possibility of S1=Nil } + SetLength (S1,Size+Length(S1)); + Move (S2[1],Pointer(Pointer(S1)+Location)^,Size); + PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero } +end; +{$endif EXTRAANSISHORT} + + +Procedure AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; +{ + Converts a AnsiString to a ShortString; +} +Var + Size : Longint; +begin + if S2=nil then + S1:='' + else + begin + Size:=PAnsiRec(S2-FirstOff)^.Len; + If Size>high(S1) then + Size:=high(S1); + Move (S2^,S1[1],Size); + byte(S1[0]):=Size; + end; +end; + + +Procedure ShortStr_To_AnsiStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_ANSISTR']; +{ + Converts a ShortString to a AnsiString; +} +Var + Size : Longint; +begin + Size:=Length(S2); + Setlength (AnsiString(S1),Size); + if Size>0 then + begin + Move (S2[1],Pointer(S1)^,Size); + { Terminating Zero } + PByte(Pointer(S1)+Size)^:=0; + end; +end; + + +Procedure Char_To_AnsiStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_ANSISTR']; +{ + Converts a ShortString to a AnsiString; +} +begin + Setlength (AnsiString(S1),1); + PByte(Pointer(S1))^:=byte(c); + { Terminating Zero } + PByte(Pointer(S1)+1)^:=0; +end; + + +Procedure PChar_To_AnsiStr(var a : ansistring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_ANSISTR']; +Var + L : Longint; +begin + if pointer(a)<>nil then + begin + AnsiStr_Decr_Ref(Pointer(a)); + pointer(a):=nil; + end; + if (not assigned(p)) or (p[0]=#0) Then + Pointer(a):=nil + else + begin + //!! Horribly inneficient, but I see no other way... + L:=1; + While P[l]<>#0 do + inc (l); + Pointer(a):=NewAnsistring(L); + SetLength(A,L); + Move (P[0],Pointer(A)^,L) + end; +end; + + +Procedure CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_ANSISTR']; +var + i : longint; + hp : pchar; +begin + if p[0]=#0 Then + Pointer(a):=nil + else + begin + Pointer(a):=NewAnsistring(L); + hp:=p; + i:=0; + while (i#0) do + begin + inc(hp); + inc(i); + end; + SetLength(A,i); + Move (P[0],Pointer(A)^,i) + end; +end; + + +Function AnsiStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSISTR_COMPARE']; +{ + Compares 2 AnsiStrings; + The result is + <0 if S10 if S1>S2 +} +Var + i,MaxI,Temp : Longint; +begin + i:=0; + Maxi:=Length(AnsiString(S1)); + temp:=Length(AnsiString(S2)); + If MaxI>Temp then + MaxI:=Temp; + Temp:=0; + While (ilen) or (Index<1) then + HandleErrorFrame(201,get_frame); +end; + + +{$ifdef EXTRAANSISHORT} +Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint; +{ + Compares a AnsiString with a ShortString; + The result is + <0 if S10 if S1>S2 +} +Var + i,MaxI,Temp : Longint; +begin + Temp:=0; + i:=0; + MaxI:=Length(AnsiString(S1)); + if MaxI>byte(S2[0]) then + MaxI:=Byte(S2[0]); + While (i0) then + begin + if Pointer(S)=nil then + begin + { Need a complete new string...} + Pointer(s):=NewAnsiString(l); + end + else + If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or + (PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then + begin + { Reallocation is needed... } + Temp:=Pointer(NewAnsiString(L)); + if Length(S)>0 then + Move(Pointer(S)^,Temp^,L); + ansistr_decr_ref(Pointer(S)); + Pointer(S):=Temp; + end; + { Force nil termination in case it gets shorter } + PByte(Pointer(S)+l)^:=0; + PAnsiRec(Pointer(S)-FirstOff)^.Len:=l; + end + else + begin + { Length=0 } + if Pointer(S)<>nil then + ansistr_decr_ref (Pointer(S)); + Pointer(S):=Nil; + end; +end; + + +Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE']; +{ + Make sure reference count of S is 1, + using copy-on-write semantics. +} +Var + SNew : Pointer; +begin + If Pointer(S)=Nil then + exit; + if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then + begin + SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len); + Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1); + PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len; + ansistr_decr_ref (Pointer(S)); { Thread safe } + Pointer(S):=SNew; + end; +end; + + +Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString; +var + ResultAddress : Pointer; +begin + ResultAddress:=Nil; + dec(index); + if Index < 0 then + Index := 0; + { Check Size. Accounts for Zero-length S, the double check is needed because + Size can be maxint and will get <0 when adding index } + if (Size>Length(S)) or + (Index+Size>Length(S)) then + Size:=Length(S)-Index; + If Size>0 then + begin + If Index<0 Then + Index:=0; + ResultAddress:=Pointer(NewAnsiString (Size)); + if ResultAddress<>Nil then + begin + Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size); + PAnsiRec(ResultAddress-FirstOff)^.Len:=Size; + PByte(ResultAddress+Size)^:=0; + end; + end; + Pointer(Copy):=ResultAddress; +end; + + +Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint; +var + substrlen, + maxi, + i,j : longint; + e : boolean; + S : AnsiString; + se : Pointer; +begin + i := 0; + j := 0; + substrlen:=Length(SubStr); + maxi:=length(source)-substrlen; + e:=(substrlen>0); + while (e) and (i <= maxi) do + begin + inc (i); + if Source[i]=SubStr[1] then + begin + S:=copy(Source,i,substrlen); + Se:=pointer(SubStr); + if AnsiStr_Compare(se,Pointer(S))=0 then + begin + j := i; + break; + end; + end; + end; + pos := j; +end; + + +Function ValAnsiFloat(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR']; +Var + SS : String; +begin + AnsiStr_To_ShortStr(SS,Pointer(S)); + ValAnsiFloat := ValFloat(SS,Code); +end; + + +Function ValAnsiUnsignedInt (Const S : AnsiString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR']; +Var + SS : ShortString; +begin + AnsiStr_To_ShortStr(SS,Pointer(S)); + ValAnsiUnsignedInt := ValUnsignedInt(SS,Code); +end; + + +Function ValAnsiSignedInt (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR']; +Var + SS : ShortString; +begin + AnsiStr_To_ShortStr (SS,Pointer(S)); + ValAnsiSignedInt := ValSignedInt(DestSize,SS,Code); +end; + + +{$IfDef SUPPORT_FIXED} +Function ValAnsiFixed(Const S : AnsiString; Var Code : ValSint): ValReal; [public, alias:'FPC_VAL_FIXED_ANSISTR']; +Var + SS : String; +begin + AnsiStr_To_ShortStr (SS,Pointer(S)); + ValAnsiFixed := Fixed(ValFloat(SS,Code)); +end; +{$EndIf SUPPORT_FIXED} + + +procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT']; +var + ss : shortstring; +begin + str_real(len,fr,d,treal_type(rt),ss); + s:=ss; +end; + + +Procedure AnsiStr_Cardinal(C : Cardinal;Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_CARDINAL']; +Var + SS : ShortString; +begin + int_str_cardinal(C,Len,SS); + S:=SS; +end; + + + +Procedure AnsiStr_Longint(L : Longint; Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_LONGINT']; +Var + SS : ShortString; +begin + int_Str_Longint (L,Len,SS); + S:=SS; +end; + + +Procedure Delete (Var S : AnsiString; Index,Size: Longint); +Var + LS : Longint; +begin + If Length(S)=0 then + exit; + if index<=0 then + begin + inc(Size,index-1); + index:=1; + end; + LS:=PAnsiRec(Pointer(S)-FirstOff)^.Len; + if (Index<=LS) and (Size>0) then + begin + UniqueString (S); + if Size+Index>LS then + Size:=LS-Index+1; + if Index+Size<=LS then + begin + Dec(Index); + Move(PByte(Pointer(S))[Index+Size],PByte(Pointer(S))[Index],LS-Index+1); + end; + Setlength(s,LS-Size); + end; +end; + + +Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint); +var + Temp : AnsiString; + LS : Longint; +begin + If Length(Source)=0 then + exit; + if index <= 0 then + index := 1; + Ls:=Length(S); + if index > LS then + index := LS+1; + Dec(Index); + Pointer(Temp) := NewAnsiString(Length(Source)+LS); + SetLength(Temp,Length(Source)+LS); + If Index>0 then + move (Pointer(S)^,Pointer(Temp)^,Index); + Move (Pointer(Source)^,PByte(Temp)[Index],Length(Source)); + If (LS-Index)>0 then + Move(PByte(Pointer(S))[Index],PByte(temp)[Length(Source)+index],LS-Index); + S:=Temp; +end; + + +Function StringOfChar(c : char;l : longint) : AnsiString; +begin + SetLength(StringOfChar,l); + FillChar(Pointer(StringOfChar)^,Length(StringOfChar),c); +end; + +Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint); + +begin + SetLength(S,Len); + Move (Buf[0],S[1],Len); +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/07/04 07:57:46 pierre + * Change Code to var param in ValAnsiUnsignedInt function + + Revision 1.42 2000/06/11 07:02:30 peter + * UniqueAnsiString -> UniqueString for Delphi compatibility + + Revision 1.41 2000/05/18 17:04:48 peter + * use freemem without size + + Revision 1.40 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.39 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.38 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.37 1999/11/28 11:24:04 sg + * Fixed bug 722: If the start position of AnsiString Copy is less than 1, + it will be set to 1 (same behaviour as in Delphi) + + Revision 1.36 1999/11/25 13:34:57 michael + + Added Ansistring setstring call + + Revision 1.35 1999/11/06 14:35:38 peter + * truncated log + + Revision 1.34 1999/11/02 23:57:54 peter + * fixed copy where size+index could be < 0 + + Revision 1.33 1999/10/27 14:27:49 florian + * StringOfChar fixed, how can be a bug in two lines of code ????? + + Revision 1.32 1999/10/27 14:17:20 florian + + StringOfChar + + Revision 1.31 1999/10/04 20:48:18 peter + * pos function speed up by a factor 40 :) + +} \ No newline at end of file diff --git a/befpc/rtl/inc/except.inc b/befpc/rtl/inc/except.inc new file mode 100644 index 0000000..f08040f --- /dev/null +++ b/befpc/rtl/inc/except.inc @@ -0,0 +1,277 @@ +{ + $Id: except.inc,v 1.1.1.1 2001-07-23 17:17:30 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt + member of the Free Pascal development team + + 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. + + **********************************************************************} + +{**************************************************************************** + Exception support +****************************************************************************} + + +Const + { Type of exception. Currently only one. } + FPC_EXCEPTION = 1; + + { types of frames for the exception address stack } + cExceptionFrame = 1; + cFinalizeFrame = 2; + +Type + PExceptAddr = ^TExceptAddr; + TExceptAddr = record + buf : pjmp_buf; + frametype : Longint; + next : PExceptAddr; + end; + + + TExceptObjectClass = Class of TObject; + +Const + CatchAllExceptions = -1; + +Var + ExceptAddrStack : PExceptAddr; + ExceptObjectStack : PExceptObject; + +Function RaiseList : PExceptObject; + +begin + RaiseList:=ExceptObjectStack; +end; + +Function PushExceptAddr (Ft: Longint): PJmp_buf ; + [Public, Alias : 'FPC_PUSHEXCEPTADDR'];saveregisters; +var + Buf : PJmp_buf; + NewAddr : PExceptAddr; +begin +{$ifdef excdebug} + writeln ('In PushExceptAddr'); +{$endif} + If ExceptAddrstack=Nil then + begin + New(ExceptAddrStack); + ExceptAddrStack^.Next:=Nil; + end + else + begin + New(NewAddr); + NewAddr^.Next:=ExceptAddrStack; + ExceptAddrStack:=NewAddr; + end; + new(buf); + ExceptAddrStack^.Buf:=Buf; + ExceptAddrStack^.FrameType:=ft; + PushExceptAddr:=Buf; +end; + + +Procedure PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); + [Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];saveregisters; +var + Newobj : PExceptObject; +begin +{$ifdef excdebug} + writeln ('In PushExceptObject'); +{$endif} + If ExceptObjectStack=Nil then + begin + New(ExceptObjectStack); + ExceptObjectStack^.Next:=Nil; + end + else + begin + New(NewObj); + NewObj^.Next:=ExceptObjectStack; + ExceptObjectStack:=NewObj; + end; + ExceptObjectStack^.FObject:=Obj; + ExceptObjectStack^.Addr:=AnAddr; + ExceptObjectStack^.Frame:=AFrame; +end; + + +Procedure DoUnHandledException; +begin + If ExceptProc<>Nil then + If ExceptObjectStack<>Nil then + TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr,ExceptObjectStack^.Frame); + RunError(217); +end; + + +Function Raiseexcept (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; +begin +{$ifdef excdebug} + writeln ('In RaiseException'); +{$endif} + Raiseexcept:=nil; + PushExceptObj(Obj,AnAddr,AFrame); + If ExceptAddrStack=Nil then + DoUnhandledException; + longjmp(ExceptAddrStack^.Buf^,FPC_Exception); +end; + + +Procedure PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK']; +var + hp : PExceptAddr; +begin +{$ifdef excdebug} + writeln ('In Popaddrstack'); +{$endif} + If ExceptAddrStack=nil then + begin + writeln ('At end of ExceptionAddresStack'); + halt (255); + end + else + begin + hp:=ExceptAddrStack; + ExceptAddrStack:=ExceptAddrStack^.Next; + dispose(hp^.buf); + dispose(hp); + end; +end; + + +function PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK']; +var + hp : PExceptObject; +begin +{$ifdef excdebug} + writeln ('In PopObjectstack'); +{$endif} + If ExceptObjectStack=nil then + begin + writeln ('At end of ExceptionObjectStack'); + halt (1); + end + else + begin + { we need to return the exception object to dispose it } + PopObjectStack:=ExceptObjectStack^.FObject; + hp:=ExceptObjectStack; + ExceptObjectStack:=ExceptObjectStack^.next; + dispose(hp); + end; +end; + +{ this is for popping exception objects when a second exception is risen } +{ in an except/on } +function PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK']; +var + hp : PExceptObject; +begin +{$ifdef excdebug} + writeln ('In PopObjectstack'); +{$endif} + If not(assigned(ExceptObjectStack)) or + not(assigned(ExceptObjectStack^.next)) then + begin + writeln ('At end of ExceptionObjectStack'); + halt (1); + end + else + begin + { we need to return the exception object to dispose it } + PopSecondObjectStack:=ExceptObjectStack^.next^.FObject; + hp:=ExceptObjectStack^.next; + ExceptObjectStack^.next:=hp^.next; + dispose(hp); + end; +end; + +Procedure ReRaise;[Public, Alias : 'FPC_RERAISE']; +begin +{$ifdef excdebug} + writeln ('In reraise'); +{$endif} + If ExceptAddrStack=Nil then + DoUnHandledException; + longjmp(ExceptAddrStack^.Buf^,FPC_Exception); +end; + + +Function Catches(Objtype : TExceptObjectClass) : TObject;[Public, Alias : 'FPC_CATCHES']; +begin + If ExceptObjectStack=Nil then + begin + Writeln ('Internal error.'); + halt (255); + end; + if Not ((Objtype = TExceptObjectClass(CatchAllExceptions)) or + (ExceptObjectStack^.FObject is ObjType)) then + Catches:=Nil + else + begin + // catch ! + Catches:=ExceptObjectStack^.FObject; + { this can't be done, because there could be a reraise (PFV) + PopObjectStack; + + Also the PopAddrStack shouldn't be done, we do it now + immediatly in the exception handler (FK) + PopAddrStack; } + end; +end; + +Procedure DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION']; +begin + { with free we're on the really save side } + o.Free; +end; + + +Procedure InitExceptions; +{ + Initialize exceptionsupport +} +begin + ExceptObjectstack:=Nil; + ExceptAddrStack:=Nil; +end; +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/06/22 18:05:56 michael + + Modifications for exception support in sysutils. Mainly added + RaiseList function. + + Revision 1.19 2000/05/04 12:25:53 pierre + * Use saveregisters for PushExcept.. + + Revision 1.18 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.17 2000/02/09 22:16:50 florian + + popsecondobjectstack added + + Revision 1.16 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.15 2000/02/06 17:17:57 florian + * popobjectstack is now a function + + Revision 1.14 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.13 1999/07/27 08:14:15 florian + * catch doesn't call popaddrstack anymore, this is done now by the compiler + + Revision 1.12 1999/07/26 12:11:28 florian + * reraise doesn't call popaddrstack anymode +} \ No newline at end of file diff --git a/befpc/rtl/inc/file.inc b/befpc/rtl/inc/file.inc new file mode 100644 index 0000000..91056ad --- /dev/null +++ b/befpc/rtl/inc/file.inc @@ -0,0 +1,422 @@ +{ + $Id: file.inc,v 1.1.1.1 2001-07-23 17:17:30 memson Exp $ + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + 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. + + **********************************************************************} + +{**************************************************************************** + subroutines For UnTyped File handling +****************************************************************************} + +type + UnTypedFile=File; + +Procedure Assign(var f:File;const Name:string); +{ + Assign Name to file f so it can be used with the file routines +} +Begin + FillChar(f,SizeOf(FileRec),0); + FileRec(f).Handle:=UnusedHandle; + FileRec(f).mode:=fmClosed; + Move(Name[1],FileRec(f).Name,Length(Name)); +End; + + +Procedure assign(var f:File;p:pchar); +{ + Assign Name to file f so it can be used with the file routines +} +begin + Assign(f,StrPas(p)); +end; + + +Procedure assign(var f:File;c:char); +{ + Assign Name to file f so it can be used with the file routines +} +begin + Assign(f,string(c)); +end; + + +Procedure Rewrite(var f:File;l:Longint);[IOCheck]; +{ + Create file f with recordsize of l +} +Begin + If InOutRes <> 0 then + exit; + Case FileRec(f).mode Of + fmInOut,fmInput,fmOutput : Close(f); + fmClosed : ; + else + Begin + InOutRes:=102; + exit; + End; + End; + If l=0 Then + InOutRes:=2 + else + Begin + { Reopen with filemode 2, to be Tp compatible (PFV) } + Do_Open(f,PChar(@FileRec(f).Name),$1002); + FileRec(f).RecSize:=l; + End; +End; + + +Procedure Reset(var f:File;l:Longint);[IOCheck]; +{ + Open file f with recordsize of l and filemode +} +Begin + If InOutRes <> 0 then + Exit; + Case FileRec(f).mode Of + fmInOut,fmInput,fmOutput : Close(f); + fmClosed : ; + else + Begin + InOutRes:=102; + exit; + End; + End; + If l=0 Then + InOutRes:=2 + else + Begin + Do_Open(f,PChar(@FileRec(f).Name),Filemode); + FileRec(f).RecSize:=l; + End; +End; + + +Procedure Rewrite(Var f:File);[IOCheck]; +{ + Create file with (default) 128 byte records +} +Begin + If InOutRes <> 0 then + exit; + Rewrite(f,128); +End; + + +Procedure Reset(Var f:File);[IOCheck]; +{ + Open file with (default) 128 byte records +} +Begin + If InOutRes <> 0 then + exit; + Reset(f,128); +End; + + +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint;var Result:Longint);[IOCheck]; +{ + Write Count records from Buf to file f, return written records in result +} +Begin + Result:=0; + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmOutput : + Result:=Do_Write(FileRec(f).Handle,Longint(@Buf),Count*FileRec(f).RecSize) + div FileRec(f).RecSize; + fmInPut: inOutRes := 105; + else InOutRes:=103; + end; +End; + + +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;var Result:Word);[IOCheck]; +{ + Write Count records from Buf to file f, return written records in Result +} +var + l : longint; +Begin + BlockWrite(f,Buf,Count,l); + Result:=l; +End; + + +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;var Result:Integer);[IOCheck]; +{ + Write Count records from Buf to file f, return written records in Result +} +var + l : longint; +Begin + BlockWrite(f,Buf,Count,l); + Result:=l; +End; + + +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint);[IOCheck]; +{ + Write Count records from Buf to file f, if none a Read and Count>0 then + InOutRes is set +} +var + Result : Longint; +Begin + BlockWrite(f,Buf,Count,Result); + If (Result0) Then + InOutRes:=101; +End; + + +Procedure BlockRead(var f:File;var Buf;Count:Longint;var Result:Longint);[IOCheck]; +{ + Read Count records from file f ro Buf, return number of read records in + Result +} +Begin + Result:=0; + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmInput : + Result:=Do_Read(FileRec(f).Handle,Longint(@Buf),count*FileRec(f).RecSize) + div FileRec(f).RecSize; + fmOutput: inOutRes := 104; + else InOutRes:=103; + end; +End; + + +Procedure BlockRead(var f:File;var Buf;count:Word;var Result:Word);[IOCheck]; +{ + Read Count records from file f to Buf, return number of read records in + Result +} +var + l : longint; +Begin + BlockRead(f,Buf,Count,l); + Result:=l; +End; + + +Procedure BlockRead(var f:File;var Buf;count:Word;var Result:Integer);[IOCheck]; +{ + Read Count records from file f to Buf, return number of read records in + Result +} +var + l : longint; +Begin + BlockRead(f,Buf,Count,l); + Result:=l; +End; + + +Procedure BlockRead(Var f:File;Var Buf;Count:Longint);[IOCheck]; +{ + Read Count records from file f to Buf, if none are read and Count>0 then + InOutRes is set +} +var + Result : Longint; +Begin + BlockRead(f,Buf,Count,Result); + If (Result0) Then + InOutRes:=100; +End; + + +Function FilePos(var f:File):Longint;[IOCheck]; +{ + Return current Position In file f in records +} +Begin + FilePos:=0; + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmInput,fmOutput : + FilePos:=Do_FilePos(FileRec(f).Handle) div FileRec(f).RecSize; + else + InOutRes:=103; + end; +End; + + +Function FileSize(var f:File):Longint;[IOCheck]; +{ + Return the size of file f in records +} +Begin + FileSize:=0; + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmInput,fmOutput : + begin + if (FileRec(f).RecSize>0) then + FileSize:=Do_FileSize(FileRec(f).Handle) div FileRec(f).RecSize; + end; + else InOutRes:=103; + end; +End; + + +Function Eof(var f:File):Boolean;[IOCheck]; +{ + Return True if we're at the end of the file f, else False is returned +} +Begin + Eof:=false; + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + {Can't use do_ routines because we need record support} + fmInOut,fmInput,fmOutput : Eof:=(FileSize(f)<=FilePos(f)); + else InOutRes:=103; + end; +End; + + +Procedure Seek(var f:File;Pos:Longint);[IOCheck]; +{ + Goto record Pos in file f +} +Begin + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmInput,fmOutput : + Do_Seek(FileRec(f).Handle,Pos*FileRec(f).RecSize); + else InOutRes:=103; + end; +End; + + +Procedure Truncate(Var f:File);[IOCheck]; +{ + Truncate/Cut file f at the current record Position +} +Begin + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmOutput : + Do_Truncate(FileRec(f).Handle,FilePos(f)*FileRec(f).RecSize); + else InOutRes:=103; + end; +End; + + +Procedure Close(var f:File);[IOCheck]; +{ + Close file f +} +Begin + If InOutRes <> 0 then + exit; + case FileRec(f).Mode of + fmInOut,fmInput,fmOutput : + begin + Do_Close(FileRec(f).Handle); + FileRec(f).mode:=fmClosed; + end + else InOutRes:=103; + end; +End; + + +Procedure Erase(var f : File);[IOCheck]; +Begin + If InOutRes <> 0 then + exit; + If FileRec(f).mode=fmClosed Then + Do_Erase(PChar(@FileRec(f).Name)); +End; + + +Procedure Rename(var f : File;p:pchar);[IOCheck]; +Begin + If InOutRes <> 0 then + exit; + If FileRec(f).mode=fmClosed Then + Begin + Do_Rename(PChar(@FileRec(f).Name),p); + Move(p^,FileRec(f).Name,StrLen(p)+1); + End; +End; + + +Procedure Rename(var f : File;const s : string);[IOCheck]; +var + p : array[0..255] Of Char; +Begin + If InOutRes <> 0 then + exit; + Move(s[1],p,Length(s)); + p[Length(s)]:=#0; + Rename(f,Pchar(@p)); +End; + + +Procedure Rename(var f : File;c : char);[IOCheck]; +var + p : array[0..1] Of Char; +Begin + If InOutRes <> 0 then + exit; + p[0]:=c; + p[1]:=#0; + Rename(f,Pchar(@p)); +End; + +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/03/24 10:26:18 jonas + * changed a lot of "if fm.mode = fmClosed then" to case statements, + because if f is not yet initialized, the mode is invalid and can + contain another value even though the file is closed + + check if a file is open in writeln_end (caused crash if used on + not opened files) + + Revision 1.19 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.18 2000/01/17 20:02:30 peter + * open with mode 2 in rewrite + + Revision 1.17 2000/01/16 22:25:38 peter + * check handle for file closing + + Revision 1.16 2000/01/07 16:41:33 daniel + * copyright 2000 + + Revision 1.15 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.14 1999/10/28 09:52:50 peter + * use filemode for rewrite instead of mode 1 + + Revision 1.13 1999/09/10 15:40:33 peter + * fixed do_open flags to be > $100, becuase filemode can be upto 255 + + Revision 1.12 1999/09/08 16:12:24 peter + * fixed inoutres for diskfull + + Revision 1.11 1999/09/07 15:54:18 hajny + * fixed problem with Close under OS/2 + +} diff --git a/befpc/rtl/inc/filerec.inc b/befpc/rtl/inc/filerec.inc new file mode 100644 index 0000000..19dc5a4 --- /dev/null +++ b/befpc/rtl/inc/filerec.inc @@ -0,0 +1,47 @@ +{ + $Id: filerec.inc,v 1.1.1.1 2001-07-23 17:17:30 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + FileRec record definition + + + 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. + + **********************************************************************} + +{ + This file contains the definition of the filerec record. + It is put separately, so it is available outside the system + unit without sacrificing TP compatibility. +} + +const + filerecnamelength = 255; +type + FileRec = Packed Record + Handle, + Mode, + RecSize : longint; + _private : array[1..32] of byte; + UserData : array[1..16] of byte; + name : array[0..filerecnamelength] of char; + End; + +{ + $Log: not supported by cvs2svn $ + Revision 1.8 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.7 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.6 2000/01/07 16:32:24 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/inc/generic.inc b/befpc/rtl/inc/generic.inc new file mode 100644 index 0000000..93d6869 --- /dev/null +++ b/befpc/rtl/inc/generic.inc @@ -0,0 +1,776 @@ +{ + $Id: generic.inc,v 1.1.1.1 2001-07-23 17:17:32 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Processor independent implementation for the system unit + (adapted for intel i386.inc file) + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{**************************************************************************** + Primitives +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_MOVE} +procedure Move(const source;var dest;count:longint); +type + longintarray = array [0..maxlongint] of longint; + bytearray = array [0..maxlongint] of byte; +var + i,size : longint; +begin + size:=count div sizeof(longint); + if (@dest)<@source) or + (@dest>@source+count) then + begin + for i:=0 to size-1 do + longintarray(dest)[i]:=longintarray(source)[i]; + for i:=size*sizeof(longint) to count-1 do + bytearray(dest)[i]:=bytearray(source)[i]; + end + else + begin + for i:=count-1 downto size*sizeof(longint) do + bytearray(dest)[i]:=bytearray(source)[i]; + for i:=size-1 downto 0 do + longintarray(dest)[i]:=longintarray(source)[i]; + end; +end; +{$endif ndef FPC_SYSTEM_HAS_MOVE} + + +{$ifndef FPC_SYSTEM_HAS_FILLCHAR} +Procedure FillChar(var x;count:longint;value:byte); +type + longintarray = array [0..maxlongint] of longint; + bytearray = array [0..maxlongint] of byte; +var + i,v : longint; +begin + v:=value*256+value; + v:=v*$10000+v; + for i:=0 to (count div 4) -1 do + longintarray(x)[i]:=v; + for i:=(count div 4)*4 to count-1 do + bytearray(x)[i]:=value; +end; +{$endif ndef FPC_SYSTEM_HAS_FILLCHAR} + + +{$ifndef RTLLITE} + +{$ifndef FPC_SYSTEM_HAS_FILLBYTE} +procedure FillByte (var x;count : longint;value : byte ); +begin + FillChar (X,Count,CHR(VALUE)); +end; +{$endif ndef FPC_SYSTEM_HAS_FILLBYTE} + + +{$ifndef FPC_SYSTEM_HAS_FILLWORD} +procedure fillword(var x;count : longint;value : word); +type + longintarray = array [0..maxlongint] of longint; + wordarray = array [0..maxlongint] of word; +var + i,v : longint; +begin + v:=value*$10000+value; + for i:=0 to (count div 2) -1 do + longintarray(x)[i]:=v; + for i:=(count div 2)*2 to count-1 do + wordarray(x)[i]:=value; +end; +{$endif ndef FPC_SYSTEM_HAS_FILLWORD} + + +{$ifndef FPC_SYSTEM_HAS_FILLDWORD} +procedure FillDWord(var x;count : longint;value : DWord); +var + I : longint; +begin + if Count<>0 then + begin + I:=Count; + while I<>0 do + begin + PDWord(@X)[I-1]:=Value; + Dec(I); + end; + end; +end; +{$endif ndef FPC_SYSTEM_HAS_FILLDWORD} + + +{$ifndef FPC_SYSTEM_HAS_INDEXCHAR} +function IndexChar(var buf;len:longint;b:char):longint; +begin + IndexChar:=IndexByte(Buf,Len,byte(B)); +end; +{$endif ndef FPC_SYSTEM_HAS_INDEXCHAR} + + +{$ifndef FPC_SYSTEM_HAS_INDEXBYTE} +function IndexByte(var buf;len:longint;b:byte):longint; +var + I : longint; +begin + I:=0; + while (pbyte(@buf)[I]<>b) and (Ib) and (Ib) and (I0) and (@Buf1<>@Buf2) then + begin + while (pbyte(@Buf1)[I]=pbyte(@Buf2)[I]) and (I0 then + I:=1 + else + if I<0 then + I:=-1; + end; + end; + CompareByte:=I; +end; +{$endif ndef FPC_SYSTEM_HAS_COMPAREBYTE} + + +{$ifndef FPC_SYSTEM_HAS_COMPAREWORD} +function CompareWord(var buf1,buf2;len:longint):longint; +var + I,J : longint; +begin + I:=0; + if (Len<>0) and (@Buf1<>@Buf2) then + begin + while (pword(@Buf1)[I]=pword(@Buf2)[I]) and (I0 then + I:=1 + else + if I<0 then + I:=-1; + end; + end; + CompareWord:=I; +end; +{$endif ndef FPC_SYSTEM_HAS_COMPAREWORD} + + +{$ifndef FPC_SYSTEM_HAS_COMPAREDWORD} +function CompareDWord(var buf1,buf2;len:longint):longint; +var + I,J : longint; +begin + I:=0; + if (Len<>0) and (@Buf1<>@Buf2) then + begin + while (PDWord(@Buf1)[I]=PDWord(@Buf2)[I]) and (I0 then + I:=1 + else + if I<0 then + I:=-1; + end; + end; + CompareDWord:=I; +end; +{$endif ndef FPC_SYSTEM_HAS_COMPAREDWORD} + + +{$ifndef FPC_SYSTEM_HAS_MOVECHAR0} +procedure MoveChar0(var buf1,buf2;len:longint); +var + I : longint; +begin + if Len<> 0 then + begin + I:=IndexByte(Buf1,Len,0); + if I<>0 then + Move(Buf1,Buf2,I); + end; +end; +{$endif ndef FPC_SYSTEM_HAS_MOVECHAR0} + + +{$ifndef FPC_SYSTEM_HAS_INDEXCHAR0} +function IndexChar0(var buf;len:longint;b:Char):longint; +var + I : longint; +begin + if Len<>0 then + begin + I:=IndexByte(Buf,Len,0); + IndexChar0:=IndexByte(Buf,I,0); + end + else + IndexChar0:=0; +end; +{$endif ndef FPC_SYSTEM_HAS_INDEXCHAR0} + + +{$ifndef FPC_SYSTEM_HAS_COMPARECHAR0} +function CompareChar0(var buf1,buf2;len:longint):longint; +var + I,J,K,bytesTodo : longint; +begin + K:=0; + if Len<>0 then + begin + I:=IndexByte(Buf1,Len,0); + J:=IndexByte(Buf2,Len,0); + if (I<>0) and (J<>0) then + begin + bytesTodo:=I; + if J0) then + RunError(210); + objectsize:=pvmt(vmt)^.size; + { reset vmt to nil for protection } + ppointer(_self+vmt_pos)^:=nil; + freemem(_self,objectsize); + _self:=nil; +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR} + + +{$ifndef FPC_SYSTEM_HAS_FPC_NEW_CLASS} +{$error No pascal version of Int_new_class} +(* procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS']; +asm + { to be sure in the future, we save also edit } + pushl %edi + { create class ? } + movl 8(%ebp),%edi + orl %edi,%edi + jz .LNEW_CLASS1 + { save registers !! } + pushl %ebx + pushl %ecx + pushl %edx + { esi contains the vmt } + pushl %esi + { call newinstance (class method!) } + call *16(%esi) + popl %edx + popl %ecx + popl %ebx + { newinstance returns a pointer to the new created } + { instance in eax } + { load esi and insert self } + movl %eax,%esi +.LNEW_CLASS1: + movl %esi,8(%ebp) + orl %eax,%eax + popl %edi +end; *) + +{$endif ndef FPC_SYSTEM_HAS_FPC_NEW_CLASS} + +{$ifndef FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS} + +{$error No pascal version of Int_dispose_class} +(* procedure int_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS']; +asm + { to be sure in the future, we save also edit } + pushl %edi + { destroy class ? } + movl 12(%ebp),%edi + orl %edi,%edi + jz .LDISPOSE_CLASS1 + { no inherited call } + movl (%esi),%edi + { save registers !! } + pushl %eax + pushl %ebx + pushl %ecx + pushl %edx + { push self } + pushl %esi + { call freeinstance } + call *20(%edi) + popl %edx + popl %ecx + popl %ebx + popl %eax +.LDISPOSE_CLASS1: + popl %edi +end; *) + +{$endif ndef FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS} + +{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT} + +procedure int_check_object(vmt : pointer);[public,alias:'FPC_CHECK_OBJECT']; + type + pvmt = ^tvmt; + tvmt = record + size,msize : longint; + parent : pointer; + end; +begin + if (vmt=nil) or + (pvmt(vmt)^.size=0) or + (pvmt(vmt)^.size+pvmt(vmt)^.msize<>0) then + RunError(210); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT} + +{ checks for a correct vmt pointer } +{ deeper check to see if the current object is } +{ really related to the true } + +{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT} + +procedure int_check_object_ext(vmt, expvmt : pointer);[public,alias:'FPC_CHECK_OBJECT_EXT']; + type + pvmt = ^tvmt; + tvmt = record + size,msize : longint; + parent : pointer; + end; +begin + if (vmt=nil) or + (pvmt(vmt)^.size=0) or + (pvmt(vmt)^.size+pvmt(vmt)^.msize<>0) then + RunError(210); + while assigned(vmt) do + if vmt=expvmt then + exit + else + vmt:=pvmt(vmt)^.parent; + RunError(220); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT} + + +{**************************************************************************** + String +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} + +procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; +var + slen : byte; +begin + if dstr=nil then + exit; + if sstr=nil then + begin + if dstr<>nil then + pstring(dstr)^[0]:=#0; + exit; + end; + slen:=length(pstring(sstr)^); + if slen255 then + s1l:=255-s2l; + move(@(pstring(s1)^[1]),@(pstring(s2)^[s2l+1]),s1l); + pstring(s2)^[0]:=chr(s1l+s2l); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} + +{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} + +function int_strcmp(dstr,sstr:pointer) : longint;[public,alias:'FPC_SHORTSTR_COMPARE']; +var + s1,s2,max,i : byte; + d : longint; +begin + s1:=length(pstring(dstr)^); + s2:=length(pstring(sstr)^); + if s10 then + exit(1) + else if d<0 then + exit(-1); + end; + if s1>s2 then + exit(1) + else if s1255 then + l:=255; + if l>0 then + move(p^,@(strpas[1]),l); + strpas[0]:=chr(l); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} + +{$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} + +function strchararray(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; +begin + if l>=256 then + l:=255 + else if l<0 then + l:=0; + move(p^,@(strchararray[1]),l); + strchararray[0]:=chr(l); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} + +{$ifndef FPC_SYSTEM_HAS_STRLEN} + +function strlen(p:pchar):longint; +var i : longint; +begin + i:=0; + while p[i]<>#0 do inc(i); + exit(i); +end; + +{$endif ndef FPC_SYSTEM_HAS_STRLEN} + +{**************************************************************************** + Caller/StackFrame Helpers +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_GET_FRAME} +{$error Get_frame must be defined for each processor } +{$endif ndef FPC_SYSTEM_HAS_GET_FRAME} + +{$ifndef FPC_SYSTEM_HAS_GET_CALLER_ADDR} +{$error Get_caller_addr must be defined for each processor } +{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_ADDR} + +{$ifndef FPC_SYSTEM_HAS_GET_CALLER_FRAME} +{$error Get_caller_frame must be defined for each processor } +{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_FRAME} + +{**************************************************************************** + Math +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_ABS_LONGINT} +function abs(l:longint):longint;[internconst:in_const_abs]; +begin + if l<0 then + abs:=-l + else + abs:=l; +end; + +{$endif ndef FPC_SYSTEM_HAS_ABS_LONGINT} + +{$ifndef FPC_SYSTEM_HAS_ODD_LONGINT} + +function odd(l:longint):boolean;[internconst:in_const_odd]; +begin + odd:=((l and 1)<>0); +end; + +{$endif ndef FPC_SYSTEM_HAS_ODD_LONGINT} + +{$ifndef FPC_SYSTEM_HAS_SQR_LONGINT} + +function sqr(l:longint):longint;[internconst:in_const_sqr]; +begin + sqr:=l*l; +end; + +{$endif ndef FPC_SYSTEM_HAS_SQR_LONGINT} + + +{$ifndef FPC_SYSTEM_HAS_SPTR} +{$error Sptr must be defined for each processor } +{$endif ndef FPC_SYSTEM_HAS_SPTR} + +{**************************************************************************** + Str() +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_INT_STR_LONGINT} + +procedure int_str(l : longint;var s : string); +var + sign : boolean; +begin + { Workaround: } + if l=$80000000 then + begin + s:='-2147483648'; + exit; + end; + if l<0 then + begin + sign:=true; + l:=-l; + end + else + sign:=false; + s:=''; + while l>0 do + begin + s:=char(ord('0')+(l mod 10))+s; + l:=l div 10; + end; + if sign then + s:='-'+s; +end; + +{$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGINT} + +{$ifndef FPC_SYSTEM_HAS_INT_STR_CARDINAL} + +procedure int_str(l : cardinal;var s : string); +begin + s:=''; + while l>0 do + begin + s:=char(ord('0')+(l mod 10))+s; + l:=l div 10; + end; + if sign then + s:='-'+s; +end; + +{$endif ndef FPC_SYSTEM_HAS_INT_STR_CARDINAL} + +{**************************************************************************** + Bounds Check +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_FPC_BOUNDCHECK} + +procedure int_boundcheck(l : longint; range : pointer);[public,alias: 'FPC_BOUNDCHECK']; + type + prange = ^trange; + trange = record + min,max : longint; + end; +begin + if (l < prange(range)^.min) or + (l > prange(range)^.max) then + HandleError(201); +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_BOUNDCHECK} + + +{$ifndef HASSAVEREGISTERS} + +{**************************************************************************** + IoCheck +****************************************************************************} + +{$ifndef FPC_SYSTEM_HAS_FPC_IOCHECK} + +procedure int_iocheck(addr : longint);[public,alias:'FPC_IOCHECK']; +var + l : longint; +begin + if InOutRes<>0 then + begin + l:=InOutRes; + InOutRes:=0; + HandleErrorFrame(l,get_frame); + end; +end; + +{$endif ndef FPC_SYSTEM_HAS_FPC_IOCHECK} + +{$endif} + +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/07/07 18:23:41 marco + * Changed move (var source;var dest) to move (const source;var dest) + + Revision 1.8 2000/03/10 13:45:31 pierre + * small fixes + + Revision 1.7 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.6 2000/01/10 09:54:30 peter + * primitives added + + Revision 1.5 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.4 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.3 1999/12/21 11:12:16 pierre + * some assembler functions translated to pascal + WARNING these are not yet TESTED !!! + + FPC_CHARARRAY_TO_SHORTSTRING added + +} diff --git a/befpc/rtl/inc/getopts.pp b/befpc/rtl/inc/getopts.pp new file mode 100644 index 0000000..c622445 --- /dev/null +++ b/befpc/rtl/inc/getopts.pp @@ -0,0 +1,522 @@ +{ + $Id: getopts.pp,v 1.1.1.1 2001-07-23 17:17:32 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team. + + Getopt implementation for Free Pascal, modeled after GNU getopt + + 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 getopts; +Interface + +Const + No_Argument = 0; + Required_Argument = 1; + Optional_Argument = 2; + EndOfOptions = #255; + +Type + POption = ^TOption; + TOption = Record + Name : String; + Has_arg : Integer; + Flag : PChar; + Value : Char; + end; + + Orderings = (require_order,permute,return_in_order); + +Const + OptSpecifier : set of char=['-']; + +Var + OptArg : String; + OptInd : Longint; + OptErr : Boolean; + OptOpt : Char; + +Function GetOpt (ShortOpts : String) : char; +Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Longint) : char; + + +Implementation + +{$ifdef TP} +uses + strings; +{$endif} + + +{*************************************************************************** + Create an ArgV +***************************************************************************} + +{$ifdef TP} + +function GetCommandLine:pchar; +begin + GetCommandLine:=ptr(prefixseg,$81); +end; + + +function GetCommandFile:pchar; +var + p : pchar; +begin + p:=ptr(memw[prefixseg:$2c],0); + repeat + while p^<>#0 do + inc(longint(p)); + { next char also #0 ? } + inc(longint(p)); + if p^=#0 then + begin + inc(longint(p),3); + GetCommandFile:=p; + exit; + end; + until false; +end; + + +type + ppchar = ^pchar; + apchar = array[0..127] of pchar; +var + argc : longint; + argv : apchar; + +procedure setup_arguments; +var + arglen, + count : longint; + argstart, + cmdline : pchar; + quote : set of char; + argsbuf : array[0..127] of pchar; +begin +{ create argv[0] which is the started filename } + argstart:=GetCommandFile; + arglen:=strlen(argstart)+1; + getmem(argsbuf[0],arglen); + move(argstart^,argsbuf[0]^,arglen); +{ create commandline } + cmdline:=GetCommandLine; + count:=1; + repeat + { skip leading spaces } + while cmdline^ in [' ',#9,#13] do + inc(longint(cmdline)); + case cmdline^ of + #0 : break; + '"' : begin + quote:=['"']; + inc(longint(cmdline)); + end; + '''' : begin + quote:=['''']; + inc(longint(cmdline)); + end; + else + quote:=[' ',#9,#13]; + end; + { scan until the end of the argument } + argstart:=cmdline; + while (cmdline^<>#0) and not(cmdline^ in quote) do + inc(longint(cmdline)); + { reserve some memory } + arglen:=cmdline-argstart; + getmem(argsbuf[count],arglen+1); + move(argstart^,argsbuf[count]^,arglen); + argsbuf[count][arglen]:=#0; + { skip quote } + if cmdline^ in quote then + inc(longint(cmdline)); + inc(count); + until false; +{ create argc } + argc:=count; +{ create an nil entry } + argsbuf[count]:=nil; + inc(count); +{ create the argv } + move(argsbuf,argv,count shl 2); +end; + +{$endif TP} + +{*************************************************************************** + Real Getopts +***************************************************************************} + +Var + NextChar, + Nrargs, + first_nonopt, + last_nonopt : Longint; + Ordering : Orderings; + +Procedure Exchange; +var + bottom, + middle, + top,i,len : longint; + temp : pchar; +begin + bottom:=first_nonopt; + middle:=last_nonopt; + top:=optind; + while (top>middle) and (middle>bottom) do + begin + if (top-middle>middle-bottom) then + begin + len:=middle-bottom; + for i:=1 to len-1 do + begin + temp:=argv[bottom+i]; + argv[bottom+i]:=argv[top-(middle-bottom)+i]; + argv[top-(middle-bottom)+i]:=temp; + end; + top:=top-len; + end + else + begin + len:=top-middle; + for i:=0 to len-1 do + begin + temp:=argv[bottom+i]; + argv[bottom+i]:=argv[middle+i]; + argv[middle+i]:=temp; + end; + bottom:=bottom+len; + end; + end; + first_nonopt:=first_nonopt + optind-last_nonopt; + last_nonopt:=optind; +end; { exchange } + + +procedure getopt_init (var opts : string); +begin +{ Initialize some defaults. } + Optarg:=''; + Optind:=1; + First_nonopt:=1; + Last_nonopt:=1; + OptOpt:='?'; + Nextchar:=0; + case opts[1] of + '-' : begin + ordering:=return_in_order; + delete(opts,1,1); + end; + '+' : begin + ordering:=require_order; + delete(opts,1,1); + end; + else + ordering:=permute; + end; +end; + + + +Function Internal_getopt (Var Optstring : string;LongOpts : POption; + LongInd : pointer;Long_only : boolean ) : char; +type + pinteger=^integer; +var + temp,endopt, + option_index : byte; + indfound : integer; + currentarg, + optname : string; + p,pfound : POption; + exact,ambig : boolean; + c : char; +begin + optarg:=''; + if optind=0 then + getopt_init(optstring); +{ Check if We need the next argument. } + if (optindlast_nonopt) and (last_nonopt<>optind) then + exchange + else + if last_nonopt<>optind then + first_nonopt:=optind; + while (optindnrargs) and (currentarg='--') then + begin + inc(optind); + if (first_nonopt<>last_nonopt) and (last_nonopt<>optind) then + exchange + else + if first_nonopt=last_nonopt then + first_nonopt:=optind; + last_nonopt:=nrargs; + optind:=nrargs; + end; + { Are we at the end of all arguments ? } + if optind>=nrargs then + begin + if first_nonopt<>last_nonopt then + optind:=first_nonopt; + Internal_getopt:=EndOfOptions; + exit; + end; + if optindnil) and ((currentarg[2]='-') and + (currentArg[1]='-')) then + inc(nextchar); + { So, now nextchar points at the first character of an option } + end; +{ Check if we have a long option } + if longopts<>nil then + if length(currentarg)>1 then + if ((currentarg[2]='-') and (currentArg[1]='-')) + or + ((not long_only) and (pos(currentarg[2],optstring)<>0)) then + begin + { Get option name } + endopt:=pos('=',currentarg); + if endopt=0 then + endopt:=length(currentarg)+1; + optname:=copy(currentarg,nextchar,endopt-nextchar); + { Match partial or full } + p:=longopts; + pfound:=nil; + exact:=false; + ambig:=false; + option_index:=0; + indfound:=0; + while (p^.name<>'') and (not exact) do + begin + if pos(optname,p^.name)<>0 then + begin + if length(optname)=length(p^.name) then + begin + exact:=true; + pfound:=p; + indfound:=option_index; + end + else + if pfound=nil then + begin + indfound:=option_index; + pfound:=p + end + else + ambig:=true; + end; + inc(longint(p),sizeof(toption)); + inc(option_index); + end; + if ambig and not exact then + begin + if opterr then + writeln(argv[0],': option "',optname,'" is ambiguous'); + nextchar:=0; + inc(optind); + Internal_getopt:='?'; + end; + if pfound<>nil then + begin + inc(optind); + if endopt<=length(currentarg) then + begin + if pfound^.has_arg>0 then + optarg:=copy(currentarg,endopt+1,length(currentarg)-endopt) + else + begin + if opterr then + if currentarg[2]='-' then + writeln(argv[0],': option "--',pfound^.name,'" doesn''t allow an argument') + else + writeln(argv[0],': option "',currentarg[1],pfound^.name,'" doesn''t allow an argument'); + nextchar:=0; + internal_getopt:='?'; + exit; + end; + end + else { argument in next paramstr... } + begin + if pfound^.has_arg=1 then + begin + if optindnil then + pinteger(longind)^:=indfound+1; + if pfound^.flag<>nil then + begin + pfound^.flag^:=pfound^.value; + internal_getopt:=#0; + exit; + end; + internal_getopt:=pfound^.value; + exit; + end; { pfound<>nil } + { We didn't find it as an option } + if (not long_only) or + ((currentarg[2]='-') or (pos(CurrentArg[nextchar],optstring)=0)) then + begin + if opterr then + if currentarg[2]='-' then + writeln(argv[0],' unrecognized option "--',optname,'"') + else + writeln(argv[0],' unrecognized option "',currentarg[1],optname,'"'); + nextchar:=0; + inc(optind); + Internal_getopt:='?'; + exit; + end; + end; { Of long options.} +{ We check for a short option. } + temp:=pos(currentarg[nextchar],optstring); + c:=currentarg[nextchar]; + inc(nextchar); + if nextchar>length(currentarg) then + begin + inc(optind); + nextchar:=0; + end; + if (temp=0) or (c=':') then + begin + if opterr then + writeln(argv[0],': illegal option -- ',c); + optopt:=c; + internal_getopt:='?'; + exit; + end; + Internal_getopt:=optstring[temp]; + if optstring[temp+1]=':' then + if currentarg[temp+2]=':' then + begin { optional argument } + optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); + nextchar:=0; + end + else + begin { required argument } + if nextchar>0 then + begin + optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); + inc(optind); + end + else + if (optind=nrargs) then + begin + if opterr then + writeln (argv[0],': option requires an argument -- ',optstring[temp]); + optopt:=optstring[temp]; + if optstring[1]=':' then + Internal_getopt:=':' + else + Internal_Getopt:='?'; + end + else + begin + optarg:=strpas(argv[optind]); + inc(optind) + end; + nextchar:=0; + end; { End of required argument} +end; { End of internal getopt...} + + +Function GetOpt(ShortOpts : String) : char; +begin + getopt:=internal_getopt(shortopts,nil,nil,false); +end; + + +Function GetLongOpts(ShortOpts : String;LongOpts : POption;var Longind : Longint) : char; +begin + getlongopts:=internal_getopt(shortopts,longopts,@longind,true); +end; + + +begin +{ create argv if running under TP } +{$ifdef TP} + setup_arguments; +{$endif} +{ Needed to detect startup } + Opterr:=true; + Optind:=0; + nrargs:=argc; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.8 2000/02/09 16:59:29 peter + * truncated log + + Revision 1.7 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.6 2000/01/07 16:32:24 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/inc/heap.inc b/befpc/rtl/inc/heap.inc new file mode 100644 index 0000000..39deaba --- /dev/null +++ b/befpc/rtl/inc/heap.inc @@ -0,0 +1,1103 @@ +{ + $Id: heap.inc,v 1.1.1.1 2001-07-23 17:17:33 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + functions for heap management in the data segment + + 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. + + **********************************************************************} + +{****************************************************************************} + +{ Reuse bigger blocks instead of allocating a new block at freelist/heapptr. + the tried bigger blocks are always multiple sizes of the current block } +{$define REUSEBIGGER} + +{ Allocate small blocks at heapptr instead of walking the freelist } +{$define SMALLATHEAPPTR} + +{ Try to find the best matching block in general freelist } +{$define BESTMATCH} + +{ Concat free blocks when placing big blocks in the mainlist } +{$define CONCATFREE} + +{ DEBUG: Dump info when the heap needs to grow } +{ define DUMPGROW} + +{$ifdef SYSTEMDEBUG} +{$define TestFreeLists} +{ define withbug this leads to crashes below } +{$endif SYSTEMDEBUG} + + +const + blocksize = 16; { at least size of freerecord } + blockshr = 4; { shr value for blocksize=2^blockshr} + maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord } + maxblock = maxblocksize div blocksize; + maxreusebigger = 8; { max reuse bigger tries } + + usedmask = 1; { flag if the block is used or not } + beforeheapendmask = 2; { flag if the block is just before a heapptr } + sizemask = not(blocksize-1); + +{****************************************************************************} + +{$ifdef DUMPGROW} + {$define DUMPBLOCKS} +{$endif} + +{ Memory manager } +const + MemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + FreeMemSize: SysFreeMemSize; + AllocMem: SysAllocMem; + ReAllocMem: SysReAllocMem; + MemSize: SysMemSize; + MemAvail: SysMemAvail; + MaxAvail: SysMaxAvail; + HeapSize: SysHeapSize; + ); + +type + ppfreerecord = ^pfreerecord; + pfreerecord = ^tfreerecord; + tfreerecord = record + size : longint; + next, + prev : pfreerecord; + end; { 12 bytes } + + pheaprecord = ^theaprecord; + theaprecord = record + { this should overlap with tfreerecord } + size : longint; + end; { 4 bytes } + + tfreelists = array[0..maxblock] of pfreerecord; +{$ifdef SYSTEMDEBUG} + tfreecount = array[0..maxblock] of dword; +{$endif SYSTEMDEBUG} + pfreelists = ^tfreelists; + +var + internal_memavail : longint; + internal_heapsize : longint; + freelists : tfreelists; +{$ifdef SYSTEMDEBUG} + freecount : tfreecount; +{$endif SYSTEMDEBUG} +{$ifdef TestFreeLists} +{ this can be turned on by debugger } +const + test_each : boolean = false; +{$endif TestFreeLists} + +{***************************************************************************** + Memory Manager +*****************************************************************************} + +procedure GetMemoryManager(var MemMgr:TMemoryManager); +begin + MemMgr:=MemoryManager; +end; + + +procedure SetMemoryManager(const MemMgr:TMemoryManager); +begin + MemoryManager:=MemMgr; +end; + + +function IsMemoryManagerSet:Boolean; +begin + IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or + (MemoryManager.FreeMem<>@SysFreeMem); +end; + + +procedure GetMem(Var p:pointer;Size:Longint);{$ifndef NEWMM}[public,alias:'FPC_GETMEM'];{$endif} +begin + p:=MemoryManager.GetMem(Size); +end; + + +procedure FreeMem(Var p:pointer;Size:Longint);{$ifndef NEWMM}[public,alias:'FPC_FREEMEM'];{$endif} +begin + MemoryManager.FreeMemSize(p,Size); + p:=nil; +end; + + +function MaxAvail:Longint; +begin + MaxAvail:=MemoryManager.MaxAvail(); +end; + + +function MemAvail:Longint; +begin + MemAvail:=MemoryManager.MemAvail(); +end; + + +{ FPC Additions } +function HeapSize:Longint; +begin + HeapSize:=MemoryManager.HeapSize(); +end; + + +function MemSize(p:pointer):Longint; +begin + MemSize:=MemoryManager.MemSize(p); +end; + + +{ Delphi style } +function FreeMem(var p:pointer):Longint; +begin + Freemem:=MemoryManager.FreeMem(p); +end; + + +function GetMem(size:longint):pointer; +begin + GetMem:=MemoryManager.GetMem(Size); +end; + + +function AllocMem(Size:Longint):pointer; +begin + AllocMem:=MemoryManager.AllocMem(size); +end; + + +function ReAllocMem(var p:pointer;Size:Longint):pointer; +begin + ReAllocMem:=MemoryManager.ReAllocMem(p,size); +end; + + +{ Needed for calls from Assembler } +procedure AsmGetMem(var p:pointer;size:longint);{$ifdef NEWMM}[public,alias:'FPC_GETMEM'];{$endif} +begin + p:=MemoryManager.GetMem(size); +end; + + +procedure AsmFreeMem(var p:pointer);{$ifdef NEWMM}[public,alias:'FPC_FREEMEM'];{$endif} +begin + if p <> nil then + begin + MemoryManager.FreeMem(p); + p:=nil; + end; +end; + + +{***************************************************************************** + Heapsize,Memavail,MaxAvail +*****************************************************************************} + +function SysHeapsize : longint; +begin + Sysheapsize:=internal_heapsize; +end; + + +function SysMemavail : longint; +begin + Sysmemavail:=internal_memavail; +end; + + +function SysMaxavail : longint; +var + hp : pfreerecord; +begin + Sysmaxavail:=heapend-heapptr; + hp:=freelists[0]; + while assigned(hp) do + begin + if hp^.size>Sysmaxavail then + Sysmaxavail:=hp^.size; + hp:=hp^.next; + end; +end; + + +{$ifdef DUMPBLOCKS} +procedure DumpBlocks; +var + s,i,j : longint; + hp : pfreerecord; +begin + for i:=1 to maxblock do + begin + hp:=freelists[i]; + j:=0; + while assigned(hp) do + begin + inc(j); + hp:=hp^.next; + end; + writeln('Block ',i*blocksize,': ',j); + end; +{ freelist 0 } + hp:=freelists[0]; + j:=0; + s:=0; + while assigned(hp) do + begin + inc(j); + if hp^.size>s then + s:=hp^.size; + hp:=hp^.next; + end; + writeln('Main: ',j,' maxsize: ',s); +end; +{$endif} + +{$ifdef TestFreeLists} + procedure TestFreeLists; +var + i,j : longint; + hp : pfreerecord; +begin + for i:=0 to maxblock do + begin + j:=0; + hp:=freelists[i]; + while assigned(hp) do + begin + inc(j); + if (i>0) and ((hp^.size and sizemask) <> i * blocksize) then + RunError(204); + hp:=hp^.next; + end; + if j<>freecount[i] then + RunError(204); + end; +end; +{$endif TestFreeLists} + +{***************************************************************************** + SysGetMem +*****************************************************************************} + +function SysGetMem(size : longint):pointer; +type + heaperrorproc=function(size:longint):integer; +var + proc : heaperrorproc; + pcurr : pfreerecord; + again : boolean; + s,s1,i, + sizeleft : longint; +{$ifdef BESTMATCH} + pbest : pfreerecord; +{$endif} +begin +{ Something to allocate ? } + if size<=0 then + begin + { give an error for < 0 } + if size<0 then + HandleError(204); + { we always need to allocate something, using heapend is not possible, + because heappend can be changed by growheap (PFV) } + size:=1; + end; +{ calc to multiply of 16 after adding the needed 8 bytes heaprecord } + size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1)); + dec(internal_memavail,size); +{ try to find a block in one of the freelists per size } + s:=size shr blockshr; + if s<=maxblock then + begin + pcurr:=freelists[s]; + { correct size match ? } + if assigned(pcurr) then + begin + { create the block we should return } + sysgetmem:=pointer(pcurr)+sizeof(theaprecord); + { fix size } + pcurr^.size:=pcurr^.size or usedmask; + { update freelist } + freelists[s]:=pcurr^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} + if assigned(freelists[s]) then + freelists[s]^.prev:=nil; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; +{$ifdef SMALLATHEAPPTR} + if heapend-heapptr>=size then + begin + sysgetmem:=heapptr; + { set end flag if we do not have enough room to add + another tfreerecord behind } + if (heapptr+size+sizeof(tfreerecord)>=heapend) then + pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask) + else + pheaprecord(sysgetmem)^.size:=size or usedmask; + inc(sysgetmem,sizeof(theaprecord)); + inc(heapptr,size); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; +{$endif} +{$ifdef REUSEBIGGER} + { try a bigger block } + s1:=s+s; + i:=0; + while (s1<=maxblock) and (isize) then + begin + if (not assigned(pbest)) or + (pcurr^.size=size then + break; +{$endif} + pcurr:=pcurr^.next; + end; +{$ifdef BESTMATCH} + if not assigned(pcurr) then + pcurr:=pbest; +{$endif} + end; + { have we found a block, then get it and free up the other left part, + if no blocks are found then allocated at the heapptr or grow the heap } + if assigned(pcurr) then + begin + { get pointer of the block we should return } + sysgetmem:=pointer(pcurr); + { remove the current block from the freelist } + if assigned(pcurr^.next) then + pcurr^.next^.prev:=pcurr^.prev; + if assigned(pcurr^.prev) then + pcurr^.prev^.next:=pcurr^.next + else + freelists[s]:=pcurr^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} + { create the left over freelist block, if at least 16 bytes are free } + sizeleft:=pcurr^.size-size; + if sizeleft>=sizeof(tfreerecord) then + begin + pcurr:=pfreerecord(pointer(pcurr)+size); + { inherit the beforeheapendmask } + pcurr^.size:=sizeleft or (pheaprecord(sysgetmem)^.size and beforeheapendmask); + { insert the block in the freelist } + pcurr^.prev:=nil; + s1:=sizeleft shr blockshr; + if s1>maxblock then + s1:=0; + pcurr^.next:=freelists[s1]; + if assigned(freelists[s1]) then + freelists[s1]^.prev:=pcurr; + freelists[s1]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s1]); +{$endif SYSTEMDEBUG} + { create the block we need to return } + pheaprecord(sysgetmem)^.size:=size or usedmask; + end + else + begin + { create the block we need to return } + pheaprecord(sysgetmem)^.size:=size or usedmask or (pheaprecord(sysgetmem)^.size and beforeheapendmask); + end; + + inc(sysgetmem,sizeof(theaprecord)); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; + { Lastly, the top of the heap is checked, to see if there is } + { still memory available. } + repeat + again:=false; + if heapend-heapptr>=size then + begin + sysgetmem:=heapptr; + if (heapptr+size+sizeof(tfreerecord)>=heapend) then + pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask) + else + pheaprecord(sysgetmem)^.size:=size or usedmask; + inc(sysgetmem,sizeof(theaprecord)); + inc(heapptr,size); +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; + { Call the heaperror proc } + if assigned(heaperror) then + begin + proc:=heaperrorproc(heaperror); + case proc(size) of + 0 : HandleError(203); + 1 : sysgetmem:=nil; + 2 : again:=true; + end; + end + else + HandleError(203); + until not again; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} +end; + + +{$ifdef CONCATFREE} +{***************************************************************************** + Try concat freerecords +*****************************************************************************} + +procedure TryConcatFreeRecord(pcurr:pfreerecord); +var + hp : pfreerecord; + pcurrsize,s1 : longint; +begin + pcurrsize:=pcurr^.size and sizemask; + hp:=pcurr; + repeat + { block used or before a heapend ? } + if (hp^.size and beforeheapendmask)<>0 then + begin + { Peter, why can't we add this one if free ?? } + pcurr^.size:=pcurrsize or beforeheapendmask; + pcurr^.next:=freelists[0]; + if assigned(pcurr^.next) then + pcurr^.next^.prev:=pcurr; + freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} + break; + end; + { get next block } + hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask)); + { when we're at heapptr then we can stop and set heapptr to pcurr } + if (hp=heapptr) then + begin + heapptr:=pcurr; + break; + end; + { block is used? then we stop and add the block to the freelist } + if (hp^.size and usedmask)<>0 then + begin + pcurr^.size:=pcurrsize; + pcurr^.next:=freelists[0]; + if assigned(pcurr^.next) then + pcurr^.next^.prev:=pcurr; + freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} + break; + end; + { remove block from freelist and increase the size } + s1:=hp^.size and sizemask; + inc(pcurrsize,s1); + s1:=s1 shr blockshr; + if s1>maxblock then + s1:=0; + if assigned(hp^.next) then + hp^.next^.prev:=hp^.prev; + if assigned(hp^.prev) then + hp^.prev^.next:=hp^.next + else + freelists[s1]:=hp^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s1]); +{$endif SYSTEMDEBUG} + until false; +end; +{$endif CONCATFREE} + +{***************************************************************************** + SysFreeMem +*****************************************************************************} + +Function SysFreeMem(var p : pointer):Longint; +var + pcurrsize,s : longint; + pcurr : pfreerecord; +begin + if p=nil then + HandleError(204); +{ fix p to point to the heaprecord } + pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord)); + pcurrsize:=pcurr^.size and sizemask; + inc(internal_memavail,pcurrsize); +{ insert the block in it's freelist } + pcurr^.size:=pcurr^.size and (not usedmask); + pcurr^.prev:=nil; + s:=pcurrsize shr blockshr; + if s>maxblock then +{$ifdef CONCATFREE} + TryConcatFreeRecord(pcurr) + else +{$else} + s:=0; +{$endif} + begin + pcurr^.next:=freelists[s]; + if assigned(pcurr^.next) then + pcurr^.next^.prev:=pcurr; + freelists[s]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} + end; + p:=nil; + SysFreeMem:=pcurrsize; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} +end; + + +{***************************************************************************** + SysFreeMemSize +*****************************************************************************} + +Function SysFreeMemSize(var p : pointer;size : longint):longint; +var + pcurrsize,s : longint; + pcurr : pfreerecord; +begin + SysFreeMemSize:=0; + if size<=0 then + begin + if size<0 then + HandleError(204); + p:=nil; + exit; + end; + if p=nil then + HandleError(204); +{ fix p to point to the heaprecord } + pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord)); + pcurrsize:=pcurr^.size and sizemask; + inc(internal_memavail,pcurrsize); +{ size check } + size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1)); + if size<>pcurrsize then + HandleError(204); +{ insert the block in it's freelist } + pcurr^.size:=pcurr^.size and (not usedmask); + pcurr^.prev:=nil; +{ set the return values } + s:=pcurrsize shr blockshr; + if s>maxblock then +{$ifdef CONCATFREE} + TryConcatFreeRecord(pcurr) + else +{$else} + s:=0; +{$endif} + begin + pcurr^.next:=freelists[s]; + if assigned(pcurr^.next) then + pcurr^.next^.prev:=pcurr; + freelists[s]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} + end; + p:=nil; + SysFreeMemSize:=pcurrsize; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} +end; + + +{***************************************************************************** + SysMemSize +*****************************************************************************} + +function SysMemSize(p:pointer):longint; +begin + SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord); +end; + + +{***************************************************************************** + SysAllocMem +*****************************************************************************} + +function SysAllocMem(size : longint):pointer; +begin + sysallocmem:=MemoryManager.GetMem(size); + if sysallocmem<>nil then + FillChar(sysallocmem^,size,0); +end; + + +{***************************************************************************** + SysResizeMem +*****************************************************************************} + +function SysTryResizeMem(var p:pointer;size : longint):boolean; +var + oldsize, + currsize, + foundsize, + sizeleft, + s : longint; + wasbeforeheapend : boolean; + hp, + pnew, + pcurr : pfreerecord; +begin +{ fix needed size } + size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1)); +{ fix p to point to the heaprecord } + pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord)); + currsize:=pcurr^.size and sizemask; + oldsize:=currsize; + wasbeforeheapend:=(pcurr^.size and beforeheapendmask)<>0; +{ is the allocated block still correct? } + if currsize=size then + begin + SysTryResizeMem:=true; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; +{ do we need to allocate more memory ? } + if size>currsize then + begin + { the size is bigger than the previous size, we need to allocated more mem. + We first check if the blocks after the current block are free. If not we + simply call getmem/freemem to get the new block } + foundsize:=0; + hp:=pcurr; + repeat + inc(foundsize,hp^.size and sizemask); + { block used or before a heapptr ? } + if (hp^.size and beforeheapendmask)<>0 then + begin + wasbeforeheapend:=true; + break; + end; + { get next block } + hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask)); + { when we're at heapptr then we can stop } + if (hp=heapptr) then + begin + inc(foundsize,heapend-heapptr); + break; + end; + if (hp^.size and usedmask)<>0 then + break; + until (foundsize>=size); + { found enough free blocks? } + if foundsize>=size then + begin + { we walk the list again and remove all blocks } + foundsize:=pcurr^.size and sizemask; + hp:=pcurr; + repeat + { get next block } + hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask)); + { when we're at heapptr then we can increase it, if there is enough + room is already checked } + if (hp=heapptr) then + begin + inc(heapptr,size-foundsize); + foundsize:=size; + break; + end; + s:=hp^.size and sizemask; + inc(foundsize,s); + { remove block from freelist } + s:=s shr blockshr; + if s>maxblock then + s:=0; + if assigned(hp^.next) then + hp^.next^.prev:=hp^.prev; + if assigned(hp^.prev) then + hp^.prev^.next:=hp^.next + else + freelists[s]:=hp^.next; +{$ifdef SYSTEMDEBUG} + dec(freecount[s]); +{$endif SYSTEMDEBUG} + until (foundsize>=size); + if wasbeforeheapend then + pcurr^.size:=foundsize or usedmask or beforeheapendmask + else + pcurr^.size:=foundsize or usedmask; + end + else + begin + { we need to call getmem/move/freemem } + SysTryResizeMem:=false; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} + exit; + end; + currsize:=pcurr^.size and sizemask; + end; +{ is the size smaller then we can adjust the block to that size and insert + the other part into the freelist } + if sizesizeof(tfreerecord) then + begin + pnew:=pfreerecord(pointer(pcurr)+size); + pnew^.size:=sizeleft or (pcurr^.size and beforeheapendmask); + { insert the block in the freelist } + pnew^.prev:=nil; + s:=sizeleft shr blockshr; + if s>maxblock then + s:=0; + pnew^.next:=freelists[s]; + if assigned(freelists[s]) then + freelists[s]^.prev:=pnew; + freelists[s]:=pnew; +{$ifdef SYSTEMDEBUG} + inc(freecount[s]); +{$endif SYSTEMDEBUG} + { fix the size of the current block and leave } + pcurr^.size:=size or usedmask; + end + else + begin + { fix the size of the current block and leave } + pcurr^.size:=size or usedmask or (pcurr^.size and beforeheapendmask); + end; + end; + dec(internal_memavail,size-oldsize); + SysTryResizeMem:=true; +{$ifdef TestFreeLists} + if test_each then + TestFreeLists; +{$endif TestFreeLists} +end; + + +{***************************************************************************** + SysResizeMem +*****************************************************************************} + +function SysReAllocMem(var p:pointer;size : longint):pointer; +var + oldsize : longint; + p2 : pointer; +begin + { Free block? } + if size=0 then + begin + if p<>nil then + MemoryManager.FreeMem(p); + end + else + { Allocate a new block? } + if p=nil then + begin + p:=MemoryManager.GetMem(size); + end + else + { Resize block } + if not SysTryResizeMem(p,size) then + begin + oldsize:=MemoryManager.MemSize(p); + p2:=MemoryManager.GetMem(size); + if p2<>nil then + Move(p^,p2^,oldsize); + MemoryManager.FreeMem(p); + p:=p2; + end; + SysReAllocMem:=p; +end; + + +{***************************************************************************** + Mark/Release +*****************************************************************************} + +procedure release(var p : pointer); +begin +end; + + +procedure mark(var p : pointer); +begin +end; + + +{***************************************************************************** + Grow Heap +*****************************************************************************} + +function growheap(size :longint) : integer; +var + sizeleft,s1, + NewPos : longint; + pcurr : pfreerecord; +begin +{$ifdef DUMPGROW} + writeln('grow ',size); + DumpBlocks; +{$endif} + { Allocate by 64K size } + size:=(size+$ffff) and $ffff0000; + { first try 256K (default) } + if size<=GrowHeapSize1 then + begin + NewPos:=Sbrk(GrowHeapSize1); + if NewPos<>-1 then + size:=GrowHeapSize1; + end + else + { second try 1024K (default) } + if size<=GrowHeapSize2 then + begin + NewPos:=Sbrk(GrowHeapSize2); + if NewPos<>-1 then + size:=GrowHeapSize2; + end + { else alloate the needed bytes } + else + NewPos:=SBrk(size); + { try again } + if NewPos=-1 then + begin + NewPos:=Sbrk(size); + if NewPos=-1 then + begin + if ReturnNilIfGrowHeapFails then + GrowHeap:=1 + else + GrowHeap:=0; + Exit; + end; + end; +{ increase heapend or add to freelist } + if heapend=pointer(newpos) then + begin + heapend:=pointer(newpos+size); + end + else + begin + { create freelist entry for old heapptr-heapend } + sizeleft:=heapend-heapptr; + if sizeleft>=sizeof(tfreerecord) then + begin + pcurr:=pfreerecord(heapptr); + pcurr^.size:=sizeleft or beforeheapendmask; +{$ifdef Withbug} + { this code was wrong because + in TryConcat an freerecord sets freelists[s] where s is size shr blockshr PM } + pcurr^.next:=freelists[0]; + pcurr^.prev:=nil; + if assigned(freelists[0]) then + freelists[0]^.prev:=pcurr; + freelists[0]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[0]); +{$endif SYSTEMDEBUG} +{$else not Withbug} + { insert the block in the freelist } + s1:=sizeleft shr blockshr; + if s1>maxblock then + s1:=0; + pcurr^.next:=freelists[s1]; + pcurr^.prev:=nil; + if assigned(freelists[s1]) then + freelists[s1]^.prev:=pcurr; + freelists[s1]:=pcurr; +{$ifdef SYSTEMDEBUG} + inc(freecount[s1]); +{$endif SYSTEMDEBUG} +{$endif Withbug} + end; + { now set the new heapptr,heapend to the new block } + heapptr:=pointer(newpos); + heapend:=pointer(newpos+size); + end; +{ set the total new heap size } + inc(internal_memavail,size); + inc(internal_heapsize,size); +{ try again } + GrowHeap:=2; +{$ifdef TestFreeLists} + TestFreeLists; +{$endif TestFreeLists} +end; + + +{***************************************************************************** + InitHeap +*****************************************************************************} + +{ This function will initialize the Heap manager and need to be called from + the initialization of the system unit } +procedure InitHeap; +begin + FillChar(FreeLists,sizeof(TFreeLists),0); +{$ifdef SYSTEMDEBUG} + FillChar(FreeCount,sizeof(TFreeCount),0); +{$endif SYSTEMDEBUG} + internal_heapsize:=GetHeapSize; + internal_memavail:=internal_heapsize; + HeapOrg:=GetHeapStart; + HeapPtr:=HeapOrg; + HeapEnd:=HeapOrg+internal_memavail; + HeapError:=@GrowHeap; +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.38 2000/04/20 15:29:15 pierre + fix for heap problem + + Revision 1.37 2000/04/07 21:10:35 pierre + + ReturnNilIfGrowHeapFails used in objects unit + to handle TMemoryStream out of memory properly + as MaxAvail is not a good test anymore. + + Revision 1.36 2000/03/13 21:22:28 peter + * concat free blocks in main freelist + + Revision 1.35 2000/03/10 12:41:21 pierre + * avoid problems if sbrk returns negative values + + Revision 1.34 2000/02/10 13:59:35 peter + * fixed bug with reallocmem to use the wrong size when copying the + data to the new allocated pointer + + Revision 1.33 2000/02/02 11:12:29 peter + * fixed internal_memavail counting for tryresizemem + + Revision 1.32 2000/01/31 23:41:30 peter + * reallocmem fixed for freemem() call when size=0 + + Revision 1.31 2000/01/24 23:56:10 peter + * fixed reallocmem which didn't work anymore and thus broke a lot + of objfpc/delphi code + + Revision 1.30 2000/01/20 12:35:35 jonas + * fixed problem with reallocmem and heaptrc + + Revision 1.29 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.28 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.27 1999/12/16 19:11:49 peter + * fixed sysmemsize which did the and sizemask wrong + + Revision 1.26 1999/12/13 21:04:46 peter + * fixed getmem call with wrong size from reallocmem + + Revision 1.25 1999/12/01 22:57:31 peter + * cmdline support + + Revision 1.24 1999/11/14 21:34:21 peter + * fixed reallocmem with a block at the end of an allocated memoryblock, + had to introduce a flag for such blocks. + * flags are now stored in the first 4 bits instead of the highest bit, + this could be done because the sizes of block are always >= 16 + + Revision 1.23 1999/11/10 22:29:51 michael + + Fixed sysreallocmem + + Revision 1.22 1999/11/01 13:56:50 peter + * freemem,reallocmem now get var argument + + Revision 1.21 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.20 1999/10/22 22:03:07 sg + * FreeMem(p) is ignored if p is NIL, instead of throwing an + runtime error 204. (Delphi ignores NIL FreeMem's, too) + + Revision 1.19 1999/10/01 07:55:54 peter + * fixed memsize which forgot the sizemask + + Revision 1.18 1999/09/22 21:59:02 peter + * best match for main freelist + * removed root field, saves 4 bytes per block + * fixed crash in dumpblocks + + Revision 1.17 1999/09/20 14:17:37 peter + * fixed growheap freelist addition when heapend-heapptr 256k will grow with 1m } + ReturnNilIfGrowHeapFails : boolean = false; +var + heaporg,heapptr,heapend,heaperror,freelist : pointer; + +{ Default MemoryManager functions } +Function SysGetmem(Size:Longint):Pointer; +Function SysFreemem(var p:pointer):Longint; +Function SysFreememSize(var p:pointer;Size:Longint):Longint; +Function SysMemSize(p:pointer):Longint; +Function SysAllocMem(size:longint):Pointer; +function SysTryResizeMem(var p:pointer;size : longint):boolean; +Function SysReAllocMem(var p:pointer;size:longint):Pointer; +Function Sysmemavail:Longint; +Function Sysmaxavail:Longint; +Function Sysheapsize:longint; + +{ Tp7 functions } +Procedure Getmem(Var p:pointer;Size:Longint); +Procedure Freemem(Var p:pointer;Size:Longint); +Function memavail:Longint; +Function maxavail:Longint; + +{ FPC additions } +Function MemSize(p:pointer):Longint; +Function heapsize:longint; + +{ Delphi functions } +function GetMem(size:longint):pointer; +function Freemem(var p:pointer):longint; +function AllocMem(Size:Longint):pointer; +function ReAllocMem(var p:pointer;Size:Longint):pointer; + +{ Needed to solve overloading problem with call from assembler (PFV) } +Procedure AsmGetmem(var p:pointer;size:Longint); +Procedure AsmFreemem(var p:pointer); + +{ Do nothing functions, are only here for tp7 compat } +Procedure mark(var p : pointer); +Procedure release(var p : pointer); + +{ + $Log: not supported by cvs2svn $ + Revision 1.18 2000/04/07 21:10:35 pierre + + ReturnNilIfGrowHeapFails used in objects unit + to handle TMemoryStream out of memory properly + as MaxAvail is not a good test anymore. + + Revision 1.17 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.16 2000/01/31 23:41:30 peter + * reallocmem fixed for freemem() call when size=0 + + Revision 1.15 2000/01/20 12:35:35 jonas + * fixed problem with reallocmem and heaptrc + + Revision 1.14 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.13 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.12 1999/11/01 13:56:50 peter + * freemem,reallocmem now get var argument + + Revision 1.11 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.10 1999/09/17 17:14:12 peter + + new heap manager supporting delphi freemem(pointer) + +} \ No newline at end of file diff --git a/befpc/rtl/inc/heaptrc.pp b/befpc/rtl/inc/heaptrc.pp new file mode 100644 index 0000000..6bec28b --- /dev/null +++ b/befpc/rtl/inc/heaptrc.pp @@ -0,0 +1,1069 @@ +{ + $Id: heaptrc.pp,v 1.1.1.1 2001-07-23 17:17:34 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Heap tracer + + 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 heaptrc; + +{ 0.99.12 had a bug that initialization/finalization only worked for + objfpc,delphi mode } +{$ifdef VER0_99_12} + {$mode objfpc} +{$endif} + +interface + +Procedure DumpHeap; +Procedure MarkHeap; + +{ define EXTRA to add more + tests : + - keep all memory after release and + check by CRC value if not changed after release + WARNING this needs extremely much memory (PM) } + +type + FillExtraInfoType = procedure(p : pointer); + + { allows to add several longint value that can help + to debug : + see for instance ppheap.pas unit of the compiler source PM } + +Procedure SetExtraInfo( size : longint;func : FillExtraInfoType); +Procedure SetHeapTraceOutput(const name : string); + +const + { tracing level + splitted in two if memory is released !! } +{$ifdef EXTRA} + tracesize = 16; +{$else EXTRA} + tracesize = 8; +{$endif EXTRA} + quicktrace : boolean=true; + { calls halt() on error by default !! } + HaltOnError : boolean = true; + { set this to true if you suspect that memory + is freed several times } +{$ifdef EXTRA} + keepreleased : boolean=true; + add_tail : boolean = true; +{$else EXTRA} + keepreleased : boolean=false; + add_tail : boolean = false; +{$endif EXTRA} + { put crc in sig + this allows to test for writing into that part } + usecrc : boolean = true; + + +implementation + +type + plongint = ^longint; + +const + { allows to add custom info in heap_mem_info } + extra_info_size : longint = 0; + exact_info_size : longint = 0; + EntryMemUsed : longint = 0; + { function to fill this info up } + fill_extra_info : FillExtraInfoType = nil; + error_in_heap : boolean = false; + inside_trace_getmem : boolean = false; + +type + pheap_mem_info = ^theap_mem_info; + { warning the size of theap_mem_info + must be a multiple of 8 + because otherwise you will get + problems when releasing the usual memory part !! + sizeof(theap_mem_info = 16+tracesize*4 so + tracesize must be even !! PM } + theap_mem_info = record + previous, + next : pheap_mem_info; + size : longint; + sig : longint; +{$ifdef EXTRA} + release_sig : longint; + prev_valid : pheap_mem_info; +{$endif EXTRA} + calls : array [1..tracesize] of longint; + extra_info : record + end; + end; + +var + ptext : ^text; + ownfile : text; +{$ifdef EXTRA} + error_file : text; + heap_valid_first, + heap_valid_last : pheap_mem_info; +{$endif EXTRA} + heap_mem_root : pheap_mem_info; + getmem_cnt, + freemem_cnt : longint; + getmem_size, + freemem_size : longint; + getmem8_size, + freemem8_size : longint; + + +{***************************************************************************** + Crc 32 +*****************************************************************************} + +var +{$ifdef Delphi} + Crc32Tbl : array[0..255] of longword; +{$else Delphi} + Crc32Tbl : array[0..255] of longint; +{$endif Delphi} + +procedure MakeCRC32Tbl; +var +{$ifdef Delphi} + crc : longword; +{$else Delphi} + crc : longint; +{$endif Delphi} + i,n : byte; +begin + for i:=0 to 255 do + begin + crc:=i; + for n:=1 to 8 do + if odd(crc) then + crc:=(crc shr 1) xor $edb88320 + else + crc:=crc shr 1; + Crc32Tbl[i]:=crc; + end; +end; + + +{$ifopt R+} +{$define Range_check_on} +{$endif opt R+} + +{$R- needed here } + +Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint; +var + i : longint; + p : pchar; +begin + p:=@InBuf; + for i:=1 to InLen do + begin + InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8); + inc(longint(p)); + end; + UpdateCrc32:=InitCrc; +end; + +Function calculate_sig(p : pheap_mem_info) : longint; +var + crc : longint; + pl : plongint; +begin + crc:=$ffffffff; + crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); + crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); + if extra_info_size>0 then + crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size); + if add_tail then + begin + { Check also 4 bytes just after allocation !! } + pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size; + crc:=UpdateCrc32(crc,pl^,sizeof(longint)); + end; + calculate_sig:=crc; +end; + +{$ifdef EXTRA} +Function calculate_release_sig(p : pheap_mem_info) : longint; +var + crc : longint; + pl : plongint; +begin + crc:=$ffffffff; + crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); + crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); + if extra_info_size>0 then + crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size); + { Check the whole of the whole allocation } + pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info); + crc:=UpdateCrc32(crc,pl^,p^.size); + { Check also 4 bytes just after allocation !! } + if add_tail then + begin + { Check also 4 bytes just after allocation !! } + pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size; + crc:=UpdateCrc32(crc,pl^,sizeof(longint)); + end; + calculate_release_sig:=crc; +end; +{$endif EXTRA} + +{$ifdef Range_check_on} +{$R+} +{$undef Range_check_on} +{$endif Range_check_on} + +{***************************************************************************** + Helpers +*****************************************************************************} + +procedure call_stack(pp : pheap_mem_info;var ptext : text); +var + i : longint; +begin + writeln(ptext,'Call trace for block 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); + for i:=1 to tracesize do + if pp^.calls[i]<>0 then + writeln(ptext,BackTraceStrFunc(pp^.calls[i])); + for i:=0 to (exact_info_size div 4)-1 do + writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^); +end; + +procedure call_free_stack(pp : pheap_mem_info;var ptext : text); +var + i : longint; + +begin + writeln(ptext,'Call trace for block at 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); + for i:=1 to tracesize div 2 do + if pp^.calls[i]<>0 then + writeln(ptext,BackTraceStrFunc(pp^.calls[i])); + writeln(ptext,' was released at '); + for i:=(tracesize div 2)+1 to tracesize do + if pp^.calls[i]<>0 then + writeln(ptext,BackTraceStrFunc(pp^.calls[i])); + for i:=0 to (exact_info_size div 4)-1 do + writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^); +end; + + +procedure dump_already_free(p : pheap_mem_info;var ptext : text); +begin + Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' released'); + call_free_stack(p,ptext); + Writeln(ptext,'freed again at'); + dump_stack(ptext,get_caller_frame(get_frame)); +end; + +procedure dump_error(p : pheap_mem_info;var ptext : text); +begin + Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); + Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8) + ,' instead of ',hexstr(calculate_sig(p),8)); + dump_stack(ptext,get_caller_frame(get_frame)); +end; + +{$ifdef EXTRA} +procedure dump_change_after(p : pheap_mem_info;var ptext : text); + var pp : pchar; + i : longint; +begin + Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); + Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8) + ,' instead of ',hexstr(calculate_release_sig(p),8)); + Writeln(ptext,'This memory was changed after call to freemem !'); + call_free_stack(p,ptext); + pp:=pointer(p)+sizeof(theap_mem_info)+extra_info_size; + for i:=0 to p^.size-1 do + if byte(pp[i])<>$F0 then + Writeln(ptext,'offset',i,':$',hexstr(i,8),'"',pp[i],'"'); +end; +{$endif EXTRA} + +procedure dump_wrong_size(p : pheap_mem_info;size : longint;var ptext : text); +var + i : longint; +begin + Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); + Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); + dump_stack(ptext,get_caller_frame(get_frame)); + for i:=0 to (exact_info_size div 4)-1 do + writeln(ptext,'info ',i,'=',plongint(@p^.extra_info+4*i)^); + call_stack(p,ptext); +end; + + +function is_in_getmem_list (p : pheap_mem_info) : boolean; +var + i : longint; + pp : pheap_mem_info; +begin + is_in_getmem_list:=false; + pp:=heap_mem_root; + i:=0; + while pp<>nil do + begin + if ((pp^.sig<>$DEADBEEF) or usecrc) and + ((pp^.sig<>calculate_sig(pp)) or not usecrc) and + (pp^.sig <> $AAAAAAAA) then + begin + writeln(ptext^,'error in linked list of heap_mem_info'); + RunError(204); + end; + if pp=p then + is_in_getmem_list:=true; + pp:=pp^.previous; + inc(i); + if i>getmem_cnt-freemem_cnt then + writeln(ptext^,'error in linked list of heap_mem_info'); + end; +end; + + +{***************************************************************************** + TraceGetMem +*****************************************************************************} + +Function TraceGetMem(size:longint):pointer; +var + i,bp : longint; + pl : plongint; + p : pointer; +begin + inc(getmem_size,size); + inc(getmem8_size,((size+7) div 8)*8); +{ Do the real GetMem, but alloc also for the info block } + bp:=size+sizeof(theap_mem_info)+extra_info_size; + if add_tail then + inc(bp,sizeof(longint)); + p:=SysGetMem(bp); +{ Create the info block } + pheap_mem_info(p)^.sig:=$DEADBEEF; + pheap_mem_info(p)^.size:=size; + if add_tail then + begin + pl:=pointer(p)+bp-sizeof(longint); + pl^:=$DEADBEEF; + end; + bp:=get_caller_frame(get_frame); + for i:=1 to tracesize do + begin + pheap_mem_info(p)^.calls[i]:=get_caller_addr(bp); + bp:=get_caller_frame(bp); + end; + { insert in the linked list } + if heap_mem_root<>nil then + heap_mem_root^.next:=pheap_mem_info(p); + pheap_mem_info(p)^.previous:=heap_mem_root; + pheap_mem_info(p)^.next:=nil; +{$ifdef EXTRA} + pheap_mem_info(p)^.prev_valid:=heap_valid_last; + heap_valid_last:=pheap_mem_info(p); + if not assigned(heap_valid_first) then + heap_valid_first:=pheap_mem_info(p); +{$endif EXTRA} + heap_mem_root:=p; + { must be changed before fill_extra_info is called + because checkpointer can be called from within + fill_extra_info PM } + inc(getmem_cnt); + if assigned(fill_extra_info) then + begin + inside_trace_getmem:=true; + fill_extra_info(@pheap_mem_info(p)^.extra_info); + inside_trace_getmem:=false; + end; +{ update the pointer } + if usecrc then + pheap_mem_info(p)^.sig:=calculate_sig(pheap_mem_info(p)); + inc(p,sizeof(theap_mem_info)+extra_info_size); + TraceGetmem:=p; +end; + + +{***************************************************************************** + TraceFreeMem +*****************************************************************************} + +function TraceFreeMemSize(var p:pointer;size:longint):longint; +var + i,bp, ppsize : longint; + pp : pheap_mem_info; +{$ifdef EXTRA} + pp2 : pheap_mem_info; +{$endif} +begin + inc(freemem_size,size); + inc(freemem8_size,((size+7) div 8)*8); + ppsize:= size + sizeof(theap_mem_info)+extra_info_size; + if add_tail then + ppsize:=ppsize+sizeof(longint); + dec(p,sizeof(theap_mem_info)+extra_info_size); + pp:=pheap_mem_info(p); + if not quicktrace and not(is_in_getmem_list(pp)) then + RunError(204); + if (pp^.sig=$AAAAAAAA) and not usecrc then + begin + error_in_heap:=true; + dump_already_free(pp,ptext^); + if haltonerror then halt(1); + end + else if ((pp^.sig<>$DEADBEEF) or usecrc) and + ((pp^.sig<>calculate_sig(pp)) or not usecrc) then + begin + error_in_heap:=true; + dump_error(pp,ptext^); +{$ifdef EXTRA} + dump_error(pp,error_file); +{$endif EXTRA} + { don't release anything in this case !! } + if haltonerror then halt(1); + exit; + end + else if pp^.size<>size then + begin + error_in_heap:=true; + dump_wrong_size(pp,size,ptext^); +{$ifdef EXTRA} + dump_wrong_size(pp,size,error_file); +{$endif EXTRA} + if haltonerror then halt(1); + { don't release anything in this case !! } + exit; + end; + { now it is released !! } + pp^.sig:=$AAAAAAAA; + if not keepreleased then + begin + if pp^.next<>nil then + pp^.next^.previous:=pp^.previous; + if pp^.previous<>nil then + pp^.previous^.next:=pp^.next; + if pp=heap_mem_root then + heap_mem_root:=heap_mem_root^.previous; + end + else + begin + bp:=get_caller_frame(get_frame); + for i:=(tracesize div 2)+1 to tracesize do + begin + pp^.calls[i]:=get_caller_addr(bp); + bp:=get_caller_frame(bp); + end; + end; + inc(freemem_cnt); + { release the normal memory at least !! } + { this way we keep all info about all released memory !! } + if keepreleased then + begin +{$ifndef EXTRA} + dec(ppsize,sizeof(theap_mem_info)+extra_info_size); + inc(p,sizeof(theap_mem_info)+extra_info_size); +{$else EXTRA} + inc(p,sizeof(theap_mem_info)+extra_info_size); + fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! } + { We want to check if the memory was changed after release !! } + pp^.release_sig:=calculate_release_sig(pp); + if pp=heap_valid_last then + begin + heap_valid_last:=pp^.prev_valid; + if pp=heap_valid_first then + heap_valid_first:=nil; + exit; + end; + pp2:=heap_valid_last; + while assigned(pp2) do + begin + if pp2^.prev_valid=pp then + begin + pp2^.prev_valid:=pp^.prev_valid; + if pp=heap_valid_first then + heap_valid_first:=pp2; + exit; + end + else + pp2:=pp2^.prev_valid; + end; + exit; +{$endif EXTRA} + end; + i:=SysFreeMemSize(p,ppsize); + dec(i,sizeof(theap_mem_info)+extra_info_size); + if add_tail then + dec(i,sizeof(longint)); + TraceFreeMemSize:=i; +end; + + +function TraceMemSize(p:pointer):Longint; +var + l : longint; +begin + l:=SysMemSize(p-(sizeof(theap_mem_info)+extra_info_size)); + dec(l,sizeof(theap_mem_info)+extra_info_size); + if add_tail then + dec(l,sizeof(longint)); + TraceMemSize:=l; +end; + + +function TraceFreeMem(var p:pointer):longint; +var + size : longint; + pp : pheap_mem_info; +begin + pp:=pheap_mem_info(pointer(p)-(sizeof(theap_mem_info)+extra_info_size)); + size:=TraceMemSize(p); + { this can never happend normaly } + if pp^.size>size then + begin + dump_wrong_size(pp,size,ptext^); +{$ifdef EXTRA} + dump_wrong_size(pp,size,error_file); +{$endif EXTRA} + end; + TraceFreeMem:=TraceFreeMemSize(p,pp^.size); +end; + + +{***************************************************************************** + ReAllocMem +*****************************************************************************} + +function TraceReAllocMem(var p:pointer;size:longint):Pointer; +var + newP: pointer; + oldsize, + i,bp : longint; + pl : plongint; + pp : pheap_mem_info; +begin +{ Free block? } + if size=0 then + begin + if p<>nil then + TraceFreeMem(p); + TraceReallocMem:=P; + exit; + end; +{ Allocate a new block? } + if p=nil then + begin + p:=TraceGetMem(size); + TraceReallocMem:=P; + exit; + end; +{ Resize block } + dec(p,sizeof(theap_mem_info)+extra_info_size); + pp:=pheap_mem_info(p); + { test block } + if ((pp^.sig<>$DEADBEEF) or usecrc) and + ((pp^.sig<>calculate_sig(pp)) or not usecrc) then + begin + error_in_heap:=true; + dump_error(pp,ptext^); +{$ifdef EXTRA} + dump_error(pp,error_file); +{$endif EXTRA} + { don't release anything in this case !! } + if haltonerror then halt(1); + exit; + end; + { Do the real ReAllocMem, but alloc also for the info block } + bp:=size+sizeof(theap_mem_info)+extra_info_size; + if add_tail then + inc(bp,sizeof(longint)); + { the internal ReAllocMem is not allowed to move any data } + if not SysTryResizeMem(p,bp) then + begin + { restore p } + inc(p,sizeof(theap_mem_info)+extra_info_size); + { get a new block } + oldsize:=TraceMemSize(p); + newP := TraceGetMem(size); + { move the data } + if newP <> nil then + move(p^,newP^,oldsize); + { release p } + traceFreeMem(p); + p := newP; + traceReAllocMem := p; + exit; + end; + pp:=pheap_mem_info(p); +{ adjust like a freemem and then a getmem, so you get correct + results in the summary display } + inc(freemem_size,pp^.size); + inc(freemem8_size,((pp^.size+7) div 8)*8); + inc(getmem_size,size); + inc(getmem8_size,((size+7) div 8)*8); +{ Create the info block } + pp^.sig:=$DEADBEEF; + pp^.size:=size; + if add_tail then + begin + pl:=pointer(p)+bp-sizeof(longint); + pl^:=$DEADBEEF; + end; + bp:=get_caller_frame(get_frame); + for i:=1 to tracesize do + begin + pp^.calls[i]:=get_caller_addr(bp); + bp:=get_caller_frame(bp); + end; + if assigned(fill_extra_info) then + fill_extra_info(@pp^.extra_info); +{ update the pointer } + if usecrc then + pp^.sig:=calculate_sig(pp); + inc(p,sizeof(theap_mem_info)+extra_info_size); + TraceReAllocmem:=p; +end; + + + +{***************************************************************************** + Check pointer +*****************************************************************************} + +{$ifndef linux} + {$S-} +{$endif} + +{$ifdef go32v2} +var + __stklen : cardinal;external name '__stklen'; + __stkbottom : cardinal;external name '__stkbottom'; + edata : cardinal; external name 'edata'; + heap_at_init : pointer; +{$endif go32v2} + +{$ifdef win32} +var + StartUpHeapEnd : pointer; + { I found no symbol for start of text section :( + so we usee the _mainCRTStartup which should be + in wprt0.ow or wdllprt0.ow PM } + text_begin : cardinal;external name '_mainCRTStartup'; + data_end : cardinal;external name '__data_end__'; +{$endif} + +procedure CheckPointer(p : pointer);[public, alias : 'FPC_CHECKPOINTER']; +var + i : longint; + pp : pheap_mem_info; + get_ebp,stack_top : cardinal; + data_end : cardinal; +label + _exit; +begin + asm + pushal + end; + if p=nil then + goto _exit; + + i:=0; + +{$ifdef go32v2} + if cardinal(p)<$1000 then + runerror(216); + asm + movl %ebp,get_ebp + leal edata,%eax + movl %eax,data_end + end; + stack_top:=__stkbottom+__stklen; + { allow all between start of code and end of data } + if cardinal(p)<=data_end then + goto _exit; + { .bss section } + if cardinal(p)<=cardinal(heap_at_init) then + goto _exit; + { stack can be above heap !! } + + if (cardinal(p)>=get_ebp) and (cardinal(p)<=stack_top) then + goto _exit; +{$endif go32v2} + + { I don't know where the stack is in other OS !! } +{$ifdef win32} + if (cardinal(p)>=$40000) and (p<=HeapOrg) then + goto _exit; + { inside stack ? } + asm + movl %ebp,get_ebp + end; + if (cardinal(p)>get_ebp) and + (cardinal(p)=heapptr then + runerror(216); + { first try valid list faster } + +{$ifdef EXTRA} + pp:=heap_valid_last; + while pp<>nil do + begin + { inside this valid block ! } + { we can be changing the extrainfo !! } + if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info){+extra_info_size}) and + (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then + begin + { check allocated block } + if ((pp^.sig=$DEADBEEF) and not usecrc) or + ((pp^.sig=calculate_sig(pp)) and usecrc) or + { special case of the fill_extra_info call } + ((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF) + and inside_trace_getmem) then + goto _exit + else + begin + writeln(ptext^,'corrupted heap_mem_info'); + dump_error(pp,ptext^); + halt(1); + end; + end + else + pp:=pp^.prev_valid; + inc(i); + if i>getmem_cnt-freemem_cnt then + begin + writeln(ptext^,'error in linked list of heap_mem_info'); + halt(1); + end; + end; + i:=0; +{$endif EXTRA} + pp:=heap_mem_root; + while pp<>nil do + begin + { inside this block ! } + if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size) and + (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then + { allocated block } + if ((pp^.sig=$DEADBEEF) and not usecrc) or + ((pp^.sig=calculate_sig(pp)) and usecrc) then + goto _exit + else + begin + writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block'); + dump_error(pp,ptext^); + runerror(204); + end; + pp:=pp^.previous; + inc(i); + if i>getmem_cnt then + begin + writeln(ptext^,'error in linked list of heap_mem_info'); + halt(1); + end; + end; + writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); + runerror(204); +_exit: + asm + popal + end; +end; + +{***************************************************************************** + Dump Heap +*****************************************************************************} + +procedure dumpheap; +var + pp : pheap_mem_info; + i : longint; + ExpectedMemAvail : longint; +begin + pp:=heap_mem_root; + Writeln(ptext^,'Heap dump by heaptrc unit'); + Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size); + Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size); + Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size); + Write(ptext^,'True heap size : ',system.HeapSize); + if EntryMemUsed > 0 then + Writeln(ptext^,' (',EntryMemUsed,' used in System startup)') + else + Writeln(ptext^); + Writeln(ptext^,'True free heap : ',MemAvail); + ExpectedMemAvail:=system.HeapSize-(getmem8_size-freemem8_size)- + (getmem_cnt-freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)-EntryMemUsed; + If ExpectedMemAvail<>MemAvail then + Writeln(ptext^,'Should be : ',ExpectedMemAvail); + i:=getmem_cnt-freemem_cnt; + while pp<>nil do + begin + if i<0 then + begin + Writeln(ptext^,'Error in heap memory list'); + Writeln(ptext^,'More memory blocks than expected'); + exit; + end; + if ((pp^.sig=$DEADBEEF) and not usecrc) or + ((pp^.sig=calculate_sig(pp)) and usecrc) then + begin + { this one was not released !! } + if exitcode<>203 then + call_stack(pp,ptext^); + dec(i); + end + else if pp^.sig<>$AAAAAAAA then + begin + dump_error(pp,ptext^); +{$ifdef EXTRA} + dump_error(pp,error_file); +{$endif EXTRA} + error_in_heap:=true; + end +{$ifdef EXTRA} + else if pp^.release_sig<>calculate_release_sig(pp) then + begin + dump_change_after(pp,ptext^); + dump_change_after(pp,error_file); + error_in_heap:=true; + end +{$endif EXTRA} + ; + pp:=pp^.previous; + end; +end; + + +procedure markheap; +var + pp : pheap_mem_info; +begin + pp:=heap_mem_root; + while pp<>nil do + begin + pp^.sig:=$AAAAAAAA; + pp:=pp^.previous; + end; +end; + + +{***************************************************************************** + AllocMem +*****************************************************************************} + +function TraceAllocMem(size:longint):Pointer; +begin + TraceAllocMem:=SysAllocMem(size); +end; + + +{***************************************************************************** + No specific tracing calls +*****************************************************************************} + +function TraceMemAvail:longint; +begin + TraceMemAvail:=SysMemAvail; +end; + +function TraceMaxAvail:longint; +begin + TraceMaxAvail:=SysMaxAvail; +end; + +function TraceHeapSize:longint; +begin + TraceHeapSize:=SysHeapSize; +end; + + +{***************************************************************************** + Install MemoryManager +*****************************************************************************} + +const + TraceManager:TMemoryManager=( + Getmem : TraceGetMem; + Freemem : TraceFreeMem; + FreememSize : TraceFreeMemSize; + AllocMem : TraceAllocMem; + ReAllocMem : TraceReAllocMem; + MemSize : TraceMemSize; + MemAvail : TraceMemAvail; + MaxAvail : TraceMaxAvail; + HeapSize : TraceHeapsize; + ); + +procedure TraceExit; +begin + { no dump if error + because this gives long long listings } + if (exitcode<>0) and (erroraddr<>nil) then + begin + Writeln(ptext^,'No heap dump by heaptrc unit'); + Writeln(ptext^,'Exitcode = ',exitcode); + if ptext<>@stderr then + begin + ptext:=@stderr; + close(ownfile); + end; + exit; + end; + if not error_in_heap then + Dumpheap; + if error_in_heap and (exitcode=0) then + exitcode:=203; +{$ifdef EXTRA} + Close(error_file); +{$endif EXTRA} + if ptext<>@stderr then + begin + ptext:=@stderr; + close(ownfile); + end; +end; + +Procedure SetHeapTraceOutput(const name : string); +var i : longint; +begin + if ptext<>@stderr then + begin + ptext:=@stderr; + close(ownfile); + end; + assign(ownfile,name); +{$I-} + append(ownfile); + if IOResult<>0 then + Rewrite(ownfile); +{$I+} + ptext:=@ownfile; + for i:=0 to Paramcount do + write(ptext^,paramstr(i),' '); + writeln(ptext^); +end; + +procedure SetExtraInfo( size : longint;func : fillextrainfotype); + + begin + if getmem_cnt>0 then + begin + writeln(ptext^,'Setting extra info is only possible at start !! '); + dumpheap; + end + else + begin + { the total size must stay multiple of 8 !! } + exact_info_size:=size; + extra_info_size:=((size+7) div 8)*8; + fill_extra_info:=func; + end; + end; + +Initialization + EntryMemUsed:=System.HeapSize-MemAvail; + MakeCRC32Tbl; + SetMemoryManager(TraceManager); + ptext:=@stderr; +{$ifdef EXTRA} + Assign(error_file,'heap.err'); + Rewrite(error_file); +{$endif EXTRA} + { checkpointer init } +{$ifdef go32v2} + Heap_at_init:=HeapPtr; +{$endif} +{$ifdef win32} + StartupHeapEnd:=HeapEnd; +{$endif} +finalization + TraceExit; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/05/18 17:03:27 peter + * fixed reallocmem with double removing from heap_mem_root list + * fixed reallocmem getmem/freemem count, now both are increased and + the _size8 counts are also increased + + Revision 1.42 2000/04/27 15:35:50 pierre + * fix for bug report 929 + + Revision 1.41 2000/02/10 13:59:35 peter + * fixed bug with reallocmem to use the wrong size when copying the + data to the new allocated pointer + + Revision 1.40 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.39 2000/02/07 10:42:44 peter + * use backtracestrfunc() + + Revision 1.38 2000/02/02 11:13:15 peter + * fixed tracereallocmem which supplied the wrong size for tryresize + + Revision 1.37 2000/01/31 23:41:30 peter + * reallocmem fixed for freemem() call when size=0 + + Revision 1.36 2000/01/20 14:25:51 jonas + * finally fixed tracereallocmem completely + + Revision 1.35 2000/01/20 13:17:11 jonas + * another problme with realloc fixed (one left) + + Revision 1.34 2000/01/20 12:35:35 jonas + * fixed problem with reallocmem and heaptrc + + Revision 1.33 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.32 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.31 2000/01/05 13:56:55 jonas + * fixed traceReallocMem with nil pointer (simply calls traceGetMem now in + such a case) + + Revision 1.30 2000/01/03 19:37:52 peter + * fixed reallocmem with p=nil + + Revision 1.29 1999/11/14 21:35:04 peter + * removed warnings + + Revision 1.28 1999/11/09 22:32:23 pierre + * several extra_size_info fixes + + Revision 1.27 1999/11/06 14:35:38 peter + * truncated log + + Revision 1.26 1999/11/01 13:56:50 peter + * freemem,reallocmem now get var argument + + Revision 1.25 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.24 1999/09/17 17:14:12 peter + + new heap manager supporting delphi freemem(pointer) + + Revision 1.23 1999/09/10 17:13:41 peter + * fixed missing var + + Revision 1.22 1999/09/08 16:14:41 peter + * pointer fixes + + Revision 1.21 1999/08/18 12:03:16 peter + * objfpc mode for 0.99.12 + + Revision 1.20 1999/08/17 14:56:03 michael + Removed the mode for objpas + +} diff --git a/befpc/rtl/inc/innr.inc b/befpc/rtl/inc/innr.inc new file mode 100644 index 0000000..b69532b --- /dev/null +++ b/befpc/rtl/inc/innr.inc @@ -0,0 +1,115 @@ +{ + $Id: innr.inc,v 1.1.1.1 2001-07-23 17:17:34 memson Exp $ + This file is part of the Free Pascal run time library and compiler. + Copyright (c) 1999-2000 by the Free Pascal development team + + Internal Function/Constant Evaluator numbers + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +const +{ Internal functions } + in_lo_word = 1; + in_hi_word = 2; + in_lo_long = 3; + in_hi_long = 4; + in_ord_x = 5; + in_length_string = 6; + in_chr_byte = 7; + in_write_x = 14; + in_writeln_x = 15; + in_read_x = 16; + in_readln_x = 17; + in_concat_x = 18; + in_assigned_x = 19; + in_str_x_string = 20; + in_ofs_x = 21; + in_sizeof_x = 22; + in_typeof_x = 23; + in_val_x = 24; + in_reset_x = 25; + in_rewrite_x = 26; + in_low_x = 27; + in_high_x = 28; + in_seg_x = 29; + in_pred_x = 30; + in_succ_x = 31; + in_reset_typedfile = 32; + in_rewrite_typedfile = 33; + in_settextbuf_file_x = 34; + in_inc_x = 35; + in_dec_x = 36; + in_include_x_y = 37; + in_exclude_x_y = 38; + in_break = 39; + in_continue = 40; + in_assert_x_y = 41; + in_addr_x = 42; + +{ Internal constant functions } + in_const_trunc = 100; + in_const_round = 101; + in_const_frac = 102; + in_const_abs = 103; + in_const_int = 104; + in_const_sqr = 105; + in_const_odd = 106; + in_const_ptr = 107; + in_const_swap_word = 108; + in_const_swap_long = 109; + in_const_pi = 110; + in_const_sqrt = 111; + in_const_arctan = 112; + in_const_cos = 113; + in_const_exp = 114; + in_const_ln = 115; + in_const_sin = 116; + in_lo_qword = 117; + in_hi_qword = 118; + in_cos_extended = 119; + in_pi = 121; + in_abs_extended = 122; + in_sqr_extended = 123; + in_sqrt_extended = 124; + in_arctan_extended = 125; + in_ln_extended = 126; + in_sin_extended = 127; + +{ MMX functions } +{ these contants are used by the mmx unit } + + { MMX } + in_mmx_pcmpeqb = 200; + in_mmx_pcmpeqw = 201; + in_mmx_pcmpeqd = 202; + in_mmx_pcmpgtb = 203; + in_mmx_pcmpgtw = 204; + in_mmx_pcmpgtd = 205; + + { 3DNow } + + { SSE } + +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.11 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.10 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.9 1999/09/15 20:23:16 florian + + constants for math functions + +} + diff --git a/befpc/rtl/inc/int64.inc b/befpc/rtl/inc/int64.inc new file mode 100644 index 0000000..209b368 --- /dev/null +++ b/befpc/rtl/inc/int64.inc @@ -0,0 +1,493 @@ +{ + $Id: int64.inc,v 1.1.1.1 2001-07-23 17:17:34 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This file contains some helper routines for int64 and qword + + 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. + + **********************************************************************} +{$Q- no overflow checking } +{$R- no range checking } + + type + tqwordrec = packed record + low : dword; + high : dword; + end; + + function count_leading_zeros(q : qword) : longint; + + var + r,i : longint; + + begin + r:=0; + for i:=0 to 31 do + begin + if (tqwordrec(q).high and ($80000000 shr i))<>0 then + begin + count_leading_zeros:=r; + exit; + end; + inc(r); + end; + for i:=0 to 31 do + begin + if (tqwordrec(q).low and ($80000000 shr i))<>0 then + begin + count_leading_zeros:=r; + exit; + end; + inc(r); + end; + count_leading_zeros:=r; + end; + + function divqword(n,z : qword) : qword;[public,alias: 'FPC_DIV_QWORD']; + + var + shift,lzz,lzn : longint; + { one : qword; } + + begin + divqword:=0; + if n=0 then + HandleErrorFrame(200,get_frame); + lzz:=count_leading_zeros(z); + lzn:=count_leading_zeros(n); + { if the denominator contains less zeros } + { then the numerator } + { the d is greater than the n } + if lzn=n then + begin + z:=z-n; + divqword:=divqword+(qword(1) shl shift); + end; + dec(shift); + n:=n shr 1; + until shift<0; + end; + + function modqword(n,z : qword) : qword;[public,alias: 'FPC_MOD_QWORD']; + + var + shift,lzz,lzn : longint; + + begin + modqword:=0; + if n=0 then + HandleErrorFrame(200,get_frame); + lzz:=count_leading_zeros(z); + lzn:=count_leading_zeros(n); + { if the denominator contains less zeros } + { then the numerator } + { the d is greater than the n } + if lzn=n then + z:=z-n; + dec(shift); + n:=n shr 1; + until shift<0; + modqword:=z; + end; + + function divint64(n,z : int64) : int64;[public,alias: 'FPC_DIV_INT64']; + + var + sign : boolean; + q1,q2 : qword; + c : comp; + + begin + if n=0 then + HandleErrorFrame(200,get_frame); + { can the fpu do the work? } + if fpuint64 then + begin + // the c:=comp(...) is necessary to shut up the compiler + c:=comp(comp(z)/comp(n)); + divint64:=qword(c); + end + else + begin + sign:=false; + if z<0 then + begin + sign:=not(sign); + q1:=qword(-z); + end + else + q1:=z; + if n<0 then + begin + sign:=not(sign); + q2:=qword(-n); + end + else + q2:=n; + + { the div is coded by the compiler as call to divqword } + if sign then + divint64:=-(q1 div q2) + else + divint64:=q1 div q2; + end; + end; + + function modint64(n,z : int64) : int64;[public,alias: 'FPC_MOD_INT64']; + + var + signed : boolean; + r,nq,zq : qword; + + begin + if n=0 then + HandleErrorFrame(200,get_frame); + if n<0 then + begin + nq:=-n; + signed:=true; + end + else + begin + signed:=false; + nq:=n; + end; + if z<0 then + begin + zq:=qword(-z); + signed:=not(signed); + end + else + zq:=z; + r:=zq mod nq; + if signed then + modint64:=-int64(r) + else + modint64:=r; + end; + + { multiplies two qwords + the longbool for checkoverflow avoids a misaligned stack + } + function mulqword(f1,f2 : qword;checkoverflow : longbool) : qword;[public,alias: 'FPC_MUL_QWORD']; + + var + _f1,bitpos : qword; + l : longint; + +{$ifdef i386} + r : qword; +{$endif i386} + + begin +{$ifdef i386} + if not(checkoverflow) then + begin + asm + movl f1+4,%edx + movl f2+4,%ecx + orl %ecx,%edx + movl f2,%edx + movl f1,%eax + jnz .Lqwordmultwomul + mull %edx + jmp .Lqwordmulready + .Lqwordmultwomul: + imul f1+4,%edx + imul %eax,%ecx + addl %edx,%ecx + mull f2 + add %ecx,%edx + .Lqwordmulready: + movl %eax,r + movl %edx,r+4 + end; + mulqword:=r; + end + else +{$endif i386} + begin + mulqword:=0; + bitpos:=1; + + // store f1 for overflow checking + _f1:=f1; + + for l:=0 to 63 do + begin + if (f2 and bitpos)<>0 then + mulqword:=mulqword+f1; + + f1:=f1 shl 1; + bitpos:=bitpos shl 1; + end; + + { if one of the operands is greater than the result an } + { overflow occurs } + if checkoverflow and ((_f1>mulqword) or (f2>mulqword)) then + HandleErrorFrame(215,get_frame); + end; + end; + + { multiplies two int64 .... + fpuint64 = false: + ... using the the qword multiplication + fpuint64 = true: + ... using the comp multiplication + the longbool for checkoverflow avoids a misaligned stack + } + function mulint64(f1,f2 : int64;checkoverflow : longbool) : int64;[public,alias: 'FPC_MUL_INT64']; + + var + sign : boolean; + q1,q2,q3 : qword; + c : comp; + + begin + { can the fpu do the work ? } + if fpuint64 and not(checkoverflow) then + begin + // the c:=comp(...) is necessary to shut up the compiler + c:=comp(comp(f1)*comp(f2)); + mulint64:=int64(c); + end + else + begin + sign:=false; + if f1<0 then + begin + sign:=not(sign); + q1:=qword(-f1); + end + else + q1:=f1; + if f2<0 then + begin + sign:=not(sign); + q2:=qword(-f2); + end + else + q2:=f2; + { the q1*q2 is coded as call to mulqword } + q3:=q1*q2; + + if checkoverflow and ((q1>q3) or (q2>q3) or + { the bit 63 can be only set if we have $80000000 00000000 } + { and sign is true } + ((tqwordrec(q3).high and $80000000)<>0) and + ((q3<>(qword(1) shl 63)) or not(sign)) + ) then + HandleErrorFrame(215,get_frame); + + if sign then + mulint64:=-q3 + else + mulint64:=q3; + end; + end; + + procedure qword_str(value : qword;var s : string); + + var + hs : string; + + begin + hs:=''; + repeat + hs:=chr(longint(value mod 10)+48)+hs; + value:=value div 10; + until value=0; + s:=hs; + end; + + procedure int64_str(value : int64;var s : string); + + var + hs : string; + q : qword; + + begin + if value<0 then + begin + q:=qword(-value); + qword_str(q,hs); + s:='-'+hs; + end + else + qword_str(qword(value),s); + end; + + procedure int_str_qword(v : qword;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; + + begin + qword_str(v,s); + if length(s)length(s) then + exit; + if negative and (s='-9223372036854775808') then + begin + Code:=0; + ValInt64:=Int64($80000000) shl 32; + exit; + end; + + while Code<=Length(s) do + begin + case s[Code] of + '0'..'9' : u:=Ord(S[Code])-Ord('0'); + 'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10); + 'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10); + else + u:=16; + end; + Prev:=Temp; + Temp:=Temp*Int64(base); + if (Temp= base) Then + Begin + ValInt64:=0; + Exit + End; + prev:=temp; + Temp:=Temp+u; + if prev>temp then + begin + ValInt64:=0; + exit; + end; + inc(code); + end; + code:=0; + ValInt64:=Temp; + If Negative Then + ValInt64:=-ValInt64; + end; + + + Function ValQWord(Const S: ShortString; var Code: ValSInt): QWord; [public, alias:'FPC_VAL_QWORD_SHORTSTR']; + var + u, prev: QWord; + base : byte; + negative : boolean; + begin + ValQWord:=0; + Code:=InitVal(s,negative,base); + If Negative or (Code>length(s)) Then + Exit; + while Code<=Length(s) do + begin + case s[Code] of + '0'..'9' : u:=Ord(S[Code])-Ord('0'); + 'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10); + 'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10); + else + u:=16; + end; + prev := ValQWord; + ValQWord:=ValQWord*QWord(base); + If (prev>ValQWord) or (u>=base) Then + Begin + ValQWord := 0; + Exit + End; + prev:=ValQWord; + ValQWord:=ValQWord+u; + if prev>ValQWord then + begin + ValQWord:=0; + exit; + end; + inc(code); + end; + code := 0; + end; + + +{ + $Log: not supported by cvs2svn $ + Revision 1.20 2000/03/17 21:27:56 jonas + * fixed declaration of val_int64 (removed destsize parameter) + * fixed val_int64 and val_qword so they reject invalid input + (u >= base) + * when reading a number, invalid input is removed from the input + buffer (+ it should be faster as well) + + Revision 1.19 2000/02/09 22:19:24 florian + + helper routine for mod added + + Revision 1.18 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.17 2000/01/27 15:43:02 florian + * improved qword*qword code, if no overflow checking is done + + Revision 1.16 2000/01/23 12:27:39 florian + * int64/int64 and int64*int64 is now done by the fpu if possible + + Revision 1.15 2000/01/23 12:22:37 florian + * reading of 64 bit type implemented + + Revision 1.14 2000/01/07 16:41:34 daniel + * copyright 2000 +} diff --git a/befpc/rtl/inc/lineinfo.pp b/befpc/rtl/inc/lineinfo.pp new file mode 100644 index 0000000..9c426a0 --- /dev/null +++ b/befpc/rtl/inc/lineinfo.pp @@ -0,0 +1,679 @@ +{ + $Id: lineinfo.pp,v 1.1.1.1 2001-07-23 17:17:35 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 2000 by Peter Vreman + + Stabs Line Info Retriever + + 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 lineinfo; +interface + +{$IFDEF OS2} + {$DEFINE EMX} (* EMX is the only possibility under OS/2 at the moment *) +{$ENDIF OS2} + +{ This is very important as this code can be called + from inside the RTE 202 error PM } +{$ifndef linux} + {$S-} +{$endif} + +procedure GetLineInfo(addr:longint;var func,source:string;var line:longint); + + +implementation + +uses + strings; + +const + N_Function = $24; + N_TextLine = $44; + N_DataLine = $46; + N_BssLine = $48; + N_SourceFile = $64; + N_IncludeFile = $84; + + maxstabs = 40; { size of the stabs buffer } + { GDB after 4.18 uses offset to function begin + in text section but OS/2 version still uses 4.16 PM } + StabsFunctionRelative : boolean = true; + +type + pstab=^tstab; + tstab=packed record + strpos : longint; + ntype : byte; + nother : byte; + ndesc : word; + nvalue : longint; + end; + +{ We use static variable so almost no stack is required, and is thus + more safe when an error has occured in the program } +var + opened : boolean; { set if the file is already open } + f : file; { current file } + stabcnt, { amount of stabs } + stabofs, { absolute stab section offset in executable } + stabstrofs : longint; { absolute stabstr section offset in executable } + dirlength : longint; { length of the dirctory part of the source file } + stabs : array[0..maxstabs-1] of tstab; { buffer } + funcstab, { stab with current function info } + linestab, { stab with current line info } + dirstab, { stab with current directory info } + filestab : tstab; { stab with current file info } + + +{**************************************************************************** + Executable Loaders +****************************************************************************} + +{$ifdef go32v2} +function LoadGo32Coff:boolean; +type + tcoffheader=packed record + mach : word; + nsects : word; + time : longint; + sympos : longint; + syms : longint; + opthdr : word; + flag : word; + other : array[0..27] of byte; + end; + tcoffsechdr=packed record + name : array[0..7] of char; + vsize : longint; + rvaofs : longint; + datalen : longint; + datapos : longint; + relocpos : longint; + lineno1 : longint; + nrelocs : word; + lineno2 : word; + flags : longint; + end; +var + coffheader : tcoffheader; + coffsec : tcoffsechdr; + i : longint; +begin + LoadGo32Coff:=false; + stabofs:=-1; + stabstrofs:=-1; + { read and check header } + if filesize(f)<2048+sizeof(tcoffheader) then + exit; + seek(f,2048); + blockread(f,coffheader,sizeof(tcoffheader)); + if coffheader.mach<>$14c then + exit; + { read section info } + for i:=1to coffheader.nSects do + begin + blockread(f,coffsec,sizeof(tcoffsechdr)); + if (coffsec.name[4]='b') and + (coffsec.name[1]='s') and + (coffsec.name[2]='t') then + begin + if (coffsec.name[5]='s') and + (coffsec.name[6]='t') then + stabstrofs:=coffsec.datapos+2048 + else + begin + stabofs:=coffsec.datapos+2048; + stabcnt:=coffsec.datalen div sizeof(tstab); + end; + end; + end; + LoadGo32Coff:=(stabofs<>-1) and (stabstrofs<>-1); +end; +{$endif Go32v2} + + +{$ifdef win32} +function LoadPeCoff:boolean; +type + tdosheader = packed record + e_magic : word; + e_cblp : word; + e_cp : word; + e_crlc : word; + e_cparhdr : word; + e_minalloc : word; + e_maxalloc : word; + e_ss : word; + e_sp : word; + e_csum : word; + e_ip : word; + e_cs : word; + e_lfarlc : word; + e_ovno : word; + e_res : array[0..3] of word; + e_oemid : word; + e_oeminfo : word; + e_res2 : array[0..9] of word; + e_lfanew : longint; + end; + tpeheader = packed record + PEMagic : longint; + Machine : word; + NumberOfSections : word; + TimeDateStamp : longint; + PointerToSymbolTable : longint; + NumberOfSymbols : longint; + SizeOfOptionalHeader : word; + Characteristics : word; + Magic : word; + MajorLinkerVersion : byte; + MinorLinkerVersion : byte; + SizeOfCode : longint; + SizeOfInitializedData : longint; + SizeOfUninitializedData : longint; + AddressOfEntryPoint : longint; + BaseOfCode : longint; + BaseOfData : longint; + ImageBase : longint; + SectionAlignment : longint; + FileAlignment : longint; + MajorOperatingSystemVersion : word; + MinorOperatingSystemVersion : word; + MajorImageVersion : word; + MinorImageVersion : word; + MajorSubsystemVersion : word; + MinorSubsystemVersion : word; + Reserved1 : longint; + SizeOfImage : longint; + SizeOfHeaders : longint; + CheckSum : longint; + Subsystem : word; + DllCharacteristics : word; + SizeOfStackReserve : longint; + SizeOfStackCommit : longint; + SizeOfHeapReserve : longint; + SizeOfHeapCommit : longint; + LoaderFlags : longint; + NumberOfRvaAndSizes : longint; + DataDirectory : array[1..$80] of byte; + end; + tcoffsechdr=packed record + name : array[0..7] of char; + vsize : longint; + rvaofs : longint; + datalen : longint; + datapos : longint; + relocpos : longint; + lineno1 : longint; + nrelocs : word; + lineno2 : word; + flags : longint; + end; +var + dosheader : tdosheader; + peheader : tpeheader; + coffsec : tcoffsechdr; + i : longint; +begin + LoadPeCoff:=false; + stabofs:=-1; + stabstrofs:=-1; + { read and check header } + if filesize(f)$4550 then + exit; + { read section info } + for i:=1to peheader.NumberOfSections do + begin + blockread(f,coffsec,sizeof(tcoffsechdr)); + if (coffsec.name[4]='b') and + (coffsec.name[1]='s') and + (coffsec.name[2]='t') then + begin + if (coffsec.name[5]='s') and + (coffsec.name[6]='t') then + stabstrofs:=coffsec.datapos + else + begin + stabofs:=coffsec.datapos; + stabcnt:=coffsec.datalen div sizeof(tstab); + end; + end; + end; + LoadPeCoff:=(stabofs<>-1) and (stabstrofs<>-1); +end; +{$endif Win32} + + +{$IFDEF EMX} +function LoadEMXaout: boolean; +type + TDosHeader = packed record + e_magic : word; + e_cblp : word; + e_cp : word; + e_crlc : word; + e_cparhdr : word; + e_minalloc : word; + e_maxalloc : word; + e_ss : word; + e_sp : word; + e_csum : word; + e_ip : word; + e_cs : word; + e_lfarlc : word; + e_ovno : word; + e_res : array[0..3] of word; + e_oemid : word; + e_oeminfo : word; + e_res2 : array[0..9] of word; + e_lfanew : longint; + end; + TEmxHeader = packed record + Version: array [1..16] of char; + Bound: word; + AoutOfs: longint; + Options: array [1..42] of char; + end; + TAoutHeader = packed record + Magic: word; + Machine: byte; + Flags: byte; + TextSize: longint; + DataSize: longint; + BssSize: longint; + SymbSize: longint; + EntryPoint: longint; + TextRelocSize: longint; + DataRelocSize: longint; + end; +const + StartPageSize = $1000; +var + DosHeader: TDosHeader; + EmxHeader: TEmxHeader; + AoutHeader: TAoutHeader; + S4: string [4]; +begin + LoadEMXaout := false; + StabOfs := -1; + StabStrOfs := -1; +{ read and check header } + if FileSize (F) > SizeOf (DosHeader) then + begin + BlockRead (F, DosHeader, SizeOf (TDosHeader)); + Seek (F, DosHeader.e_cparhdr shl 4); + BlockRead (F, EmxHeader, SizeOf (TEmxHeader)); + S4 [0] := #4; + Move (EmxHeader.Version, S4 [1], 4); + if S4 = 'emx ' then + begin + Seek (F, EmxHeader.AoutOfs); + BlockRead (F, AoutHeader, SizeOf (TAoutHeader)); + + if AOutHeader.Magic=$10B then + StabOfs := StartPageSize + else + StabOfs :=EmxHeader.AoutOfs + SizeOf (TAoutHeader); + StabOfs := StabOfs + + AoutHeader.TextSize + + AoutHeader.DataSize + + AoutHeader.TextRelocSize + + AoutHeader.DataRelocSize; +(* I don't really know, where this "+ 4" comes from, *) +(* but it seems to be correct. :-) - TH *) +(* Maybe not PM *) + StabCnt := AoutHeader.SymbSize div SizeOf (TStab); + StabStrOfs := StabOfs + AoutHeader.SymbSize; + StabsFunctionRelative:=false; + LoadEMXaout := (StabOfs <> -1) and (StabStrOfs <> -1); + end; + end; +end; +{$ENDIF EMX} + + +{$ifdef linux} +function LoadElf32:boolean; +type + telf32header=packed record + magic0123 : longint; + file_class : byte; + data_encoding : byte; + file_version : byte; + padding : array[$07..$0f] of byte; + e_type : word; + e_machine : word; + e_version : longword; + e_entry : longword; // entrypoint + e_phoff : longword; // program header offset + e_shoff : longword; // sections header offset + e_flags : longword; + e_ehsize : word; // elf header size in bytes + e_phentsize : word; // size of an entry in the program header array + e_phnum : word; // 0..e_phnum-1 of entrys + e_shentsize : word; // size of an entry in sections header array + e_shnum : word; // 0..e_shnum-1 of entrys + e_shstrndx : word; // index of string section header + end; + telf32sechdr=packed record + sh_name : longword; + sh_type : longword; + sh_flags : longword; + sh_addr : longword; + sh_offset : longword; + sh_size : longword; + sh_link : longword; + sh_info : longword; + sh_addralign : longword; + sh_entsize : longword; + end; +var + elfheader : telf32header; + elfsec : telf32sechdr; + secnames : array[0..255] of char; + pname : pchar; + i : longint; +begin + LoadElf32:=false; + stabofs:=-1; + stabstrofs:=-1; + { read and check header } + if filesize(f)$464c457f then + exit; + if elfheader.e_shentsize<>sizeof(telf32sechdr) then + exit; + { read section names } + seek(f,elfheader.e_shoff+elfheader.e_shstrndx*sizeof(telf32sechdr)); + blockread(f,elfsec,sizeof(telf32sechdr)); + seek(f,elfsec.sh_offset); + blockread(f,secnames,sizeof(secnames)); + { read section info } + seek(f,elfheader.e_shoff); + for i:=1to elfheader.e_shnum do + begin + blockread(f,elfsec,sizeof(telf32sechdr)); + pname:=@secnames[elfsec.sh_name]; + if (pname[4]='b') and + (pname[1]='s') and + (pname[2]='t') then + begin + if (pname[5]='s') and + (pname[6]='t') then + stabstrofs:=elfsec.sh_offset + else + begin + stabofs:=elfsec.sh_offset; + stabcnt:=elfsec.sh_size div sizeof(tstab); + end; + end; + end; + LoadElf32:=(stabofs<>-1) and (stabstrofs<>-1); +end; +{$endif linux} + + +{**************************************************************************** + Executable Open/Close +****************************************************************************} + +procedure CloseStabs; +begin + close(f); + opened:=false; +end; + + +function OpenStabs:boolean; +var + ofm : word; +begin + OpenStabs:=false; + assign(f,paramstr(0)); + {$I-} + ofm:=filemode; + filemode:=$40; + reset(f,1); + filemode:=ofm; + {$I+} + if ioresult<>0 then + exit; + opened:=true; +{$ifdef go32v2} + if LoadGo32Coff then + begin + OpenStabs:=true; + exit; + end; +{$endif} +{$IFDEF EMX} + if LoadEMXaout then + begin + OpenStabs:=true; + exit; + end; +{$ENDIF EMX} +{$ifdef win32} + if LoadPECoff then + begin + OpenStabs:=true; + exit; + end; +{$endif} +{$ifdef linux} + if LoadElf32 then + begin + OpenStabs:=true; + exit; + end; +{$endif} + CloseStabs; +end; + + +procedure GetLineInfo(addr:longint;var func,source:string;var line:longint); +var + res : {$ifdef tp}integer{$else}longint{$endif}; + stabsleft, + stabscnt,i : longint; + found : boolean; + lastfunc : tstab; +begin + fillchar(func,high(func)+1,0); + fillchar(source,high(source)+1,0); + line:=0; + if not opened then + begin + if not OpenStabs then + exit; + end; + fillchar(funcstab,sizeof(tstab),0); + fillchar(filestab,sizeof(tstab),0); + fillchar(dirstab,sizeof(tstab),0); + fillchar(linestab,sizeof(tstab),0); + fillchar(lastfunc,sizeof(tstab),0); + found:=false; + seek(f,stabofs); + stabsleft:=stabcnt; + repeat + if stabsleft>maxstabs then + stabscnt:=maxstabs + else + stabscnt:=stabsleft; + blockread(f,stabs,stabscnt*sizeof(tstab),res); + stabscnt:=res div sizeof(tstab); + for i:=0 to stabscnt-1 do + begin + case stabs[i].ntype of + N_BssLine, + N_DataLine, + N_TextLine : + begin + if (stabs[i].ntype=N_TextLine) and StabsFunctionRelative then + inc(stabs[i].nvalue,lastfunc.nvalue); + if (stabs[i].nvalue<=addr) and + (stabs[i].nvalue>linestab.nvalue) then + begin + { if it's equal we can stop and take the last info } + if stabs[i].nvalue=addr then + found:=true + else + linestab:=stabs[i]; + end; + end; + N_Function : + begin + lastfunc:=stabs[i]; + if (stabs[i].nvalue<=addr) and + (stabs[i].nvalue>funcstab.nvalue) then + begin + funcstab:=stabs[i]; + fillchar(linestab,sizeof(tstab),0); + end; + end; + N_SourceFile, + N_IncludeFile : + begin + if (stabs[i].nvalue<=addr) and + (stabs[i].nvalue>=filestab.nvalue) then + begin + { if same value then the first one + contained the directory PM } + if stabs[i].nvalue=filestab.nvalue then + dirstab:=filestab + else + fillchar(dirstab,sizeof(tstab),0); + filestab:=stabs[i]; + fillchar(linestab,sizeof(tstab),0); + { if new file then func is not valid anymore PM } + if stabs[i].ntype=N_SourceFile then + begin + fillchar(funcstab,sizeof(tstab),0); + fillchar(lastfunc,sizeof(tstab),0); + end; + end; + end; + end; + end; + dec(stabsleft,stabscnt); + until found or (stabsleft=0); +{ get the line,source,function info } + line:=linestab.ndesc; + if dirstab.ntype<>0 then + begin + seek(f,stabstrofs+dirstab.strpos); + blockread(f,source[1],high(source)-1,res); + dirlength:=strlen(@source[1]); + source[0]:=chr(dirlength); + end + else + dirlength:=0; + if filestab.ntype<>0 then + begin + seek(f,stabstrofs+filestab.strpos); + blockread(f,source[dirlength+1],high(source)-(dirlength+1),res); + source[0]:=chr(strlen(@source[1])); + end; + if funcstab.ntype<>0 then + begin + seek(f,stabstrofs+funcstab.strpos); + blockread(f,func[1],high(func)-1,res); + func[0]:=chr(strlen(@func[1])); + i:=pos(':',func); + if i>0 then + Delete(func,i,255); + end; +end; + + +function StabBackTraceStr(addr:longint):string; +var + func, + source : string; + hs : string[32]; + line : longint; +begin + GetLineInfo(addr,func,source,line); +{ if there was an error with opening reset the hook to the system default } + if not Opened then + BackTraceStrFunc:=@SysBackTraceStr; +{ create string } + StabBackTraceStr:=' 0x'+HexStr(addr,8); + if func<>'' then + StabBackTraceStr:=StabBackTraceStr+' '+func; + if source<>'' then + begin + if func<>'' then + StabBackTraceStr:=StabBackTraceStr+', '; + if line<>0 then + begin + str(line,hs); + StabBackTraceStr:=StabBackTraceStr+' line '+hs; + end; + StabBackTraceStr:=StabBackTraceStr+' of '+source; + end; +end; + + +initialization + BackTraceStrFunc:=@StabBackTraceStr; + +finalization + if opened then + CloseStabs; + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.12 2000/06/22 18:36:18 peter + * removed notes + + Revision 1.11 2000/06/05 13:04:11 pierre + * StabOfs for OS2 changed, hopefully correct now + + Revision 1.10 2000/05/08 13:23:46 peter + * export function so ppl can use it in their own programs + + Revision 1.9 2000/04/20 13:03:41 pierre + * disable stack check in lineinfo + + Revision 1.8 2000/04/12 11:15:06 pierre + * reset funcstab when changing object + + Revision 1.7 2000/03/23 22:00:08 pierre + * fix for OS/2 hopefully + + Revision 1.6 2000/03/19 18:10:41 hajny + + added support for EMX + + Revision 1.5 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.4 2000/02/08 15:23:02 pierre + * fix for directories included in stabsinfo + + Revision 1.3 2000/02/06 22:13:42 florian + * small typo for go32 fixed + + Revision 1.2 2000/02/06 19:14:22 peter + * linux elf support + + Revision 1.1 2000/02/06 17:19:22 peter + * lineinfo unit added which uses stabs to get lineinfo for backtraces + +} \ No newline at end of file diff --git a/befpc/rtl/inc/lstrings.pp b/befpc/rtl/inc/lstrings.pp new file mode 100644 index 0000000..e57759c --- /dev/null +++ b/befpc/rtl/inc/lstrings.pp @@ -0,0 +1,544 @@ +{ + $Id: lstrings.pp,v 1.1.1.1 2001-07-23 17:17:35 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team + + 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. + + **********************************************************************} +{ + This file contains the implementation of the LongString type, + and all things that are needed for it. + LongSTring is defined as a 'silent' pchar : + a pchar that points to : + + @ : Longint for size + @+4 : Unused byte; + @+5 : String; + So LS[i] is converted to the address @LS+4+i. + + pchar[0]-pchar[3] : Longint Size + pchar [4] : Unused + pchar[5] : String; + +} + +{$ifdef lstrings_unit} +{ Compile as a separate unit - development only} +unit lstrings; + +Interface + +Type longstring = pchar; + ShortString = string; + +{$i textrec.inc} + +{ Internal functions, will not appear in systemh.inc } + +Function NewLongString (Len : Longint) : LongString; +Procedure DisposeLongString (Var S : LongString; Len : Longint); +Procedure Long_String_Concat (Var S1 : LongString; Const S2 : LongString; maxlen : Longint); +Procedure Long_ShortString_Concat (Var S1: LongString; Const S2 : ShortString; maxlen : Longint); +Procedure Long_To_ShortString (Var S1 : ShortString; Const S2 : LongString; Maxlen : Longint); +Procedure Short_To_LongString (Var S1 : LongString; Const S2 : ShortString; Maxlen : Longint); +Function LongCompare (Const S1,S2 : Longstring): Longint; +Function LongCompare (Const S1 : LongString; Const S2 : ShortString): Longint; + +{ Public functions, Will end up in systemh.inc } + +Procedure SetLength (Var S : LongString; l : Longint); +Procedure Write_Text_LongString (Len : Longint; T : Textrec; Var S : LongString); +Function Length (Const S : LongString) : Longint; +Function Copy (Const S : LongString; Index,Size : Longint) : LongString; +Function Pos (Const Substr : LongString; Const Source : Longstring) : Longint; +Procedure Insert (Const Source : LongString; Var S : LongString; Index : Longint); +Procedure Delete (Var S : LongString; Index,Size: Longint); +Procedure Val (Const S : LongString; var R : real; Var Code : Integer); +{Procedure Val (Const S : LongString; var D : Double; Var Code : Integer);} +Procedure Val (Const S : LongString; var E : Extended; Code : Integer); +Procedure Val (Const S : LongString; var C : Cardinal; Code : Integer); +Procedure Val (Const S : LongString; var L : Longint; Var Code : Integer); +Procedure Val (Const S : LongString; var W : Word; Var Code : Integer); +Procedure Val (Const S : LongString; var I : Integer; Var Code : Integer); +Procedure Val (Const S : LongString; var B : Byte; Var Code : Integer); +Procedure Val (Const S : LongString; var SI : ShortInt; Var Code : Integer); +Procedure Str (Const R : Real;Len, fr : longint; Var S : LongString); +{Procedure Str (Const D : Double;Len,fr : longint; Var S : LongString);} +Procedure Str (Const E : Extended;Len,fr : longint; Var S : LongString); +Procedure Str (Const C : Cardinal;len : Longint; Var S : LongString); +Procedure Str (Const L : LongInt;len : longint; Var S : LongString); +Procedure Str (Const W : Word;len : longint; Var S : LongString); +Procedure Str (Const I : Integer;len : Longint; Var S : LongString); +Procedure Str (Const B : Byte; Len : longint; Var S : LongString); +Procedure Str (Const SI : ShortInt; Len : longint; Var S : LongString); + +Implementation + +{$endif} + +Type PLongint = ^Longint; + +{ --------------------------------------------------------------------- + Internal functions, not in interface. + ---------------------------------------------------------------------} + +Function NewLongString (Len : Longint) : LongString; +{ + Allocate a new string on the heap. + initialize it to zero length +} +Var P : Pointer; + +begin + GetMem(P,Len+5); + If P<>Nil then + begin + PLongint(P)^:=0; + pchar(P+4)^:=#0; + end; + NewLongString:=P; +end; + + + +Procedure DisposeLongString (Var S : LongString; Len : Longint); +{ + DeAllocates a LongString From the heap. +} +begin + FreeMem (Pointer(S),Len+5); +end; + + + +Procedure Long_String_Concat (Var S1 : LongString; Const S2 : LongString; maxlen : Longint); +{ + Concatenates 2 LongStrings : S1+S2 + If maxlen<>-1 then the result has maximal length maxlen. +} +Var Size : Longint; + +begin + Size:=PLongint(S2)^; + If maxlen<>-1 then + if Size+PLongint(S1)^>MaxLen then + Size:=Maxlen-PLongint(S1)^; + If Size<=0 then exit; + Move (pchar(S2)[5],pchar(S1)[PLongint(S1)^+5],Size); + PLongint(S1)^:=PLongint(S1)^+Size; +end; + + + +Procedure Long_ShortString_Concat (Var S1: LongString; Const S2 : ShortString; maxlen : Longint); +{ + Concatenates a long with a short string; : S2 + S2 + If maxlen<>-1 then the result has maximal length maxlen. +} +Var Size : Longint; + +begin + Size:=Byte(S2[0]); + if MaxLen<>-1 then + if Size+PLongint(S1)^>Maxlen then + Size:=Maxlen-PLongint(S1)^; + If Size<=0 then exit; + Move (S2[1],Pchar(S1)[PLongint(S1)^+5],Size); + PLongint(S1)^:=PLongint(S1)^+Size; +end; + + + +Procedure Long_To_ShortString (Var S1 : ShortString; Const S2 : LongString; Maxlen : Longint); +{ + Converts a LongString to a longstring; + if maxlen<>-1, the resulting string has maximal length maxlen + else a default length of 255 is taken. +} +Var Size : Longint; + +begin + Size:=PLongint(S2)^; + if maxlen=-1 then maxlen:=255; + If Size>maxlen then Size:=maxlen; + Move (Pchar(S2)[5],S1[1],Size); + S1[0]:=chr(Size); +end; + + + +Procedure Short_To_LongString (Var S1 : LongString; Const S2 : ShortString; Maxlen : Longint); +{ + Converts a ShortString to a LongString; + if maxlen<>-1 then the resulting string has length maxlen. +} +Var Size : Longint; + +begin + Size:=Byte(S2[0]); + if maxlen=-1 then maxlen:=255; + If Size>maxlen then Size:=maxlen; + Move (S2[1],pchar(S1)[5],Size); + PLongint(S1)^:=Size; +end; + + + +Function LongCompare (Const S1,S2 : Longstring): Longint; +{ + Compares 2 longStrings; + The result is + <0 if S10 if S1>S2 +} +Var i,MaxI,Temp : Longint; + +begin + Temp:=0; + i:=1; + MaxI:=PLongint(S1)^; + if MaxI>PLOngint(S2)^ then MaxI:=PLongint(S2)^; + While (i<=MaxI) and (Temp=0) do + begin + Temp:= Byte( Pchar(S1)[i+4] ) - Byte( Pchar(S2)[I+4] ); + inc(i); + end; + if temp=0 then temp:=Plongint(S1)^-PLongint(S2)^; + LongCompare:=Temp; +end; + + + +Function LongCompare (Const S1 : LongString; Const S2 : ShortString): Longint; +{ + Compares a longString with a ShortString; + The result is + <0 if S10 if S1>S2 +} +Var i,MaxI,Temp : Longint; + +begin + Temp:=0; + i:=1; + MaxI:=PLongint(S1)^; + if MaxI>byte(S2[0]) then MaxI:=Byte(S2[0]); + While (i<=MaxI) and (Temp=0) do + begin + Temp:=(Byte(Pchar(S1)[i+4])-Byte(S2[I])); + inc(i); + end; + LongCompare:=Temp; +end; + + + +Procedure Write_Text_LongString (Len : Longint; T : TextRec; Var S : LongString); +{ + Writes a LongString to the Text file T +} +begin +end; + + +{ --------------------------------------------------------------------- + Public functions, In interface. + ---------------------------------------------------------------------} + +Function Length (Const S : LongString) : Longint; + +begin + Length:=PLongint(S)^; +end; + + + +Procedure SetLength (Var S : LongString; l : Longint); + +begin + PLongint(S)^:=l; +end; + +Function Copy (Const S : LongString; Index,Size : Longint) : LongString; + +var ResultAddress : pchar; + +begin + ResultAddress:=NewLongString (Size); + if ResultAddress=Nil then + {We're in deep shit here !!} + exit; + dec(index); + if PLongint(S)^0 then + Move (Pchar(S)[Index+5],ResultAddress[5],Size) + Else + Size:=0; + PLongint(ResultAddress)^:=Size; + Copy:=ResultAddress +end; + + + +Function Pos (Const Substr : LongString; Const Source : Longstring) : Longint; + +var i,j : longint; + e : boolean; + s : longstring; + +begin + i := 0; + j := 0; + e := true; + if Plongint(substr)^=0 then e := false; + while (e) and (i <= length (Source) - length (substr)) do + begin + inc (i); + s :=copy(Source,i,length(Substr)); + if LongCompare(substr,s)=0 then + begin + j := i; + e := false; + end; + DisposeLongString(s,length(Substr)); + end; + pos := j; +end; + + + +Procedure Val (Const S : LongString; var R : real; Var Code : Integer); + +Var SS : String; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,R,Code); +end; + + +{ +Procedure Val (Const S : LongString; var D : Double; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + Val(SS,D,Code); +end; +} + + +Procedure Val (Const S : LongString; var E : Extended; Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,E,Code); +end; + + + +Procedure Val (Const S : LongString; var C : Cardinal; Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,C,Code); +end; + + + +Procedure Val (Const S : LongString; var L : Longint; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,L,Code); +end; + + + +Procedure Val (Const S : LongString; var W : Word; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,W,Code); +end; + + + +Procedure Val (Const S : LongString; var I : Integer; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,I,Code); +end; + + + +Procedure Val (Const S : LongString; var B : Byte; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,B,Code); +end; + + + +Procedure Val (Const S : LongString; var SI : ShortInt; Var Code : Integer); + +Var SS : ShortString; + +begin + Long_To_ShortString (SS,S,255); + System.Val(SS,SI,Code); +end; + + +Procedure Str (Const R : Real;Len,fr : Longint; Var S : LongString); + +Var SS : ShortString; + +begin + {int_Str_Real (R,Len,fr,SS);} + Short_To_LongString (S,SS,255); +end; + + +{ +Procedure Str (Const D : Double;Len,fr: Longint; Var S : LongString); + +Var SS : ShortString; + +begin + {int_Str_Double (D,Len,fr,SS);} + Short_To_LongString (S,SS,255); +end; +} + + +Procedure Str (Const E : Extended;Lenf,Fr: Longint; Var S : LongString); + +Var SS : ShortString; + +begin + {int_Str_Extended (E,Len,fr,SS);} + Short_To_LongString (S,SS,255); +end; + + + +Procedure Str (Const C : Cardinal;Len : Longint; Var S : LongString); + +begin +end; + + + +Procedure Str (Const L : Longint; Len : Longint; Var S : LongString); + +Var SS : ShortString; + +begin + {int_Str_Longint (L,Len,fr,SS);} + Short_To_LongString (S,SS,255); +end; + + + +Procedure Str (Const W : Word;Len : Longint; Var S : LongString); + +begin +end; + + + +Procedure Str (Const I : Integer;Len : Longint; Var S : LongString); + +begin +end; + + + +Procedure Str (Const B : Byte; Len : Longint; Var S : LongString); + +begin +end; + + + +Procedure Str (Const SI : ShortInt; Len : Longint; Var S : LongString); + +begin +end; + + + +Procedure Delete (Var S : LongString; Index,Size: Longint); + +begin + if index<=0 then + begin + Size:=Size+index-1; + index:=1; + end; + if (Index<=PLongint(s)^) and (Size>0) then + begin + if Size+Index>PLongint(s)^ then + Size:=PLongint(s)^-Index+1; + PLongint(s)^:=PLongint(s)^-Size; + if Index<=Length(s) then + Move(pchar(s)[Index+Size+4],pchar(s)[Index+4],Length(s)-Index+1); + end; +end; + +Procedure Insert (Const Source : LongString; Var S : LongString; Index : Longint); + +var s3,s4 : pchar; + +begin + if index <= 0 then index := 1; + s3 := longString(copy (s, index, length(s))); + if index > PLongint(s)^ then index := PLongint(S)^+1; + PLongint(s)^ := index - 1; + s4 :=Pchar ( NewLongString (Plongint(Source)^) ); + Long_String_Concat(LongString(s4),Source,-1); + Long_String_Concat(LongString(S4),LongString(s3),-1); + Long_String_Concat(S,LongString(S4),-1); + DisposeLongstring(LongString(S3),PLongint(S3)^); + DisposeLongString(LongString(S4),PLongint(S4)^); +end; + +{$ifdef lstrings_unit} +end. +{$endif} + +{ + $Log: not supported by cvs2svn $ + Revision 1.4 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.3 2000/01/07 16:41:34 daniel + * copyright 2000 + +} diff --git a/befpc/rtl/inc/makefile.inc b/befpc/rtl/inc/makefile.inc new file mode 100644 index 0000000..bf8ed5a --- /dev/null +++ b/befpc/rtl/inc/makefile.inc @@ -0,0 +1,22 @@ +# +# Here we set some variables, needed by all OSes. +# + +# System unit include files. These are composed from header and +# implementation files. + +SYSNAMES=systemh heaph mathh filerec textrec system real2str sstrings innr \ + file typefile text rtti heap astrings objpas objpash except int64 +SYSINCNAMES=$(addsuffix .inc,$(SYSNAMES)) + +# Other unit names which can be used for all systems +# +UNITNAMES=os_types +#UNITNAMES=getops +#UNITPPNAMES=$(addsuffix .pp,$(UNITNAMES)) + +# Other files... +#astrings.pp +#complex.pp +#cpne.pp +#lstrings.pp diff --git a/befpc/rtl/inc/mathh.inc b/befpc/rtl/inc/mathh.inc new file mode 100644 index 0000000..c09ffb2 --- /dev/null +++ b/befpc/rtl/inc/mathh.inc @@ -0,0 +1,76 @@ +{ + $Id: mathh.inc,v 1.1.1.1 2001-07-23 17:17:35 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl, + member of the Free Pascal development team + + 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. + + **********************************************************************} + + { declarations of the math routines } + +{$ifdef DEFAULT_EXTENDED} + function abs(d : extended) : extended; + function arctan(d : extended) : extended; + function cos(d : extended) : extended; + function exp(d : extended) : extended; + function frac(d : extended) : extended; + function int(d : extended) : extended; + function ln(d : extended) : extended; + function pi : extended; + function round(d : extended) : longint; + function sin(d : extended) : extended; + function sqr(d : extended) : extended; + function sqrt(d : extended) : extended; + function trunc(d : extended) : longint; + function power(bas,expo : extended) : extended; +{$else DEFAULT_EXTENDED} + function abs(d : real) : real; + function arctan(d : real) : real; + function cos(d : real) : real; + function exp(d : real) : real; + function frac(d : real) : real; + function int(d : real) : real; + function ln(d : real) : real; + function round(d : real) : longint; + function sin(d : real) : real; + function sqr(d : real) : real; + function sqrt(d : real) : real; + function trunc(d : real) : longint; + function power(bas,expo : real) : real; + function pi : real; +{$endif DEFAULT_EXTENDED} + + function power(bas,expo : longint) : longint; + +{$ifdef HASFIXED} + function sqrt(d : fixed) : fixed; + function Round(x: fixed): longint; + function sqr(d : fixed) : fixed; + function abs(d : fixed) : fixed; + function frac(d : fixed) : fixed; + function trunc(d : fixed) : longint; + function int(d : fixed) : fixed; +{$endif HASFIXED} + +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/02/15 14:36:57 florian + * disabled FIXED data type per default + + Revision 1.8 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.7 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.6 2000/01/07 16:32:24 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/inc/objects.pp b/befpc/rtl/inc/objects.pp new file mode 100644 index 0000000..085f6cc --- /dev/null +++ b/befpc/rtl/inc/objects.pp @@ -0,0 +1,2837 @@ +{ + $Id: objects.pp,v 1.1.1.1 2001-07-23 17:17:37 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Objects.pas clone for Free Pascal + + 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. + + **********************************************************************} + +{************[ SOURCE FILE OF FREE VISION ]****************} +{ } +{ System independent clone of objects.pas } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Parts Copyright (c) 1999-2000 by Florian Klaempfl } +{ fnklaemp@cip.ft.uni-erlangen.de } +{ } +{ Parts Copyright (c) 1999-2000 by Frank ZAGO } +{ zago@ecoledoc.ipc.fr } +{ } +{ Parts Copyright (c) 1999-2000 by MH Spiegel } +{ } +{ Parts Copyright (c) 1996, 1999-2000 by Leon de Boer } +{ ldeboer@ibm.net } +{ } +{ Free Vision project coordinator Balazs Scheidler } +{ bazsi@tas.vein.hu } +{ } +UNIT Objects; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{==== Select assembler ==============================================} +{$IFDEF CPU86} + {$ASMMODE ATT} +{$ENDIF} + +{$IFDEF CPU68} + {$ASMMODE MOT} +{$ENDIF} + +{==== Compiler directives ===========================================} +{$H-} { No ansistrings } +{$E+} { Emulation is on } +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$ifndef Linux} + {$S-} { Disable Stack Checking } +{$endif} +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ STREAM ERROR STATE MASKS } +{---------------------------------------------------------------------------} +CONST + stOk = 0; { No stream error } + stError = -1; { Access error } + stInitError = -2; { Initialize error } + stReadError = -3; { Stream read error } + stWriteError = -4; { Stream write error } + stGetError = -5; { Get object error } + stPutError = -6; { Put object error } + stSeekError = -7; { Seek error in stream } + stOpenError = -8; { Error opening stream } + +{---------------------------------------------------------------------------} +{ STREAM ACCESS MODE CONSTANTS } +{---------------------------------------------------------------------------} +CONST + stCreate = $3C00; { Create new file } + stOpenRead = $3D00; { Read access only } + stOpenWrite = $3D01; { Write access only } + stOpen = $3D02; { Read/write access } + +{---------------------------------------------------------------------------} +{ TCollection ERROR CODES } +{---------------------------------------------------------------------------} +CONST + coIndexError = -1; { Index out of range } + coOverflow = -2; { Overflow } + +{---------------------------------------------------------------------------} +{ VMT HEADER CONSTANT - HOPEFULLY WE CAN DROP THIS LATER } +{---------------------------------------------------------------------------} +CONST + vmtHeaderSize = 8; { VMT header size } + +CONST +{---------------------------------------------------------------------------} +{ MAXIUM DATA SIZES } +{---------------------------------------------------------------------------} +{$IFDEF FPC} + MaxBytes = 128*1024*1024; { Maximum data size } +{$ELSE} + MaxBytes = 16384; +{$ENDIF} + MaxWords = MaxBytes DIV SizeOf(Word); { Max word data size } + MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max ptr data size } + MaxCollectionSize = MaxBytes DIV SizeOf(Pointer); { Max collection size } + MaxTPCompatibleCollectionSize = 65520 div 4; + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ CHARACTER SET } +{---------------------------------------------------------------------------} +TYPE + TCharSet = SET Of Char; { Character set } + PCharSet = ^TCharSet; { Character set ptr } + +{---------------------------------------------------------------------------} +{ GENERAL ARRAYS } +{---------------------------------------------------------------------------} +TYPE + TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array } + PByteArray = ^TByteArray; { Byte array pointer } + + TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array } + PWordArray = ^TWordArray; { Word array pointer } + + TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array } + PPointerArray = ^TPointerArray; { Pointer array ptr } + +{---------------------------------------------------------------------------} +{ POINTER TO STRING } +{---------------------------------------------------------------------------} +TYPE + PString = ^String; { String pointer } + +{---------------------------------------------------------------------------} +{ OS dependent File type / consts } +{---------------------------------------------------------------------------} +{$IFDEF GO32V1} +type + FNameStr = String[79]; + THandle = Integer; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} +{$IFDEF GO32V2} +type + FNameStr = String; + THandle = Integer; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} +{$IFDEF Win32} +type + FNameStr = String; + THandle = Longint; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} +{$IFDEF OS2} +type + FNameStr = String; + THandle = Word; +const + MaxReadBytes = $7fffffff; + invalidhandle = $ffff; +{$ENDIF} +{$IFDEF LINUX} +type + FNameStr = String; + { values are words, though the OS calls return 32-bit values } + { to check (CEC) } + THandle = Longint; +const + MaxReadBytes = $7fffffff; + invalidhandle = -1; +{$ENDIF} +{$IFDEF BEOS} +type + FNameStr = String; + THandle = Longint; +const + MaxReadBytes = $7fffffff; + invalidhandle = -1; +{$ENDIF} +{$IFDEF AMIGA} +type + FNameStr = String; + THandle = Longint; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} +{$IFDEF ATARI} +type + FNameStr = String[79]; + THandle = Integer; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} +{$IFDEF MAC} +type + FNameStr = String; + THandle = Integer; +const + MaxReadBytes = $fffe; + invalidhandle = -1; +{$ENDIF} + +{---------------------------------------------------------------------------} +{ DOS ASCIIZ FILENAME } +{---------------------------------------------------------------------------} +TYPE + AsciiZ = Array [0..255] Of Char; { Filename array } + +{---------------------------------------------------------------------------} +{ BIT SWITCHED TYPE CONSTANTS } +{---------------------------------------------------------------------------} +TYPE + Sw_Word = Cardinal; { Long Word now } + Sw_Integer = LongInt; { Long integer now } + +{***************************************************************************} +{ PUBLIC RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TYPE CONVERSION RECORDS } +{---------------------------------------------------------------------------} +TYPE + WordRec = packed RECORD + Lo, Hi: Byte; { Word to bytes } + END; + + LongRec = packed RECORD + Lo, Hi: Word; { LongInt to words } + END; + + PtrRec = packed RECORD + Ofs, Seg: Word; { Pointer to words } + END; + +{---------------------------------------------------------------------------} +{ TStreamRec RECORD - STREAM OBJECT RECORD } +{---------------------------------------------------------------------------} +TYPE + PStreamRec = ^TStreamRec; { Stream record ptr } + TStreamRec = Packed RECORD + ObjType: Sw_Word; { Object type id } + VmtLink: pointer; { VMT link } + Load : Pointer; { Object load code } + Store: Pointer; { Object store code } + Next : PStreamRec; { Next stream record } + END; + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TPoint OBJECT - POINT OBJECT } +{---------------------------------------------------------------------------} +TYPE + PPoint = ^TPoint; + TPoint = OBJECT + X, Y: Sw_Integer; + END; + +{---------------------------------------------------------------------------} +{ TRect OBJECT - RECTANGLE OBJECT } +{---------------------------------------------------------------------------} + PRect = ^TRect; + TRect = OBJECT + A, B: TPoint; { Corner points } + FUNCTION Empty: Boolean; + FUNCTION Equals (R: TRect): Boolean; + FUNCTION Contains (P: TPoint): Boolean; + PROCEDURE Copy (R: TRect); + PROCEDURE Union (R: TRect); + PROCEDURE Intersect (R: TRect); + PROCEDURE Move (ADX, ADY: Sw_Integer); + PROCEDURE Grow (ADX, ADY: Sw_Integer); + PROCEDURE Assign (XA, YA, XB, YB: Sw_Integer); + END; + +{---------------------------------------------------------------------------} +{ TObject OBJECT - BASE ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TObject = OBJECT + CONSTRUCTOR Init; + PROCEDURE Free; + FUNCTION Is_Object(P:Pointer):Boolean; + DESTRUCTOR Done; Virtual; + END; + PObject = ^TObject; + +{ ******************************* REMARK ****************************** } +{ Two new virtual methods have been added to the object in the form of } +{ Close and Open. The main use here is in the Disk Based Descendants } +{ the calls open and close the given file so these objects can be } +{ used like standard files. Two new fields have also been added to } +{ speed up seeks on descendants. All existing code will compile and } +{ work completely normally oblivious to these new methods and fields. } +{ ****************************** END REMARK *** Leon de Boer, 15May96 * } + +{---------------------------------------------------------------------------} +{ TStream OBJECT - STREAM ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStream = OBJECT (TObject) + Status : Integer; { Stream status } + ErrorInfo : Integer; { Stream error info } + StreamSize: LongInt; { Stream current size } + Position : LongInt; { Current position } + TPCompatible : Boolean; + CONSTRUCTOR Init; + FUNCTION Get: PObject; + FUNCTION StrRead: PChar; + FUNCTION GetPos: Longint; Virtual; + FUNCTION GetSize: Longint; Virtual; + FUNCTION ReadStr: PString; + PROCEDURE Open (OpenMode: Word); Virtual; + PROCEDURE Close; Virtual; + PROCEDURE Reset; + PROCEDURE Flush; Virtual; + PROCEDURE Truncate; Virtual; + PROCEDURE Put (P: PObject); + PROCEDURE StrWrite (P: PChar); + PROCEDURE WriteStr (P: PString); + PROCEDURE Seek (Pos: LongInt); Virtual; + PROCEDURE Error (Code, Info: Integer); Virtual; + PROCEDURE Read (Var Buf; Count: Sw_Word); Virtual; + PROCEDURE Write (Var Buf; Count: Sw_Word); Virtual; + PROCEDURE CopyFrom (Var S: TStream; Count: Longint); + END; + PStream = ^TStream; + +{ ******************************* REMARK ****************************** } +{ A few minor changes to this object and an extra field added called } +{ FName which holds an AsciiZ array of the filename this allows the } +{ streams file to be opened and closed like a normal text file. All } +{ existing code should work without any changes. } +{ ****************************** END REMARK *** Leon de Boer, 19May96 * } + +{---------------------------------------------------------------------------} +{ TDosStream OBJECT - DOS FILE STREAM OBJECT } +{---------------------------------------------------------------------------} +TYPE + TDosStream = OBJECT (TStream) + Handle: THandle; { DOS file handle } + FName : AsciiZ; { AsciiZ filename } + CONSTRUCTOR Init (FileName: FNameStr; Mode: Word); + DESTRUCTOR Done; Virtual; + PROCEDURE Close; Virtual; + PROCEDURE Truncate; Virtual; + PROCEDURE Seek (Pos: LongInt); Virtual; + PROCEDURE Open (OpenMode: Word); Virtual; + PROCEDURE Read (Var Buf; Count: Sw_Word); Virtual; + PROCEDURE Write (Var Buf; Count: Sw_Word); Virtual; + END; + PDosStream = ^TDosStream; + +{ ******************************* REMARK ****************************** } +{ A few minor changes to this object and an extra field added called } +{ lastmode which holds the read or write condition last using the } +{ speed up buffer which helps speed up the flush, position and size } +{ functions. All existing code should work without any changes. } +{ ****************************** END REMARK *** Leon de Boer, 19May96 * } + +{---------------------------------------------------------------------------} +{ TBufStream OBJECT - BUFFERED DOS FILE STREAM } +{---------------------------------------------------------------------------} +TYPE + TBufStream = OBJECT (TDosStream) + LastMode: Byte; { Last buffer mode } + BufSize : Sw_Word; { Buffer size } + BufPtr : Sw_Word; { Buffer start } + BufEnd : Sw_Word; { Buffer end } + Buffer : PByteArray; { Buffer allocated } + CONSTRUCTOR Init (FileName: FNameStr; Mode, Size: Word); + DESTRUCTOR Done; Virtual; + PROCEDURE Close; Virtual; + PROCEDURE Flush; Virtual; + PROCEDURE Truncate; Virtual; + PROCEDURE Seek (Pos: LongInt); Virtual; + PROCEDURE Open (OpenMode: Word); Virtual; + PROCEDURE Read (Var Buf; Count: Sw_Word); Virtual; + PROCEDURE Write (Var Buf; Count: Sw_Word); Virtual; + END; + PBufStream = ^TBufStream; + +{ ******************************* REMARK ****************************** } +{ All the changes here should be completely transparent to existing } +{ code. Basically the memory blocks do not have to be base segments } +{ but this means our list becomes memory blocks rather than segments. } +{ The stream will also expand like the other standard streams!! } +{ ****************************** END REMARK *** Leon de Boer, 19May96 * } + +{---------------------------------------------------------------------------} +{ TMemoryStream OBJECT - MEMORY STREAM OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMemoryStream = OBJECT (TStream) + BlkCount: Sw_Word; { Number of segments } + BlkSize : Word; { Memory block size } + MemSize : LongInt; { Memory alloc size } + BlkList : PPointerArray; { Memory block list } + CONSTRUCTOR Init (ALimit: Longint; ABlockSize: Word); + DESTRUCTOR Done; Virtual; + PROCEDURE Truncate; Virtual; + PROCEDURE Read (Var Buf; Count: Sw_Word); Virtual; + PROCEDURE Write (Var Buf; Count: Sw_Word); Virtual; + PRIVATE + FUNCTION ChangeListSize (ALimit: Sw_Word): Boolean; + END; + PMemoryStream = ^TMemoryStream; + + +TYPE + TItemList = Array [0..MaxCollectionSize - 1] Of Pointer; + PItemList = ^TItemList; + +{ ******************************* REMARK ****************************** } +{ The changes here look worse than they are. The Sw_Integer simply } +{ switches between Integers and LongInts if switched between 16 and 32 } +{ bit code. All existing code will compile without any changes. } +{ ****************************** END REMARK *** Leon de Boer, 10May96 * } + +{---------------------------------------------------------------------------} +{ TCollection OBJECT - COLLECTION ANCESTOR OBJECT } +{---------------------------------------------------------------------------} + TCollection = OBJECT (TObject) + Items: PItemList; { Item list pointer } + Count: Sw_Integer; { Item count } + Limit: Sw_Integer; { Item limit count } + Delta: Sw_Integer; { Inc delta size } + CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION At (Index: Sw_Integer): Pointer; + FUNCTION IndexOf (Item: Pointer): Sw_Integer; Virtual; + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + FUNCTION LastThat (Test: Pointer): Pointer; + FUNCTION FirstThat (Test: Pointer): Pointer; + PROCEDURE Pack; + PROCEDURE FreeAll; + PROCEDURE DeleteAll; + PROCEDURE Free (Item: Pointer); + PROCEDURE Insert (Item: Pointer); Virtual; + PROCEDURE Delete (Item: Pointer); + PROCEDURE AtFree (Index: Sw_Integer); + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE AtDelete (Index: Sw_Integer); + PROCEDURE ForEach (Action: Pointer); + PROCEDURE SetLimit (ALimit: Sw_Integer); Virtual; + PROCEDURE Error (Code, Info: Integer); Virtual; + PROCEDURE AtPut (Index: Sw_Integer; Item: Pointer); + PROCEDURE AtInsert (Index: Sw_Integer; Item: Pointer); + PROCEDURE Store (Var S: TStream); + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + END; + PCollection = ^TCollection; + +{---------------------------------------------------------------------------} +{ TSortedCollection OBJECT - SORTED COLLECTION ANCESTOR } +{---------------------------------------------------------------------------} +TYPE + TSortedCollection = OBJECT (TCollection) + Duplicates: Boolean; { Duplicates flag } + CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION KeyOf (Item: Pointer): Pointer; Virtual; + FUNCTION IndexOf (Item: Pointer): Sw_Integer; Virtual; + FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual; + FUNCTION Search (Key: Pointer; Var Index: Sw_Integer): Boolean;Virtual; + PROCEDURE Insert (Item: Pointer); Virtual; + PROCEDURE Store (Var S: TStream); + END; + PSortedCollection = ^TSortedCollection; + +{---------------------------------------------------------------------------} +{ TStringCollection OBJECT - STRING COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStringCollection = OBJECT (TSortedCollection) + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual; + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + END; + PStringCollection = ^TStringCollection; + +{---------------------------------------------------------------------------} +{ TStrCollection OBJECT - STRING COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStrCollection = OBJECT (TSortedCollection) + FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual; + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + END; + PStrCollection = ^TStrCollection; + +{ ******************************* REMARK ****************************** } +{ This is a completely >> NEW << object which holds a collection of } +{ strings but does not alphabetically sort them. It is a very useful } +{ object for insert ordered list boxes! } +{ ****************************** END REMARK *** Leon de Boer, 15May96 * } + +{---------------------------------------------------------------------------} +{ TUnSortedStrCollection - UNSORTED STRING COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TUnSortedStrCollection = OBJECT (TStringCollection) + PROCEDURE Insert (Item: Pointer); Virtual; + END; + PUnSortedStrCollection = ^TUnSortedStrCollection; + +{---------------------------------------------------------------------------} +{ TResourceCollection OBJECT - RESOURCE COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TResourceCollection = OBJECT (TStringCollection) + FUNCTION KeyOf (Item: Pointer): Pointer; Virtual; + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + END; + PResourceCollection = ^TResourceCollection; + +{---------------------------------------------------------------------------} +{ TResourceFile OBJECT - RESOURCE FILE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TResourceFile = OBJECT (TObject) + Stream : PStream; { File as a stream } + Modified: Boolean; { Modified flag } + CONSTRUCTOR Init (AStream: PStream); + DESTRUCTOR Done; Virtual; + FUNCTION Count: Sw_Integer; + FUNCTION KeyAt (I: Sw_Integer): String; + FUNCTION Get (Key: String): PObject; + FUNCTION SwitchTo (AStream: PStream; Pack: Boolean): PStream; + PROCEDURE Flush; + PROCEDURE Delete (Key: String); + PROCEDURE Put (Item: PObject; Key: String); + PRIVATE + BasePos: LongInt; { Base position } + IndexPos: LongInt; { Index position } + Index: TResourceCollection; { Index collection } + END; + PResourceFile = ^TResourceFile; + +TYPE + TStrIndexRec = Packed RECORD + Key, Count, Offset: Word; + END; + + TStrIndex = Array [0..9999] Of TStrIndexRec; + PStrIndex = ^TStrIndex; + +{---------------------------------------------------------------------------} +{ TStringList OBJECT - STRING LIST OBJECT } +{---------------------------------------------------------------------------} + TStringList = OBJECT (TObject) + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION Get (Key: Sw_Word): String; + PRIVATE + Stream : PStream; + BasePos : Longint; + IndexSize: Sw_Word; + Index : PStrIndex; + PROCEDURE ReadStr (Var S: String; Offset, Skip: Sw_Word); + END; + PStringList = ^TStringList; + +{---------------------------------------------------------------------------} +{ TStrListMaker OBJECT - RESOURCE FILE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStrListMaker = OBJECT (TObject) + CONSTRUCTOR Init (AStrSize, AIndexSize: Sw_Word); + DESTRUCTOR Done; Virtual; + PROCEDURE Put (Key: Sw_Word; S: String); + PROCEDURE Store (Var S: TStream); + PRIVATE + StrPos : Sw_Word; + StrSize : Sw_Word; + Strings : PByteArray; + IndexPos : Sw_Word; + IndexSize: Sw_Word; + Index : PStrIndex; + Cur : TStrIndexRec; + PROCEDURE CloseCurrent; + END; + PStrListMaker = ^TStrListMaker; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DYNAMIC STRING INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewStr------------------------------------------------------------- +Allocates a dynamic string into memory. If S is nil, NewStr returns +a nil pointer, otherwise NewStr allocates Length(S)+1 bytes of memory +containing a copy of S, and returns a pointer to the string. +12Jun96 LdB +---------------------------------------------------------------------} +FUNCTION NewStr (Const S: String): PString; + +{-DisposeStr--------------------------------------------------------- +Disposes of a PString allocated by the function NewStr. +12Jun96 LdB +---------------------------------------------------------------------} +PROCEDURE DisposeStr (P: PString); + +PROCEDURE SetStr(VAR p:pString; CONST s:STRING); + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STREAM INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-Abstract----------------------------------------------------------- +Terminates program with a run-time error 211. When implementing +an abstract object type, call Abstract in those virtual methods that +must be overridden in descendant types. This ensures that any +attempt to use instances of the abstract object type will fail. +12Jun96 LdB +---------------------------------------------------------------------} +PROCEDURE Abstract; + +{-RegisterObjects---------------------------------------------------- +Registers the three standard objects TCollection, TStringCollection +and TStrCollection. +02Sep97 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterObjects; + +{-RegisterType------------------------------------------------------- +Registers the given object type with Free Vision's streams, creating +a list of known objects. Streams can only store and return these known +object types. Each registered object needs a unique stream registration +record, of type TStreamRec. +02Sep97 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterType (Var S: TStreamRec); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ GENERAL FUNCTION INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-LongMul------------------------------------------------------------ +Returns the long integer value of X * Y integer values. +04Sep97 LdB +---------------------------------------------------------------------} +FUNCTION LongMul (X, Y: Integer): LongInt; + +{-LongDiv------------------------------------------------------------ +Returns the integer value of long integer X divided by integer Y. +04Sep97 LdB +---------------------------------------------------------------------} +FUNCTION LongDiv (X: Longint; Y: Integer): Integer; + + +{***************************************************************************} +{ PUBLIC INITIALIZED VARIABLES } +{***************************************************************************} + + +CONST +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/OS2 PUBLIC VARIABLES } +{---------------------------------------------------------------------------} + StreamError: Pointer = Nil; { Stream error ptr } + DosStreamError: Word = $0; { Dos stream error } + DefaultTPCompatible: Boolean = false; + +{---------------------------------------------------------------------------} +{ STREAM REGISTRATION RECORDS } +{---------------------------------------------------------------------------} + +CONST + RCollection: TStreamRec = ( + ObjType: 50; + VmtLink: Ofs(TypeOf(TCollection)^); + Load: @TCollection.Load; + Store: @TCollection.Store); + + RStringCollection: TStreamRec = ( + ObjType: 51; + VmtLink: Ofs(TypeOf(TStringCollection)^); + Load: @TStringCollection.Load; + Store: @TStringCollection.Store); + + RStrCollection: TStreamRec = ( + ObjType: 69; + VmtLink: Ofs(TypeOf(TStrCollection)^); + Load: @TStrCollection.Load; + Store: @TStrCollection.Store); + + RStringList: TStreamRec = ( + ObjType: 52; + VmtLink: Ofs(TypeOf(TStringList)^); + Load: @TStringList.Load; + Store: Nil); + + RStrListMaker: TStreamRec = ( + ObjType: 52; + VmtLink: Ofs(TypeOf(TStrListMaker)^); + Load: Nil; + Store: @TStrListMaker.Store); + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ HELPER ROUTINES FOR CALLING } +{***************************************************************************} + +type + FramePointer = pointer; + PointerLocal = function(_EBP: FramePointer; Param1: pointer): pointer; + PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer; + PointerMethod = function(Obj: pointer; Param1: pointer): pointer; + +function PreviousFramePointer: FramePointer;assembler; +asm +{$ifdef i386} + movl (%ebp), %eax +{$endif} +{$ifdef m68k} + move.l a6,d0 +{$endif} +end ['EAX']; + + +function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer; +begin + asm +{$ifdef i386} + movl Obj, %esi +{$endif} +{$ifdef m68k} + move.l Obj, a5 +{$endif} + end; + CallPointerConstructor := PointerConstructor(Ctor)(VMT, Obj, Param1) +end; + + +function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer; +begin + asm +{$ifdef i386} + movl Obj, %esi +{$endif} +{$ifdef m68k} + move.l Obj, a5 +{$endif} + end; + CallPointerMethod := PointerMethod(Method)(Obj, Param1) +end; + + +function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer; +begin + CallPointerLocal := PointerLocal(Func)(Frame, Param1) +end; + + +{***************************************************************************} +{ PRIVATE INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/OS2 PRIVATE VARIABLES } +{---------------------------------------------------------------------------} +CONST + StreamTypes: PStreamRec = Nil; { Stream types reg } + +{***************************************************************************} +{ PRIVATE INTERNAL ROUTINES } +{***************************************************************************} + +{$I objinc.inc} + +{---------------------------------------------------------------------------} +{ RegisterError -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterError; +BEGIN + RunError(212); { Register error } +END; + + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRect OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +PROCEDURE CheckEmpty (Var Rect: TRect); +BEGIN + With Rect Do Begin + If (A.X >= B.X) OR (A.Y >= B.Y) Then Begin { Zero or reversed } + A.X := 0; { Clear a.x } + A.Y := 0; { Clear a.y } + B.X := 0; { Clear b.x } + B.Y := 0; { Clear b.y } + End; + End; +END; + +{--TRect--------------------------------------------------------------------} +{ Empty -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRect.Empty: Boolean; +BEGIN + Empty := (A.X >= B.X) OR (A.Y >= B.Y); { Empty result } +END; + +{--TRect--------------------------------------------------------------------} +{ Equals -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRect.Equals (R: TRect): Boolean; +BEGIN + Equals := (A.X = R.A.X) AND (A.Y = R.A.Y) AND + (B.X = R.B.X) AND (B.Y = R.B.Y); { Equals result } +END; + +{--TRect--------------------------------------------------------------------} +{ Contains -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRect.Contains (P: TPoint): Boolean; +BEGIN + Contains := (P.X >= A.X) AND (P.X < B.X) AND + (P.Y >= A.Y) AND (P.Y < B.Y); { Contains result } +END; + +{--TRect--------------------------------------------------------------------} +{ Copy -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Copy (R: TRect); +BEGIN + A := R.A; { Copy point a } + B := R.B; { Copy point b } +END; + +{--TRect--------------------------------------------------------------------} +{ Union -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Union (R: TRect); +BEGIN + If (R.A.X < A.X) Then A.X := R.A.X; { Take if smaller } + If (R.A.Y < A.Y) Then A.Y := R.A.Y; { Take if smaller } + If (R.B.X > B.X) Then B.X := R.B.X; { Take if larger } + If (R.B.Y > B.Y) Then B.Y := R.B.Y; { Take if larger } +END; + +{--TRect--------------------------------------------------------------------} +{ Intersect -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Intersect (R: TRect); +BEGIN + If (R.A.X > A.X) Then A.X := R.A.X; { Take if larger } + If (R.A.Y > A.Y) Then A.Y := R.A.Y; { Take if larger } + If (R.B.X < B.X) Then B.X := R.B.X; { Take if smaller } + If (R.B.Y < B.Y) Then B.Y := R.B.Y; { Take if smaller } + CheckEmpty(Self); { Check if empty } +END; + +{--TRect--------------------------------------------------------------------} +{ Move -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Move (ADX, ADY: Sw_Integer); +BEGIN + Inc(A.X, ADX); { Adjust A.X } + Inc(A.Y, ADY); { Adjust A.Y } + Inc(B.X, ADX); { Adjust B.X } + Inc(B.Y, ADY); { Adjust B.Y } +END; + +{--TRect--------------------------------------------------------------------} +{ Grow -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Grow (ADX, ADY: Sw_Integer); +BEGIN + Dec(A.X, ADX); { Adjust A.X } + Dec(A.Y, ADY); { Adjust A.Y } + Inc(B.X, ADX); { Adjust B.X } + Inc(B.Y, ADY); { Adjust B.Y } + CheckEmpty(Self); { Check if empty } +END; + +{--TRect--------------------------------------------------------------------} +{ Assign -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRect.Assign (XA, YA, XB, YB: Sw_Integer); +BEGIN + A.X := XA; { Hold A.X value } + A.Y := YA; { Hold A.Y value } + B.X := XB; { Hold B.X value } + B.Y := YB; { Hold B.Y value } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TObject OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +TYPE + DummyObject = OBJECT (TObject) { Internal object } + Data: RECORD END; { Helps size VMT link } + END; + +{ ******************************* REMARK ****************************** } +{ I Prefer this code because it self sizes VMT link rather than using a } +{ fixed record structure thus it should work on all compilers without a } +{ specific record to match each compiler. } +{ ****************************** END REMARK *** Leon de Boer, 10May96 * } + +{--TObject------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TObject.Init; +VAR LinkSize: LongInt; Dummy: DummyObject; +BEGIN + LinkSize := LongInt(@Dummy.Data)-LongInt(@Dummy); { Calc VMT link size } + FillChar(Pointer(LongInt(@Self)+LinkSize)^, + SizeOf(Self)-LinkSize, #0); { Clear data fields } +END; + +{--TObject------------------------------------------------------------------} +{ Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TObject.Free; +BEGIN + Dispose(PObject(@Self), Done); { Dispose of self } +END; + +{--TObject------------------------------------------------------------------} +{ Is_Object -> Platforms DOS/DPMI/WIN/OS2 - Checked 5Mar00 DM } +{---------------------------------------------------------------------------} +FUNCTION TObject.Is_Object(P:Pointer):Boolean; +TYPE + PVMT=^VMT; + VMT=RECORD + Size,NegSize:Longint; + ParentLink:PVMT; + END; +VAR SP:^PVMT; Q:PVMT; +BEGIN + SP:=@SELF; + Q:=SP^; + Is_Object:=False; + While Q<>Nil Do Begin + IF Q=P THEN Begin + Is_Object:=True; + Break; + End; + Q:=Q^.Parentlink; + End; +END; + +{--TObject------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TObject.Done; +BEGIN { Abstract method } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStream OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONSTRUCTOR TStream.Init; +BEGIN + TPCompatible := DefaultTPCompatible; +END; + +{--TStream------------------------------------------------------------------} +{ Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStream.Get: PObject; +VAR ObjType: Sw_Word; P: PStreamRec; ObjTypeWord: Word; +BEGIN + If TPCompatible Then Begin + { Read 16-bit word for TP compatibility. } + Read(ObjTypeWord, SizeOf(ObjTypeWord)); + ObjType := ObjTypeWord + End + else + Read(ObjType, SizeOf(ObjType)); { Read object type } + If (ObjType<>0) Then Begin { Object registered } + P := StreamTypes; { Current reg list } + While (P <> Nil) AND (P^.ObjType <> ObjType) { Find object type OR } + Do P := P^.Next; { Find end of chain } + If (P=Nil) Then Begin { Not registered } + Error(stGetError, ObjType); { Obj not registered } + Get := Nil; { Return nil pointer } + End Else + Get :=PObject( + CallPointerConstructor(P^.Load,Nil,P^.VMTLink, @Self)) { Call constructor } + End Else Get := Nil; { Return nil pointer } +END; + +{--TStream------------------------------------------------------------------} +{ StrRead -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStream.StrRead: PChar; +VAR L: Word; P: PChar; +BEGIN + Read(L, SizeOf(L)); { Read length } + If (L = 0) Then StrRead := Nil Else Begin { Check for empty } + GetMem(P, L + 1); { Allocate memory } + If (P <> Nil) Then Begin { Check allocate okay } + Read(P[0], L); { Read the data } + P[L] := #0; { Terminate with #0 } + End; + StrRead := P; { Return PChar } + End; +END; + +{--TStream------------------------------------------------------------------} +{ ReadStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStream.ReadStr: PString; +VAR L: Byte; P: PString; +BEGIN + Read(L, 1); { Read string length } + If (L > 0) Then Begin + GetMem(P, L + 1); { Allocate memory } + If (P <> Nil) Then Begin { Check allocate okay } + P^[0] := Char(L); { Hold length } + Read(P^[1], L); { Read string data } + End; + ReadStr := P; { Return string ptr } + End Else ReadStr := Nil; +END; + +{--TStream------------------------------------------------------------------} +{ GetPos -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStream.GetPos: LongInt; +BEGIN + If (Status=stOk) Then GetPos := Position { Return position } + Else GetPos := -1; { Stream in error } +END; + +{--TStream------------------------------------------------------------------} +{ GetSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStream.GetSize: LongInt; +BEGIN + If (Status=stOk) Then GetSize := StreamSize { Return stream size } + Else GetSize := -1; { Stream in error } +END; + +{--TStream------------------------------------------------------------------} +{ Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Close; +BEGIN { Abstract method } +END; + +{--TStream------------------------------------------------------------------} +{ Reset -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Reset; +BEGIN + Status := 0; { Clear status } + ErrorInfo := 0; { Clear error info } +END; + +{--TStream------------------------------------------------------------------} +{ Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Flush; +BEGIN { Abstract method } +END; + +{--TStream------------------------------------------------------------------} +{ Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Truncate; +BEGIN + Abstract; { Abstract error } +END; + +{--TStream------------------------------------------------------------------} +{ Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Put (P: PObject); +VAR ObjType: Sw_Word; Link: pointer; Q: PStreamRec; VmtPtr: ^pointer; + ObjTypeWord: Word; +BEGIN + VmtPtr := Pointer(P); { Xfer object to ptr } + if assigned(vmtptr) then + Link := VmtPtr^ { VMT link } + else + Link:=nil; + ObjType := 0; { Set objtype to zero } + If (P<>Nil) AND (Link<>Nil) Then Begin { We have a VMT link } + Q := StreamTypes; { Current reg list } + While (Q <> Nil) AND (Q^.VMTLink <> Link) { Find link match OR } + Do Q := Q^.Next; { Find end of chain } + If (Q=Nil) Then Begin { End of chain found } + Error(stPutError, 0); { Not registered error } + Exit; { Now exit } + End Else ObjType := Q^.ObjType; { Update object type } + End; + If TPCompatible Then Begin + ObjTypeWord := ObjType; + Write(ObjTypeWord, SizeOf(ObjTypeWord)) + end + else + Write(ObjType, SizeOf(ObjType)); { Write object type } + If (ObjType<>0) Then { Registered object } + CallPointerMethod(Q^.Store, P, @Self); +END; + +{--TStream------------------------------------------------------------------} +{ Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Seek (Pos: LongInt); +BEGIN + If (Status = stOk) Then Begin { Check status } + If (Pos < 0) Then Pos := 0; { Remove negatives } + If (Pos <= StreamSize) Then Position := Pos { If valid set pos } + Else Error(stSeekError, Pos); { Position error } + End; +END; + +{--TStream------------------------------------------------------------------} +{ StrWrite -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.StrWrite (P: PChar); +VAR L: Word; Q: PByteArray; +BEGIN + L := 0; { Preset zero size } + Q := PByteArray(P); { Transfer type } + If (Q <> Nil) Then While (Q^[L] <> 0) Do Inc(L); { PChar length } + Write(L, SizeOf(L)); { Store length } + If (P <> Nil) Then Write(P[0], L); { Write data } +END; + +{--TStream------------------------------------------------------------------} +{ WriteStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.WriteStr (P: PString); +CONST Empty: String[1] = ''; +BEGIN + If (P <> Nil) Then Write(P^, Length(P^) + 1) { Write string } + Else Write(Empty, 1); { Write empty string } +END; + +{--TStream------------------------------------------------------------------} +{ Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Open (OpenMode: Word); +BEGIN { Abstract method } +END; + +{--TStream------------------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Error (Code, Info: Integer); +TYPE TErrorProc = Procedure(Var S: TStream); +BEGIN + Status := Code; { Hold error code } + ErrorInfo := Info; { Hold error info } + If (StreamError <> Nil) Then + TErrorProc(StreamError)(Self); { Call error ptr } +END; + +{--TStream------------------------------------------------------------------} +{ Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Read (Var Buf; Count: Sw_Word); +BEGIN + Abstract; { Abstract error } +END; + +{--TStream------------------------------------------------------------------} +{ Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.Write (Var Buf; Count: Sw_Word); +BEGIN + Abstract; { Abstract error } +END; + +{--TStream------------------------------------------------------------------} +{ CopyFrom -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStream.CopyFrom (Var S: TStream; Count: Longint); +VAR W: Word; Buffer: Array[0..1023] of Byte; +BEGIN + While (Count > 0) Do Begin + If (Count > SizeOf(Buffer)) Then { To much data } + W := SizeOf(Buffer) Else W := Count; { Size to transfer } + S.Read(Buffer, W); { Read from stream } + Write(Buffer, W); { Write to stream } + Dec(Count, W); { Dec write count } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TDosStream OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TDosStream---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDosStream.Init (FileName: FNameStr; Mode: Word); +VAR Success: Integer; +BEGIN + Inherited Init; { Call ancestor } + FileName := FileName+#0; { Make asciiz } + Move(FileName[1], FName, Length(FileName)); { Create asciiz name } + Handle := FileOpen(FName, Mode); { Open the file } + If (Handle <> 0) Then Begin { Handle valid } + Success := SetFilePos(Handle, 0, 2, StreamSize); { Locate end of file } + If (Success = 0) Then + Success := SetFilePos(Handle, 0, 0, Position); { Reset to file start } + End Else Success := 103; { Open file failed } + If (Handle = 0) OR (Success <> 0) Then Begin { Open failed } + Handle := InvalidHandle; { Reset invalid handle } + Error(stInitError, Success); { Call stream error } + End; +END; + +{--TDosStream---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TDosStream.Done; +BEGIN + If (Handle <> InvalidHandle) Then FileClose(Handle); { Close the file } + Inherited Done; { Call ancestor } +END; + +{--TDosStream---------------------------------------------------------------} +{ Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Close; +BEGIN + If (Handle <> InvalidHandle) Then FileClose(Handle); { Close the file } + Position := 0; { Zero the position } + Handle := invalidhandle; { Handle now invalid } +END; + +{--TDosStream---------------------------------------------------------------} +{ Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Truncate; +VAR Success: Integer; +BEGIN + If (Status=stOk) Then Begin { Check status okay } + Success := SetFileSize(Handle, Position); { Truncate file } + If (Success = 0) Then StreamSize := Position { Adjust size } + Else Error(stError, Success); { Identify error } + End; +END; + +{--TDosStream---------------------------------------------------------------} +{ Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Seek (Pos: LongInt); +VAR Success: Integer; Li: LongInt; +BEGIN + If (Status=stOk) Then Begin { Check status okay } + If (Pos < 0) Then Pos := 0; { Negatives removed } + If (Handle = InvalidHandle) Then Success := 103 Else { File not open } + Success := SetFilePos(Handle, Pos, 0, Li); { Set file position } + If ((Success = -1) OR (Li <> Pos)) Then Begin { We have an error } + If (Success = -1) Then Error(stSeekError, 0) { General seek error } + Else Error(stSeekError, Success); { Specific seek error } + End Else Position := Li; { Adjust position } + End; +END; + +{--TDosStream---------------------------------------------------------------} +{ Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Open (OpenMode: Word); +BEGIN + If (Status=stOk) Then Begin { Check status okay } + If (Handle = InvalidHandle) Then Begin { File not open } + Handle := FileOpen(FName, OpenMode); { Open the file } + Position := 0; { Reset position } + If (Handle=0) Then Begin { File open failed } + Handle := InvalidHandle; { Reset handle } + Error(stOpenError, 103); { Call stream error } + End; + End Else Error(stOpenError, 104); { File already open } + End; +END; + +{--TDosStream---------------------------------------------------------------} +{ Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Read (Var Buf; Count: Sw_Word); +VAR Success: Integer; W, BytesMoved: Sw_Word; P: PByteArray; +BEGIN + If (Position + Count > StreamSize) Then { Insufficient data } + Error(stReadError, 0); { Read beyond end!!! } + If (Handle = InvalidHandle) Then Error(stReadError, 103); { File not open } + P := @Buf; { Transfer address } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + W := Count; { Transfer read size } + If (Count>MaxReadBytes) Then + W := MaxReadBytes; { Cant read >64K bytes } + Success := FileRead(Handle, P^, W, BytesMoved); { Read from file } + If ((Success<>0) OR (BytesMoved<>W)) Then Begin { Error was detected } + BytesMoved := 0; { Clear bytes moved } + If (Success <> 0) Then + Error(stReadError, Success) { Specific read error } + Else Error(stReadError, 0); { Non specific error } + End; + Inc(Position, BytesMoved); { Adjust position } + P := Pointer(LongInt(P) + BytesMoved); { Adjust buffer ptr } + Dec(Count, BytesMoved); { Adjust count left } + End; + If (Count<>0) Then FillChar(P^, Count, #0); { Error clear buffer } +END; + +{--TDosStream---------------------------------------------------------------} +{ Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 16May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDosStream.Write (Var Buf; Count: Sw_Word); +VAR Success: Integer; W, BytesMoved: Sw_Word; P: PByteArray; +BEGIN + If (Handle = InvalidHandle) Then Error(stWriteError, 103); { File not open } + P := @Buf; { Transfer address } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + W := Count; { Transfer read size } + If (Count>MaxReadBytes) Then + W := MaxReadBytes; { Cant read >64K bytes } + Success := FileWrite(Handle, P^, W, BytesMoved); { Write to file } + If ((Success<>0) OR (BytesMoved<>W)) Then Begin { Error was detected } + BytesMoved := 0; { Clear bytes moved } + If (Success<>0) Then + Error(stWriteError, Success) { Specific write error } + Else Error(stWriteError, 0); { Non specific error } + End; + Inc(Position, BytesMoved); { Adjust position } + P := Pointer(LongInt(P) + BytesMoved); { Transfer address } + Dec(Count, BytesMoved); { Adjust count left } + If (Position > StreamSize) Then { File expanded } + StreamSize := Position; { Adjust stream size } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TBufStream OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TBufStream---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TBufStream.Init (FileName: FNameStr; Mode, Size: Word); +BEGIN + Inherited Init(FileName, Mode); { Call ancestor } + BufSize := Size; { Hold buffer size } + If (Size<>0) Then GetMem(Buffer, Size); { Allocate buffer } + If (Buffer=Nil) Then Error(stInitError, 0); { Buffer allocate fail } +END; + +{--TBufStream---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TBufStream.Done; +BEGIN + Flush; { Flush the file } + Inherited Done; { Call ancestor } + If (Buffer<>Nil) Then FreeMem(Buffer, BufSize); { Release buffer } +END; + +{--TBufStream---------------------------------------------------------------} +{ Close -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Close; +BEGIN + Flush; { Flush the buffer } + Inherited Close; { Call ancestor } +END; + +{--TBufStream---------------------------------------------------------------} +{ Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Flush; +VAR Success: Integer; W: Sw_Word; +BEGIN + If (LastMode=2) AND (BufPtr<>0) Then Begin { Must update file } + If (Handle = InvalidHandle) Then Success := 103 { File is not open } + Else Success := FileWrite(Handle, Buffer^, + BufPtr, W); { Write to file } + If (Success<>0) OR (W<>BufPtr) Then { We have an error } + If (Success=0) Then Error(stWriteError, 0) { Unknown write error } + Else Error(stError, Success); { Specific write error } + End; + BufPtr := 0; { Reset buffer ptr } + BufEnd := 0; { Reset buffer end } +END; + +{--TBufStream---------------------------------------------------------------} +{ Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Truncate; +BEGIN + Flush; { Flush buffer } + Inherited Truncate; { Truncate file } +END; + +{--TBufStream---------------------------------------------------------------} +{ Seek -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Seek (Pos: LongInt); +BEGIN + If (Status=stOk) Then Begin { Check status okay } + If (Position<>Pos) Then Begin { Move required } + Flush; { Flush the buffer } + Inherited Seek(Pos); { Call ancestor } + End; + End; +END; + +{--TBufStream---------------------------------------------------------------} +{ Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Open (OpenMode: Word); +BEGIN + If (Status=stOk) Then Begin { Check status okay } + BufPtr := 0; { Clear buffer start } + BufEnd := 0; { Clear buffer end } + Inherited Open(OpenMode); { Call ancestor } + End; +END; + +{--TBufStream---------------------------------------------------------------} +{ Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Read (Var Buf; Count: Sw_Word); +VAR Success: Integer; W, Bw: Sw_Word; P: PByteArray; +BEGIN + If (Position + Count > StreamSize) Then { Read pas stream end } + Error(stReadError, 0); { Call stream error } + If (Handle = InvalidHandle) Then Error(stReadError, 103); { File not open } + P := @Buf; { Transfer address } + If (LastMode=2) Then Flush; { Flush write buffer } + LastMode := 1; { Now set read mode } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + If (BufPtr=BufEnd) Then Begin { Buffer is empty } + If (Position + BufSize > StreamSize) Then + Bw := StreamSize - Position { Amount of file left } + Else Bw := BufSize; { Full buffer size } + Success := FileRead(Handle, Buffer^, Bw, W); { Read from file } + If ((Success<>0) OR (Bw<>W)) Then Begin { Error was detected } + If (Success<>0) Then + Error(stReadError, Success) { Specific read error } + Else Error(stReadError, 0); { Non specific error } + End Else Begin + BufPtr := 0; { Reset BufPtr } + BufEnd := W; { End of buffer } + End; + End; + If (Status=stOk) Then Begin { Status still okay } + W := BufEnd - BufPtr; { Space in buffer } + If (Count < W) Then W := Count; { Set transfer size } + Move(Buffer^[BufPtr], P^, W); { Data from buffer } + Dec(Count, W); { Reduce count } + Inc(BufPtr, W); { Advance buffer ptr } + P := Pointer(LongInt(P) + W); { Transfer address } + Inc(Position, W); { Advance position } + End; + End; + If (Status<>stOk) AND (Count>0) Then + FillChar(P^, Count, #0); { Error clear buffer } +END; + +{--TBufStream---------------------------------------------------------------} +{ Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 17May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBufStream.Write (Var Buf; Count: Sw_Word); +VAR Success: Integer; W: Sw_Word; P: PByteArray; +BEGIN + If (Handle = InvalidHandle) Then Error(stWriteError, 103); { File not open } + If (LastMode=1) Then Flush; { Flush read buffer } + LastMode := 2; { Now set write mode } + P := @Buf; { Transfer address } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + If (BufPtr=BufSize) Then Begin { Buffer is full } + Success := FileWrite(Handle, Buffer^, BufSize, + W); { Write to file } + If (Success<>0) OR (W<>BufSize) Then { We have an error } + If (Success=0) Then Error(stWriteError, 0) { Unknown write error } + Else Error(stError, Success); { Specific write error } + BufPtr := 0; { Reset BufPtr } + End; + If (Status=stOk) Then Begin { Status still okay } + W := BufSize - BufPtr; { Space in buffer } + If (Count < W) Then W := Count; { Transfer size } + Move(P^, Buffer^[BufPtr], W); { Data to buffer } + Dec(Count, W); { Reduce count } + Inc(BufPtr, W); { Advance buffer ptr } + P := Pointer(LongInt(P) + W); { Transfer address } + Inc(Position, W); { Advance position } + If (Position > StreamSize) Then { File has expanded } + StreamSize := Position; { Update new size } + End; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMemoryStream OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMemoryStream------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMemoryStream.Init (ALimit: LongInt; ABlockSize: Word); +VAR W: Word; +BEGIN + Inherited Init; { Call ancestor } + If (ABlockSize=0) Then BlkSize := 8192 Else { Default blocksize } + BlkSize := ABlockSize; { Set blocksize } + If (ALimit = 0) Then W := 1 Else { At least 1 block } + W := (ALimit + BlkSize - 1) DIV BlkSize; { Blocks needed } + If NOT ChangeListSize(W) Then { Try allocate blocks } + Error(stInitError, 0); { Initialize error } +END; + +{--TMemoryStream------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMemoryStream.Done; +BEGIN + ChangeListSize(0); { Release all memory } + Inherited Done; { Call ancestor } +END; + +{--TMemoryStream------------------------------------------------------------} +{ Truncate -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMemoryStream.Truncate; +VAR W: Word; +BEGIN + If (Status=stOk) Then Begin { Check status okay } + If (Position = 0) Then W := 1 Else { At least one block } + W := (Position + BlkSize - 1) DIV BlkSize; { Blocks needed } + If ChangeListSize(W) Then StreamSize := Position { Set stream size } + Else Error(stError, 0); { Error truncating } + End; +END; + +{--TMemoryStream------------------------------------------------------------} +{ Read -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMemoryStream.Read (Var Buf; Count: Sw_Word); +VAR W, CurBlock, BlockPos: Word; Li: LongInt; P, Q: PByteArray; +BEGIN + If (Position + Count > StreamSize) Then { Insufficient data } + Error(stReadError, 0); { Read beyond end!!! } + P := @Buf; { Transfer address } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + CurBlock := Position DIV BlkSize; { Current block } + { * REMARK * - Do not shorten this, result can be > 64K } + Li := CurBlock; { Transfer current block } + Li := Li * BlkSize; { Current position } + { * REMARK END * - Leon de Boer } + BlockPos := Position - Li; { Current position } + W := BlkSize - BlockPos; { Current block space } + If (W > Count) Then W := Count; { Adjust read size } + Q := Pointer(LongInt(BlkList^[CurBlock]) + + BlockPos); { Calc pointer } + Move(Q^, P^, W); { Move data to buffer } + Inc(Position, W); { Adjust position } + P := Pointer(LongInt(P) + W); { Transfer address } + Dec(Count, W); { Adjust count left } + End; + If (Count<>0) Then FillChar(P^, Count, #0); { Error clear buffer } +END; + +{--TMemoryStream------------------------------------------------------------} +{ Write -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMemoryStream.Write (Var Buf; Count: Sw_Word); +VAR W, CurBlock, BlockPos: Word; Li: LongInt; P, Q: PByteArray; +BEGIN + If (Position + Count > MemSize) Then Begin { Expansion needed } + If (Position + Count = 0) Then W := 1 Else { At least 1 block } + W := (Position+Count+BlkSize-1) DIV BlkSize; { Blocks needed } + If NOT ChangeListSize(W) Then + Error(stWriteError, 0); { Expansion failed!!! } + End; + P := @Buf; { Transfer address } + While (Count>0) AND (Status=stOk) Do Begin { Check status & count } + CurBlock := Position DIV BlkSize; { Current segment } + { * REMARK * - Do not shorten this, result can be > 64K } + Li := CurBlock; { Transfer current block } + Li := Li * BlkSize; { Current position } + { * REMARK END * - Leon de Boer } + BlockPos := Position - Li; { Current position } + W := BlkSize - BlockPos; { Current block space } + If (W > Count) Then W := Count; { Adjust write size } + Q := Pointer(LongInt(BlkList^[CurBlock]) + + BlockPos); { Calc pointer } + Move(P^, Q^, W); { Transfer data } + Inc(Position, W); { Adjust position } + P := Pointer(LongInt(P) + W); { Transfer address } + Dec(Count, W); { Adjust count left } + If (Position > StreamSize) Then { File expanded } + StreamSize := Position; { Adjust stream size } + End; +END; + +{***************************************************************************} +{ TMemoryStream PRIVATE METHODS } +{***************************************************************************} + +{--TMemoryStream------------------------------------------------------------} +{ ChangeListSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMemoryStream.ChangeListSize (ALimit: Sw_Word): Boolean; +VAR I, W: Word; Li: LongInt; P: PPointerArray; + OldVal : Boolean; +BEGIN + If (ALimit <> BlkCount) Then Begin { Change is needed } + ChangeListSize := False; { Preset failure } + If (ALimit > MaxPtrs) Then Exit; { To many blocks req } + If (ALimit <> 0) Then Begin { Create segment list } + Li := ALimit * SizeOf(Pointer); { Block array size } + If (MaxAvail > Li) Then Begin + GetMem(P, Li); { Allocate memory } + FillChar(P^, Li, #0); { Clear the memory } + End Else Begin + OldVal:=ReturnNilIfGrowHeapFails; + ReturnNilIfGrowHeapFails:=true; + GetMem(P,Li); + ReturnNilIfGrowHeapFails:=OldVal; + If P = Nil Then Exit; + FillChar(P^, Li, #0); { Clear the memory } + End; { Insufficient memory } + If (BlkCount <> 0) AND (BlkList <> Nil) Then { Current list valid } + If (BlkCount <= ALimit) Then Move(BlkList^, + P^, BlkCount * SizeOf(Pointer)) Else { Move whole old list } + Move(BlkList^, P^, Li); { Move partial list } + End Else P := Nil; { No new block list } + If (ALimit < BlkCount) Then { Shrink stream size } + For W := BlkCount-1 DownTo ALimit Do + FreeMem(BlkList^[W], BlkSize); { Release memory block } + If (P <> Nil) AND (ALimit > BlkCount) Then Begin { Expand stream size } + For W := BlkCount To ALimit-1 Do Begin + If (MaxAvail < BlkSize) Then Begin { Check enough memory } + OldVal:=ReturnNilIfGrowHeapFails; + ReturnNilIfGrowHeapFails:=true; + GetMem(P^[W],BlkSize); + ReturnNilIfGrowHeapFails:=OldVal; + If P = Nil Then Begin + For I := BlkCount To W-1 Do + FreeMem(P^[I], BlkSize); { Free mem allocated } + FreeMem(P, Li); { Release memory } + Exit; + End { Now exit } + End Else GetMem(P^[W], BlkSize); { Allocate memory } + End; + End; + If (BlkCount <> 0) AND (BlkList<>Nil) Then + FreeMem(BlkList, BlkCount * SizeOf(Pointer)); { Release old list } + BlkList := P; { Hold new block list } + BlkCount := ALimit; { Hold new count } + { * REMARK * - Do not shorten this, result can be > 64K } + MemSize := BlkCount; { Block count } + MemSize := MemSize * BlkSize; { Current position } + { * REMARK END * - Leon de Boer } + End; + ChangeListSize := True; { Successful } +END; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TCollection--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCollection.Init (ALimit, ADelta: Sw_Integer); +BEGIN + Inherited Init; { Call ancestor } + Delta := ADelta; { Set increment } + SetLimit(ALimit); { Set limit } +END; + +{--TCollection--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCollection.Load (Var S: TStream); +VAR C, I: Sw_Integer; +BEGIN + If S.TPCompatible Then Begin + { I ignore endianness issues here. If endianness is different, + you can't expect binary compatible resources anyway. } + Count := 0; S.Read(Count, Sizeof(Word)); + Limit := 0; S.Read(Limit, Sizeof(Word)); + Delta := 0; S.Read(Delta, Sizeof(Word)) + End + Else Begin + S.Read(Count, Sizeof(Count)); { Read count } + S.Read(Limit, Sizeof(Limit)); { Read limit } + S.Read(Delta, Sizeof(Delta)); { Read delta } + End; + Items := Nil; { Clear item pointer } + C := Count; { Hold count } + I := Limit; { Hold limit } + Count := 0; { Clear count } + Limit := 0; { Clear limit } + SetLimit(I); { Set requested limit } + Count := C; { Set count } + For I := 0 To C-1 Do AtPut(I, GetItem(S)); { Get each item } +END; + +{--TCollection--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TCollection.Done; +BEGIN + FreeAll; { Free all items } + SetLimit(0); { Release all memory } +END; + +{--TCollection--------------------------------------------------------------} +{ At -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCollection.At (Index: Sw_Integer): Pointer; +BEGIN + If (Index < 0) OR (Index >= Count) Then Begin { Invalid index } + Error(coIndexError, Index); { Call error } + At := Nil; { Return nil } + End Else At := Items^[Index]; { Return item } +END; + +{--TCollection--------------------------------------------------------------} +{ IndexOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCollection.IndexOf (Item: Pointer): Sw_Integer; +VAR I: Sw_Integer; +BEGIN + If (Count>0) Then Begin { Count is positive } + For I := 0 To Count-1 Do { For each item } + If (Items^[I]=Item) Then Begin { Look for match } + IndexOf := I; { Return index } + Exit; { Now exit } + End; + End; + IndexOf := -1; { Return index } +END; + +{--TCollection--------------------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCollection.GetItem (Var S: TStream): Pointer; +BEGIN + GetItem := S.Get; { Item off stream } +END; + +{--TCollection--------------------------------------------------------------} +{ LastThat -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCollection.LastThat (Test: Pointer): Pointer; +VAR I: LongInt; + +BEGIN + For I := Count DownTo 1 Do + Begin { Down from last item } + IF Boolean(Byte(Longint(CallPointerLocal(Test,PreviousFramePointer,Items^[I-1])))) THEN + Begin { Test each item } + LastThat := Items^[I-1]; { Return item } + Exit; { Now exit } + End; + End; + LastThat := Nil; { None passed test } +END; + +{--TCollection--------------------------------------------------------------} +{ FirstThat -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCollection.FirstThat (Test: Pointer): Pointer; +VAR I: LongInt; +BEGIN + For I := 1 To Count Do Begin { Up from first item } + IF Boolean(Byte(Longint(CallPointerLocal(Test,PreviousFramePointer,Items^[I-1])))) THEN + Begin { Test each item } + FirstThat := Items^[I-1]; { Return item } + Exit; { Now exit } + End; + End; + FirstThat := Nil; { None passed test } +END; + +{--TCollection--------------------------------------------------------------} +{ Pack -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Pack; +VAR I, J: Sw_Integer; +BEGIN + I := 0; { Initialize dest } + J := 0; { Intialize test } + While (INil) Then Begin { Found a valid item } + If (I<>J) Then Begin + Items^[I] := Items^[J]; { Transfer item } + Items^[J] := Nil; { Now clear old item } + End; + Inc(I); { One item packed } + End; + Inc(J); { Next item to test } + End; + If (I Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.FreeAll; +VAR I: Sw_Integer; +BEGIN + for I := Count-1 downto 0 do + FreeItem(At(I)); + Count := 0; { Clear item count } +END; + +{--TCollection--------------------------------------------------------------} +{ DeleteAll -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.DeleteAll; +BEGIN + Count := 0; { Clear item count } +END; + +{--TCollection--------------------------------------------------------------} +{ Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Free (Item: Pointer); +BEGIN + Delete(Item); { Delete from list } + FreeItem(Item); { Free the item } +END; + +{--TCollection--------------------------------------------------------------} +{ Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Insert (Item: Pointer); +BEGIN + AtInsert(Count, Item); { Insert item } +END; + +{--TCollection--------------------------------------------------------------} +{ Delete -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Delete (Item: Pointer); +BEGIN + AtDelete(IndexOf(Item)); { Delete from list } +END; + +{--TCollection--------------------------------------------------------------} +{ AtFree -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.AtFree (Index: Sw_Integer); +VAR Item: Pointer; +BEGIN + Item := At(Index); { Retreive item ptr } + AtDelete(Index); { Delete item } + FreeItem(Item); { Free the item } +END; + +{--TCollection--------------------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.FreeItem (Item: Pointer); +VAR P: PObject; +BEGIN + P := PObject(Item); { Convert pointer } + If (P<>Nil) Then Dispose(P, Done); { Dispose of object } +END; + +{--TCollection--------------------------------------------------------------} +{ AtDelete -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.AtDelete (Index: Sw_Integer); +BEGIN + If (Index >= 0) AND (Index < Count) Then Begin { Valid index } + Dec(Count); { One less item } + If (Count>Index) Then Move(Items^[Index+1], + Items^[Index], (Count-Index)*Sizeof(Pointer)); { Shuffle items down } + End Else Error(coIndexError, Index); { Index error } +END; + +{--TCollection--------------------------------------------------------------} +{ ForEach -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.ForEach (Action: Pointer); +VAR I: LongInt; +BEGIN + For I := 1 To Count Do { Up from first item } + CallPointerLocal(Action,PreviousFramePointer,Items^[I-1]); { Call with each item } +END; + +{--TCollection--------------------------------------------------------------} +{ SetLimit -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.SetLimit (ALimit: Sw_Integer); +VAR + AItems: PItemList; +BEGIN + If (ALimit < Count) Then + ALimit := Count; + If (ALimit > MaxCollectionSize) Then + ALimit := MaxCollectionSize; + If (ALimit <> Limit) Then + Begin + If (ALimit = 0) Then + AItems := Nil + Else + Begin + GetMem(AItems, ALimit * SizeOf(Pointer)); + If (AItems<>Nil) Then + FillChar(AItems^,ALimit * SizeOf(Pointer), #0); + End; + If (AItems<>Nil) OR (ALimit=0) Then + Begin + If (AItems <>Nil) AND (Items <> Nil) Then + Move(Items^, AItems^, Count*SizeOf(Pointer)); + If (Limit <> 0) AND (Items <> Nil) Then + FreeMem(Items, Limit * SizeOf(Pointer)); + end; + Items := AItems; + Limit := ALimit; + End; +END; + +{--TCollection--------------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Error (Code, Info: Integer); +BEGIN + RunError(212 - Code); { Run error } +END; + +{--TCollection--------------------------------------------------------------} +{ AtPut -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.AtPut (Index: Sw_Integer; Item: Pointer); +BEGIN + If (Index >= 0) AND (Index < Count) Then { Index valid } + Items^[Index] := Item { Put item in index } + Else Error(coIndexError, Index); { Index error } +END; + +{--TCollection--------------------------------------------------------------} +{ AtInsert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.AtInsert (Index: Sw_Integer; Item: Pointer); +VAR I: Sw_Integer; +BEGIN + If (Index >= 0) AND (Index <= Count) Then Begin { Valid index } + If (Count=Limit) Then SetLimit(Limit+Delta); { Expand size if able } + If (Limit>Count) Then Begin + If (Index < Count) Then Begin { Not last item } + For I := Count-1 DownTo Index Do { Start from back } + Items^[I+1] := Items^[I]; { Move each item } + End; + Items^[Index] := Item; { Put item in list } + Inc(Count); { Inc count } + End Else Error(coOverflow, Index); { Expand failed } + End Else Error(coIndexError, Index); { Index error } +END; + +{--TCollection--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.Store (Var S: TStream); +var + LimitWord, DeltaWord: Word; + + PROCEDURE DoPutItem (P: Pointer);{$IFNDEF FPC}FAR;{$ENDIF} + BEGIN + PutItem(S, P); { Put item on stream } + END; + +BEGIN + If S.TPCompatible Then Begin + { Check if it is safe to write in TP-compatible stream. + If Count is too big, signal an error. + If Limit or Delta are too big, write smaller values. } + If (Count > MaxTPCompatibleCollectionSize) + Then S.Error(stWriteError, 0) + Else Begin + S.Write(Count, Sizeof(Word)); + if Limit > MaxTPCompatibleCollectionSize + then LimitWord := MaxTPCompatibleCollectionSize + else LimitWord := Limit; + S.Write(LimitWord, Sizeof(Word)); + if Delta > MaxTPCompatibleCollectionSize + then DeltaWord := MaxTPCompatibleCollectionSize + else DeltaWord := Delta; + S.Write(DeltaWord, Sizeof(Word)); + End + End + Else Begin + S.Write(Count, Sizeof(Count)); { Write count } + S.Write(Limit, Sizeof(Limit)); { Write limit } + S.Write(Delta, Sizeof(Delta)); { Write delta } + End; + ForEach(@DoPutItem); { Each item to stream } +END; + +{--TCollection--------------------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCollection.PutItem (Var S: TStream; Item: Pointer); +BEGIN + S.Put(Item); { Put item on stream } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TSortedCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TSortedCollection--------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TSortedCollection.Init (ALimit, ADelta: Sw_Integer); +BEGIN + Inherited Init(ALimit, ADelta); { Call ancestor } + Duplicates := False; { Clear flag } +END; + +{--TSortedCollection--------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TSortedCollection.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Duplicates, SizeOf(Duplicates)); { Read duplicate flag } +END; + +{--TSortedCollection--------------------------------------------------------} +{ KeyOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TSortedCollection.KeyOf (Item: Pointer): Pointer; +BEGIN + KeyOf := Item; { Return item as key } +END; + +{--TSortedCollection--------------------------------------------------------} +{ IndexOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TSortedCollection.IndexOf (Item: Pointer): Sw_Integer; +VAR I, J: Sw_Integer; +BEGIN + J := -1; { Preset result } + If Search(KeyOf(Item), I) Then Begin { Search for item } + If Duplicates Then { Duplicates allowed } + While (I < Count) AND (Item <> Items^[I]) Do + Inc(I); { Count duplicates } + If (I < Count) Then J := I; { Index result } + End; + IndexOf := J; { Return result } +END; + +{--TSortedCollection--------------------------------------------------------} +{ Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Sw_Integer; +BEGIN + Abstract; { Abstract method } + Compare:=0; +END; + +{--TSortedCollection--------------------------------------------------------} +{ Search -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TSortedCollection.Search (Key: Pointer; Var Index: Sw_Integer): Boolean; +VAR L, H, I, C: Sw_Integer; +BEGIN + Search := False; { Preset failure } + L := 0; { Start count } + H := Count - 1; { End count } + While (L <= H) Do Begin + I := (L + H) SHR 1; { Mid point } + C := Compare(KeyOf(Items^[I]), Key); { Compare with key } + If (C < 0) Then L := I + 1 Else Begin { Item to left } + H := I - 1; { Item to right } + If C = 0 Then Begin { Item match found } + Search := True; { Result true } + If NOT Duplicates Then L := I; { Force kick out } + End; + End; + End; + Index := L; { Return result } +END; + +{--TSortedCollection--------------------------------------------------------} +{ Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TSortedCollection.Insert (Item: Pointer); +VAR I: Sw_Integer; +BEGIN + If NOT Search(KeyOf(Item), I) OR Duplicates Then { Item valid } + AtInsert(I, Item); { Insert the item } +END; + +{--TSortedCollection--------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TSortedCollection.Store (Var S: TStream); +BEGIN + TCollection.Store(S); { Call ancestor } + S.Write(Duplicates, SizeOf(Duplicates)); { Write duplicate flag } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStringCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStringCollection--------------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStringCollection.GetItem (Var S: TStream): Pointer; +BEGIN + GetItem := S.ReadStr; { Get new item } +END; + +{--TStringCollection--------------------------------------------------------} +{ Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 21Aug97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStringCollection.Compare (Key1, Key2: Pointer): Sw_Integer; +VAR I, J: Sw_Integer; P1, P2: PString; +BEGIN + P1 := PString(Key1); { String 1 pointer } + P2 := PString(Key2); { String 2 pointer } + If (Length(P1^)P2^[I]) Then Compare := 1 Else { String1 > String2 } + If (Length(P1^)>Length(P2^)) Then Compare := 1 { String1 > String2 } + Else If (Length(P1^) String2 } +END; + +{--TStringCollection--------------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringCollection.FreeItem (Item: Pointer); +BEGIN + DisposeStr(Item); { Dispose item } +END; + +{--TStringCollection--------------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringCollection.PutItem (Var S: TStream; Item: Pointer); +BEGIN + S.WriteStr(Item); { Write string } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStrCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStrCollection-----------------------------------------------------------} +{ Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStrCollection.Compare (Key1, Key2: Pointer): Sw_Integer; +VAR I, J: Sw_Integer; P1, P2: PByteArray; +BEGIN + P1 := PByteArray(Key1); { PChar 1 pointer } + P2 := PByteArray(Key2); { PChar 2 pointer } + I := 0; { Preset no size } + If (P1<>Nil) Then While (P1^[I]<>0) Do Inc(I); { PChar 1 length } + J := 0; { Preset no size } + If (P2<>Nil) Then While (P2^[J]<>0) Do Inc(J); { PChar 2 length } + If (I < J) Then J := I; { Shortest length } + I := 0; { First character } + While (I String2 } +END; + +{--TStrCollection-----------------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStrCollection.GetItem (Var S: TStream): Pointer; +BEGIN + GetItem := S.StrRead; { Get string item } +END; + +{--TStrCollection-----------------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStrCollection.FreeItem (Item: Pointer); +VAR I: Sw_Integer; P: PByteArray; +BEGIN + If (Item<>Nil) Then Begin { Item is valid } + P := PByteArray(Item); { Create byte pointer } + I := 0; { Preset no size } + While (P^[I]<>0) Do Inc(I); { Find PChar end } + FreeMem(Item, I+1); { Release memory } + End; +END; + +{--TStrCollection-----------------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStrCollection.PutItem (Var S: TStream; Item: Pointer); +BEGIN + S.StrWrite(Item); { Write the string } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TUnSortedStrCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TUnSortedCollection------------------------------------------------------} +{ Insert -> Platforms DOS/DPMI/WIN/OS2 - Checked 23May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TUnSortedStrCollection.Insert (Item: Pointer); +BEGIN + AtInsert(Count, Item); { Insert - NO sorting } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TResourceItem RECORD } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +TYPE + TResourceItem = packed RECORD + Posn: LongInt; { Resource position } + Size: LongInt; { Resource size } + Key : String; { Resource key } + End; + PResourceItem = ^TResourceItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TResourceCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TResourceCollection------------------------------------------------------} +{ KeyOf -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceCollection.KeyOf (Item: Pointer): Pointer; +BEGIN + KeyOf := @PResourceItem(Item)^.Key; { Pointer to key } +END; + +{--TResourceCollection------------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceCollection.GetItem (Var S: TStream): Pointer; +VAR B: Byte; Pos: Longint; Size: Longint; Ts: String; P: PResourceItem; +BEGIN + S.Read(Pos, SizeOf(Pos)); { Read position } + S.Read(Size, SizeOf(Size)); { Read size } + S.Read(B, 1); { Read key length } + GetMem(P, B + (SizeOf(TResourceItem) - + SizeOf(Ts) + 1)); { Allocate min memory } + If (P<>Nil) Then Begin { If allocate works } + P^.Posn := Pos; { Xfer position } + P^.Size := Size; { Xfer size } + P^.Key[0] := Char(B); { Xfer string length } + S.Read(P^.Key[1], B); { Xfer string data } + End; + GetItem := P; { Return pointer } +END; + +{--TResourceCollection------------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TResourceCollection.FreeItem (Item: Pointer); +VAR Ts: String; +BEGIN + If (Item<>Nil) Then FreeMem(Item, + SizeOf(TResourceItem) - SizeOf(Ts) + + Length(PResourceItem(Item)^.Key) + 1); { Release memory } +END; + +{--TResourceCollection------------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 24May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TResourceCollection.PutItem (Var S: TStream; Item: Pointer); +VAR Ts: String; +BEGIN + If (Item<>Nil) Then S.Write(PResourceItem(Item)^, + SizeOf(TResourceItem) - SizeOf(Ts) + + Length(PResourceItem(Item)^.Key) + 1); { Write to stream } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ PRIVATE RESOURCE MANAGER CONSTANTS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +CONST + RStreamMagic: LongInt = $52504246; { 'FBPR' } + RStreamBackLink: LongInt = $4C424246; { 'FBBL' } + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ PRIVATE RESOURCE MANAGER TYPES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +TYPE +{$IFDEF NewExeFormat} { New EXE format } + TExeHeader = packed RECORD + eHdrSize: Word; + eMinAbove: Word; + eMaxAbove: Word; + eInitSS: Word; + eInitSP: Word; + eCheckSum: Word; + eInitPC: Word; + eInitCS: Word; + eRelocOfs: Word; + eOvlyNum: Word; + eRelocTab: Word; + eSpace: Array[1..30] of Byte; + eNewHeader: Word; + END; +{$ENDIF} + + THeader = packed RECORD + Signature: Word; + Case Integer Of + 0: ( + LastCount: Word; + PageCount: Word; + ReloCount: Word); + 1: ( + InfoType: Word; + InfoSize: Longint); + End; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TResourceFile OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TResourceFile------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TResourceFile.Init(AStream: PStream); +VAR Found, Stop: Boolean; Header: THeader; + {$IFDEF NewExeFormat} ExeHeader: TExeHeader; {$ENDIF} +BEGIN + TObject.Init; { Initialize object } + Found := False; { Preset false } + If (AStream<>Nil) Then Begin + Stream := AStream; { Hold stream } + BasePos := Stream^.GetPos; { Get position } + Repeat + Stop := True; { Preset stop } + If (BasePos <= Stream^.GetSize-SizeOf(THeader)) + Then Begin { Valid file header } + Stream^.Seek(BasePos); { Seek to position } + Stream^.Read(Header, SizeOf(THeader)); { Read header } + Case Header.Signature Of + {$IFDEF NewExeFormat} { New format file } + $5A4D: Begin + Stream^.Read(ExeHeader, SizeOf(TExeHeader)); + BasePos := ExeHeader.eNewHeader; { Hold position } + Stop := False; { Clear stop flag } + End; + $454E: Begin + BasePos := Stream^.GetSize - 8; { Hold position } + Stop := False; { Clear stop flag } + End; + $4246: Begin + Stop := False; { Clear stop flag } + Case Header.Infotype Of + $5250: Begin { Found Resource } + Found := True; { Found flag is true } + Stop := True; { Set stop flag } + End; + $4C42: Dec(BasePos, Header.InfoSize-8);{ Found BackLink } + $4648: Dec(BasePos, SizeOf(THeader)*2);{ Found HelpFile } + Else Stop := True; { Set stop flag } + End; + End; + $424E: If Header.InfoType = $3230 { Found Debug Info } + Then Begin + Dec(BasePos, Header.InfoSize); { Adjust position } + Stop := False; { Clear stop flag } + End; + {$ELSE} + $5A4D: Begin + Inc(BasePos, LongInt(Header.PageCount)*512 + - (-Header.LastCount AND 511)); { Calc position } + Stop := False; { Clear stop flag } + End; + $4246: If Header.InfoType = $5250 Then { Header was found } + Found := True Else Begin + Inc(BasePos, Header.InfoSize + 8); { Adjust position } + Stop := False; { Clear stop flag } + End; + {$ENDIF} + End; + End; + Until Stop; { Until flag is set } + End; + If Found Then Begin { Resource was found } + Stream^.Seek(BasePos + SizeOf(LongInt) * 2); { Seek to position } + Stream^.Read(IndexPos, SizeOf(LongInt)); { Read index position } + Stream^.Seek(BasePos + IndexPos); { Seek to resource } + Index.Load(Stream^); { Load resource } + End Else Begin + IndexPos := SizeOf(LongInt) * 3; { Set index position } + Index.Init(0, 8); { Set index } + End; +END; + +{--TResourceFile------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TResourceFile.Done; +BEGIN + Flush; { Flush the file } + Index.Done; { Dispose of index } + If (Stream<>Nil) Then Dispose(Stream, Done); { Dispose of stream } +END; + +{--TResourceFile------------------------------------------------------------} +{ Count -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceFile.Count: Sw_Integer; +BEGIN + Count := Index.Count; { Return index count } +END; + +{--TResourceFile------------------------------------------------------------} +{ KeyAt -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceFile.KeyAt (I: Sw_Integer): String; +BEGIN + KeyAt := PResourceItem(Index.At(I))^.Key; { Return key } +END; + +{--TResourceFile------------------------------------------------------------} +{ Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceFile.Get (Key: String): PObject; +VAR I: Sw_Integer; +BEGIN + If (Stream = Nil) OR (NOT Index.Search(@Key, I)) { No match on key } + Then Get := Nil Else Begin + Stream^.Seek(BasePos + + PResourceItem(Index.At(I))^.Posn); { Seek to position } + Get := Stream^.Get; { Get item } + End; +END; + +{--TResourceFile------------------------------------------------------------} +{ SwitchTo -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream; +VAR NewBasePos: LongInt; + + PROCEDURE DoCopyResource (Item: PResourceItem);{$IFNDEF FPC}FAR;{$ENDIF} + BEGIN + Stream^.Seek(BasePos + Item^.Posn); { Move stream position } + Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position } + AStream^.CopyFrom(Stream^, Item^.Size); { Copy the item } + END; + +BEGIN + SwitchTo := Stream; { Preset return } + If (AStream<>Nil) AND (Stream<>Nil) Then Begin { Both streams valid } + NewBasePos := AStream^.GetPos; { Get position } + If Pack Then Begin + AStream^.Seek(NewBasePos + SizeOf(LongInt)*3); { Seek to position } + Index.ForEach(@DoCopyResource); { Copy each resource } + IndexPos := AStream^.GetPos - NewBasePos; { Hold index position } + End Else Begin + Stream^.Seek(BasePos); { Seek to position } + AStream^.CopyFrom(Stream^, IndexPos); { Copy the resource } + End; + Stream := AStream; { Hold new stream } + BasePos := NewBasePos; { New base position } + Modified := True; { Set modified flag } + End; +END; + +{--TResourceFile------------------------------------------------------------} +{ Flush -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TResourceFile.Flush; +VAR ResSize: LongInt; LinkSize: LongInt; +BEGIN + If (Modified) AND (Stream<>Nil) Then Begin { We have modification } + Stream^.Seek(BasePos + IndexPos); { Seek to position } + Index.Store(Stream^); { Store the item } + ResSize := Stream^.GetPos - BasePos; { Hold position } + LinkSize := ResSize + SizeOf(LongInt) * 2; { Hold link size } + Stream^.Write(RStreamBackLink, SizeOf(LongInt)); { Write link back } + Stream^.Write(LinkSize, SizeOf(LongInt)); { Write link size } + Stream^.Seek(BasePos); { Move stream position } + Stream^.Write(RStreamMagic, SizeOf(LongInt)); { Write number } + Stream^.Write(ResSize, SizeOf(LongInt)); { Write record size } + Stream^.Write(IndexPos, SizeOf(LongInt)); { Write index position } + Stream^.Flush; { Flush the stream } + End; + Modified := False; { Clear modified flag } +END; + +{--TResourceFile------------------------------------------------------------} +{ Delete -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TResourceFile.Delete (Key: String); +VAR I: Sw_Integer; +BEGIN + If Index.Search(@Key, I) Then Begin { Search for key } + Index.Free(Index.At(I)); { Delete from index } + Modified := True; { Set modified flag } + End; +END; + +{--TResourceFile------------------------------------------------------------} +{ Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 18Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TResourceFile.Put (Item: PObject; Key: String); +VAR I: Sw_Integer; Ts: String; P: PResourceItem; +BEGIN + If (Stream=Nil) Then Exit; { Stream not valid } + If Index.Search(@Key, I) Then P := Index.At(I) { Search for item } + Else Begin + GetMem(P, Length(Key) + (SizeOf(TResourceItem) - + SizeOf(Ts) + 1)); { Allocate memory } + If (P<>Nil) Then Begin + P^.Key := Key; { Store key } + Index.AtInsert(I, P); { Insert item } + End; + End; + If (P<>Nil) Then Begin + P^.Posn := IndexPos; { Set index position } + Stream^.Seek(BasePos + IndexPos); { Seek file position } + Stream^.Put(Item); { Put item on stream } + IndexPos := Stream^.GetPos - BasePos; { Hold index position } + P^.Size := IndexPos - P^.Posn; { Calc size } + Modified := True; { Set modified flag } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStringList OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStringList--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStringList.Load (Var S: TStream); +VAR Size: Word; +BEGIN + Stream := @S; { Hold stream pointer } + S.Read(Size, SizeOf(Word)); { Read size } + BasePos := S.GetPos; { Hold position } + S.Seek(BasePos + Size); { Seek to position } + S.Read(IndexSize, SizeOf(Integer)); { Read index size } + GetMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Allocate memory } + S.Read(Index^, IndexSize * SizeOf(TStrIndexRec)); { Read indexes } +END; + +{--TStringList--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStringList.Done; +BEGIN + FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Release memory } +END; + +{--TStringList--------------------------------------------------------------} +{ Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStringList.Get (Key: Sw_Word): String; +VAR I: Word; S: String; +BEGIN + S := ''; { Preset empty string } + If (IndexSize>0) Then Begin { We must have strings } + I := 0; { First entry } + While (I Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringList.ReadStr (Var S: String; Offset, Skip: Sw_Word); +BEGIN + Stream^.Seek(BasePos + Offset); { Seek to position } + Inc(Skip); { Adjust skip } + Repeat + Stream^.Read(S[0], 1); { Read string size } + Stream^.Read(S[1], Ord(S[0])); { Read string data } + Dec(Skip); { One string read } + Until (Skip = 0); +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStrListMaker OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStrListMaker------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStrListMaker.Init (AStrSize, AIndexSize: Sw_Word); +BEGIN + Inherited Init; { Call ancestor } + StrSize := AStrSize; { Hold size } + IndexSize := AIndexSize; { Hold index size } + GetMem(Strings, AStrSize); { Allocate memory } + GetMem(Index, AIndexSize * SizeOf(TStrIndexRec)); { Allocate memory } +END; + +{--TStrListMaker------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStrListMaker.Done; +BEGIN + FreeMem(Index, IndexSize * SizeOf(TStrIndexRec)); { Free index memory } + FreeMem(Strings, StrSize); { Free data memory } +END; + +{--TStrListMaker------------------------------------------------------------} +{ Put -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStrListMaker.Put (Key: Sw_Word; S: String); +BEGIN + If (Cur.Count = 16) OR (Key <> Cur.Key + Cur.Count) + Then CloseCurrent; { Close current } + If (Cur.Count = 0) Then Begin + Cur.Key := Key; { Set key } + Cur.Offset := StrPos; { Set offset } + End; + Inc(Cur.Count); { Inc count } + Move(S, Strings^[StrPos], Length(S) + 1); { Move string data } + Inc(StrPos, Length(S) + 1); { Adjust position } +END; + +{--TStrListMaker------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStrListMaker.Store (Var S: TStream); +BEGIN + CloseCurrent; { Close all current } + S.Write(StrPos, SizeOf(Word)); { Write position } + S.Write(Strings^, StrPos); { Write string data } + S.Write(IndexPos, SizeOf(Word)); { Write index position } + S.Write(Index^, IndexPos * SizeOf(TStrIndexRec)); { Write indexes } +END; + +{***************************************************************************} +{ TStrListMaker PRIVATE METHODS } +{***************************************************************************} + +{--TStrListMaker------------------------------------------------------------} +{ CloseCurrent -> Platforms DOS/DPMI/WIN/OS2 - Checked 30Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStrListMaker.CloseCurrent; +BEGIN + If (Cur.Count <> 0) Then Begin + Index^[IndexPos] := Cur; { Hold index position } + Inc(IndexPos); { Next index } + Cur.Count := 0; { Adjust count } + End; +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DYNAMIC STRING INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewStr -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewStr (Const S: String): PString; +VAR P: PString; +BEGIN + If (S = '') Then P := Nil Else Begin { Return nil } + GetMem(P, Length(S) + 1); { Allocate memory } + If (P<>Nil) Then P^ := S; { Hold string } + End; + NewStr := P; { Return result } +END; + +{---------------------------------------------------------------------------} +{ DisposeStr -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DisposeStr (P: PString); +BEGIN + If (P <> Nil) Then FreeMem(P, Length(P^) + 1); { Release memory } +END; + + +PROCEDURE SetStr(VAR p:pString; CONST s:STRING); +BEGIN + IF p<>NIL THEN + FreeMem(P, Length(P^) + 1); + GetMem(p,LENGTH(s)+1); + pSTRING(p)^ := s +END; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STREAM INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ Abstract -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE Abstract; +BEGIN + RunError(211); { Abstract error } +END; + +{---------------------------------------------------------------------------} +{ RegisterObjects -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 02Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterObjects; +BEGIN + RegisterType(RCollection); { Register object } + RegisterType(RStringCollection); { Register object } + RegisterType(RStrCollection); { Register object } +END; + +{---------------------------------------------------------------------------} +{ RegisterType -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 02Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterType (Var S: TStreamRec); +VAR P: PStreamRec; +BEGIN + P := StreamTypes; { Current reg list } + While (P <> Nil) AND (P^.ObjType <> S.ObjType) + Do P := P^.Next; { Find end of chain } + If (P = Nil) AND (S.ObjType <> 0) Then Begin { Valid end found } + S.Next := StreamTypes; { Chain the list } + StreamTypes := @S; { We are now first } + End Else RegisterError; { Register the error } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ GENERAL FUNCTION INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ LongMul -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 04Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION LongMul (X, Y: Integer): LongInt; + BEGIN + LongMul:=Longint(X*Y); + END; +{---------------------------------------------------------------------------} +{ LongDiv -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 04Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION LongDiv (X: LongInt; Y: Integer): Integer; +BEGIN + LongDiv := Integer(X DIV Y); +END; + + +END. +{ + $Log: not supported by cvs2svn $ + Revision 1.37 2000/04/07 21:10:35 pierre + + ReturnNilIfGrowHeapFails used in objects unit + to handle TMemoryStream out of memory properly + as MaxAvail is not a good test anymore. + + Revision 1.36 2000/03/06 20:15:32 daniel + + Added is_object method to Tobject. It is similar to the is operator. + + Revision 1.35 2000/02/09 16:59:30 peter + * truncated log + + Revision 1.34 2000/01/07 16:41:34 daniel + * copyright 2000 + + Revision 1.33 2000/01/07 16:32:24 daniel + * copyright 2000 added + + Revision 1.32 1999/12/06 18:25:30 peter + * fixed vmtptr crash in tstream.put + + Revision 1.31 1999/11/06 14:35:38 peter + * truncated log + + Revision 1.30 1999/09/10 17:15:13 peter + * fixed freeall + +} \ No newline at end of file diff --git a/befpc/rtl/inc/objpas.inc b/befpc/rtl/inc/objpas.inc new file mode 100644 index 0000000..49040c9 --- /dev/null +++ b/befpc/rtl/inc/objpas.inc @@ -0,0 +1,493 @@ +{ + $Id: objpas.inc,v 1.1.1.1 2001-07-23 17:17:37 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This unit makes Free Pascal as much as possible Delphi compatible + + 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. + + **********************************************************************} + +{**************************************************************************** + Internal Routines called from the Compiler +****************************************************************************} + + { the reverse order of the parameters make code generation easier } + function int_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; + begin + int_do_is:=aobject.inheritsfrom(aclass); + end; + + + { the reverse order of the parameters make code generation easier } + procedure int_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; + begin + if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then + handleerror(219); + end; + + +{**************************************************************************** + TOBJECT +****************************************************************************} + + constructor TObject.Create; + + begin + end; + + destructor TObject.Destroy; + + begin + end; + + procedure TObject.Free; + + begin + // the call via self avoids a warning + if self<>nil then + self.destroy; + end; + + class function TObject.InstanceSize : LongInt; + + type + plongint = ^longint; + + begin + { type of self is class of tobject => it points to the vmt } + { the size is saved at offset 0 } + InstanceSize:=plongint(self)^; + end; + + class function TObject.InitInstance(instance : pointer) : tobject; + + begin + fillchar(instance^,self.instancesize,0); + { insert VMT pointer into the new created memory area } + { (in class methods self contains the VMT!) } + ppointer(instance)^:=pointer(self); + InitInstance:=TObject(Instance); + end; + + class function TObject.ClassParent : tclass; + + begin + { type of self is class of tobject => it points to the vmt } + { the parent vmt is saved at offset vmtParent } + classparent:=pclass(pointer(self)+vmtParent)^; + end; + + class function TObject.NewInstance : tobject; + + var + p : pointer; + + begin + getmem(p,instancesize); + InitInstance(p); + NewInstance:=TObject(p); + end; + + procedure TObject.FreeInstance; + + var + p : Pointer; + + begin + CleanupInstance; + + { self is a register, so we can't pass it call by reference } + p:=Pointer(Self); + FreeMem(p,InstanceSize); + end; + + function TObject.ClassType : TClass; + + begin + ClassType:=TClass(Pointer(Self)^) + end; + + type + tmethodnamerec = packed record + name : pshortstring; + addr : pointer; + end; + + tmethodnametable = packed record + count : dword; + entries : packed array[0..0] of tmethodnamerec; + end; + + pmethodnametable = ^tmethodnametable; + + class function TObject.MethodAddress(const name : shortstring) : pointer; + + var + methodtable : pmethodnametable; + i : dword; + c : tclass; + + begin + c:=self; + while assigned(c) do + begin + methodtable:=pmethodnametable((Pointer(c)+vmtMethodTable)^); + if assigned(methodtable) then + begin + for i:=0 to methodtable^.count-1 do + if methodtable^.entries[i].name^=name then + begin + MethodAddress:=methodtable^.entries[i].addr; + exit; + end; + end; + c:=c.ClassParent; + end; + MethodAddress:=nil; + end; + + class function TObject.MethodName(address : pointer) : shortstring; + + var + methodtable : pmethodnametable; + i : dword; + c : tclass; + + begin + c:=self; + while assigned(c) do + begin + methodtable:=pmethodnametable((Pointer(c)+vmtMethodTable)^); + if assigned(methodtable) then + begin + for i:=0 to methodtable^.count-1 do + if methodtable^.entries[i].addr=address then + begin + MethodName:=methodtable^.entries[i].name^; + exit; + end; + end; + c:=c.ClassParent; + end; + MethodName:=''; + end; + + + + + function TObject.FieldAddress(const name : shortstring) : pointer; + + type + PFieldInfo = ^TFieldInfo; + TFieldInfo = packed record + FieldOffset: LongWord; + ClassTypeIndex: Word; + Name: ShortString; + end; + + PFieldTable = ^TFieldTable; + TFieldTable = packed record + FieldCount: Word; + ClassTable: Pointer; + { Fields: array[Word] of TFieldInfo; Elements have variant size! } + end; + + var + UName: ShortString; + CurClassType: TClass; + FieldTable: PFieldTable; + FieldInfo: PFieldInfo; + i: Integer; + + begin + if Length(name) > 0 then + begin + UName := UpCase(name); + CurClassType := ClassType; + while CurClassType <> nil do + begin + FieldTable := PFieldTable((Pointer(CurClassType) + vmtFieldTable)^); + if FieldTable <> nil then + begin + FieldInfo := PFieldInfo(Pointer(FieldTable) + 6); + for i := 0 to FieldTable^.FieldCount - 1 do + begin + if UpCase(FieldInfo^.Name) = UName then + begin + fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset; + exit; + end; + Inc(Pointer(FieldInfo), 7 + Length(FieldInfo^.Name)); + end; + end; + { Try again with the parent class type } + CurClassType := CurClassType.ClassParent; + end; + end; + + fieldaddress:=nil; + end; + + function TObject.SafeCallException(exceptobject : tobject; + exceptaddr : pointer) : longint; + + begin + safecallexception:=0; + end; + + class function TObject.ClassInfo : pointer; + + begin + ClassInfo:=ppointer(Pointer(self)+vmtTypeInfo)^; + end; + + class function TObject.ClassName : ShortString; + + begin + ClassName:=PShortString((Pointer(Self)+vmtClassName)^)^; + end; + + class function TObject.ClassNameIs(const name : string) : boolean; + + begin + ClassNameIs:=Upcase(ClassName)=Upcase(name); + end; + + class function TObject.InheritsFrom(aclass : TClass) : Boolean; + + var + c : tclass; + + begin + c:=self; + while assigned(c) do + begin + if c=aclass then + begin + InheritsFrom:=true; + exit; + end; + c:=c.ClassParent; + end; + InheritsFrom:=false; + end; + + class function TObject.stringmessagetable : pstringmessagetable; + + type + pdword = ^dword; + + begin + stringmessagetable:=pstringmessagetable((pointer(Self)+vmtMsgStrPtr)^); + end; + + type + tmessagehandler = procedure(var msg) of object; + tmessagehandlerrec = packed record + proc : pointer; + obj : pointer; + end; + + + procedure TObject.Dispatch(var message); + + type + tmsgtable = record + index : dword; + method : pointer; + end; + + pmsgtable = ^tmsgtable; + + pdword = ^dword; + + var + index : dword; + count,i : longint; + msgtable : pmsgtable; + p : pointer; + vmt : tclass; + msghandler : tmessagehandler; + + begin + index:=dword(message); + vmt:=ClassType; + while assigned(vmt) do + begin + // See if we have messages at all in this class. + p:=pointer(vmt)+vmtDynamicTable; + If Assigned(p) and (Pdword(p)^<>0) then + begin + msgtable:=pmsgtable(pdword(P)^+4); + count:=pdword(pdword(P)^)^; + end + else + Count:=0; + { later, we can implement a binary search here } + for i:=0 to count-1 do + begin + if index=msgtable[i].index then + begin + p:=msgtable[i].method; + tmessagehandlerrec(msghandler).proc:=p; + tmessagehandlerrec(msghandler).obj:=self; + msghandler(message); + { we don't need any longer the assembler + solution + asm + pushl message + pushl %esi + movl p,%edi + call *%edi + end; + } + exit; + end; + end; + vmt:=vmt.ClassParent; + end; + DefaultHandler(message); + end; + + procedure TObject.DispatchStr(var message); + + type + pdword = ^dword; + + var + name : shortstring; + count,i : longint; + msgstrtable : pmsgstrtable; + p : pointer; + vmt : tclass; + msghandler : tmessagehandler; + + begin + name:=pshortstring(@message)^; + vmt:=ClassType; + while assigned(vmt) do + begin + p:=(pointer(vmt)+vmtMsgStrPtr); + If (P<>Nil) and (PDWord(P)^<>0) then + begin + count:=pdword(pdword(p)^)^; + msgstrtable:=pmsgstrtable(pdword(P)^+4); + end + else + Count:=0; + { later, we can implement a binary search here } + for i:=0 to count-1 do + begin + if name=msgstrtable[i].name^ then + begin + p:=msgstrtable[i].method; + tmessagehandlerrec(msghandler).proc:=p; + tmessagehandlerrec(msghandler).obj:=self; + msghandler(message); + { we don't need any longer the assembler + solution + asm + pushl message + pushl %esi + movl p,%edi + call *%edi + end; + } + exit; + end; + end; + vmt:=vmt.ClassParent; + end; + DefaultHandlerStr(message); + end; + + procedure TObject.DefaultHandler(var message); + + begin + end; + + procedure TObject.DefaultHandlerStr(var message); + + begin + end; + + procedure TObject.CleanupInstance; + + var + vmt : tclass; + + begin + vmt:=ClassType; + while vmt<>nil do + begin + if Assigned(Pointer((Pointer(vmt)+vmtInitTable)^)) then + Finalize(Pointer(Self),Pointer((Pointer(vmt)+vmtInitTable)^)); + vmt:=vmt.ClassParent; + end; + end; + + procedure TObject.AfterConstruction; + + begin + end; + + procedure TObject.BeforeDestruction; + + begin + end; + +{**************************************************************************** + Exception Support +****************************************************************************} + +{$i except.inc} + +{**************************************************************************** + Initialize +****************************************************************************} + +{ + $Log: not supported by cvs2svn $ + Revision 1.18 2000/07/08 21:27:42 sg + * Fixed TObject.FieldAddress + + Revision 1.17 2000/07/08 07:24:24 sg + * FieldAddress now returns immediately if name='' + + Revision 1.16 2000/06/29 16:32:50 sg + * Implemented TObject.FieldAddress + + Revision 1.15 2000/05/16 08:06:14 michael + + Fixed ClassNameIs so it is case insensitive + + Revision 1.14 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.13 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.12 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.11 1999/09/15 20:28:35 florian + * fixed methodname/address: the loops must go from 0 to ...^.count-1 + + Revision 1.10 1999/09/12 14:53:26 florian + + tobject.methodaddress und tobject.methodname durchsucht nun auch + die Elternklassen + + Revision 1.9 1999/09/12 08:01:00 florian + + implementation of TObject.MethodName and TObject.MethodAddress (not + in the compiler yet) + + Revision 1.8 1999/09/08 16:14:41 peter + * pointer fixes + +} diff --git a/befpc/rtl/inc/objpash.inc b/befpc/rtl/inc/objpash.inc new file mode 100644 index 0000000..c532449 --- /dev/null +++ b/befpc/rtl/inc/objpash.inc @@ -0,0 +1,265 @@ +{ + $Id: objpash.inc,v 1.1.1.1 2001-07-23 17:17:37 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This unit makes Free Pascal as much as possible Delphi compatible + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{***************************************************************************** + Basic Types/constants +*****************************************************************************} + + const +{$ifdef NEWVMTOFFSET} + vmtInstanceSize = 0; + vmtParent = 8; + { These were negative value's, but are now positive, else classes + couldn't be used with shared linking which copies only all data from + the .global directive and not the data before the directive (PFV) } + vmtClassName = 12; + vmtDynamicTable = 16; + vmtMethodTable = 20; + vmtFieldTable = 24; + vmtTypeInfo = 28; + vmtInitTable = 32; + vmtAutoTable = 36; + vmtIntfTable = 40; + vmtMsgStrPtr = 44; + { methods } + vmtMethodStart = 48; + vmtDestroy = vmtMethodStart; + vmtNewInstance = vmtMethodStart+4; + vmtFreeInstance = vmtMethodStart+8; + vmtSafeCallException = vmtMethodStart+12; + vmtDefaultHandler = vmtMethodStart+16; + vmtAfterConstruction = vmtMethodStart+20; + vmtBeforeDestruction = vmtMethodStart+24; + vmtDefaultHandlerStr = vmtMethodStart+28; +{$else} + vmtMsgStrPtr = -36; + vmtIntfTable = -32; + vmtAutoTable = -28; + vmtInitTable = -24; + vmtTypeInfo = -20; + vmtFieldTable = -16; + vmtMethodTable = -12; + vmtDynamicTable = -8; + vmtClassName = -4; + vmtInstanceSize = 0; + vmtParent = 8; + vmtDestroy = 12; + vmtNewInstance = 16; + vmtFreeInstance = 20; + vmtSafeCallException = 24; + vmtDefaultHandler = 28; + vmtAfterConstruction = 32; + vmtBeforeDestruction = 36; + vmtDefaultHandlerStr = 40; +{$endif} + + type + { some pointer definitions } + pshortstring = ^shortstring; + plongstring = ^longstring; + pansistring = ^ansistring; + pwidestring = ^widestring; + // pstring = pansistring; + pextended = ^extended; + ppointer = ^pointer; + + { now the let's declare the base classes for the class object } + { model } + tobject = class; + tclass = class of tobject; + pclass = ^tclass; + + + { to access the message table from outside } + tmsgstrtable = record + name : pshortstring; + method : pointer; + end; + + pmsgstrtable = ^tmsgstrtable; + + tstringmessagetable = record + count : dword; + msgstrtable : array[0..0] of tmsgstrtable; + end; + + pstringmessagetable = ^tstringmessagetable; + + tobject = class + public + { please don't change the order of virtual methods, because } + { their vmt offsets are used by some assembler code which uses } + { hard coded addresses (FK) } + constructor create; + { the virtual procedures must be in THAT order } + destructor destroy;virtual; + class function newinstance : tobject;virtual; + procedure freeinstance;virtual; + function safecallexception(exceptobject : tobject; + exceptaddr : pointer) : longint;virtual; + procedure defaulthandler(var message);virtual; + + procedure free; + class function initinstance(instance : pointer) : tobject; + procedure cleanupinstance; + function classtype : tclass; + class function classinfo : pointer; + class function classname : shortstring; + class function classnameis(const name : string) : boolean; + class function classparent : tclass; + class function instancesize : longint; + class function inheritsfrom(aclass : tclass) : boolean; + class function stringmessagetable : pstringmessagetable; + { message handling routines } + procedure dispatch(var message); + procedure dispatchstr(var message); + + class function methodaddress(const name : shortstring) : pointer; + class function methodname(address : pointer) : shortstring; + function fieldaddress(const name : shortstring) : pointer; + + { new since Delphi 4 } + procedure AfterConstruction;virtual; + procedure BeforeDestruction;virtual; + + { new for gtk, default handler for text based messages } + procedure DefaultHandlerStr(var message);virtual; + + { interface functions, I don't know if we need this } + { + function getinterface(const iid : tguid;out obj) : boolean; + class function getinterfaceentry(const iid : tguid) : pinterfaceentry; + class function getinterfacetable : pinterfacetable; + } + end; + + TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer); + + { Exception object stack } + PExceptObject = ^TExceptObject; + TExceptObject = record + FObject : TObject; + Addr, + Frame : pointer; + Next : PExceptObject; + end; + + Const + ExceptProc : TExceptProc = Nil; + + Function RaiseList : PExceptObject; + + +{***************************************************************************** + Variant Type +*****************************************************************************} + + Const + varEmpty = $0000; + varNull = $0001; + varSmallint = $0002; + varInteger = $0003; + varSingle = $0004; + varDouble = $0005; + varCurrency = $0006; + varDate = $0007; + varOleStr = $0008; + varDispatch = $0009; + varError = $000A; + varBoolean = $000B; + varVariant = $000C; + varUnknown = $000D; + varByte = $0011; + varString = $0100; + varAny = $0101; + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + vtQWord = 17; + + Type + PVarRec = ^TVarRec; + TVarRec = record + case VType : Longint of + vtInteger : (VInteger: 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; +{ + $Log: not supported by cvs2svn $ + Revision 1.11 2000/06/22 18:05:56 michael + + Modifications for exception support in sysutils. Mainly added + RaiseList function. + + Revision 1.10 2000/05/14 18:47:53 florian + * TVarRec with Int64/QWord stuff extended + + Revision 1.9 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.8 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.7 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.6 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.5 1999/12/02 19:28:53 peter + * public added to TObject + + Revision 1.4 1999/08/09 22:20:03 peter + * classes vmt changed to only positive addresses + * sharedlib creation is working + +} \ No newline at end of file diff --git a/befpc/rtl/inc/os_types.pp b/befpc/rtl/inc/os_types.pp new file mode 100644 index 0000000..d66d928 --- /dev/null +++ b/befpc/rtl/inc/os_types.pp @@ -0,0 +1,66 @@ +UNIT os_types; + +{ + Note: + This file is meant as a helper for porting C and C++ interfaces to FreePascal. + It got required since FPC's resolving of the integer type depends on selected + slang but not much on the target platform like its state of the art in C. + When porting API interfaces its recomended to use the types defined here. + 2000-Mar-18 alex +} + +INTERFACE + +TYPE +// ordinal types +{$ifdef Go32v1} + tOS_INT = LongInt; + tOS_UINT = DWord; +{$define OS_TYPES} +{$endif} +{$ifdef Go32v2} + tOS_INT = LongInt; + tOS_UINT = DWord; +{$define OS_TYPES} +{$endif} +{$ifdef WIN16} + tOS_INT = SmallInt; + tOS_UINT = Word; +{$define OS_TYPES} +{$endif} +{$ifdef WIN32} + tOS_INT = LongInt; + tOS_UINT = DWord; +{$define OS_TYPES} +{$endif} +{$ifdef WIN64} + tOS_INT = Comp; { 8 byte signed ordinal } + tOS_UINT = QWord; { 8 byte unsigned ordinal }{ possibly still needs to be defined } +{$define OS_TYPES} +{$endif} +{$ifdef LINUX} +{ TODO - how can we decide if we run on a 32 or a 64 bit linux platform ??? } + tOS_INT = LongInt; + tOS_UINT = DWord; +{$define OS_TYPES} +{$endif} +{$ifdef OS2} +{ TODO - just an assumption } + tOS_INT = LongInt; + tOS_UINT = DWord; +{$define OS_TYPES} +{$endif} + +{$ifdef OS_TYPES} +// derive pointers from base types + ptOS_INT = ^tOS_INT; + ptOS_UINT = ^tOS_UINT; +{$else} +{$warning In Unit OS_Types: no case for your target present } +{$endif} + +IMPLEMENTATION + +{begin}{of init} +end. + diff --git a/befpc/rtl/inc/readme b/befpc/rtl/inc/readme new file mode 100644 index 0000000..cf13cd1 --- /dev/null +++ b/befpc/rtl/inc/readme @@ -0,0 +1,33 @@ +This directory contains only RTL parts independent +of the processor and of the operating system. + +The include files contain the following: + +astrings.pp AnsiStrings implementation. +except.inc Delphi styled exception support. +file.inc Untyped file support routines. +filerec.inc Untyped file record definition. +heap.inc Runtime heap manager . +heaph.inc Declarations of Heap functions. +innr.inc Internal function delcarations. +int64.inc Support for 64-bit integer arithmetic. +lstrings.pp LongStrings routine implementation. +mathh.inc Declarations of mathematical functions. +real2str.inc Routine to convert floating point numbers to strings. +rtti.inc Delphi like runtime type information +sstrings.inc ShortStrings (TP/BP pascal like strings) implementation. +system.inc OS and Processor independent implementation part of system unit. +systemh.inc Interface part of the system unit. +text.inc Text file support routines. +textrec.inc Definition of Textrec record. +typefile.inc Text file record definition. +generic.inc Processor independant implementation of assembler procs on i386 + (to allow easy porting to new processors). + +The unit files are: + +ucomplex.pp Complex functions using operator overloading +getopts.pp Pascal implementation of the GNU Getops +objects.pp Turbo Pascal like implementation of objects unit +heaptrc.pp Runtime memory leak tracer and tests for memory integrity. + diff --git a/befpc/rtl/inc/real2str.inc b/befpc/rtl/inc/real2str.inc new file mode 100644 index 0000000..2884dd0 --- /dev/null +++ b/befpc/rtl/inc/real2str.inc @@ -0,0 +1,475 @@ +{ + $Id: real2str.inc,v 1.1.1.1 2001-07-23 17:17:38 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team + + 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. + + **********************************************************************} + +type + { See symdefh.inc tfloattyp } + treal_type = (rt_s32real,rt_s64real,rt_s80real,rt_c64bit,rt_f16bit,rt_f32bit); + { corresponding to single double extended fixed comp for i386 } + +Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; var s : string); +{$ifdef SUPPORT_EXTENDED} +type + TSplitExtended = packed record + case byte of + 0: (bytes: Array[0..9] of byte); + 1: (words: Array[0..4] of word); + 2: (cards: Array[0..1] of cardinal; w: word); + end; +const + maxDigits = 17; +{$else} +{$ifdef SUPPORT_DOUBLE} +type + TSplitDouble = packed record + case byte of + 0: (bytes: Array[0..7] of byte); + 1: (words: Array[0..3] of word); + 2: (cards: Array[0..1] of cardinal); + end; +const + maxDigits = 14; +{$else} +{$ifdef SUPPORT_SINGLE} +type + TSplitSingle = packed record + case byte of + 0: (bytes: Array[0..3] of byte); + 1: (words: Array[0..1] of word); + 2: (cards: Array[0..0] of cardinal); + end; +const + maxDigits = 9; +{$endif SUPPORT_SINGLE} +{$endif SUPPORT_DOUBLE} +{$endif SUPPORT_EXTENDED} + +type + { the value in the last position is used for rounding } + TIntPartStack = array[1..maxDigits+1] of valReal; + +var + roundCorr, corrVal: valReal; + intPart, spos, endpos, fracCount: longint; + correct, currprec: longint; + temp : string; + power : string[10]; + sign : boolean; + dot : byte; + mantZero, expMaximal: boolean; + + procedure RoundStr(var s: string; lastPos: byte); + var carry: longint; + begin + carry := 1; + repeat + s[lastPos] := chr(ord(s[lastPos])+carry); + carry := 0; + if s[lastPos] > '9' then + begin + s[lastPos] := '0'; + carry := 1; + end; + dec(lastPos); + until carry = 0; + end; + + procedure getIntPart(d: extended); + var + intPartStack: TIntPartStack; + stackPtr, endStackPtr, digits: longint; + overflow: boolean; + begin + { position in the stack (gets increased before first write) } + stackPtr := 0; + { number of digits processed } + digits := 0; + { did we wrap around in the stack? Necessary to know whether we should round } + overflow :=false; + { generate a list consisting of d, d/10, d/100, ... until d < 1.0 } + while d > 1.0-roundCorr do + begin + inc(stackPtr); + inc(digits); + if stackPtr > maxDigits+1 then + begin + stackPtr := 1; + overflow := true; + end; + intPartStack[stackPtr] := d; + d := d / 10.0; + end; + { if no integer part, exit } + if digits = 0 then + exit; + endStackPtr := stackPtr+1; + if endStackPtr > maxDigits + 1 then + endStackPtr := 1; + { now, all digits are calculated using trunc(d*10^(-n)-int(d*10^(-n-1))*10) } + corrVal := 0.0; + { the power of 10 with which the resulting string has to be "multiplied" } + { if the decimal point is placed after the first significant digit } + correct := digits-1; + repeat + if (currprec > 0) then + begin + intPart:= trunc(intPartStack[stackPtr]-corrVal); + dec(currPrec); + inc(spos); + temp[spos] := chr(intPart+ord('0')); + if temp[spos] > '9' then + begin + temp[spos] := chr(ord(temp[spos])-10); + roundStr(temp,spos-1); + end; + end; + corrVal := int(intPartStack[stackPtr]) * 10.0; + dec(stackPtr); + if stackPtr = 0 then + stackPtr := maxDigits+1; + until (overflow and (stackPtr = endStackPtr)) or + (not overflow and (stackPtr = maxDigits+1)) or (currPrec = 0); + { round if we didn't use all available digits yet and if the } + { remainder is > 5 } + if overflow and + (trunc(intPartStack[stackPtr]-corrVal) > 5.0 - roundCorr) then + roundStr(temp,spos); + end; + +var maxlen : longint; { Maximal length of string for float } + minlen : longint; { Minimal length of string for float } + explen : longint; { Length of exponent, including E and sign. + Must be strictly larger than 2 } +const + maxexp = 1e+35; { Maximum value for decimal expressions } + minexp = 1e-35; { Minimum value for decimal expressions } + zero = '0000000000000000000000000000000000000000'; + +begin + case real_type of + rt_s32real : + begin + maxlen:=16; + minlen:=8; + explen:=4; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((16-4-3)*ln(10))); + end; + rt_s64real : + begin +{ if the maximum suppported type is double, we can print out one digit } +{ less, because otherwise we can't round properly and 1e-400 becomes } +{ 0.99999999999e-400 (JM) } +{$ifdef support_extended} + maxlen:=23; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((23-5-3)*ln(10))); +{$else support_extended} +{$ifdef support_double} + maxlen := 22; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((22-4-3)*ln(10))); +{$endif support_double} +{$endif support_extended} + minlen:=9; + explen:=5; + end; + rt_s80real : + begin + { Different in TP help, but this way the output is the same (JM) } + maxlen:=25; + minlen:=10; + explen:=6; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((25-6-3)*ln(10))); + end; + rt_c64bit : + begin + maxlen:=23; + minlen:=10; + { according to TP (was 5) (FK) } + explen:=6; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((23-6-3)*ln(10))); + end; + rt_f16bit : + begin + maxlen:=16; + minlen:=8; + explen:=4; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((16-4-3)*ln(10))); + end; + rt_f32bit : + begin + maxlen:=16; + minlen:=8; + explen:=4; + { correction used with comparing to avoid rounding/precision errors } + roundCorr := (1/exp((16-4-3)*ln(10))); + end; + end; + { check parameters } + { default value for length is -32767 } + if len=-32767 then + len:=maxlen; + { determine sign. before precision, needs 2 less calls to abs() } +{$ifndef big_endian} +{$ifdef SUPPORT_EXTENDED} + { extended, format (MSB): 1 Sign bit, 15 bit exponent, 64 bit mantissa } + sign := (TSplitExtended(d).w and $8000) <> 0; + expMaximal := (TSplitExtended(d).w and $7fff) = 32767; + mantZero := (TSplitExtended(d).cards[0] = 0) and + (TSplitExtended(d).cards[1] = 0); +{$else SUPPORT_EXTENDED} +{$ifdef SUPPORT_DOUBLE} + { double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa } + sign := ((TSplitDouble(d).cards[1] shr 20) and $800) <> 0; + expMaximal := ((TSplitDouble(d).cards[1] shr 20) and $7ff) = 2047; + mantZero := (TSplitDouble(d).cards[1] and $fffff = 0) and + (TSplitDouble(d).cards[0] = 0); +{$else SUPPORT_DOUBLE} +{$ifdef SUPPORT_SINGLE} + { single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa } + sign := ((TSplitSingle(d).words[1] shr 7) and $100) <> 0; + expMaximal := ((TSplitSingle(d).words[1] shr 7) and $ff) = 255; + mantZero := (TSplitSingle(d).cards[0] and $7fffff = 0); +{$else SUPPORT_SINGLE} + {$error No big endian floating type supported yet in real2str} +{$endif SUPPORT_SINGLE} +{$endif SUPPORT_DOUBLE} +{$endif SUPPORT_EXTENDED} +{$else big_endian} + {$error sign/NaN/Inf not yet supported for big endian CPU's in str_real} +{$endif big_endian} + if expMaximal then + if mantZero then + if sign then + temp := '-Inf' + else temp := 'Inf' + else temp := 'NaN' + else + begin + { d:=abs(d); this converts d to double so we loose precision } + { for the same reason I converted d:=frac(d) to d:=d-int(d); (PM) } + if sign then + d:=-d; + { determine precision : maximal precision is : } + currPrec := maxlen-explen-2; + { this is also the maximal number of decimals !!} + if f>currprec then + f:=currprec; + { when doing a fixed-point, we need less characters.} + if (f<0) {or ((d<>0) and ((d>maxexp) and (d>minexp)))} then + begin + { determine maximal number of decimals } + if (len>=0) and (len0) and (len 1.0- roundCorr then + d := frac(d); + { if we have to round earlier than the amount of available precision, } + { only calculate digits up to that point } + if (f >= 0) and (currPrec > f) then + currPrec := f; + { if integer part was zero, go to the first significant digit of the } + { fractional part } + { make sure we don't get an endless loop if d = 0 } + if (spos = 2) and (d <> 0.0) then + begin + { take rounding errors into account } + while d < 0.1-roundCorr do + begin + d := d * 10.0; + dec(correct); + { adjust the precision depending on how many digits we } + { already "processed" by multiplying by 10, but only if } + { the amount of precision is specified } + if f >= 0 then + dec(currPrec); + end; + dec(correct); + end; + { current length of the output string in endPos } + endPos := spos; + { always calculate at least 1 fractional digit for rounding } + if (currPrec >= 0) then + begin + corrVal := 0.5; + for fracCount := 1 to currPrec do + corrVal := corrVal / 10.0; + if d >= corrVal then + d := d + corrVal; + if int(d) = 1 then + begin + roundStr(temp,spos); + d := frac(d); + end; + { calculate the necessary fractional digits } + for fracCount := 1 to currPrec do + begin + if d > 1.0- roundCorr then + d := frac(d) * 10.0 + else d := d * 10.0; + inc(spos); + temp[spos] := chr(trunc(d)+ord('0')); + if temp[spos] > '9' then + { possible because trunc and the "*10.0" aren't exact :( } + begin + temp[spos] := chr(ord(temp[spos]) - 10); + roundStr(temp,spos-1); + end; + end; + { new length of string } + endPos := spos; + end; + setLength(temp,endPos); + { delete leading zero if we didn't need it while rounding at the } + { string level } + if temp[2] = '0' then + delete(temp,2,1) + { the rounding caused an overflow to the next power of 10 } + else inc(correct); + if sign then + temp[1] := '-'; + if (f<0) or (correct>(round(ln(maxexp)/ln(10)))) then + begin + insert ('.',temp,3); + str(abs(correct),power); + if length(power)=0 then + begin + if length(temp)0 then + setlength(temp,pos('.',temp)+f) + else + setLength(temp,pos('.',temp)-1); + end; + end; + if length(temp)0) then + begin + IOSock(f); + textrec(f).bufpos:=0; + end; +end; + + + +Procedure CloseSock(var F:text); +begin + { Nothing special has to be done here } +end; + + + +Procedure Sock2Text(Sock:Longint;Var SockIn,SockOut:Text); +{ + Set up two Pascal Text file descriptors for reading and writing) +} +begin +{ First the reading part.} + Assign(SockIn,'.'); + Textrec(SockIn).Handle:=Sock; + Textrec(Sockin).userdata[1]:=S_IN; + TextRec(SockIn).OpenFunc:=@OpenSock; + TextRec(SockIn).InOutFunc:=@IOSock; + TextRec(SockIn).FlushFunc:=@FlushSock; + TextRec(SockIn).CloseFunc:=@CloseSock; +{ Now the writing part. } + Assign(SockOut,'.'); + Textrec(SockOut).Handle:=Sock; + Textrec(SockOut).userdata[1]:=S_OUT; + TextRec(SockOut).OpenFunc:=@OpenSock; + TextRec(SockOut).InOutFunc:=@IOSock; + TextRec(SockOut).FlushFunc:=@FlushSock; + TextRec(SockOut).CloseFunc:=@CloseSock; +end; + + +{****************************************************************************** + Untyped File +******************************************************************************} + +Procedure Sock2File(Sock:Longint;Var SockIn,SockOut:File); +begin +{Input} + Assign(SockIn,'.'); + FileRec(SockIn).Handle:=Sock; + FileRec(SockIn).RecSize:=1; + FileRec(Sockin).userdata[1]:=S_IN; +{Output} + Assign(SockOut,'.'); + FileRec(SockOut).Handle:=Sock; + FileRec(SockOut).RecSize:=1; + FileRec(SockOut).userdata[1]:=S_OUT; +end; + +{****************************************************************************** + InetSock +******************************************************************************} + +Function DoAccept(Sock:longint;Var addr:TInetSockAddr):longint; + +Var AddrLen : Longint; + +begin + AddrLEn:=SizeOf(Addr); + DoAccept:=Accept(Sock,Addr,AddrLen); +end; + +Function DoConnect(Sock:longint;const addr: TInetSockAddr): Boolean; + +begin + DoConnect:=Connect(Sock,Addr,SizeOF(TInetSockAddr)); +end; + +Function Connect(Sock:longint;const addr: TInetSockAddr;var SockIn,SockOut:text):Boolean; + +begin + Connect:=DoConnect(Sock,addr); + If Connect then + Sock2Text(Sock,SockIn,SockOut); +end; + +Function Connect(Sock:longint;const addr:TInetSockAddr;var SockIn,SockOut:file):Boolean; + +begin + Connect:=DoConnect(Sock,addr); + If Connect then + Sock2File(Sock,SockIn,SockOut); +end; + +Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:text):Boolean; +var + s : longint; +begin + S:=DoAccept(Sock,addr); + if S>0 then + begin + Sock2Text(S,SockIn,SockOut); + Accept:=true; + end + else + Accept:=false; +end; + +Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:File):Boolean; +var + s : longint; +begin + S:=DoAccept(Sock,addr); + if S>0 then + begin + Sock2File(S,SockIn,SockOut); + Accept:=true; + end + else + Accept:=false; +end; +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/06/21 22:27:50 pierre + * no bufpos reset on flush for fminput + + Revision 1.6 2000/05/22 12:38:51 jonas + * CloseSock is now a dummy (it called system.close, but this doesn't + make any sense since itself can only be called by system.close) This + caused an endless loop with my last changes where the mode of a + textrec is set to fmClosed only after the closeFunc() has been called. + + Revision 1.5 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.4 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.3 2000/01/07 16:32:25 daniel + * copyright 2000 added + +} \ No newline at end of file diff --git a/befpc/rtl/inc/socketsh.inc b/befpc/rtl/inc/socketsh.inc new file mode 100644 index 0000000..18309b1 --- /dev/null +++ b/befpc/rtl/inc/socketsh.inc @@ -0,0 +1,139 @@ +{ + $Id: socketsh.inc,v 1.1.1.1 2001-07-23 17:17:38 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +Const + { Socket Types } + SOCK_STREAM = 1; { stream (connection) socket } + SOCK_DGRAM = 2; { datagram (conn.less) socket } + SOCK_RAW = 3; { raw socket } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequential packet socket } + + AF_UNSPEC = 0; + AF_UNIX = 1; { Unix domain sockets } + AF_INET = 2; { Internet IP Protocol } + + { Protocol Families } + PF_UNSPEC = AF_UNSPEC; + PF_UNIX = AF_UNIX; + PF_INET = AF_INET; + +{$ifdef linux} +{ For setsockoptions(2) } + SOL_SOCKET = 1; + SO_DEBUG = 1; + SO_REUSEADDR= 2; + SO_TYPE = 3; + SO_ERROR = 4; + SO_DONTROUTE= 5; + SO_BROADCAST= 6; + SO_SNDBUF = 7; + SO_RCVBUF = 8; + SO_KEEPALIVE= 9; + SO_OOBINLINE= 10; + SO_NO_CHECK = 11; + SO_PRIORITY = 12; + SO_LINGER = 13; + SO_BSDCOMPAT= 14; +{ To add : SO_REUSEPORT 15 } + SO_PASSCRED= 16; + SO_PEERCRED= 17; + SO_RCVLOWAT= 18; + SO_SNDLOWAT= 19; + SO_RCVTIMEO= 20; + SO_SNDTIMEO= 21; + +{ Security levels - as per NRL IPv6 - don't actually do anything } + + SO_SECURITY_AUTHENTICATION = 22; + SO_SECURITY_ENCRYPTION_TRANSPORT= 23; + SO_SECURITY_ENCRYPTION_NETWORK = 24; + + SO_BINDTODEVICE= 25; + +{ Socket filtering } + + SO_ATTACH_FILTER= 26; + SO_DETACH_FILTER= 27; + + SO_PEERNAME = 28; +{$endif} +const + { Two constants to determine whether part of soket is for in or output } + S_IN = 0; + S_OUT = 1; + +Type + TSockAddr = packed Record + family:word; { was byte, fixed } + data :array [0..13] of char; + end; + + TInetSockAddr = packed Record + family:Word; + port :Word; + addr :Cardinal; + pad :array [1..8] of byte; { to get to the size of sockaddr... } + end; + + TSockArray = Array[1..2] of Longint; + +Var + SocketError:Longint; + +{Basic Socket Functions} +Function Socket(Domain,SocketType,Protocol:Longint):Longint; +Function Send(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; +Function Recv(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; +Function Bind(Sock:Longint;Var Addr;AddrLen:Longint):Boolean; +Function Listen (Sock,MaxConnect:Longint):Boolean; +Function Accept(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +Function Connect(Sock:Longint;Var Addr;Addrlen:Longint):boolean; +Function Shutdown(Sock:Longint;How:Longint):Longint; +Function GetSocketName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +Function GetPeerName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +Function SetSocketOptions(Sock,Level,OptName:Longint;Var OptVal;optlen:longint):Longint; +Function GetSocketOptions(Sock,Level,OptName:Longint;Var OptVal;Var optlen:longint):Longint; +Function SocketPair(Domain,SocketType,Protocol:Longint;var Pair:TSockArray):Longint; + +{Text Support} +Procedure Sock2Text(Sock:Longint;Var SockIn,SockOut:Text); + +{Untyped File Support} +Procedure Sock2File(Sock:Longint;Var SockIn,SockOut:File); + +{Better Pascal Calling, Overloaded Functions!} +Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:File):Boolean; +Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:text):Boolean; +Function Connect(Sock:longint;const addr:TInetSockAddr;var SockIn,SockOut:text):Boolean; +Function Connect(Sock:longint;const addr:TInetSockAddr;var SockIn,SockOut:file):Boolean; + +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/06/19 13:31:46 michael + + Corrected GetSocketOptions + + Revision 1.6 2000/06/02 17:30:43 marco + * added some constants for getsocketoptions under a linux define. + Allows server example to work ok. + + Revision 1.5 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.4 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.3 2000/01/07 16:32:25 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/inc/sstrings.inc b/befpc/rtl/inc/sstrings.inc new file mode 100644 index 0000000..63156f5 --- /dev/null +++ b/befpc/rtl/inc/sstrings.inc @@ -0,0 +1,593 @@ +{ + $Id: sstrings.inc,v 1.1.1.1 2001-07-23 17:17:38 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + 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. + + **********************************************************************} + +{**************************************************************************** + subroutines for string handling +****************************************************************************} + +{$I real2str.inc} + +function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring; +begin + if count<0 then + count:=0; + if index>1 then + dec(index) + else + index:=0; + if index>length(s) then + count:=0 + else + if index+count>length(s) then + count:=length(s)-index; + Copy[0]:=chr(Count); + Move(s[Index+1],Copy[1],Count); +end; + + +procedure delete(var s : shortstring;index : StrLenInt;count : StrLenInt); +begin + if index<=0 then + begin + inc(count,index-1); + index:=1; + end; + if (Index<=Length(s)) and (Count>0) then + begin + if Count+Index>length(s) then + Count:=length(s)-Index+1; + s[0]:=Chr(length(s)-Count); + if Index<=Length(s) then + Move(s[Index+Count],s[Index],Length(s)-Index+1); + end; +end; + + +procedure insert(const source : shortstring;var s : shortstring;index : StrLenInt); +var + cut,srclen,indexlen : longint; +begin + if index<1 then + index:=1; + if index>length(s) then + index:=length(s)+1; + indexlen:=Length(s)-Index+1; + srclen:=length(Source); + if length(source)+length(s)>=sizeof(s) then + begin + cut:=length(source)+length(s)-sizeof(s)+1; + if cut>indexlen then + begin + dec(srclen,cut-indexlen); + indexlen:=0; + end + else + dec(indexlen,cut); + end; + move(s[Index],s[Index+srclen],indexlen); + move(Source[1],s[Index],srclen); + s[0]:=chr(index+srclen+indexlen-1); +end; + + +procedure insert(source : Char;var s : shortstring;index : StrLenInt); +var + indexlen : longint; +begin + if index<1 then + index:=1; + if index>length(s) then + index:=length(s)+1; + indexlen:=Length(s)-Index+1; + if (length(s)+1=sizeof(s)) and (indexlen>0) then + dec(indexlen); + move(s[Index],s[Index+1],indexlen); + s[Index]:=Source; + s[0]:=chr(index+indexlen); +end; + + +function pos(const substr : shortstring;const s : shortstring):StrLenInt; +var + i,j : StrLenInt; + e : boolean; +begin + i := 0; + j := 0; + e:=(length(SubStr)>0); + while e and (i<=Length(s)-Length(SubStr)) do + begin + inc(i); + if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then + begin + j:=i; + e:=false; + end; + end; + Pos:=j; +end; + + +{Faster when looking for a single char...} +function pos(c:char;const s:shortstring):StrLenInt; +var + i : StrLenInt; +begin + for i:=1 to length(s) do + if s[i]=c then + begin + pos:=i; + exit; + end; + pos:=0; +end; + + +procedure SetLength(var s:shortstring;len:StrLenInt); +begin + if Len>255 then + Len:=255; + s[0]:=chr(len); +end; + + +function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring; +begin + if (index=1) and (Count>0) then + Copy:=c + else + Copy:=''; +end; + + +function pos(const substr : shortstring;c:char): StrLenInt; +begin + if (length(substr)=1) and (substr[1]=c) then + Pos:=1 + else + Pos:=0; +end; + + +{ removed must be internal to be accepted in const expr !! PM +function length(c:char):StrLenInt; +begin + Length:=1; +end; +} + +{$ifdef IBM_CHAR_SET} +const + UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165; + LoCaseTbl : shortstring[7]=#129#132#148#130#135#134#164; +{$endif} + +function upcase(c : char) : char; +{$IFDEF IBM_CHAR_SET} +var + i : longint; +{$ENDIF} +begin + if (c in ['a'..'z']) then + upcase:=char(byte(c)-32) + else +{$IFDEF IBM_CHAR_SET} + begin + i:=Pos(c,LoCaseTbl); + if i>0 then + upcase:=UpCaseTbl[i] + else + upcase:=c; + end; +{$ELSE} + upcase:=c; +{$ENDIF} +end; + + +function upcase(const s : shortstring) : shortstring; +var + i : longint; +begin + upcase[0]:=s[0]; + for i := 1 to length (s) do + upcase[i] := upcase (s[i]); +end; + + +{$ifndef RTLLITE} + +function lowercase(c : char) : char; +{$IFDEF IBM_CHAR_SET} +var + i : longint; +{$ENDIF} +begin + if (c in ['A'..'Z']) then + lowercase:=char(byte(c)+32) + else +{$IFDEF IBM_CHAR_SET} + begin + i:=Pos(c,UpCaseTbl); + if i>0 then + lowercase:=LoCaseTbl[i] + else + lowercase:=c; + end; + {$ELSE} + lowercase:=c; + {$ENDIF} +end; + + +function lowercase(const s : shortstring) : shortstring; +var + i : longint; +begin + lowercase [0]:=s[0]; + for i:=1 to length(s) do + lowercase[i]:=lowercase (s[i]); +end; + + +function hexstr(val : longint;cnt : byte) : shortstring; +const + HexTbl : array[0..15] of char='0123456789ABCDEF'; +var + i : longint; +begin + hexstr[0]:=char(cnt); + for i:=cnt downto 1 do + begin + hexstr[i]:=hextbl[val and $f]; + val:=val shr 4; + end; +end; + + +function binstr(val : longint;cnt : byte) : shortstring; +var + i : longint; +begin + binstr[0]:=char(cnt); + for i:=cnt downto 1 do + begin + binstr[i]:=char(48+val and 1); + val:=val shr 1; + end; +end; + +{$endif RTLLITE} + + +function space (b : byte): shortstring; +begin + space[0] := chr(b); + FillChar (Space[1],b,' '); +end; + + +{***************************************************************************** + Str() Helpers +*****************************************************************************} + +procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; +begin + str_real(len,fr,d,treal_type(rt),s); +end; + + +procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT']; +begin + int_str(v,s); + if length(s)=length(s)) or (s[code]<>'0'); + end; + '%' : begin + base:=2; + inc(code); + end; + end; + end; + InitVal:=code; +end; + + +Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR']; +var + u, temp, prev: ValUInt; + base : byte; + negative : boolean; +begin + ValSignedInt := 0; + Temp:=0; + Code:=InitVal(s,negative,base); + if Code>length(s) then + exit; + if negative and (s='-2147483648') then + begin + Code:=0; + ValSignedInt:=$80000000; + exit; + end; + + while Code<=Length(s) do + begin + case s[Code] of + '0'..'9' : u:=Ord(S[Code])-Ord('0'); + 'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10); + 'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10); + else + u:=16; + end; + Prev := Temp; + Temp := Temp*ValUInt(base); + If ((base = 10) and + (prev > MaxSIntValue div ValUInt(Base))) or + (Temp < prev) Then + Begin + ValSignedInt := 0; + Exit + End; + if (u>=base) or + ((base = 10) and + (MaxSIntValue < u+temp)) or + ((base <> 10) and + (ValUInt(MaxUIntValue-Temp) < u)) then + begin + ValSignedInt:=0; + exit; + end; + Temp:=Temp+u; + inc(code); + end; + code := 0; + ValSignedInt := ValSInt(Temp); + If Negative Then + ValSignedInt := -ValSignedInt; + If Not(Negative) and (base <> 10) Then + {sign extend the result to allow proper range checking} + Case DestSize of + 1: If (ValSignedInt > High(ShortInt)) and (ValSignedInt <= High(Byte)) Then + ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Byte)); + 2: If (ValSignedInt > High(Integer)) and (ValSignedInt <= High(Word)) Then + ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Word)); +{ Uncomment the folling once full 64bit support is in place + 4: If (ValSignedInt > High(Longint)) and (ValSignedInt <= High(Cardinal)) Then + ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Cardinal));} + End; +end; + + +Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR']; +var + u, prev: ValUInt; + base : byte; + negative : boolean; +begin + ValUnSignedInt:=0; + Code:=InitVal(s,negative,base); + If Negative or (Code>length(s)) Then + Exit; + while Code<=Length(s) do + begin + case s[Code] of + '0'..'9' : u:=Ord(S[Code])-Ord('0'); + 'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10); + 'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10); + else + u:=16; + end; + prev := ValUnsignedInt; + ValUnsignedInt:=ValUnsignedInt*ValUInt(base); + If prev > ValUnsignedInt Then + {we've had an overflow. Can't check this with + "If ValUnsignedInt <= (MaxUIntValue div ValUInt(Base)) Then" + because this division always overflows! (JM)} + Begin + ValUnsignedInt := 0; + Exit + End; + if (u>=base) or (ValUInt(MaxUIntValue-ValUnsignedInt) < u) then + begin + ValUnsignedInt:=0; + exit; + end; + ValUnsignedInt:=ValUnsignedInt+u; + inc(code); + end; + code := 0; +end; + + +Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; +var + hd, + esign,sign : valreal; + exponent,i : longint; + flags : byte; +begin + ValFloat:=0.0; + code:=1; + exponent:=0; + esign:=1; + flags:=0; + sign:=1; + while (code<=length(s)) and (s[code] in [' ',#9]) do + inc(code); + case s[code] of + '+' : inc(code); + '-' : begin + sign:=-1; + inc(code); + end; + end; + while (Code<=Length(s)) and (s[code] in ['0'..'9']) do + begin + { Read integer part } + flags:=flags or 1; + valfloat:=valfloat*10+(ord(s[code])-ord('0')); + inc(code); + end; +{ Decimal ? } + if (s[code]='.') and (length(s)>=code) then + begin + hd:=1.0; + inc(code); + while (s[code] in ['0'..'9']) and (length(s)>=code) do + begin + { Read fractional part. } + flags:=flags or 2; + valfloat:=valfloat*10+(ord(s[code])-ord('0')); + hd:=hd*10.0; + inc(code); + end; + valfloat:=valfloat/hd; + end; + { Again, read integer and fractional part} + if flags=0 then + begin + valfloat:=0.0; + exit; + end; + { Exponent ? } + if (upcase(s[code])='E') and (length(s)>=code) then + begin + inc(code); + if s[code]='+' then + inc(code) + else + if s[code]='-' then + begin + esign:=-1; + inc(code); + end; + if not(s[code] in ['0'..'9']) or (length(s)=code) do + begin + exponent:=exponent*10; + exponent:=exponent+ord(s[code])-ord('0'); + inc(code); + end; + end; +{ Calculate Exponent } +{ + if esign>0 then + for i:=1 to exponent do + valfloat:=valfloat*10 + else + for i:=1 to exponent do + valfloat:=valfloat/10; } + hd:=1.0; + for i:=1 to exponent do + hd:=hd*10.0; + if esign>0 then + valfloat:=valfloat*hd + else + valfloat:=valfloat/hd; +{ Not all characters are read ? } + if length(s)>=code then + begin + valfloat:=0.0; + exit; + end; +{ evaluate sign } + valfloat:=valfloat*sign; +{ success ! } + code:=0; +end; + + +{$ifdef SUPPORT_FIXED} +Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR']; +begin + ValFixed := Fixed(ValFloat(s,code)); +end; +{$endif SUPPORT_FIXED} + + +Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint); +begin + Move (Buf[0],S[1],Len); + S[0]:=chr(len); +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.35 2000/04/06 11:51:47 pierre + * fix for extended constants + + Revision 1.34 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.33 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.32 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.31 1999/12/11 19:07:44 jonas + * avoid unwanted type conversion from cardinal to longint in val for + signed and unsigned 32bit int + + Revision 1.30 1999/11/06 14:35:39 peter + * truncated log + +} \ No newline at end of file diff --git a/befpc/rtl/inc/strings.pp b/befpc/rtl/inc/strings.pp new file mode 100644 index 0000000..6d87a89 --- /dev/null +++ b/befpc/rtl/inc/strings.pp @@ -0,0 +1,162 @@ +{ + $Id: strings.pp,v 1.1.1.1 2001-07-23 17:17:39 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + Strings unit for PChar (asciiz/C compatible strings) handling + + 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 strings; +interface + + { Returns the length of a string } + function strlen(p : pchar) : longint; + + { Converts a Pascal string to a null-terminated string } + function strpcopy(d : pchar;const s : string) : pchar; + + { Converts a null-terminated string to a Pascal string } + function strpas(p : pchar) : string; + + { Copies source to dest, returns a pointer to dest } + function strcopy(dest,source : pchar) : pchar; + + { Copies at most maxlen bytes from source to dest. } + { Returns a pointer to dest } + function strlcopy(dest,source : pchar;maxlen : longint) : pchar; + + { Copies source to dest and returns a pointer to the terminating } + { null character. } + function strecopy(dest,source : pchar) : pchar; + + { Returns a pointer tro the terminating null character of p } + function strend(p : pchar) : pchar; + + { Appends source to dest, returns a pointer do dest} + function strcat(dest,source : pchar) : pchar; + + { Compares str1 und str2, returns } + { a value <0 if str10 if str1>str2 } + function strcomp(str1,str2 : pchar) : longint; + + { The same as strcomp, but at most l characters are compared } + function strlcomp(str1,str2 : pchar;l : longint) : longint; + + { The same as strcomp but case insensitive } + function stricomp(str1,str2 : pchar) : longint; + + { Copies l characters from source to dest, returns dest. } + function strmove(dest,source : pchar;l : longint) : pchar; + + { Appends at most l characters from source to dest } + function strlcat(dest,source : pchar;l : longint) : pchar; + + { Returns a pointer to the first occurrence of c in p } + { If c doesn't occur, nil is returned } + function strscan(p : pchar;c : char) : pchar; + + { Returns a pointer to the last occurrence of c in p } + { If c doesn't occur, nil is returned } + function strrscan(p : pchar;c : char) : pchar; + + { converts p to all-lowercase, returns p } + function strlower(p : pchar) : pchar; + + { converts p to all-uppercase, returns p } + function strupper(p : pchar) : pchar; + + { The same al stricomp, but at most l characters are compared } + function strlicomp(str1,str2 : pchar;l : longint) : longint; + + { Returns a pointer to the first occurrence of str2 in } + { str2 Otherwise returns nil } + function strpos(str1,str2 : pchar) : pchar; + + { Makes a copy of p on the heap, and returns a pointer to this copy } + function strnew(p : pchar) : pchar; + + { Allocates L bytes on the heap, returns a pchar pointer to it } + function stralloc(L : longint) : pchar; + + { Releases a null-terminated string from the heap } + procedure strdispose(p : pchar); + +implementation + +{ Read Processor dependent part, shared with sysutils unit } +{$i strings.inc } + +{ Read processor denpendent part, NOT shared with sysutils unit } +{$i stringss.inc } + +{ Functions not in assembler, but shared with sysutils unit } +{$i stringsi.inc} + +{ Functions, different from the one in sysutils } + + function stralloc(L : longint) : pchar; + + begin + StrAlloc:=Nil; + GetMem (Stralloc,l); + end; + + function strnew(p : pchar) : pchar; + + var + len : longint; + + begin + strnew:=nil; + if (p=nil) or (p^=#0) then + exit; + len:=strlen(p)+1; + getmem(strnew,len); + if strnew<>nil then + strmove(strnew,p,len); + end; + + procedure strdispose(p : pchar); + + begin + if p<>nil then + begin + freemem(p); + p:=nil; + end; + end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/03/19 08:40:14 peter + * strdispose uses freemem(pointer) and resets pointer to nil + + Revision 1.6 2000/03/18 15:43:05 jonas + * strdispose now uses dispose instead of freemem(strlen()+1) + + Revision 1.5 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.4 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.3 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.2 1999/12/10 15:02:12 peter + * strnew is ofcourse also different between sysutils and strings, just + like stralloc/strdispose. + +} + diff --git a/befpc/rtl/inc/stringsi.inc b/befpc/rtl/inc/stringsi.inc new file mode 100644 index 0000000..750b58c --- /dev/null +++ b/befpc/rtl/inc/stringsi.inc @@ -0,0 +1,87 @@ +{ + $Id: stringsi.inc,v 1.1.1.1 2001-07-23 17:17:39 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Processor independent part for strings and sysutils units + + 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. + + **********************************************************************} + + function strcat(dest,source : pchar) : pchar; + + begin + strcopy(strend(dest),source); + strcat:=dest; + end; + + function strlcat(dest,source : pchar;l : longint) : pchar; + + var + destend : pchar; + + begin + destend:=strend(dest); + dec(l,destend-dest); + if l>0 then + strlcopy(destend,source,l); + strlcat:=dest; + end; + + function strmove(dest,source : pchar;l : longint) : pchar; + + begin + move(source^,dest^,l); + strmove:=dest; + end; + + + function strpos(str1,str2 : pchar) : pchar; + + var + p : pchar; + lstr2 : longint; + + begin + strpos:=nil; + p:=strscan(str1,str2^); + if p=nil then + exit; + lstr2:=strlen(str2); + while p<>nil do + begin + if strlcomp(p,str2,lstr2)=0 then + begin + strpos:=p; + exit; + end; + inc(longint(p)); + p:=strscan(p,str2^); + end; + end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.6 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.5 1999/12/10 15:02:12 peter + * strnew is ofcourse also different between sysutils and strings, just + like stralloc/strdispose. + + Revision 1.4 1999/09/13 11:42:42 peter + * fixed strlcat + + Revision 1.3 1999/09/01 09:25:10 peter + * fixed return of strcat,strlcat + +} diff --git a/befpc/rtl/inc/system.inc b/befpc/rtl/inc/system.inc new file mode 100644 index 0000000..cb6e0b8 --- /dev/null +++ b/befpc/rtl/inc/system.inc @@ -0,0 +1,734 @@ +{ + $Id: system.inc,v 1.1.1.1 2001-07-23 17:17:39 memson Exp $ + + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + 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. + + **********************************************************************} + +{**************************************************************************** + Local types +****************************************************************************} + +{ + TextRec and FileRec are put in a separate file to make it available to other + units without putting it explicitly in systemh. + This way we keep TP compatibility, and the TextRec definition is available + for everyone who needs it. +} +{$i filerec.inc} +{$i textrec.inc} + +Procedure HandleError (Errno : Longint); forward; +Procedure HandleErrorFrame (Errno : longint;frame : longint); forward; + +type + FileFunc = Procedure(var t : TextRec); + + PByte = ^Byte; + PWord = ^word; + PDWord = ^DWord; + PLongint = ^Longint; + +const +{ Random / Randomize constants } + OldRandSeed : Cardinal = 0; + InitialSeed : Boolean = TRUE; + Seed2 : Cardinal = 0; + Seed3 : Cardinal = 0; + +{ For Error Handling.} + ErrorBase : Longint = 0; + +{ Used by the ansistrings and maybe also other things in the future } +var + emptychar : char;public name 'FPC_EMPTYCHAR'; + + +{**************************************************************************** + Routines which have compiler magic +****************************************************************************} + +{$I innr.inc} + +Function lo(i : Integer) : byte; [INTERNPROC: In_lo_Word]; +Function lo(w : Word) : byte; [INTERNPROC: In_lo_Word]; +Function lo(l : Longint) : Word; [INTERNPROC: In_lo_long]; +Function lo(l : DWord) : Word; [INTERNPROC: In_lo_long]; +Function hi(i : Integer) : byte; [INTERNPROC: In_hi_Word]; +Function hi(w : Word) : byte; [INTERNPROC: In_hi_Word]; +Function hi(l : Longint) : Word; [INTERNPROC: In_hi_long]; +Function hi(l : DWord) : Word; [INTERNPROC: In_hi_long]; + +{$ifdef INT64} +Function lo(q : QWord) : DWord; [INTERNPROC: In_lo_qword]; +Function lo(i : Int64) : DWord; [INTERNPROC: In_lo_qword]; +Function hi(q : QWord) : DWord; [INTERNPROC: In_hi_qword]; +Function hi(i : Int64) : DWord; [INTERNPROC: In_hi_qword]; +{$endif} + +Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte]; +Function Length(s : string) : byte; [INTERNPROC: In_Length_string]; +Function Length(c : char) : byte; [INTERNPROC: In_Length_string]; + +Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile]; +Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile]; + + +{**************************************************************************** + Include processor specific routines +****************************************************************************} + +{$IFDEF I386} + {$IFDEF M68K} + {$Error Can't determine processor type !} + {$ENDIF} + {$I i386.inc} { Case dependent, don't change } +{$ELSE} + {$IFDEF M68K} + {$I m68k.inc} { Case dependent, don't change } + {$ELSE} + {$Error Can't determine processor type !} + {$ENDIF} +{$ENDIF} + +{ Include generic pascal only routines which are not defined in the processor + specific include file } +{$I generic.inc} + + +{**************************************************************************** + Set Handling +****************************************************************************} + +{ Include set support which is processor specific} +{$I set.inc} + + +{**************************************************************************** + Math Routines +****************************************************************************} + +{$ifndef RTLLITE} + +function Hi(b : byte): byte; +begin + Hi := b shr 4 +end; + +function Lo(b : byte): byte; +begin + Lo := b and $0f +end; + +Function swap (X : Word) : Word;[internconst:in_const_swap_word]; +Begin + swap:=(X and $ff) shl 8 + (X shr 8) +End; + +Function Swap (X : Integer) : Integer;[internconst:in_const_swap_word]; +Begin + swap:=(X and $ff) shl 8 + (X shr 8) +End; + +Function swap (X : Longint) : Longint;[internconst:in_const_swap_long]; +Begin + Swap:=(X and $ffff) shl 16 + (X shr 16) +End; + +Function Swap (X : Cardinal) : Cardinal;[internconst:in_const_swap_long]; +Begin + Swap:=(X and $ffff) shl 16 + (X shr 16) +End; + +{$ifdef INT64} +Function Swap (X : QWord) : QWord; +Begin + Swap:=(X and $ffffffff) shl 32 + (X shr 32); +End; + +Function swap (X : Int64) : Int64; +Begin + Swap:=(X and $ffffffff) shl 32 + (X shr 32); +End; +{$endif} + +{$endif RTLLITE} + +{ Include processor specific routines } +{$I math.inc} + +{**************************************************************************** + Subroutines for String handling +****************************************************************************} + +{ Needs to be before RTTI handling } + +{$i sstrings.inc} + +{$i astrings.inc} + +{$ifdef haswidechar} +{$i wstrings.inc} +{$endif haswidechar} + +{**************************************************************************** + Run-Time Type Information (RTTI) +****************************************************************************} + +{$i rtti.inc} + +{ requires sstrings.inc for initval } +{$ifdef INT64} +{$I int64.inc} +{$endif INT64} + + +{**************************************************************************** + Random function routines + + This implements a very long cycle random number generator by combining + three independant generators. The technique was described in the March + 1987 issue of Byte. + Taken and modified with permission from the PCQ Pascal rtl code. +****************************************************************************} + +{$R-} +{$Q-} + +Procedure NewSeed;Forward; + + +Function Random : Extended; +begin + if (InitialSeed) OR (RandSeed <> OldRandSeed) then + Begin + { This is a pretty complicated affair } + { Initially we must call NewSeed when RandSeed is initalized } + { We must also call NewSeed each time RandSeed is reinitialized } + { DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK } + { UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC) } + InitialSeed:=FALSE; + OldRandSeed:=RandSeed; + NewSeed; + end; + Inc(RandSeed); + RandSeed := (RandSeed * 706) mod 500009; + OldRandSeed:=RandSeed; + INC(Seed2); + Seed2 := (Seed2 * 774) MOD 600011; + INC(Seed3); + Seed3 := (Seed3 * 871) MOD 765241; + Random := + frac(RandSeed/500009.0 + + Seed2/600011.0 + + Seed3/765241.0); +end; + +Function internRandom(l : Cardinal) : Cardinal; +begin + if (InitialSeed) OR (RandSeed <> OldRandSeed) then + Begin + { This is a pretty complicated affair } + { Initially we must call NewSeed when RandSeed is initalized } + { We must also call NewSeed each time RandSeed is reinitialized } + { DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK } + { UNLESS YOU WANT RANDOM TO CRASH OF COURSE (CEC) } + InitialSeed:=FALSE; + OldRandSeed:=RandSeed; + NewSeed; + end; + Inc(RandSeed); + RandSeed := (RandSeed * 998) mod 1000003; + OldRandSeed:=RandSeed; + if l<>0 then + begin + internRandom := RandSeed mod l; + end + else internRandom:=0; +end; + +function random(l:cardinal): cardinal; +begin + random := trunc(random()*l); +end; + +{$ifndef cardinalmulfixed} +function random(l:longint): longint; +begin + random := trunc(random()*l); +end; +{$endif cardinalmulfixed} + +Procedure NewSeed; +begin + randseed := randseed mod 1000003; + Seed2 := (internRandom(65000) * internRandom(65000)) mod 600011; + Seed3 := (internRandom(65000) * internRandom(65000)) mod 765241; +end; + +{**************************************************************************** + Memory Management +****************************************************************************} + +{$ifndef RTLLITE} + +Function Ptr(sel,off : Longint) : pointer;[internconst:in_const_ptr]; +Begin + sel:=0; + ptr:=pointer(off); +End; + +Function CSeg : Word; +Begin + Cseg:=0; +End; + +Function DSeg : Word; +Begin + Dseg:=0; +End; + +Function SSeg : Word; +Begin + Sseg:=0; +End; + +{$endif RTLLITE} + + +{***************************************************************************** + Directory support. +*****************************************************************************} + +Procedure getdir(drivenr:byte;Var dir:ansistring); +{ this is needed to also allow ansistrings, the shortstring version is + OS dependent } +var + s : shortstring; +begin + getdir(drivenr,s); + dir:=s; +end; + +{$ifopt R+} +{$define RangeCheckWasOn} +{$R-} +{$endif opt R+} + +{$ifopt I+} +{$define IOCheckWasOn} +{$I-} +{$endif opt I+} + +{$ifopt Q+} +{$define OverflowCheckWasOn} +{$Q-} +{$endif opt Q+} + +{***************************************************************************** + Miscellaneous +*****************************************************************************} + +procedure int_overflow;[public,alias:'FPC_OVERFLOW']; +begin + HandleErrorFrame(215,get_frame); +end; + + +{$ifdef HASSAVEREGISTERS} +procedure int_iocheck(addr : longint);[saveregisters,public,alias:'FPC_IOCHECK']; +var + l : longint; +begin + if InOutRes<>0 then + begin + l:=InOutRes; + InOutRes:=0; + HandleErrorFrame(l,get_frame); + end; +end; +{$endif} + + +Function IOResult:Word; +Begin + IOResult:=InOutRes; + InOutRes:=0; +End; + + +procedure fillchar(var x;count : longint;value : boolean); +begin + fillchar(x,count,byte(value)); +end; + + +procedure fillchar(var x;count : longint;value : char); +begin + fillchar(x,count,byte(value)); +end; + + +{***************************************************************************** + Initialization / Finalization +*****************************************************************************} + +const + maxunits=1024; { See also files.pas of the compiler source } +type + TInitFinalRec=record + InitProc, + FinalProc : TProcedure; + end; + TInitFinalTable=record + TableCount, + InitCount : longint; + Procs : array[1..maxunits] of TInitFinalRec; + end; + +var + InitFinalTable : TInitFinalTable;external name 'INITFINAL'; + +procedure InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; +var + i : longint; +begin + with InitFinalTable do + begin + for i:=1to TableCount do + begin + if assigned(Procs[i].InitProc) then + Procs[i].InitProc(); + InitCount:=i; + end; + end; +end; + + +procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS']; +begin + with InitFinalTable do + begin + while (InitCount>0) do + begin + // we've to decrement the cound before calling the final. code + // else a halt in the final. code leads to a endless loop + dec(InitCount); + if assigned(Procs[InitCount+1].FinalProc) then + Procs[InitCount+1].FinalProc(); + end; + end; +end; + + +{***************************************************************************** + Error / Exit / ExitProc +*****************************************************************************} + +Procedure system_exit;forward; + +Procedure do_exit;[Public,Alias:'FPC_DO_EXIT']; +var + current_exit : Procedure; +Begin + while exitProc<>nil Do + Begin + InOutRes:=0; + current_exit:=tProcedure(exitProc); + exitProc:=nil; + current_exit(); + End; + { Finalize units } + FinalizeUnits; + { Show runtime error } + If erroraddr<>nil Then + Begin + Writeln(stdout,'Runtime error ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8)); + { to get a nice symify } + Writeln(stdout,BackTraceStrFunc(Longint(Erroraddr))); + dump_stack(stdout,ErrorBase); + Writeln(stdout,''); + End; + { call system dependent exit code } + System_exit; +End; + + +Procedure Halt(ErrNum: Byte); +Begin + ExitCode:=Errnum; + Do_Exit; +end; + + +function SysBackTraceStr (Addr: longint): ShortString; +begin + SysBackTraceStr:=' 0x'+HexStr(addr,8); +end; + + +Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : longint); +begin + If pointer(ErrorProc)<>Nil then + ErrorProc(Errno,pointer(addr),pointer(frame)); + errorcode:=Errno; + exitcode:=Errno; + erroraddr:=pointer(addr); + errorbase:=frame; + halt(errorcode); +end; + +Procedure HandleErrorFrame (Errno : longint;frame : longint); +{ + Procedure to handle internal errors, i.e. not user-invoked errors + Internal function should ALWAYS call HandleError instead of RunError. + Can be used for exception handlers to specify the frame +} +begin + HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame)); +end; + + +Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR']; +{ + Procedure to handle internal errors, i.e. not user-invoked errors + Internal function should ALWAYS call HandleError instead of RunError. +} +begin + HandleErrorFrame(Errno,get_frame); +end; + + +procedure runerror(w : word);[alias: 'FPC_RUNERROR']; +begin + errorcode:=w; + exitcode:=w; + erroraddr:=pointer(get_caller_addr(get_frame)); + errorbase:=get_caller_frame(get_frame); + halt(errorcode); +end; + + +Procedure RunError; +Begin + RunError (0); +End; + + +Procedure Halt; +Begin + Halt(0); +End; + +function do_isdevice(handle:longint):boolean;forward; + + +Procedure dump_stack(var f : text;bp : Longint); +var + i, prevbp : Longint; + is_dev : boolean; +Begin + prevbp:=bp-1; + i:=0; + is_dev:=do_isdevice(textrec(f).Handle); + while bp > prevbp Do + Begin + Writeln(f,BackTraceStrFunc(get_caller_addr(bp))); + Inc(i); + If ((i>max_frame_dump) and is_dev) or (i>256) Then + exit; + prevbp:=bp; + bp:=get_caller_frame(bp); + End; +End; + + +Type + PExitProcInfo = ^TExitProcInfo; + TExitProcInfo = Record + Next : PExitProcInfo; + SaveExit : Pointer; + Proc : TProcedure; + End; +const + ExitProcList: PExitProcInfo = nil; + +Procedure DoExitProc; +var + P : PExitProcInfo; + Proc : TProcedure; +Begin + P:=ExitProcList; + ExitProcList:=P^.Next; + ExitProc:=P^.SaveExit; + Proc:=P^.Proc; + DisPose(P); + Proc(); +End; + + +Procedure AddExitProc(Proc: TProcedure); +var + P : PExitProcInfo; +Begin + New(P); + P^.Next:=ExitProcList; + P^.SaveExit:=ExitProc; + P^.Proc:=Proc; + ExitProcList:=P; + ExitProc:=@DoExitProc; +End; + + +{***************************************************************************** + Abstract/Assert support. +*****************************************************************************} + +procedure AbstractError;[public,alias : 'FPC_ABSTRACTERROR']; +begin + If pointer(AbstractErrorProc)<>nil then + AbstractErrorProc(); + HandleErrorFrame(211,get_frame); +end; + + +Procedure int_assert(Const Msg,FName:Shortstring;LineNo,ErrorAddr:Longint); [{$ifdef HASSAVEREGISTERS}SaveRegisters,{$endif}Public,Alias : 'FPC_ASSERT']; +begin + if pointer(AssertErrorProc)<>nil then + AssertErrorProc(Msg,FName,LineNo,ErrorAddr) + else + HandleErrorFrame(227,get_frame); +end; + + +Procedure SysAssert(Const Msg,FName:Shortstring;LineNo,ErrorAddr:Longint); +begin + If msg='' then + write(stderr,'Assertion failed') + else + write(stderr,msg); + Writeln(stderr,' (',FName,', line ',LineNo,').'); + Writeln(stderr,''); +end; + + +{***************************************************************************** + SetJmp/LongJmp support. +*****************************************************************************} + +{$i setjump.inc} + + +{$ifdef IOCheckWasOn} +{$I+} +{$endif} + +{$ifdef RangeCheckWasOn} +{$R+} +{$endif} + +{$ifdef OverflowCheckWasOn} +{$Q+} +{$endif} + +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$i objpas.inc} + +{ + $Log: not supported by cvs2svn $ + Revision 1.89 2000/05/23 20:35:41 pierre + * disable check in Exit and Error code + + Revision 1.88 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.87 2000/04/14 12:17:12 pierre + + get longer backtrace when redirected to file + + Revision 1.86 2000/04/02 09:39:25 florian + * halt in the finalization statement of a unit lead to an endless loop; fixed + + Revision 1.85 2000/03/14 07:31:57 pierre + + HandleErrorAddrFrame + + Revision 1.84 2000/02/26 15:49:40 jonas + + new str_real which is completely TP compatible regarding output + format and which should have no rounding errors anymore + + Revision 1.83 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.82 2000/02/09 12:17:51 peter + * moved halt to system.inc + * syslinux doesn't use direct asm anymore + + Revision 1.81 2000/02/06 17:19:22 peter + * lineinfo unit added which uses stabs to get lineinfo for backtraces + + Revision 1.80 2000/01/10 09:54:30 peter + * primitives added + + Revision 1.79 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.78 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.77 1999/12/21 11:10:22 pierre + * allow v09912 to compile system + + Revision 1.76 1999/12/18 14:54:34 florian + * very basic widestring support + + Revision 1.75 1999/12/12 13:29:34 jonas + * remove "random(longint): longint" if cardinalmulfixed is defined + + Revision 1.74 1999/12/01 12:37:13 jonas + + function random(longint): longint + + Revision 1.73 1999/11/20 12:48:09 jonas + * reinstated old random generator, but modified it so the integer + one now has a much longer period + + Revision 1.72 1999/11/15 21:49:47 peter + * exception address fixes + + Revision 1.71 1999/11/09 22:40:12 pierre + + get also first BackTrace address with ' 0x' prefix + + Revision 1.70 1999/11/09 20:14:12 daniel + * Committed new random generator. + + Revision 1.69 1999/11/06 14:35:39 peter + * truncated log + + Revision 1.68 1999/10/26 12:31:00 peter + * *errorproc are not procvars instead of pointers which allows better + error checking for the parameters (shortstring<->ansistring) + + Revision 1.67 1999/09/18 16:05:12 jonas + * dump_stack now actually dumps its info to f (was still hardcoded + to stderr) + + Revision 1.66 1999/08/05 23:45:14 peter + * saveregister is now working and used for assert and iocheck (which has + been moved to system.inc because it's now system independent) + + Revision 1.65 1999/07/28 12:58:22 peter + * fixed assert() to push/pop registers + +} \ No newline at end of file diff --git a/befpc/rtl/inc/systemh.inc b/befpc/rtl/inc/systemh.inc new file mode 100644 index 0000000..bce9536 --- /dev/null +++ b/befpc/rtl/inc/systemh.inc @@ -0,0 +1,539 @@ +{ + $Id: systemh.inc,v 1.1.1.1 2001-07-23 17:17:39 memson Exp $ + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This File contains the OS independent declarations of the system unit + + 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. + + **********************************************************************} + +{ + Supported conditionnals: + ------------------------ + RTLLITE Create a somewhat smaller RTL +} + +{**************************************************************************** + Needed switches +****************************************************************************} + +{$I-,Q-,H-,R-,V-} +{$mode objfpc} + +{ don't use FPU registervariables on the i386 } +{$ifdef i386} + {$maxfpuregisters 0} +{$endif i386} + +{ needed for insert,delete,readln } +{$P+} + +{ Stack check gives a note under linux } +{$ifndef linux} + {$S-} +{$endif} + +{**************************************************************************** + Global Types and Constants +****************************************************************************} + +Type + shortint = -128..127; + SmallInt = -32768..32767; + Longint = $80000000..$7fffffff; { $8000000 creates a longint overfow !! } + byte = 0..255; + Word = 0..65535; + dword = cardinal; + longword = cardinal; + +{ at least declare Turbo Pascal real types } +{$ifdef i386} + StrLenInt = LongInt; + + {$define DEFAULT_EXTENDED} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + {$define SUPPORT_EXTENDED} + {$define SUPPORT_COMP} + + { define SUPPORT_FIXED} + + ValSInt = Longint; + ValUInt = Cardinal; + ValReal = Extended; +{$endif} + +{$ifdef m68k} + StrLenInt = Longint; + + ValSInt = Longint; + ValUInt = Cardinal; + ValReal = Real; + + {$define SUPPORT_SINGLE} +{$endif} + +{ Zero - terminated strings } + PChar = ^Char; + PPChar = ^PChar; +{ Delphi types } + TAnsiChar = Char; + AnsiChar = TAnsiChar; + PAnsiChar = PChar; + PQWord = ^QWord; + PInt64 = ^Int64; + +{$ifdef HASWIDECHAR} + PWideChar = ^WideChar; +{$endif HASWIDECHAR} + +{ procedure type } + TProcedure = Procedure; + +const +{ Maximum value of the biggest signed and unsigned integer type available} + MaxSIntValue = High(ValSInt); + MaxUIntValue = High(ValUInt); + +{ max. values for longint and int} + maxLongint = $7fffffff; + maxSmallint = 32767; + +{ Integer type definition } +type + Integer = smallint; +const + maxint = maxsmallint; + +{ Compatibility With TP } +const +{$ifdef i386} + Test8086 : byte = 2; { Always i386 or newer } + Test8087 : byte = 3; { Always 387 or newer. Emulated if needed. } + { code to use comps in int64mul and div code is commented out! (JM) } + FPUInt64 : boolean = false; { set this to false if you don't want that } + { the fpu does int64*int64 and } + { int64 div int64, if the * is overflow } + { checked, it is done in software } +{$endif i386} +{$ifdef m68k} + Test68000 : byte = 0; { Must be determined at startup for both } + Test68881 : byte = 0; +{$endif} + +{ max level in dumping on error } + Max_Frame_Dump : Word = 8; + +{ Exit Procedure handling consts and types } + ExitProc : pointer = nil; + Erroraddr: pointer = nil; + Errorcode: Word = 0; + +{ file input modes } + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + fmAppend = $D7B4; + Filemode : byte = 2; + CmdLine : PChar = nil; + +var +{ Standard In- and Output } + Output, + Input, + StdOut, + StdErr : Text; + ExitCode, + InOutRes : Word; + StackBottom, + LowestStack, + RandSeed : Cardinal; +{ Delphi compatible } + IsLibrary,IsMultiThreaded,IsConsole : boolean; + + +{**************************************************************************** + Processor specific routines +****************************************************************************} + +Procedure Move(const source;var dest;count:Longint); +Procedure FillChar(Var x;count:Longint;Value:Boolean); +Procedure FillChar(Var x;count:Longint;Value:Char); +Procedure FillChar(Var x;count:Longint;Value:Byte); +{$ifndef RTLLITE} +procedure FillByte(var x;count:longint;value:byte); +Procedure FillWord(Var x;count:Longint;Value:Word); +procedure FillDWord(var x;count:longint;value:DWord); +function IndexChar(var buf;len:longint;b:char):longint; +function IndexByte(var buf;len:longint;b:byte):longint; +function Indexword(var buf;len:longint;b:word):longint; +function IndexDWord(var buf;len:longint;b:DWord):longint; +function CompareChar(var buf1,buf2;len:longint):longint; +function CompareByte(var buf1,buf2;len:longint):longint; +function CompareWord(var buf1,buf2;len:longint):longint; +function CompareDWord(var buf1,buf2;len:longint):longint; +procedure MoveChar0(var buf1,buf2;len:longint); +function IndexChar0(var buf;len:longint;b:char):longint; +function CompareChar0(var buf1,buf2;len:longint):longint; +{$endif} + + +{**************************************************************************** + Math Routines +****************************************************************************} + +{$ifndef RTLLITE} +Function lo(w:Word):byte; +Function lo(l:Longint):Word; +Function lo(l:DWord):Word; +Function lo(i:Integer):byte; +Function lo(B: Byte):Byte; +Function hi(w:Word):byte; +Function hi(i:Integer):byte; +Function hi(l:Longint):Word; +Function hi(b : Byte) : Byte; +Function hi(l: DWord): Word; +Function Swap (X:Word):Word; +Function Swap (X:Integer):Integer; +Function Swap (X:Cardinal):Cardinal; +Function Swap (X:LongInt):LongInt; +{$ifdef INT64} +Function lo(q : QWord) : DWord; +Function lo(i : Int64) : DWord; +Function hi(q : QWord) : DWord; +Function hi(i : Int64) : DWord; +Function Swap (X:QWord):QWord; +Function Swap (X:Int64):Int64; +{$endif} +{$endif RTLLITE} + +Function Random(l:cardinal):cardinal; +{$ifndef cardinalmulfixed} +Function Random(l:longint):longint; +{$endif cardinalmulfixed} +Function Random: extended; +Procedure Randomize; + +Function abs(l:Longint):Longint; +Function sqr(l:Longint):Longint; +Function odd(l:Longint):Boolean; + +{ float math routines } +{$I mathh.inc} + +{**************************************************************************** + Addr/Pointer Handling +****************************************************************************} + +{$ifndef RTLLITE} +Function ptr(sel,off:Longint):pointer; +Function Cseg:Word; +Function Dseg:Word; +Function Sseg:Word; +{$endif RTLLITE} + +{**************************************************************************** + PChar and String Handling +****************************************************************************} + +function strpas(p:pchar):shortstring; +function strlen(p:pchar):longint; + +{ Shortstring functions } +Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring; +Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt); +Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt); +Procedure Insert(source:Char;Var s:shortstring;index:StrLenInt); +Function Pos(const substr:shortstring;const s:shortstring):StrLenInt; +Function Pos(C:Char;const s:shortstring):StrLenInt; +Procedure SetLength(var s:shortstring;len:StrLenInt); +Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint); +Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint); +Function Length(s:string):byte; +Function upCase(const s:shortstring):shortstring; +{$ifndef RTLLITE} +Function lowerCase(const s:shortstring):shortstring; +{$endif} +Function Space(b:byte):shortstring; +{$ifndef RTLLITE} +Function hexStr(Val:Longint;cnt:byte):shortstring; +Function binStr(Val:Longint;cnt:byte):shortstring; +{$endif RTLLITE} + +{ Char functions } +Function Chr(b:byte):Char; +Function upCase(c:Char):Char; +{$ifndef RTLLITE} +Function lowerCase(c:Char):Char; +{$endif RTLLITE} +function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring; +function pos(const substr : shortstring;c:char): StrLenInt; +function length(c:char):byte; + + +{**************************************************************************** + AnsiString Handling +****************************************************************************} + +Procedure SetLength (Var S : AnsiString; l : Longint); +Procedure UniqueString (Var S : AnsiString); +Function Length (Const S : AnsiString) : Longint; +Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString; +Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint; +Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint); +Procedure Delete (Var S : AnsiString; Index,Size: Longint); +Function StringOfChar(c : char;l : longint) : AnsiString; + + +{**************************************************************************** + Untyped File Management +****************************************************************************} + +Procedure Assign(Var f:File;const Name:string); +Procedure Assign(Var f:File;p:pchar); +Procedure Assign(Var f:File;c:char); +Procedure Rewrite(Var f:File;l:Longint); +Procedure Rewrite(Var f:File); +Procedure Reset(Var f:File;l:Longint); +Procedure Reset(Var f:File); +Procedure Close(Var f:File); +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint;Var Result:Longint); +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;Var Result:Word); +Procedure BlockWrite(Var f:File;Var Buf;Count:Word;Var Result:Integer); +Procedure BlockWrite(Var f:File;Var Buf;Count:Longint); +Procedure BlockRead(Var f:File;Var Buf;count:Longint;Var Result:Longint); +Procedure BlockRead(Var f:File;Var Buf;count:Word;Var Result:Word); +Procedure BlockRead(Var f:File;Var Buf;count:Word;Var Result:Integer); +Procedure BlockRead(Var f:File;Var Buf;count:Longint); +Function FilePos(Var f:File):Longint; +Function FileSize(Var f:File):Longint; +Procedure Seek(Var f:File;Pos:Longint); +Function EOF(Var f:File):Boolean; +Procedure Erase(Var f:File); +Procedure Rename(Var f:File;const s:string); +Procedure Rename(Var f:File;p:pchar); +Procedure Rename(Var f:File;c:char); +Procedure Truncate (Var F:File); + + +{**************************************************************************** + Typed File Management +****************************************************************************} + +Procedure Assign(Var f:TypedFile;const Name:string); +Procedure Assign(Var f:TypedFile;p:pchar); +Procedure Assign(Var f:TypedFile;c:char); +Procedure Rewrite(Var f:TypedFile); +Procedure Reset(Var f:TypedFile); + + +{**************************************************************************** + Text File Management +****************************************************************************} + +Procedure Assign(Var t:Text;const s:string); +Procedure Assign(Var t:Text;p:pchar); +Procedure Assign(Var t:Text;c:char); +Procedure Close(Var t:Text); +Procedure Rewrite(Var t:Text); +Procedure Reset(Var t:Text); +Procedure Append(Var t:Text); +Procedure Flush(Var t:Text); +Procedure Erase(Var t:Text); +Procedure Rename(Var t:Text;const s:string); +Procedure Rename(Var t:Text;p:pchar); +Procedure Rename(Var t:Text;c:char); +Function EOF(Var t:Text):Boolean; +Function EOF:Boolean; +Function EOLn(Var t:Text):Boolean; +Function EOLn:Boolean; +Function SeekEOLn (Var t:Text):Boolean; +Function SeekEOF (Var t:Text):Boolean; +Function SeekEOLn:Boolean; +Function SeekEOF:Boolean; +Procedure SetTextBuf(Var f:Text; Var Buf); +Procedure SetTextBuf(Var f:Text; Var Buf; Size:Longint); + + +{**************************************************************************** + Directory Management +****************************************************************************} + +Procedure chdir(const s:string); +Procedure mkdir(const s:string); +Procedure rmdir(const s:string); +Procedure getdir(drivenr:byte;Var dir:shortstring); +Procedure getdir(drivenr:byte;Var dir:ansistring); + + +{***************************************************************************** + Miscelleaous +*****************************************************************************} + +{ os independent calls to allow backtraces } +function get_frame:longint; +function get_caller_addr(framebp:longint):longint; +function get_caller_frame(framebp:longint):longint; + +Function IOResult:Word; +Function Sptr:Longint; + + +{***************************************************************************** + Init / Exit / ExitProc +*****************************************************************************} + +Function Paramcount:Longint; +Function ParamStr(l:Longint):string; +{$ifndef RTLLITE} +Procedure Dump_Stack(var f : text;bp:Longint); +{$endif RTLLITE} +Procedure RunError(w:Word); +Procedure RunError; +Procedure halt(errnum:byte); +{$ifndef RTLLITE} +Procedure AddExitProc(Proc:TProcedure); +{$endif RTLLITE} +Procedure halt; + + +{***************************************************************************** + Abstract/Assert/Error Handling +*****************************************************************************} + +procedure AbstractError; +Function SysBackTraceStr(Addr: Longint): ShortString; +Procedure SysAssert(Const Msg,FName:ShortString;LineNo,ErrorAddr:Longint); + +{ Error handlers } +Type + TBackTraceStrFunc = Function (Addr: Longint): ShortString; + TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer); + TAbstractErrorProc = Procedure; + TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno,erroraddr:longint); + + + +const + BackTraceStrFunc : TBackTraceStrFunc = @SysBackTraceStr; + ErrorProc : TErrorProc = nil; + AbstractErrorProc : TAbstractErrorProc = nil; + AssertErrorProc : TAssertErrorProc = @SysAssert; + + +{***************************************************************************** + SetJmp/LongJmp +*****************************************************************************} + +{$i setjumph.inc} + + +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$i objpash.inc} + +{ + $Log: not supported by cvs2svn $ + Revision 1.87 2000/07/07 19:22:27 pierre + * correct last commit error + + Revision 1.86 2000/07/07 18:23:41 marco + * Changed move (var source;var dest) to move (const source;var dest) + + Revision 1.85 2000/06/22 18:41:25 peter + * moved islibrary,isconsole,ismulithread to systemh as they are + os independent + + Revision 1.84 2000/06/22 18:05:56 michael + + Modifications for exception support in sysutils. Mainly added + RaiseList function. + + Revision 1.83 2000/06/11 07:02:30 peter + * UniqueAnsiString -> UniqueString for Delphi compatibility + + Revision 1.82 2000/05/14 18:46:54 florian + * TVarRec with In64/QWord stuff extended + + Revision 1.81 2000/04/24 11:11:50 peter + * backtraces for exceptions are now only generated from the place of the + exception + * frame is also pushed for exceptions + * raise statement enhanced with [,] + + Revision 1.80 2000/03/26 11:36:28 jonas + + $maxfpuregisters 0 for i386 in systemh (to avoid requiring too much + empty FPU registers for sysstem routines + * fixed bug in str_real when using :x:0 + * str_real now doesn't call exp() anymore at runtime, so it should + require less free FPU registers now (and be slightly faster) + + Revision 1.79 2000/03/14 10:20:18 michael + + Added constants and types for Delphi compatibility + + Revision 1.78 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.77 2000/02/06 17:19:22 peter + * lineinfo unit added which uses stabs to get lineinfo for backtraces + + Revision 1.76 2000/01/21 15:32:07 jonas + * set FPUInt64 to false for i386, because comp mul and div code for int64 is + commented out in int64.inc + + Revision 1.75 2000/01/10 09:54:30 peter + * primitives added + + Revision 1.74 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.73 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.72 1999/12/20 11:20:14 peter + + smallint, maxsmallint + * integer is redefined as smallint + + Revision 1.71 1999/12/18 14:55:05 florian + * very basic widestring support + + Revision 1.70 1999/12/12 13:29:34 jonas + * remove "random(longint): longint" if cardinalmulfixed is defined + + Revision 1.69 1999/12/01 12:37:13 jonas + + function random(longint): longint + + Revision 1.68 1999/11/25 13:34:57 michael + + Added Ansistring setstring call + + Revision 1.67 1999/11/20 12:48:09 jonas + * reinstated old random generator, but modified it so the integer + one now has a much longer period + + Revision 1.66 1999/11/09 20:14:12 daniel + * Committed new random generator. + + Revision 1.65 1999/11/06 14:35:39 peter + * truncated log + + Revision 1.64 1999/10/27 14:19:10 florian + + StringOfChar + + Revision 1.63 1999/10/26 12:31:00 peter + * *errorproc are not procvars instead of pointers which allows better + error checking for the parameters (shortstring<->ansistring) + + Revision 1.62 1999/08/19 11:16:13 peter + * settextbuf size is now longint + +} \ No newline at end of file diff --git a/befpc/rtl/inc/text.inc b/befpc/rtl/inc/text.inc new file mode 100644 index 0000000..f15ed06 --- /dev/null +++ b/befpc/rtl/inc/text.inc @@ -0,0 +1,1108 @@ +{ + $Id: text.inc,v 1.1.1.1 2001-07-23 17:17:40 memson Exp $ + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + 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. + + **********************************************************************} + +{ + Possible Defines: + + EOF_CTRLZ Is Ctrl-Z (#26) a EOF mark for textfiles + SHORT_LINEBREAK Use short Linebreaks #10 instead of #10#13 + + SHORT_LINEBREAK is defined in the Linux system unit (syslinux.pp) +} + +{**************************************************************************** + subroutines For TextFile handling +****************************************************************************} + + +Procedure FileCloseFunc(Var t:TextRec); +Begin + Do_Close(t.Handle); + t.Handle:=UnusedHandle; +End; + +Procedure FileReadFunc(var t:TextRec); +Begin + t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize); + t.BufPos:=0; +End; + + +Procedure FileWriteFunc(var t:TextRec); +var + i : longint; +Begin + i:=Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos); + if i<>t.BufPos then + InOutRes:=101; + t.BufPos:=0; +End; + + +Procedure FileOpenFunc(var t:TextRec); +var + Flags : Longint; +Begin + Case t.mode Of + fmInput : Flags:=$10000; + fmOutput : Flags:=$11001; + fmAppend : Flags:=$10101; + else + begin + InOutRes:=102; + exit; + end; + End; + Do_Open(t,PChar(@t.Name),Flags); + t.CloseFunc:=@FileCloseFunc; + t.FlushFunc:=nil; + if t.Mode=fmInput then + t.InOutFunc:=@FileReadFunc + else + begin + t.InOutFunc:=@FileWriteFunc; + { Only install flushing if its a NOT a file, and only check if there + was no error opening the file, becuase else we always get a bad + file handle error 6 (PFV) } + if (InOutRes=0) and + Do_Isdevice(t.Handle) then + t.FlushFunc:=@FileWriteFunc; + end; +End; + + +Procedure assign(var t:Text;const s:String); +Begin + FillChar(t,SizEof(TextRec),0); +{ only set things that are not zero } + TextRec(t).Handle:=UnusedHandle; + TextRec(t).mode:=fmClosed; + TextRec(t).BufSize:=TextRecBufSize; + TextRec(t).Bufptr:=@TextRec(t).Buffer; + TextRec(t).OpenFunc:=@FileOpenFunc; + Move(s[1],TextRec(t).Name,Length(s)); +End; + + +Procedure assign(var t:Text;p:pchar); +begin + Assign(t,StrPas(p)); +end; + + +Procedure assign(var t:Text;c:char); +begin + Assign(t,string(c)); +end; + + +Procedure Close(var t : Text);[IOCheck]; +Begin + if InOutRes<>0 then + Exit; + case TextRec(t).mode of + fmInput,fmOutPut,fmAppend: + Begin + { Write pending buffer } + If Textrec(t).Mode=fmoutput then + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); + { Only close functions not connected to stdout.} + If ((TextRec(t).Handle<>StdInputHandle) and + (TextRec(t).Handle<>StdOutputHandle) and + (TextRec(t).Handle<>StdErrorHandle)) Then + FileFunc(TextRec(t).CloseFunc)(TextRec(t)); + TextRec(t).mode := fmClosed; + { Reset buffer for safety } + TextRec(t).BufPos:=0; + TextRec(t).BufEnd:=0; + End + else inOutRes := 103; + End; +End; + + +Procedure OpenText(var t : Text;mode,defHdl:Longint); +Begin + Case TextRec(t).mode Of {This gives the fastest code} + fmInput,fmOutput,fmInOut : Close(t); + fmClosed : ; + else + Begin + InOutRes:=102; + exit; + End; + End; + TextRec(t).mode:=mode; + TextRec(t).bufpos:=0; + TextRec(t).bufend:=0; + FileFunc(TextRec(t).OpenFunc)(TextRec(t)); + { reset the mode to closed when an error has occured } + if InOutRes<>0 then + TextRec(t).mode:=fmClosed; +End; + + +Procedure Rewrite(var t : Text);[IOCheck]; +Begin + If InOutRes<>0 then + exit; + OpenText(t,fmOutput,1); +End; + + +Procedure Reset(var t : Text);[IOCheck]; +Begin + If InOutRes<>0 then + exit; + OpenText(t,fmInput,0); +End; + + +Procedure Append(var t : Text);[IOCheck]; +Begin + If InOutRes<>0 then + exit; + OpenText(t,fmAppend,1); +End; + + +Procedure Flush(var t : Text);[IOCheck]; +Begin + If InOutRes<>0 then + exit; + if TextRec(t).mode<>fmOutput then + begin + if TextRec(t).mode=fmInput then + InOutRes:=105 + else + InOutRes:=103; + exit; + end; +{ Not the flushfunc but the inoutfunc should be used, becuase that + writes the data, flushfunc doesn't need to be assigned } + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); +End; + + +Procedure Erase(var t:Text);[IOCheck]; +Begin + If InOutRes <> 0 then + exit; + If TextRec(t).mode=fmClosed Then + Do_Erase(PChar(@TextRec(t).Name)); +End; + + +Procedure Rename(var t : text;p:pchar);[IOCheck]; +Begin + If InOutRes <> 0 then + exit; + If TextRec(t).mode=fmClosed Then + Begin + Do_Rename(PChar(@TextRec(t).Name),p); + Move(p^,TextRec(t).Name,StrLen(p)+1); + End; +End; + + +Procedure Rename(var t : Text;const s : string);[IOCheck]; +var + p : array[0..255] Of Char; +Begin + If InOutRes <> 0 then + exit; + Move(s[1],p,Length(s)); + p[Length(s)]:=#0; + Rename(t,Pchar(@p)); +End; + + +Procedure Rename(var t : Text;c : char);[IOCheck]; +var + p : array[0..1] Of Char; +Begin + If InOutRes <> 0 then + exit; + p[0]:=c; + p[1]:=#0; + Rename(t,Pchar(@p)); +End; + + +Function Eof(Var t: Text): Boolean;[IOCheck]; +Begin + If (InOutRes<>0) then + exit(true); + if (TextRec(t).mode<>fmInput) Then + begin + if TextRec(t).mode=fmOutput then + InOutRes:=104 + else + InOutRes:=103; + exit(true); + end; + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + begin + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + exit(true); + end; +{$ifdef EOF_CTRLZ} + Eof:=(TextRec(t).Bufptr^[TextRec(t).BufPos]=#26); +{$else} + Eof:=false; +{$endif EOL_CTRLZ} +end; + + +Function Eof:Boolean; +Begin + Eof:=Eof(Input); +End; + + +Function SeekEof (Var t : Text) : Boolean; +Begin + If (InOutRes<>0) then + exit(true); + if (TextRec(t).mode<>fmInput) Then + begin + if TextRec(t).mode=fmOutPut then + InOutRes:=104 + else + InOutRes:=103; + exit(true); + end; + repeat + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + begin + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + exit(true); + end; + case TextRec(t).Bufptr^[TextRec(t).BufPos] of + #26 : exit(true); + #10,#13, + #9,' ' : ; + else + exit(false); + end; + inc(TextRec(t).BufPos); + until false; +End; + + +Function SeekEof : Boolean; +Begin + SeekEof:=SeekEof(Input); +End; + + +Function Eoln(var t:Text) : Boolean; +Begin + If (InOutRes<>0) then + exit(true); + if (TextRec(t).mode<>fmInput) Then + begin + if TextRec(t).mode=fmOutPut then + InOutRes:=104 + else + InOutRes:=103; + exit(true); + end; + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + begin + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + exit(true); + end; + Eoln:=(TextRec(t).Bufptr^[TextRec(t).BufPos] in [#10,#13]); +End; + + +Function Eoln : Boolean; +Begin + Eoln:=Eoln(Input); +End; + + +Function SeekEoln (Var t : Text) : Boolean; +Begin + If (InOutRes<>0) then + exit(true); + if (TextRec(t).mode<>fmInput) Then + begin + if TextRec(t).mode=fmOutput then + InOutRes:=104 + else + InOutRes:=103; + exit(true); + end; + repeat + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + begin + FileFunc(TextRec(t).InOutFunc)(TextRec(t)); + If TextRec(t).BufPos>=TextRec(t).BufEnd Then + exit(true); + end; + case TextRec(t).Bufptr^[TextRec(t).BufPos] of + #26, + #10,#13 : exit(true); + #9,' ' : ; + else + exit(false); + end; + inc(TextRec(t).BufPos); + until false; +End; + + +Function SeekEoln : Boolean; +Begin + SeekEoln:=SeekEoln(Input); +End; + + +Procedure SetTextBuf(Var F : Text; Var Buf);[INTERNPROC: In_settextbuf_file_x]; + + +Procedure SetTextBuf(Var F : Text; Var Buf; Size : Longint); +Begin + TextRec(f).BufPtr:=@Buf; + TextRec(f).BufSize:=Size; + TextRec(f).BufPos:=0; + TextRec(f).BufEnd:=0; +End; + + +{***************************************************************************** + Write(Ln) +*****************************************************************************} + +Procedure WriteBuffer(var f:TextRec;var b;len:longint); +var + p : pchar; + left, + idx : longint; +begin + p:=pchar(@b); + idx:=0; + left:=f.BufSize-f.BufPos; + while len>left do + begin + move(p[idx],f.Bufptr^[f.BufPos],left); + dec(len,left); + inc(idx,left); + inc(f.BufPos,left); + FileFunc(f.InOutFunc)(f); + left:=f.BufSize-f.BufPos; + end; + move(p[idx],f.Bufptr^[f.BufPos],len); + inc(f.BufPos,len); +end; + + +Procedure WriteBlanks(var f:TextRec;len:longint); +var + left : longint; +begin + left:=f.BufSize-f.BufPos; + while len>left do + begin + FillChar(f.Bufptr^[f.BufPos],left,' '); + dec(len,left); + inc(f.BufPos,left); + FileFunc(f.InOutFunc)(f); + left:=f.BufSize-f.BufPos; + end; + FillChar(f.Bufptr^[f.BufPos],len,' '); + inc(f.BufPos,len); +end; + + +Procedure Write_End(var f:TextRec);[Public,Alias:'FPC_WRITE_END']; +begin + if f.FlushFunc<>nil then + FileFunc(f.FlushFunc)(f); +end; + + +Procedure Writeln_End(var f:TextRec);[Public,Alias:'FPC_WRITELN_END']; +const +{$IFDEF SHORT_LINEBREAK} + eollen=1; + eol : array[0..0] of char=(#10); +{$ELSE SHORT_LINEBREAK} + eollen=2; + eol : array[0..1] of char=(#13,#10); +{$ENDIF SHORT_LINEBREAK} +begin + If InOutRes <> 0 then exit; + case f.mode of + fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }: + begin + { Write EOL } + WriteBuffer(f,eol,eollen); + { Flush } + if f.FlushFunc<>nil then + FileFunc(f.FlushFunc)(f); + end; + fmInput: InOutRes:=105 + else InOutRes:=103; + end; +end; + + +Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_SHORTSTR']; +Begin + If (InOutRes<>0) then + exit; + case f.mode of + fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }: + begin + If Len>Length(s) Then + WriteBlanks(f,Len-Length(s)); + WriteBuffer(f,s[1],Length(s)); + end; + fmInput: InOutRes:=105 + else InOutRes:=103; + end; +End; + + +Procedure Write_Array(Len : Longint;var f : TextRec;const s : array of char);[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY']; +var + ArrayLen : longint; + p : pchar; +Begin + If (InOutRes<>0) then + exit; + case f.mode of + fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }: + begin + p:=pchar(@s); + ArrayLen:=StrLen(p); + if ArrayLen>sizeof(s) then + ArrayLen:=sizeof(s); + If Len>ArrayLen Then + WriteBlanks(f,Len-ArrayLen); + WriteBuffer(f,p^,ArrayLen); + end; + fmInput: InOutRes:=105 + else InOutRes:=103; + end; +End; + + +Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_POINTER']; +var + PCharLen : longint; +Begin + If (p=nil) or (InOutRes<>0) then + exit; + case f.mode of + fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }: + begin + PCharLen:=StrLen(p); + If Len>PCharLen Then + WriteBlanks(f,Len-PCharLen); + WriteBuffer(f,p^,PCharLen); + end; + fmInput: InOutRes:=105 + else InOutRes:=103; + end; +End; + + +Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; S : Pointer);[Public,alias:'FPC_WRITE_TEXT_ANSISTR']; +{ + Writes a AnsiString to the Text file T +} +begin + If S=Nil then + exit; + Write_pchar (Len,t,PChar(S)); +end; + + +Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_SINT']; +var + s : String; +Begin + If (InOutRes<>0) then + exit; + Str(l,s); + Write_Str(Len,t,s); +End; + + +Procedure Write_UInt(Len : Longint;var t : TextRec;l : ValUInt);[Public,Alias:'FPC_WRITE_TEXT_UINT']; +var + s : String; +Begin + If (InOutRes<>0) then + exit; + Str(L,s); + Write_Str(Len,t,s); +End; + + +{$ifdef INT64} +procedure write_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_WRITE_TEXT_QWORD']; +var + s : string; +begin + if (InOutRes<>0) then + exit; + qword_str(q,s); + write_str(len,t,s); +end; + +procedure write_int64(len : longint;var t : textrec;i : int64);[public,alias:'FPC_WRITE_TEXT_INT64']; +var + s : string; +begin + if (InOutRes<>0) then + exit; + int64_str(i,s); + write_str(len,t,s); +end; +{$endif INT64} + + +Procedure Write_Float(rt,fixkomma,Len : Longint;var t : TextRec;r : ValReal);[Public,Alias:'FPC_WRITE_TEXT_FLOAT']; +var + s : String; +Begin + If (InOutRes<>0) then + exit; + Str_real(Len,fixkomma,r,treal_type(rt),s); + Write_Str(Len,t,s); +End; + + +Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias:'FPC_WRITE_TEXT_BOOLEAN']; +Begin + If (InOutRes<>0) then + exit; +{ Can't use array[boolean] because b can be >0 ! } + if b then + Write_Str(Len,t,'TRUE') + else + Write_Str(Len,t,'FALSE'); +End; + + +Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias:'FPC_WRITE_TEXT_CHAR']; +Begin + If (InOutRes<>0) then + exit; + if (TextRec(t).mode<>fmOutput) Then + begin + if TextRec(t).mode=fmClosed then + InOutRes:=103 + else + InOutRes:=105; + exit; + end; + If Len>1 Then + WriteBlanks(t,Len-1); + If t.BufPos+1>=t.BufSize Then + FileFunc(t.InOutFunc)(t); + t.Bufptr^[t.BufPos]:=c; + Inc(t.BufPos); +End; + + +{***************************************************************************** + Read(Ln) +*****************************************************************************} + +Function NextChar(var f:TextRec;var s:string):Boolean; +begin + if f.BufPos=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + NextChar:=true; + end + else + NextChar:=false; +end; + + +Function IgnoreSpaces(var f:TextRec):Boolean; +{ + Removes all leading spaces,tab,eols from the input buffer, returns true if + the buffer is empty +} +var + s : string; +begin + s:=''; + IgnoreSpaces:=false; + while f.Bufptr^[f.BufPos] in [#9,#10,#13,' '] do + if not NextChar(f,s) then + exit; + IgnoreSpaces:=true; +end; + + +procedure ReadNumeric(var f:TextRec;var s:string); +{ + Read numeric input, if buffer is empty then return True +} +begin + repeat + if not NextChar(f,s) then + exit; + until (length(s)=high(s)) or (f.BufPtr^[f.BufPos] in [#9,#10,#13,' ']); +end; + + +Procedure Read_End(var f:TextRec);[Public,Alias:'FPC_READ_END']; +begin + if f.FlushFunc<>nil then + FileFunc(f.FlushFunc)(f); +end; + + +Procedure ReadLn_End(var f : TextRec);[Public,Alias:'FPC_READLN_END']; +var prev: char; +Begin +{ Check error and if file is open and load buf if empty } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + if f.BufPos>=f.BufEnd Then + begin + FileFunc(f.InOutFunc)(f); + if (f.BufPos>=f.BufEnd) then + { Flush if set } + begin + if (f.FlushFunc<>nil) then + FileFunc(f.FlushFunc)(f); + exit; + end; + end; + repeat + prev := f.BufPtr^[f.BufPos]; + inc(f.BufPos); +{ no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, } +{ #13#10 = Dos), so if we've got #10, we can safely exit } + if prev = #10 then + exit; + if f.BufPos>=f.BufEnd Then + begin + FileFunc(f.InOutFunc)(f); + if (f.BufPos>=f.BufEnd) then + { Flush if set } + begin + if (f.FlushFunc<>nil) then + FileFunc(f.FlushFunc)(f); + exit; + end; + end; + if (prev=#13) then + { is there also a #10 after it? } + begin + if (f.BufPtr^[f.BufPos]=#10) then + { yes, skip that one as well } + inc(f.BufPos); + exit; + end; + until false; +End; + + +Function ReadPCharLen(var f:TextRec;s:pchar;maxlen:longint):longint; +var + sPos,len : Longint; + p,startp,maxp : pchar; +Begin + ReadPCharLen:=0; +{ Check error and if file is open } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; +{ Read maximal until Maxlen is reached } + sPos:=0; + repeat + If f.BufPos>=f.BufEnd Then + begin + FileFunc(f.InOutFunc)(f); + If f.BufPos>=f.BufEnd Then + break; + end; + p:=@f.Bufptr^[f.BufPos]; + if SPos+f.BufEnd-f.BufPos>MaxLen then + maxp:=@f.BufPtr^[f.BufPos+MaxLen-SPos] + else + maxp:=@f.Bufptr^[f.BufEnd]; + startp:=p; + { search linefeed } + while (p0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; +{ Read next char or EOF } + If f.BufPos>=f.BufEnd Then + begin + FileFunc(f.InOutFunc)(f); + If f.BufPos>=f.BufEnd Then + exit(#26); + end; + Read_Char:=f.Bufptr^[f.BufPos]; + inc(f.BufPos); +end; + + +Function Read_SInt(var f : TextRec):ValSInt;[Public,Alias:'FPC_READ_TEXT_SINT']; +var + hs : String; + code : Longint; +Begin + Read_SInt:=0; +{ Leave if error or not open file, else check for empty buf } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + If f.BufPos>=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + hs:=''; + if IgnoreSpaces(f) then + ReadNumeric(f,hs); + Val(hs,Read_SInt,code); + If code<>0 Then + InOutRes:=106; +End; + + +Function Read_UInt(var f : TextRec):ValUInt;[Public,Alias:'FPC_READ_TEXT_UINT']; +var + hs : String; + code : longint; +Begin + Read_UInt:=0; +{ Leave if error or not open file, else check for empty buf } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + If f.BufPos>=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + hs:=''; + if IgnoreSpaces(f) then + ReadNumeric(f,hs); + val(hs,Read_UInt,code); + If code<>0 Then + InOutRes:=106; +End; + + +Function Read_Float(var f : TextRec):ValReal;[Public,Alias:'FPC_READ_TEXT_FLOAT']; +var + hs : string; + code : Word; +begin + Read_Float:=0.0; +{ Leave if error or not open file, else check for empty buf } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + If f.BufPos>=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + hs:=''; + if IgnoreSpaces(f) then + ReadNumeric(f,hs); + val(hs,Read_Float,code); + If code<>0 Then + InOutRes:=106; +end; + + +{$ifdef INT64} +function Read_QWord(var f : textrec) : qword;[public,alias:'FPC_READ_TEXT_QWORD']; +var + hs : String; + code : longint; +Begin + Read_QWord:=0; + { Leave if error or not open file, else check for empty buf } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + If f.BufPos>=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + hs:=''; + if IgnoreSpaces(f) then + ReadNumeric(f,hs); + val(hs,Read_QWord,code); + If code<>0 Then + InOutRes:=106; +End; + +function Read_Int64(var f : textrec) : int64;[public,alias:'FPC_READ_TEXT_INT64']; +var + hs : String; + code : Longint; +Begin + Read_Int64:=0; +{ Leave if error or not open file, else check for empty buf } + If (InOutRes<>0) then + exit; + if (f.mode<>fmInput) Then + begin + case TextRec(f).mode of + fmOutPut,fmAppend: + InOutRes:=104 + else + InOutRes:=103; + end; + exit; + end; + If f.BufPos>=f.BufEnd Then + FileFunc(f.InOutFunc)(f); + hs:=''; + if IgnoreSpaces(f) then + ReadNumeric(f,hs); + Val(hs,Read_Int64,code); + If code<>0 Then + InOutRes:=106; +End; +{$endif INT64} + + +{***************************************************************************** + Initializing +*****************************************************************************} + +procedure OpenStdIO(var f:text;mode,hdl:longint); +begin + Assign(f,''); + TextRec(f).Handle:=hdl; + TextRec(f).Mode:=mode; + TextRec(f).Closefunc:=@FileCloseFunc; + case mode of + fmInput : + TextRec(f).InOutFunc:=@FileReadFunc; + fmOutput : + begin + TextRec(f).InOutFunc:=@FileWriteFunc; + TextRec(f).FlushFunc:=@FileWriteFunc; + end; + else + HandleError(102); + end; +end; + + +{ + $Log: not supported by cvs2svn $ + Revision 1.72 2000/03/24 10:26:18 jonas + * changed a lot of "if fm.mode = fmClosed then" to case statements, + because if f is not yet initialized, the mode is invalid and can + contain another value even though the file is closed + + check if a file is open in writeln_end (caused crash if used on + not opened files) + + Revision 1.71 2000/03/19 08:36:41 peter + * length check for readnumeric + + Revision 1.70 2000/03/17 21:27:56 jonas + * fixed declaration of val_int64 (removed destsize parameter) + * fixed val_int64 and val_qword so they reject invalid input + (u >= base) + * when reading a number, invalid input is removed from the input + buffer (+ it should be faster as well) + + Revision 1.69 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.68 2000/01/31 12:11:53 jonas + * committed the rest of my fix :) + + Revision 1.67 2000/01/31 10:15:43 pierre + * Jonas' fix for bug811 + + Revision 1.66 2000/01/23 12:22:37 florian + * reading of 64 bit type implemented + + Revision 1.65 2000/01/20 20:19:37 florian + * writing of int64/qword fixed + + Revision 1.64 2000/01/08 17:08:36 jonas + + Mac linebreak (#13) support for readln + + Revision 1.63 2000/01/07 16:41:36 daniel + * copyright 2000 + + Revision 1.62 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.61 1999/12/02 17:40:06 peter + * read_int64 dummy added + + Revision 1.60 1999/11/06 14:35:39 peter + * truncated log + + Revision 1.59 1999/10/26 12:25:19 peter + * inoutres 103 for closed files, just like delphi + + Revision 1.58 1999/10/04 20:42:45 peter + * read ansistring speedup (no length(s) calls anymore) + + Revision 1.57 1999/09/10 17:14:43 peter + * remove CR when reading one char less then size + + Revision 1.56 1999/09/10 15:40:33 peter + * fixed do_open flags to be > $100, becuase filemode can be upto 255 + + Revision 1.55 1999/09/08 16:12:24 peter + * fixed inoutres for diskfull + + Revision 1.54 1999/09/07 07:44:58 peter + * fixed array of char writing which didn't write the last char + + Revision 1.53 1999/08/19 11:16:14 peter + * settextbuf size is now longint + + Revision 1.52 1999/08/03 21:58:45 peter + * small speed improvements + + Revision 1.51 1999/07/26 09:43:24 florian + + write helper routine for in64 implemented + +} diff --git a/befpc/rtl/inc/textrec.inc b/befpc/rtl/inc/textrec.inc new file mode 100644 index 0000000..81ed7ef --- /dev/null +++ b/befpc/rtl/inc/textrec.inc @@ -0,0 +1,57 @@ +{ + $Id: textrec.inc,v 1.1.1.1 2001-07-23 17:17:40 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Textrec record definition + + + 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. + + **********************************************************************} + +{ + This file contains the definition of the textrec record. + It is put separately, so it is available outside the system + unit without sacrificing TP compatibility. +} + +const + TextRecNameLength = 256; + TextRecBufSize = 256; +type + TextBuf = array[0..TextRecBufSize-1] of char; + TextRec = Packed Record + Handle, + Mode, + bufsize, + _private, + bufpos, + bufend : longint; + bufptr : ^textbuf; + openfunc, + inoutfunc, + flushfunc, + closefunc : pointer; + UserData : array[1..16] of byte; + name : array[0..textrecnamelength-1] of char; + buffer : textbuf; + End; + +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.8 2000/01/07 16:41:37 daniel + * copyright 2000 + + Revision 1.7 2000/01/07 16:32:25 daniel + * copyright 2000 added + +} diff --git a/befpc/rtl/inc/typefile.inc b/befpc/rtl/inc/typefile.inc new file mode 100644 index 0000000..ac92b65 --- /dev/null +++ b/befpc/rtl/inc/typefile.inc @@ -0,0 +1,113 @@ +{ + $Id: typefile.inc,v 1.1.1.1 2001-07-23 17:17:40 memson Exp $ + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + 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. + + **********************************************************************} + +{**************************************************************************** + subroutines for typed file handling +****************************************************************************} + +Procedure assign(var f:TypedFile;const Name:string); +{ + Assign Name to file f so it can be used with the file routines +} +Begin + FillChar(f,SizeOF(FileRec),0); + FileRec(f).Handle:=UnusedHandle; + FileRec(f).mode:=fmClosed; + Move(Name[1],FileRec(f).Name,Length(Name)); +End; + + +Procedure assign(var f:TypedFile;p:pchar); +{ + Assign Name to file f so it can be used with the file routines +} +begin + Assign(f,StrPas(p)); +end; + + +Procedure assign(var f:TypedFile;c:char); +{ + Assign Name to file f so it can be used with the file routines +} +begin + Assign(f,string(c)); +end; + + +Procedure Int_Typed_Reset(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias:'FPC_RESET_TYPED']; +Begin + If InOutRes <> 0 then + exit; + Reset(UnTypedFile(f),Size); +End; + + +Procedure Int_Typed_Rewrite(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias:'FPC_REWRITE_TYPED']; +Begin + If InOutRes <> 0 then + exit; + Rewrite(UnTypedFile(f),Size); +End; + + +Procedure Int_Typed_Write(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias :'FPC_TYPED_WRITE']; +Begin + If InOutRes <> 0 then + exit; + case fileRec(f).mode of + fmOutPut,fmInOut: + Do_Write(FileRec(f).Handle,Longint(@Buf),TypeSize); + fmInput: inOutRes := 105; + else inOutRes := 103; + end; +End; + +Procedure Int_Typed_Read(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias :'FPC_TYPED_READ']; +var + Result : Longint; +Begin + If InOutRes <> 0 then + exit; + case FileRec(f).mode of + fmInput,fmInOut: + begin + Result:=Do_Read(FileRec(f).Handle,Longint(@Buf),TypeSize); + If Result0.0) or (z.im<>0.0) then + begin + root := sqrt(0.5 * (abs(z.re) + cmod(z))); + q := z.im / (2.0 * root); + if z.re >= 0.0 then + begin + csqrt.re := root; + csqrt.im := q; + end + else if z.im < 0.0 then + begin + csqrt.re := - q; + csqrt.im := - root + end + else + begin + csqrt.re := q; + csqrt.im := root + end + end + else csqrt := z; + end; + + + operator ** (z1, z2 : complex) z : complex; + { exp : z := z1 ** z2 } + begin + z := cexp(z2*cln(z1)); + end; + + operator ** (z1 : complex; r : real) z : complex; + { multiplication : z := z1 * r } + begin + z := cexp( r *cln(z1)); + end; + + operator ** (r : real; z1 : complex) z : complex; + { multiplication : z := r + z1 } + begin + z := cexp(z1*ln(r)); + end; + + { direct trigonometric functions } + + function ccos (z : complex) : complex; + { complex cosinus } + { cos(x+iy) = cos(x).cos(iy) - sin(x).sin(iy) } + { cos(ix) = cosh(x) et sin(ix) = i.sinh(x) } + begin + ccos.re := cos(z.re) * cosh(z.im); + ccos.im := - sin(z.re) * sinh(z.im); + end; + + function csin (z : complex) : complex; + { sinus complex } + { sin(x+iy) = sin(x).cos(iy) + cos(x).sin(iy) } + { cos(ix) = cosh(x) et sin(ix) = i.sinh(x) } + begin + csin.re := sin(z.re) * cosh(z.im); + csin.im := cos(z.re) * sinh(z.im); + end; + + function ctg (z : complex) : complex; + { tangente } + var ccosz, temp : complex; + begin + ccosz := ccos(z); + temp := csin(z); + ctg := temp / ccosz; + end; + + { fonctions trigonometriques inverses } + + function carc_cos (z : complex) : complex; + { arc cosinus complex } + { arccos(z) = -i.argch(z) } + begin + carc_cos := -i*carg_ch(z); + end; + + function carc_sin (z : complex) : complex; + { arc sinus complex } + { arcsin(z) = -i.argsh(i.z) } + begin + carc_sin := -i*carg_sh(i*z); + end; + + function carc_tg (z : complex) : complex; + { arc tangente complex } + { arctg(z) = -i.argth(i.z) } + begin + carc_tg := -i*carg_th(i*z); + end; + + { hyberbolic complex functions } + + function cch (z : complex) : complex; + { hyberbolic cosinus } + { cosh(x+iy) = cosh(x).cosh(iy) + sinh(x).sinh(iy) } + { cosh(iy) = cos(y) et sinh(iy) = i.sin(y) } + begin + cch.re := cosh(z.re) * cos(z.im); + cch.im := sinh(z.re) * sin(z.im); + end; + + function csh (z : complex) : complex; + { hyberbolic sinus } + { sinh(x+iy) = sinh(x).cosh(iy) + cosh(x).sinh(iy) } + { cosh(iy) = cos(y) et sinh(iy) = i.sin(y) } + begin + csh.re := sinh(z.re) * cos(z.im); + csh.im := cosh(z.re) * sin(z.im); + end; + + function cth (z : complex) : complex; + { hyberbolic complex tangent } + { th(x) = sinh(x) / cosh(x) } + { cosh(x) > 1 qq x } + var temp : complex; + begin + temp := cch(z); + z := csh(z); + cth := z / temp; + end; + + { inverse complex hyperbolic functions } + + function carg_ch (z : complex) : complex; + { hyberbolic arg cosinus } + { _________ } + { argch(z) = -/+ ln(z + i.V 1 - z.z) } + begin + carg_ch:=-cln(z+i*csqrt(z*z-1.0)); + end; + + function carg_sh (z : complex) : complex; + { hyperbolic arc sinus } + { ________ } + { argsh(z) = ln(z + V 1 + z.z) } + begin + carg_sh:=cln(z+csqrt(z*z+1.0)); + end; + + function carg_th (z : complex) : complex; + { hyperbolic arc tangent } + { argth(z) = 1/2 ln((z + 1) / (1 - z)) } + begin + carg_th:=cln((z+1.0)/(z-1.0))/2.0; + end; + + { functions to write out a complex value } + function cstr(z : complex) : string; + var + istr : string; + begin + str(z.im,istr); + str(z.re,cstr); + while istr[1]=' ' do + delete(istr,1,1); + if z.im<0 then + cstr:=cstr+istr+'i' + else if z.im>0 then + cstr:=cstr+'+'+istr+'i'; + end; + + function cstr(z:complex;len : integer) : string; + var + istr : string; + begin + str(z.im:len,istr); + while istr[1]=' ' do + delete(istr,1,1); + str(z.re:len,cstr); + if z.im<0 then + cstr:=cstr+istr+'i' + else if z.im>0 then + cstr:=cstr+'+'+istr+'i'; + end; + + function cstr(z:complex;len,dec : integer) : string; + var + istr : string; + begin + str(z.im:len:dec,istr); + while istr[1]=' ' do + delete(istr,1,1); + str(z.re:len:dec,cstr); + if z.im<0 then + cstr:=cstr+istr+'i' + else if z.im>0 then + cstr:=cstr+'+'+istr+'i'; + end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/02/09 16:59:31 peter + * truncated log + + Revision 1.4 2000/01/07 16:41:37 daniel + * copyright 2000 + + Revision 1.3 2000/01/07 16:32:25 daniel + * copyright 2000 added + + Revision 1.2 1999/12/20 22:24:48 pierre + + cinv in interface + +} diff --git a/befpc/rtl/inc/wstrings.inc b/befpc/rtl/inc/wstrings.inc new file mode 100644 index 0000000..a6c9e1a --- /dev/null +++ b/befpc/rtl/inc/wstrings.inc @@ -0,0 +1,45 @@ +{ + $Id: wstrings.inc,v 1.1.1.1 2001-07-23 17:17:40 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl, + member of the Free Pascal development team. + + This file implements support routines for WideStrings with FPC + + 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. + + **********************************************************************} +{ +Type + PWideRec = ^TWideRec; + TWideRec = Packed Record + Maxlen, + len, + ref : Longint; + First : WChar; + end; +} + +Procedure UniqueWideString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE']; +{ + Make sure reference count of S is 1, + using copy-on-write semantics. +} + +begin +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.2 2000/01/07 16:41:37 daniel + * copyright 2000 + + Revision 1.1 1999/12/18 14:55:53 florian + + initial version + +} diff --git a/befpc/rtl/objpas/README b/befpc/rtl/objpas/README new file mode 100644 index 0000000..d15a44e --- /dev/null +++ b/befpc/rtl/objpas/README @@ -0,0 +1,23 @@ +This directory contains units that are part of the Object Pascal support +of the Free Pascal Compiler. + +You can find here the following files: + +objpas.pp : makes Free Pascal more Borland Delphi compatible, data types + are redefined + +math.pp : Contains basic mathematical functions, as well as some financial + functions. + +sysutils.pp : Contains the exception support of the Free Pascal Compiler. + +*h.inc : Contain parts of the sysutils unit, with function declarations. +*.inc : Contain parts of the sysutils unit, with implementations of: + dati : Date & Time handling functions. + fina : FileName handling functions. + sysstr : miscellaneous string handling functions, and conversion + routines. + syspch : miscellaneous pchar handling functions. + +Enjoy ! +The Free Pascal Development Team. diff --git a/befpc/rtl/objpas/dati.inc b/befpc/rtl/objpas/dati.inc new file mode 100644 index 0000000..dce6a4d --- /dev/null +++ b/befpc/rtl/objpas/dati.inc @@ -0,0 +1,703 @@ +{ + ********************************************************************* + $Id: dati.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +{==============================================================================} +{ internal functions } +{==============================================================================} + +const + DayTable: array[Boolean, 1..12] of longint = + ((0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334), + (0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335)); + +function DoEncodeDate(Year, Month, Day: Word): longint; +var + c, ya: cardinal; +begin + if (Month > 0) and (Month < 13) and (Day > 0) and (Day < 32) then + begin + if month > 2 then + Dec(Month,3) + else + begin + Inc(Month,9); + Dec(Year); + end; + c:= Year DIV 100; + ya:= Year - 100*c; + result := (146097*c) SHR 2 + (1461*ya) SHR 2 + (153*Month+2) DIV 5 + Day - 693900; + end + else + result:=0; +end; + +function DoEncodeTime(Hour, Minute, Second, MilliSecond: word): longint; +begin + If ((hour>=0) and (Hour<24)) and + ((Minute>=0) and (Minute<60)) and + ((Second>=0) and (Second<60)) and + ((MilliSecond>=0) and (Millisecond<1000)) then + Result := (Hour * 3600000 + Minute * 60000 + Second * 1000 + MilliSecond) + else + Result:=0; +end; + + +{==============================================================================} +{ Public functions } +{==============================================================================} + +{ DateTimeToTimeStamp converts DateTime to a TTimeStamp } + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; +begin + result.Time := Trunc(Frac(DateTime) * MSecsPerDay); + result.Date := 1 + DateDelta + Trunc(System.Int(DateTime)); +end ; + +{ TimeStampToDateTime converts TimeStamp to a TDateTime value } + +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +begin + result := (TimeStamp.Date - DateDelta - 1) + (TimeStamp.Time / MSecsPerDay); +end ; + +{ MSecsToTimeStamp } + +function MSecsToTimeStamp(MSecs: comp): TTimeStamp; +begin + result.Date := Round(msecs / msecsperday); + msecs:= comp(msecs-result.date*msecsperday); + result.Time := Round(MSecs); +end ; + +{ TimeStampToMSecs } + +function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp; +begin + result := TimeStamp.Time + timestamp.date*msecsperday; +end ; + +{ EncodeDate packs three variables Year, Month and Day into a + TDateTime value the result is the number of days since 12/30/1899 } + +function EncodeDate(Year, Month, Day: word): TDateTime; +begin + result := DoEncodeDate(Year, Month, Day); +end ; + +{ EncodeTime packs four variables Hour, Minute, Second and MilliSecond into + a TDateTime value } + +function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime; +begin + Result := DoEncodeTime(hour, minute, second, millisecond) / MSecsPerDay; +end ; + +{ DecodeDate unpacks the value Date into three values: + Year, Month and Day } + +procedure DecodeDate(Date: TDateTime; var Year, Month, Day: word); +var + j : cardinal; +begin + j := pred((Trunc(System.Int(Date)) + 693900) SHL 2); + Year:= j DIV 146097; + j:= j - 146097 * Year; + Day := j SHR 2; + j:=(Day SHL 2 + 3) DIV 1461; + Day:= (Day SHL 2 + 7 - 1461*j) SHR 2; + Month:=(5 * Day-3) DIV 153; + Day:= (5 * Day +2 - 153*Month) DIV 5; + Year:= 100 * Year + j; + if Month < 10 then + inc(Month,3) + else + begin + dec(Month,9); + inc(Year); + end; +end; + +{ DecodeTime unpacks Time into four values: + Hour, Minute, Second and MilliSecond } + +procedure DecodeTime(Time: TDateTime; var Hour, Minute, Second, MilliSecond: word); +Var + l : cardinal; +begin + l := Round(Frac(time) * MSecsPerDay); + Hour := l div 3600000; + l := l mod 3600000; + Minute := l div 60000; + l := l mod 60000; + Second := l div 1000; + l := l mod 1000; + MilliSecond := l; +end; + +{ DateTimeToSystemTime converts DateTime value to SystemTime } + +procedure DateTimeToSystemTime(DateTime: TDateTime; var SystemTime: TSystemTime); +begin + DecodeDate(DateTime, SystemTime.Year, SystemTime.Month, SystemTime.Day); + DecodeTime(DateTime, SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond); +end ; + +{ SystemTimeToDateTime converts SystemTime to a TDateTime value } + +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +begin + result := DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day) + + DoEncodeTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond) / MSecsPerDay; +end ; + +{ DayOfWeek returns the Day of the week (sunday is day 1) } + +function DayOfWeek(DateTime: TDateTime): integer; +begin + Result := 1 + (Abs(Trunc(DateTime) - 1) mod 7); +end ; + +{ Date returns the current Date } + +function Date: TDateTime; +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + result := DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day); +end ; + +{ Time returns the current Time } + +function Time: TDateTime; +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + Result := DoEncodeTime(SystemTime.Hour,SystemTime.Minute,SystemTime.Second,SystemTime.MilliSecond) / MSecsPerDay; +end ; + +{ Now returns the current Date and Time } + +function Now: TDateTime; +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + result := DoEncodeDate(SystemTime.Year,SystemTime.Month,SystemTime.Day) + + DoEncodeTime(SystemTime.Hour,SystemTime.Minute,SystemTime.Second,SystemTime.MilliSecond) / MSecsPerDay; +end ; + +{ IncMonth increments DateTime with NumberOfMonths months, + NumberOfMonths can be less than zero } + +function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer): TDateTime; +var + Year, Month, Day: word; + S : Integer; +begin + If NumberOfMonths>=0 then + s:=1 + else + s:=-1; + DecodeDate(DateTime, Year, Month, Day); + inc(Year,(NumberOfMonths div 12)); + inc(Month,(NumberOfMonths mod 12)-1); // Mod result always positive + if Month>11 then + begin + Dec(Month, S*12); + Inc(Year, S); + end; + Inc(Month); { Months from 1 to 12 } + if (Month = 2) and (IsLeapYear(Year)) and (Day > 28) then + Day := 28; + result := Frac(DateTime) + DoEncodeDate(Year, Month, Day); +end ; + +{ IsLeapYear returns true if Year is a leap year } + +function IsLeapYear(Year: Word): boolean; +begin + Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0)); +end; + +{ DateToStr returns a string representation of Date using ShortDateFormat } + +function DateToStr(Date: TDateTime): string; +begin + result := FormatDateTime('ddddd', Date); +end ; + +{ TimeToStr returns a string representation of Time using ShortTimeFormat } + +function TimeToStr(Time: TDateTime): string; +begin + result := FormatDateTime('t', Time); +end ; + +{ DateTimeToStr returns a string representation of DateTime using ShortDateTimeFormat } + +function DateTimeToStr(DateTime: TDateTime): string; +begin + result := FormatDateTime('c', DateTime); +end ; + +{ StrToDate converts the string S to a TDateTime value + if S does not represent a valid date value + an EConvertError will be raised } + +function StrToDate(const S: string): TDateTime; +var + df:string; + d,m,y:word; + n,i:longint; + c:word; + dp,mp,yp,which : Byte; + s1:string[4]; + values:array[1..3] of longint; + LocalTime:tsystemtime; +begin + df := UpperCase(ShortDateFormat); + { Determine order of D,M,Y } + yp:=0; + mp:=0; + dp:=0; + Which:=0; + i:=0; + while (i3 then + Raise EConvertError.Create('Illegal format string'); +{ Get actual values } + for i := 1 to 3 do + values[i] := 0; + s1 := ''; + n := 0; + for i := 1 to length(s) do + begin + if (s[i] in ['0'..'9']) then + s1 := s1 + s[i]; + if (s[i] in [dateseparator,' ']) or (i = length(s)) then + begin + inc(n); + if n>3 then + Raise EConvertError.Create('Invalid date format'); + val(s1, values[n], c); + if c<>0 then + Raise EConvertError.Create('Invalid date format'); + s1 := ''; + end ; + end ; + // Fill in values. + If N=3 then + begin + y:=values[yp]; + m:=values[mp]; + d:=values[dp]; + end + Else + begin + getLocalTime(LocalTime); + y := LocalTime.Year; + If n<2 then + begin + d:=values[1]; + m := LocalTime.Month; + end + else + If dp= 0) and (y < 100) then + inc(y,1900); + Result := DoEncodeDate(y, m, d); +end ; + + +{ StrToTime converts the string S to a TDateTime value + if S does not represent a valid time value an + EConvertError will be raised } + +function StrToTime(const s: string): TDateTime; +var + Len, Current: integer; PM: boolean; + + function GetElement: integer; + var + j: integer; c: word; + begin + result := -1; + Inc(Current); + while (result = -1) and (Current < Len) do begin + if S[Current] in ['0'..'9'] then begin + j := Current; + while (Current < Len) and (s[Current + 1] in ['0'..'9']) do + Inc(Current); + val(copy(S, j, 1 + Current - j), result, c); + end + else if (S[Current] = TimeAMString[1]) or (S[Current] in ['a', 'A']) then begin + Current := 1 + Len; + end + else if (S[Current] = TimePMString[1]) or (S[Current] in ['p', 'P']) then begin + Current := 1 + Len; + PM := True; + end + else if (S[Current] = TimeSeparator) or (S[Current] = ' ') then + Inc(Current) + else + raise EConvertError.Create('Invalid Time format'); + end ; + end ; + +var + i: integer; + TimeValues: array[0..4] of integer; + +begin +Current := 0; +Len := length(s); +PM := False; +for i:=0 to 4 do + timevalues[i]:=0; +i := 0; +TimeValues[i] := GetElement; +while (i < 5) and (TimeValues[i] <> -1) do begin + i := i + 1; + TimeValues[i] := GetElement; + end ; +If (i<5) and (TimeValues[I]=-1) then + TimeValues[I]:=0; +if PM then Inc(TimeValues[0], 12); +result := EncodeTime(TimeValues[0], TimeValues[1], TimeValues[2], TimeValues[3]); +end ; + +{ StrToDateTime converts the string S to a TDateTime value + if S does not represent a valid date and time value + an EConvertError will be raised } + +function StrToDateTime(const s: string): TDateTime; +var i: integer; +begin +i := pos(' ', s); +if i > 0 then result := StrToDate(Copy(S, 1, i - 1)) + StrToTime(Copy(S, i + 1, length(S))) +else result := StrToDate(S); +end ; + +{ FormatDateTime formats DateTime to the given format string FormatStr } + +function FormatDateTime(FormatStr: string; DateTime: TDateTime): string; +var + ResultLen: integer; + ResultBuffer: array[0..255] of char; + ResultCurrent: pchar; + + procedure StoreStr(Str: pchar; Len: integer); + begin + if ResultLen + Len < SizeOf(ResultBuffer) then begin + StrMove(ResultCurrent, Str, Len); + ResultCurrent := ResultCurrent + Len; + ResultLen := ResultLen + Len; + end ; + end ; + + procedure StoreString(const Str: string); + var Len: integer; + begin + Len := Length(Str); + if ResultLen + Len < SizeOf(ResultBuffer) then begin + StrMove(ResultCurrent, pchar(Str), Len); + ResultCurrent := ResultCurrent + Len; + ResultLen := ResultLen + Len; + end; + end; + + procedure StoreInt(Value, Digits: integer); + var S: string; Len: integer; + begin + S := IntToStr(Value); + Len := Length(S); + if Len < Digits then begin + S := copy('0000', 1, Digits - Len) + S; + Len := Digits; + end ; + StoreStr(pchar(@S[1]), Len); + end ; + + Function TimeReFormat(Const S : string) : string; + // Change m into n for time formatting. + Var i : longint; + + begin + Result:=S; + For I:=1 to Length(Result) do + If Result[i]='m' then + result[i]:='n'; + end; + +var + Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word; + + procedure StoreFormat(const FormatStr: string); + var + Token: char; + FormatCurrent: pchar; + FormatEnd: pchar; + Count: integer; + Clock12: boolean; + P: pchar; + + begin + FormatCurrent := Pchar(FormatStr); + FormatEnd := FormatCurrent + Length(FormatStr); + Clock12 := false; + P := FormatCurrent; + while P < FormatEnd do begin + Token := UpCase(P^); + if Token in ['"', ''''] then begin + P := P + 1; + while (P < FormatEnd) and (P^ <> Token) do + P := P + 1; + end + else if Token = 'A' then begin + if (StrLIComp(P, 'A/P', 3) = 0) or + (StrLIComp(P, 'AMPM', 4) = 0) or + (StrLIComp(P, 'AM/PM', 5) = 0) then begin + Clock12 := true; + break; + end ; + end ; + P := P + 1; + end ; + while FormatCurrent < FormatEnd do begin + Token := UpCase(FormatCurrent^); + Count := 1; + P := FormatCurrent + 1; + case Token of + '''', '"': begin + while (P < FormatEnd) and (p^ <> Token) do + P := P + 1; + P := P + 1; + Count := P - FormatCurrent; + StoreStr(FormatCurrent + 1, Count - 2); + end ; + 'A': begin + if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then begin + Count := 4; + if Hour < 12 then StoreString(TimeAMString) + else StoreString(TimePMString); + end + else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then begin + Count := 5; + if Hour < 12 then StoreStr('am', 2) + else StoreStr('pm', 2); + end + else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then begin + Count := 3; + if Hour < 12 then StoreStr('a', 1) + else StoreStr('p', 1); + end + else + Raise EConvertError.Create('Illegal character in format string'); + end ; + '/': StoreStr(@DateSeparator, 1); + ':': StoreStr(@TimeSeparator, 1); + ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y': begin + while (P < FormatEnd) and (UpCase(P^) = Token) do + P := P + 1; + Count := P - FormatCurrent; + case Token of + ' ': StoreStr(FormatCurrent, Count); + 'Y': begin + case Count of + 1: StoreInt(Year, 0); + 2: StoreInt(Year mod 100, 2); + 4: StoreInt(Year, 4); + end ; + end ; + 'M': begin + case Count of + 1: StoreInt(Month, 0); + 2: StoreInt(Month, 2); + 3: StoreString(ShortMonthNames[Month]); + 4: StoreString(LongMonthNames[Month]); + end ; + end ; + 'D': begin + case Count of + 1: StoreInt(Day, 0); + 2: StoreInt(Day, 2); + 3: StoreString(ShortDayNames[DayOfWeek]); + 4: StoreString(LongDayNames[DayOfWeek]); + 5: StoreFormat(ShortDateFormat); + 6: StoreFormat(LongDateFormat); + end ; + end ; + 'H': begin + if Clock12 then begin + if Count = 1 then StoreInt(Hour mod 12, 0) + else StoreInt(Hour mod 12, 2); + end + else begin + if Count = 1 then StoreInt(Hour, 0) + else StoreInt(Hour, 2); + end ; + end ; + 'N': begin + if Count = 1 then StoreInt(Minute, 0) + else StoreInt(Minute, 2); + end ; + 'S': begin + if Count = 1 then StoreInt(Second, 0) + else StoreInt(Second, 2); + end ; + 'T': begin + if Count = 1 then StoreFormat(timereformat(ShortTimeFormat)) + else StoreFormat(TimeReformat(LongTimeFormat)); + end ; + 'C': + begin + StoreFormat(ShortDateFormat); + if (Hour<>0) or (Minute<>0) or (Second<>0) then + begin + StoreString(' '); + StoreFormat(TimeReformat(ShortTimeFormat)); + end; + end; + end ; + end ; + else + StoreStr(@Token, 1); + end ; + FormatCurrent := FormatCurrent + Count; + end ; + end ; + +begin + DecodeDate(DateTime, Year, Month, Day); + DecodeTime(DateTime, Hour, Minute, Second, MilliSecond); + DayOfWeek := SysUtils.DayOfWeek(DateTime); + ResultLen := 0; + ResultCurrent := @ResultBuffer; + StoreFormat(FormatStr); + ResultBuffer[ResultLen] := #0; + result := StrPas(@ResultBuffer); +end ; + +{ DateTimeToString formats DateTime to the given format in FormatStr } + +procedure DateTimeToString(var Result: string; const FormatStr: string; const DateTime: TDateTime); +begin + Result := FormatDateTime(FormatStr, DateTime); +end ; + + +Function DateTimeToFileDate(DateTime : TDateTime) : Longint; + +Var YY,MM,DD,H,m,s,msec : Word; + +begin + Decodedate (DateTime,YY,MM,DD); + If (YY<1980) or (YY>2099) then + Result:=0 + else + begin + DecodeTime (DateTime,h,m,s,msec); + Result:=(s shr 1) or (m shl 5) or (h shl 11); + Result:=Result or DD shl 16 or (MM shl 21) or ((YY-1980) shl 25); + end; +end; + + +Function FileDateToDateTime (Filedate : Longint) : TDateTime; + +Var Date,Time : Word; + +begin + Date:=FileDate shr 16; + Time:=FileDate and $ffff; + Result:=EncodeDate((Date shr 9) + 1980,(Date shr 5) and 15, Date and 31) + + EncodeTime(Time shr 11, (Time shr 5) and 63, (Time and 31) shl 1,0); +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.22 2000/06/18 18:02:54 peter + * fixed decodetime which used trunc instead of round + + Revision 1.21 2000/02/27 14:41:25 peter + * removed warnings/notes + + Revision 1.20 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.19 1999/11/29 16:59:27 pierre + * fix for form bug 719 + + Revision 1.18 1999/11/06 14:41:30 peter + * truncated log + + Revision 1.17 1999/10/28 09:52:29 peter + * fixed dayofweek + + Revision 1.16 1999/08/11 21:53:04 peter + * fixed formatdatetime('c',...) + * fixed strtodate + * dateencode/decode is now delphi compatible + + Revision 1.15 1999/07/24 11:21:14 peter + * fixed encode/decode date/time + +} + diff --git a/befpc/rtl/objpas/datih.inc b/befpc/rtl/objpas/datih.inc new file mode 100644 index 0000000..8fc3584 --- /dev/null +++ b/befpc/rtl/objpas/datih.inc @@ -0,0 +1,118 @@ +{ + ********************************************************************* + $Id: datih.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + + +const + SecsPerDay = 24 * 60 * 60; // Seconds and milliseconds per day + MSecsPerDay = SecsPerDay * 1000; + + DateDelta = 693594; // Days between 1/1/0001 and 12/31/1899 + + TwoDigitYearCenturyWindow : word=0; + { Threshold to be subtracted from year before + age-detection.} + + { date time formatting characters: + c : shortdateformat + ' ' + shorttimeformat + d : day of month + dd : day of month (leading zero) + ddd : day of week (abbreviation) + dddd : day of week (full) + ddddd : shortdateformat + dddddd : longdateformat + m : month + mm : month (leading zero) + mmm : month (abbreviation) + mmmm : month (full) + y : year (four digits) + yy : year (two digits) + yyyy : year (with century) + h : hour + hh : hour (leading zero) + n : minute + nn : minute (leading zero) + s : second + ss : second (leading zero) + t : shorttimeformat + tt : longtimeformat + am/pm : use 12 hour clock and display am and pm accordingly + a/p : use 12 hour clock and display a and p accordingly + / : insert date seperator + : : insert time seperator + "xx" : literal text + 'xx' : literal text + } + +type + TSystemTime = record + Year, Month, Day: word; + Hour, Minute, Second, MilliSecond: word; + end ; + + TDateTime = double; + + TTimeStamp = record + Time: integer; { Number of milliseconds since midnight } + Date: integer; { One plus number of days since 1/1/0001 } + end ; + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; +function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp; +function EncodeDate(Year, Month, Day :word): TDateTime; +function EncodeTime(Hour, Minute, Second, MilliSecond:word): TDateTime; +procedure DecodeDate(Date: TDateTime; var Year, Month, Day: word); +procedure DecodeTime(Time: TDateTime; var Hour, Minute, Second, MilliSecond: word); +procedure DateTimeToSystemTime(DateTime: TDateTime; var SystemTime: TSystemTime); +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +function DayOfWeek(DateTime: TDateTime): integer; +function Date: TDateTime; +function Time: TDateTime; +function Now: TDateTime; +function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer): TDateTime; +function IsLeapYear(Year: Word): boolean; +function DateToStr(Date: TDateTime): string; +function TimeToStr(Time: TDateTime): string; +function DateTimeToStr(DateTime: TDateTime): string; +function StrToDate(const S: string): TDateTime; +function StrToTime(const S: string): TDateTime; +function StrToDateTime(const S: string): TDateTime; +function FormatDateTime(FormatStr: string; DateTime: TDateTime):string; +procedure DateTimeToString(var Result: string; const FormatStr: string; const DateTime: TDateTime); +Function DateTimeToFileDate(DateTime : TDateTime) : Longint; +Function FileDateToDateTime (Filedate : Longint) : TDateTime; + +{ + + $Log: not supported by cvs2svn $ + Revision 1.8 2000/07/08 18:50:21 marco + * added twoyearsomethingwindow + + Revision 1.7 2000/04/24 11:09:05 peter + * removed eoln + + Revision 1.6 2000/02/09 16:59:32 peter + * truncated log + +} diff --git a/befpc/rtl/objpas/diskh.inc b/befpc/rtl/objpas/diskh.inc new file mode 100644 index 0000000..2617ae3 --- /dev/null +++ b/befpc/rtl/objpas/diskh.inc @@ -0,0 +1,43 @@ +{ + $Id: diskh.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Disk functions from Delphi's sysutils.pas + + 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. + + **********************************************************************} + +{$ifdef Int64} + Function DiskFree(drive: byte) : int64; + Function DiskSize(drive: byte) : int64; +{$else} + Function DiskFree(drive: byte) : longint; + Function DiskSize(drive: byte) : longint; +{$endif} +Function GetCurrentDir : String; +Function SetCurrentDir (Const NewDir : String) : Boolean; +Function CreateDir (Const NewDir : String) : Boolean; +Function RemoveDir (Const Dir : String) : Boolean; + +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/05/15 19:28:41 peter + * int64 support for diskfree,disksize + + Revision 1.4 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.3 2000/01/07 16:41:43 daniel + * copyright 2000 + + Revision 1.2 1999/11/06 14:41:30 peter + * truncated log + +} diff --git a/befpc/rtl/objpas/filutilh.inc b/befpc/rtl/objpas/filutilh.inc new file mode 100644 index 0000000..1affe40 --- /dev/null +++ b/befpc/rtl/objpas/filutilh.inc @@ -0,0 +1,87 @@ +{ + $Id: filutilh.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + File utility calls + + 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. + + **********************************************************************} + +Type + THandle = Longint; + +Type + TSearchRec = Record + Time,Size, Attr : Longint; + Name : TFileName; + ExcludeAttr : Longint; + FindHandle : THandle; + {$ifdef Win32} + FindData : TWin32FindData; + {$endif} + end; + +Const + { File attributes } + faReadOnly = $00000001; + faHidden = $00000002; + faSysFile = $00000004; + faVolumeId = $00000008; + faDirectory = $00000010; + faArchive = $00000020; + faAnyFile = $0000003f; + + { File open modes } + fmOpenRead = $0000; + fmOpenWrite = $0001; + fmOpenReadWrite = $0002; + + { File seek origins } + fsFromBeginning = 0; + fsFromCurrent = 1; + fsFromEnd = 2; + +Function FileOpen (Const FileName : string; Mode : Integer) : Longint; +Function FileCreate (Const FileName : String) : Longint; +Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint; +Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint; +Function FileSeek (Handle,FOffset,Origin : Longint) : Longint; +Procedure FileClose (Handle : Longint); +Function FileTruncate (Handle,Size: Longint) : boolean; +Function FileAge (Const FileName : String): Longint; +Function FileExists (Const FileName : String) : Boolean; +Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint; +Function FindNext (Var Rslt : TSearchRec) : Longint; +Procedure FindClose (Var F : TSearchrec); +Function FileGetDate (Handle : Longint) : Longint; +Function FileSetDate (Handle,Age : Longint) : Longint; +Function FileGetAttr (Const FileName : String) : Longint; +Function FileSetAttr (Const Filename : String; Attr: longint) : Longint; +Function DeleteFile (Const FileName : String) : Boolean; +Function RenameFile (Const OldName, NewName : String) : Boolean; +Function FileSearch (Const Name, DirList : String) : String; + + +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/06/04 14:22:15 hajny + * parameter name change in FileSeek + + Revision 1.8 2000/02/17 22:16:05 sg + * Changed the second argument of FileWrite from "var buffer" to + "const buffer", like in Delphi. + + Revision 1.7 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.6 2000/01/07 16:41:43 daniel + * copyright 2000 + +} diff --git a/befpc/rtl/objpas/fina.inc b/befpc/rtl/objpas/fina.inc new file mode 100644 index 0000000..bf8e1a9 --- /dev/null +++ b/befpc/rtl/objpas/fina.inc @@ -0,0 +1,194 @@ +{ + ********************************************************************* + $Id: fina.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +function ChangeFileExt(const FileName, Extension: string): string; +var i: longint; +begin +I := Length(FileName); +while (I > 0) and not(FileName[I] in ['/', '.', '\', ':']) do Dec(I); +if (I = 0) or (FileName[I] <> '.') then I := 255; +Result := Copy(FileName, 1, I - 1) + Extension; +end; + +function ExtractFilePath(const FileName: string): string; +var i: longint; +begin +i := Length(FileName); +while (i > 0) and not (FileName[i] in ['/', '\', ':']) do Dec(i); +If I>0 then + Result := Copy(FileName, 1, i) +else + Result:=''; +end; + +function ExtractFileDir(const FileName: string): string; +var i: longint; +begin +I := Length(FileName); +while (I > 0) and not (FileName[I] in ['/', '\', ':']) do Dec(I); +if (I > 1) and (FileName[I] in ['\', '/']) and + not (FileName[I - 1] in ['/', '\', ':']) then Dec(I); +Result := Copy(FileName, 1, I); +end; + +function ExtractFileDrive(const FileName: string): string; +var i: longint; +begin +if (Length(FileName) >= 3) and (FileName[2] = ':') then + result := Copy(FileName, 1, 2) +else if (Length(FileName) >= 2) and (FileName[1] in ['/', '\']) and + (FileName[2] in ['/', '\']) then begin + i := 2; + While (i < Length(Filename)) do begin + if Filename[i + 1] in ['/', '\'] then break; + inc(i); + end ; + Result := Copy(FileName, 1, i); + end +else Result := ''; +end; + +function ExtractFileName(const FileName: string): string; +var i: longint; +begin +I := Length(FileName); +while (I > 0) and not (FileName[I] in ['/', '\', ':']) do Dec(I); +Result := Copy(FileName, I + 1, 255); +end; + +function ExtractFileExt(const FileName: string): string; +var i: longint; +begin +I := Length(FileName); +while (I > 0) and not (FileName[I] in ['.', '/', '\', ':']) do Dec(I); +if (I > 0) and (FileName[I] = '.') then + Result := Copy(FileName, I, 255) +else Result := ''; +end; + +function ExpandFileName (Const FileName : string): String; + +Var S : String; + +Begin + S:=FileName; + DoDirSeparators(S); +{$ifdef linux} + Result:=Linux.fexpand(S); +{$else} + Result:=Dos.Fexpand(S); +{$endif} +end; + +function ExpandUNCFileName (Const FileName : string): String; +begin + Result:=ExpandFileName (FileName); + //!! Here should follow code to replace the drive: part with UNC... +end; + +Const MaxDirs = 129; + +function ExtractRelativepath (Const BaseName,DestName : String): String; + +Var Source, Dest : String; + Sc,Dc,I,J : Longint; + SD,DD : Array[1..MaxDirs] of PChar; + +Const OneLevelBack = '..'+OSDirSeparator; + +begin + If Upcase(ExtractFileDrive(BaseName))<>Upcase(ExtractFileDrive(DestName)) Then + begin + Result:=DestName; + exit; + end; + Source:=ExtractFilePath(BaseName); + Dest:=ExtractFilePath(DestName); + SC:=GetDirs (Source,SD); + DC:=GetDirs (Dest,DD); + I:=1; + While (I-1 then inc(Result); +end; + +{ + $Log: not supported by cvs2svn $ + Revision 1.7 2000/02/09 16:59:32 peter + * truncated log + +} diff --git a/befpc/rtl/objpas/finah.inc b/befpc/rtl/objpas/finah.inc new file mode 100644 index 0000000..1456a7e --- /dev/null +++ b/befpc/rtl/objpas/finah.inc @@ -0,0 +1,51 @@ +{ + ********************************************************************* + $Id: finah.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +Const + DirSeparators : set of char = ['/','\']; +{$ifdef Linux} + OSDirSeparator = '/'; +{$else} + OsDirSeparator = '\'; +{$endif} + +function ChangeFileExt(const FileName, Extension: string): string; +function ExtractFilePath(const FileName: string): string; +function ExtractFileDrive(const FileName: string): string; +function ExtractFileName(const FileName: string): string; +function ExtractFileExt(const FileName: string): string; +function ExtractFileDir(Const FileName : string): string; +function ExpandFileName (Const FileName : string): String; +function ExpandUNCFileName (Const FileName : string): String; +function ExtractRelativepath (Const BaseName,DestNAme : String): String; +Procedure DoDirSeparators (Var FileName : String); +Function SetDirSeparators (Const FileName : String) : String; +Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint; + +{ + $Log: not supported by cvs2svn $ + Revision 1.4 2000/02/09 16:59:32 peter + * truncated log + +} + diff --git a/befpc/rtl/objpas/makefile.op b/befpc/rtl/objpas/makefile.op new file mode 100644 index 0000000..cb3c354 --- /dev/null +++ b/befpc/rtl/objpas/makefile.op @@ -0,0 +1,14 @@ +objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMPPU) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp $(REDIR) + +SYSUTILINC = $(wildcard $(OBJPASDIR)/*.inc) +sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(SYSUTILINC) filutil.inc disk.inc \ + objpas$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR) + +typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT) + $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR) + +math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/math.pp $(REDIR) + diff --git a/befpc/rtl/objpas/math.pp b/befpc/rtl/objpas/math.pp new file mode 100644 index 0000000..459df84 --- /dev/null +++ b/befpc/rtl/objpas/math.pp @@ -0,0 +1,911 @@ +{ + $Id: math.pp,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + 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. + + **********************************************************************} +{ + This unit is an equivalent to the Delphi math unit + (with some improvements) + + About assembler usage: + ---------------------- + I used as few as possible assembler to allow an easy port + to other processors. Today, I think it's wasted time to write + assembler because different versions of a family of processors + need different implementations. + + To improve performance, I changed all integer arguments and + functions results to longint, because 16 bit instructions are + lethal for a modern intel processor. + (FK) + + What's to do: + o a lot of function :), search for !!!! + o some statistical functions + o all financial functions + o optimizations +} + +unit math; +interface + +{$MODE objfpc} + + uses + sysutils; + + type + { the original delphi functions use extended as argument, } + { but I would prefer double, because 8 bytes is a very } + { natural size for the processor } + { WARNING : changing float type will } + { break all assembler code PM } + float = extended; + PFloat = ^Float; + PInteger = ^Integer; + + tpaymenttime = (ptendofperiod,ptstartofperiod); + + einvalidargument = class(ematherror); + +{ Min/max determination } +function MinIntValue(const Data: array of Integer): Integer; +function MaxIntValue(const Data: array of Integer): Integer; + +{ Extra, not present in Delphi, but used frequently } +function Min(Int1,Int2:Integer):Integer; +function Min(Int1,Int2:Cardinal):Cardinal; +function Max(Int1,Int2:Integer):Integer; +function Max(Int1,Int2:Cardinal):Cardinal; + +{ angle conversion } + +function degtorad(deg : float) : float; +function radtodeg(rad : float) : float; +function gradtorad(grad : float) : float; +function radtograd(rad : float) : float; +function degtograd(deg : float) : float; +function gradtodeg(grad : float) : float; +{ one cycle are 2*Pi rad } +function cycletorad(cycle : float) : float; +function radtocycle(rad : float) : float; + +{ trigoniometric functions } + +function tan(x : float) : float; +function cotan(x : float) : float; +procedure sincos(theta : float;var sinus,cosinus : float); + +{ inverse functions } + +function arccos(x : float) : float; +function arcsin(x : float) : float; + +{ calculates arctan(x/y) and returns an angle in the correct quadrant } +function arctan2(x,y : float) : float; + +{ hyperbolic functions } + +function cosh(x : float) : float; +function sinh(x : float) : float; +function tanh(x : float) : float; + +{ area functions } + +{ delphi names: } +function arccosh(x : float) : float; +function arcsinh(x : float) : float; +function arctanh(x : float) : float; +{ IMHO the function should be called as follows (FK) } +function arcosh(x : float) : float; +function arsinh(x : float) : float; +function artanh(x : float) : float; + +{ triangle functions } + +{ returns the length of the hypotenuse of a right triangle } +{ if x and y are the other sides } +function hypot(x,y : float) : float; + +{ logarithm functions } + +function log10(x : float) : float; +function log2(x : float) : float; +function logn(n,x : float) : float; + +{ returns natural logarithm of x+1 } +function lnxp1(x : float) : float; + +{ exponential functions } + +function power(base,exponent : float) : float; +{ base^exponent } +function intpower(base : float;exponent : longint) : float; + +{ number converting } + +{ rounds x towards positive infinity } +function ceil(x : float) : longint; +{ rounds x towards negative infinity } +function floor(x : float) : longint; + +{ misc. functions } + +{ splits x into mantissa and exponent (to base 2) } +procedure frexp(x : float;var mantissa,exponent : float); +{ returns x*(2^p) } +function ldexp(x : float;p : longint) : float; + +{ statistical functions } + +function mean(const data : array of float) : float; +function sum(const data : array of float) : float; +function mean(const data : PFloat; Const N : longint) : float; +function sum(const data : PFloat; Const N : Longint) : float; +function sumofsquares(const data : array of float) : float; +function sumofsquares(const data : PFloat; Const N : Integer) : float; +{ calculates the sum and the sum of squares of data } +procedure sumsandsquares(const data : array of float; + var sum,sumofsquares : float); +procedure sumsandsquares(const data : PFloat; Const N : Integer; + var sum,sumofsquares : float); +function minvalue(const data : array of float) : float; +function minvalue(const data : array of integer) : Integer; +function minvalue(const data : PFloat; Const N : Integer) : float; +function MinValue(const Data : PInteger; Const N : Integer): Integer; +function maxvalue(const data : array of float) : float; +function maxvalue(const data : array of integer) : Integer; +function maxvalue(const data : PFloat; Const N : Integer) : float; +function maxvalue(const data : PInteger; Const N : Integer) : Integer; +{ calculates the standard deviation } +function stddev(const data : array of float) : float; +function stddev(const data : PFloat; Const N : Integer) : float; +{ calculates the mean and stddev } +procedure meanandstddev(const data : array of float; + var mean,stddev : float); +procedure meanandstddev(const data : PFloat; + Const N : Longint;var mean,stddev : float); +function variance(const data : array of float) : float; +function totalvariance(const data : array of float) : float; +function variance(const data : PFloat; Const N : Integer) : float; +function totalvariance(const data : PFloat; Const N : Integer) : float; +{ returns random values with gaussian distribution } +function randg(mean,stddev : float) : float; + +{ I don't know what the following functions do: } +function popnstddev(const data : array of float) : float; +function popnstddev(const data : PFloat; Const N : Integer) : float; +function popnvariance(const data : PFloat; Const N : Integer) : float; +function popnvariance(const data : array of float) : float; +procedure momentskewkurtosis(const data : array of float; + var m1,m2,m3,m4,skew,kurtosis : float); +procedure momentskewkurtosis(const data : PFloat; Const N : Integer; + var m1,m2,m3,m4,skew,kurtosis : float); + +{ geometrical function } + +{ returns the euclidean L2 norm } +function norm(const data : array of float) : float; +function norm(const data : PFloat; Const N : Integer) : float; + +implementation + +ResourceString + SMathError = 'Math Error : %s'; + SInvalidArgument = 'Invalid argument'; + +Procedure DoMathError(Const S : String); +begin + Raise EMathError.CreateFmt(SMathError,[S]); +end; + +Procedure InvalidArgument; + +begin + Raise EInvalidArgument.Create(SInvalidArgument); +end; + +function degtorad(deg : float) : float; + + begin + degtorad:=deg*(pi/180.0); + end; + +function radtodeg(rad : float) : float; + + begin + radtodeg:=rad*(180.0/pi); + end; + +function gradtorad(grad : float) : float; + + begin + gradtorad:=grad*(pi/200.0); + end; + +function radtograd(rad : float) : float; + + begin + radtograd:=rad*(200.0/pi); + end; + +function degtograd(deg : float) : float; + + begin + degtograd:=deg*(200.0/180.0); + end; + +function gradtodeg(grad : float) : float; + + begin + gradtodeg:=grad*(180.0/200.0); + end; + +function cycletorad(cycle : float) : float; + + begin + cycletorad:=(2*pi)*cycle; + end; + +function radtocycle(rad : float) : float; + + begin + { avoid division } + radtocycle:=rad*(1/(2*pi)); + end; + +function tan(x : float) : float; + + begin + Tan:=Sin(x)/Cos(x) + end; + +function cotan(x : float) : float; + + begin + cotan:=Cos(X)/Sin(X); + end; + +procedure sincos(theta : float;var sinus,cosinus : float); + + begin + {$ifndef i386} + sinus:=sin(theta); + cosinus:=cos(theta); + {$else} + asm + fldl theta + fsincos + fwait + movl cosinus,%eax + fstpl (%eax) + movl sinus,%eax + fstpl (%eax) + end; + {$endif} + end; + +{ Sign, ArcSin and ArcCos from Arjan van Dijk (arjan.vanDijk@User.METAIR.WAU.NL) } + +function sign(x : float) : float; +begin + if x > 0 then sign := 1.0 + else if x < 0 then sign := -1.0 + else sign := 0.0; +end; + +function arcsin(x : float) : float; +begin + if abs(x) > 1 then InvalidArgument + else if abs(x) < 0.5 then + arcsin := arctan(x/sqrt(1-sqr(x))) + else + arcsin := sign(x) * (pi*0.5 - arctan(sqrt(1 / sqr(x) - 1))); +end; + +function Arccos(x : Float) : Float; +begin + arccos := pi*0.5 - arcsin(x); +end; + + +function arctan2( x,y : float) : float; + + {$ifndef i386} + begin + ArcTan2:=ArcTan(x/y); + {$else} + { without the assembler keyword, you have to store the result to } + { __result at the end of the assembler block (JM) } + assembler; + asm + fldt X + fldt Y + fpatan + //leave + // ret $20 This is wrong for 4 byte aligned OS !! + {$endif} + end; + +function cosh(x : float) : float; + + var + temp : float; + + begin + temp:=exp(x); + cosh:=0.5*(temp+1.0/temp); + end; + +function sinh(x : float) : float; + + var + temp : float; + + begin + temp:=exp(x); + sinh:=0.5*(temp-1.0/temp); + end; + +Const MaxTanh=5000; { rather arbitrary, but more or less correct } + +function tanh(x : float) : float; + + var Temp : float; + + begin + if x>MaxTanh then exit(1.0) + else if x<-MaxTanh then exit (-1.0); + temp:=exp(-2*x); + tanh:=(1-temp)/(1+temp) + end; + +function arccosh(x : float) : float; + + begin + arccosh:=arcosh(x); + end; + +function arcsinh(x : float) : float; + + begin + arcsinh:=arsinh(x); + end; + +function arctanh(x : float) : float; + + begin + if x>1 then InvalidArgument; + arctanh:=artanh(x); + end; + +function arcosh(x : float) : float; + + begin + if x<1 then InvalidArgument; + arcosh:=Ln(x+Sqrt(x*x-1)); + end; + +function arsinh(x : float) : float; + + begin + arsinh:=Ln(x+Sqrt(1+x*x)); + end; + +function artanh(x : float) : float; + begin + If abs(x)>1 then InvalidArgument; + artanh:=(Ln((1+x)/(1-x)))*0.5; + end; + +function hypot(x,y : float) : float; + + begin + hypot:=Sqrt(x*x+y*y) + end; + +function log10(x : float) : float; + + begin + log10:=ln(x)/ln(10); + end; + +function log2(x : float) : float; + + begin + log2:=ln(x)/ln(2) + end; + +function logn(n,x : float) : float; + + begin + if n<0 then InvalidArgument; + logn:=ln(x)/ln(n); + end; + +function lnxp1(x : float) : float; + + begin + if x<-1 then + InvalidArgument; + lnxp1:=ln(1+x); + end; + +function power(base,exponent : float) : float; + + begin + If Exponent=0.0 then + Result:=1.0 + else + If base>0.0 then + Power:=exp(exponent * ln (base)) + else if base=0.0 then + Result:=0.0 + else + InvalidArgument + end; + +function intpower(base : float;exponent : longint) : float; + + var + i : longint; + + begin + i:=abs(exponent); + intpower:=1.0; + while i>0 do + begin + while (i and 1)=0 do + begin + i:=i shr 1; + base:=sqr(base); + end; + i:=i-1; + intpower:=intpower*base; + end; + if exponent<0 then + intpower:=1.0/intpower; + end; + +function ceil(x : float) : longint; + + begin + Ceil:=Trunc(x); + If Frac(x)>0 then + Ceil:=Ceil+1; + end; + +function floor(x : float) : longint; + + begin + Floor:=Trunc(x); + If Frac(x)<0 then + Floor := Floor-1; + end; + +procedure frexp(x : float;var mantissa,exponent : float); + + begin + + end; + +function ldexp(x : float;p : longint) : float; + + begin + ldexp:=x*intpower(2.0,p); + end; + +function mean(const data : array of float) : float; + + begin + Result:=Mean(@data[0],High(Data)+1); + end; + +function mean(const data : PFloat; Const N : longint) : float; + + begin + mean:=sum(Data,N); + mean:=mean/N; + end; + +function sum(const data : array of float) : float; + + begin + Result:=Sum(@Data[0],High(Data)+1); + end; + +function sum(const data : PFloat;Const N : longint) : float; + + var + i : longint; + + begin + sum:=0.0; + for i:=0 to N-1 do + sum:=sum+data[i]; + end; + + function sumofsquares(const data : array of float) : float; + + begin + Result:=sumofsquares(@data[0],High(Data)+1); + end; + + function sumofsquares(const data : PFloat; Const N : Integer) : float; + + var + i : longint; + + begin + sumofsquares:=0.0; + for i:=0 to N-1 do + sumofsquares:=sumofsquares+sqr(data[i]); + end; + +procedure sumsandsquares(const data : array of float; + var sum,sumofsquares : float); + +begin + sumsandsquares (@Data[0],High(Data)+1,Sum,sumofsquares); +end; + +procedure sumsandsquares(const data : PFloat; Const N : Integer; + var sum,sumofsquares : float); + + var + i : Integer; + temp : float; + + begin + sumofsquares:=0.0; + sum:=0.0; + for i:=0 to N-1 do + begin + temp:=data[i]; + sumofsquares:=sumofsquares+sqr(temp); + sum:=sum+temp; + end; + end; + + + +function stddev(const data : array of float) : float; + +begin + Result:=Stddev(@Data[0],High(Data)+1) +end; + +function stddev(const data : PFloat; Const N : Integer) : float; + + begin + StdDev:=Sqrt(Variance(Data,N)); + end; + +procedure meanandstddev(const data : array of float; + var mean,stddev : float); + +begin + Meanandstddev(@Data[0],High(Data)+1,Mean,stddev); +end; + +procedure meanandstddev(const data : PFloat; + Const N : Longint;var mean,stddev : float); + +Var I : longint; + +begin + Mean:=0; + StdDev:=0; + For I:=0 to N-1 do + begin + Mean:=Mean+Data[i]; + StdDev:=StdDev+Sqr(Data[i]); + end; + Mean:=Mean/N; + StdDev:=(StdDev-N*Sqr(Mean)); + If N>1 then + StdDev:=Sqrt(Stddev/(N-1)) + else + StdDev:=0; +end; + +function variance(const data : array of float) : float; + + begin + Variance:=Variance(@Data[0],High(Data)+1); + end; + +function variance(const data : PFloat; Const N : Integer) : float; + + begin + If N=1 then + Result:=0 + else + Result:=TotalVariance(Data,N)/(N-1); + end; + +function totalvariance(const data : array of float) : float; + +begin + Result:=TotalVariance(@Data[0],High(Data)+1); +end; + +function totalvariance(const data : Pfloat;Const N : Integer) : float; + + var S,SS : Float; + + begin + If N=1 then + Result:=0 + else + begin + SumsAndSquares(Data,N,S,SS); + Result := SS-Sqr(S)/N; + end; + end; + +function randg(mean,stddev : float) : float; + + Var U1,S2 : Float; + + begin + repeat + u1:= 2*random-1; + S2:=Sqr(U1)+sqr(2*random-1); + until s2<1; + randg:=Sqrt(-2*ln(S2)/S2)*u1*stddev+Mean; + end; + +function popnstddev(const data : array of float) : float; + + begin + PopnStdDev:=Sqrt(PopnVariance(@Data[0],High(Data)+1)); + end; + +function popnstddev(const data : PFloat; Const N : Integer) : float; + + begin + PopnStdDev:=Sqrt(PopnVariance(Data,N)); + end; + +function popnvariance(const data : array of float) : float; + +begin + popnvariance:=popnvariance(@data[0],high(Data)+1); +end; + +function popnvariance(const data : PFloat; Const N : Integer) : float; + + begin + PopnVariance:=TotalVariance(Data,N)/N; + end; + +procedure momentskewkurtosis(const data : array of float; + var m1,m2,m3,m4,skew,kurtosis : float); + +begin + momentskewkurtosis(@Data[0],High(Data)+1,m1,m2,m3,m4,skew,kurtosis); +end; + +procedure momentskewkurtosis(const data : PFloat; Const N : Integer; + var m1,m2,m3,m4,skew,kurtosis : float); + + Var S,SS,SC,SQ,invN,Acc,M1S,S2N,S3N,temp : Float; + I : Longint; + + begin + invN:=1.0/N; + s:=0; + ss:=0; + sq:=0; + sc:=0; + for i:=0 to N-1 do + begin + temp:=Data[i]; { faster } + S:=S+temp; + acc:=temp*temp; + ss:=ss+acc; + Acc:=acc*temp; + Sc:=sc+acc; + acc:=acc*temp; + sq:=sq+acc; + end; + M1:=s*invN; + M1S:=M1*M1; + S2N:=SS*invN; + S3N:=SC*invN; + M2:=S2N-M1S; + M3:=S3N-(M1*3*S2N) + 2*M1S*M1; + M4:=SQ*invN - (M1 * 4 * S3N) + (M1S*6*S2N-3*Sqr(M1S)); + Skew:=M3*power(M2,-3/2); + Kurtosis:=M4 / Sqr(M2); + end; + +function norm(const data : array of float) : float; + + begin + norm:=Norm(@data[0],High(Data)+1); + end; + +function norm(const data : PFloat; Const N : Integer) : float; + + begin + norm:=sqrt(sumofsquares(data,N)); + end; + + +function MinIntValue(const Data: array of Integer): Integer; +var + I: Integer; +begin + Result := Data[Low(Data)]; + For I := Succ(Low(Data)) To High(Data) Do + If Data[I] < Result Then Result := Data[I]; +end; + +function MinValue(const Data: array of Integer): Integer; + +begin + Result:=MinValue(Pinteger(@Data[0]),High(Data)+1) +end; + +function MinValue(const Data: PInteger; Const N : Integer): Integer; +var + I: Integer; +begin + Result := Data[0]; + For I := 0 To N-1 do + If Data[I] < Result Then Result := Data[I]; +end; + + +function minvalue(const data : array of float) : float; + +begin + Result:=minvalue(PFloat(@data[0]),High(Data)+1); +end; + +function minvalue(const data : PFloat; Const N : Integer) : float; + +var + i : longint; + +begin + { get an initial value } + minvalue:=data[0]; + for i:=0 to N-1 do + if data[i] Result Then Result := Data[I]; +end; + +function maxvalue(const data : array of float) : float; + +begin + Result:=maxvalue(PFloat(@data[0]),High(Data)+1); +end; + +function maxvalue(const data : PFloat; Const N : Integer) : float; + +var + i : longint; + +begin + { get an initial value } + maxvalue:=data[0]; + for i:=0 to N-1 do + if data[i]>maxvalue then + maxvalue:=data[i]; +end; + +function MaxValue(const Data: array of Integer): Integer; + +begin + Result:=MaxValue(PInteger(@Data[0]),High(Data)+1) +end; + +function maxvalue(const data : PInteger; Const N : Integer) : Integer; + +var + i : longint; + +begin + { get an initial value } + maxvalue:=data[0]; + for i:=0 to N-1 do + if data[i]>maxvalue then + maxvalue:=data[i]; +end; + + +function Min(Int1,Int2:Integer):Integer; +begin + If Int1 < Int2 Then Result := Int1 + Else Result := Int2; +end; + +function Min(Int1,Int2:Cardinal):Cardinal; +begin + If Int1 < Int2 Then Result := Int1 + Else Result := Int2; +end; + +function Max(Int1,Int2:Integer):Integer; +begin + If Int1 > Int2 Then Result := Int1 + Else Result := Int2; +end; + +function Max(Int1,Int2:Cardinal):Cardinal; +begin + If Int1 > Int2 Then Result := Int1 + Else Result := Int2; +end; + + +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.25 2000/07/08 17:12:56 michael + + Final fixes + + Revision 1.24 2000/07/08 07:03:20 michael + + fixed meanandstddev + + Revision 1.23 2000/07/08 06:45:07 michael + + Added some functions + + Revision 1.22 2000/07/06 21:59:25 michael + + Added many overloaded functions with as argument pointer to + array and count + + Implemented meanandstddev + + Improved power + + Revision 1.21 2000/07/06 12:13:59 michael + + SOme changes in error reporting + + Revision 1.20 2000/07/05 13:19:59 michael + + Corrected arsinh function + + Revision 1.19 2000/07/04 20:53:22 michael + + Exceptions now used for errors + + Revision 1.18 2000/04/29 10:10:51 jonas + * fixed arctan2 (tbug788 now works correctly) + + Revision 1.17 2000/04/20 13:12:40 pierre + * fix bug visible in new tests/webtbs/tbug788 file + + Revision 1.16 2000/04/20 08:14:27 jonas + * better arcsin/arccos from Arjan van Dijk + + Revision 1.15 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.14 2000/01/11 21:07:33 marco + * Changed some (%ebp) to real parameters + + Revision 1.13 2000/01/07 16:41:43 daniel + * copyright 2000 + + Revision 1.12 1999/09/21 20:47:05 florian + * ceil and floor still had bugs :), hopefully it's the final fix now + +} \ No newline at end of file diff --git a/befpc/rtl/objpas/objpas.pp b/befpc/rtl/objpas/objpas.pp new file mode 100644 index 0000000..b659a4e --- /dev/null +++ b/befpc/rtl/objpas/objpas.pp @@ -0,0 +1,427 @@ +{ + $Id: objpas.pp,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This unit makes Free Pascal as much as possible Delphi compatible + + 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. + + **********************************************************************} +{$Mode ObjFpc} +{$I-} +{$ifndef linux} + {$S-} +{$endif} +unit objpas; + + interface + + { first, in object pascal, the integer type must be redefined } + const + MaxInt = MaxLongint; + type + integer = longint; + +{ Old compilers search for these variables in objpas unit } +{$ifndef SYSTEMTVARREC} + pvarrec = system.pvarrec; + tvarrec = system.tvarrec; +{$endif} + +{**************************************************************************** + Compatibility routines. +****************************************************************************} + + { Untyped file support } + + Procedure AssignFile(Var f:File;const Name:string); + Procedure AssignFile(Var f:File;p:pchar); + Procedure AssignFile(Var f:File;c:char); + Procedure CloseFile(Var f:File); + + { Text file support } + Procedure AssignFile(Var t:Text;const s:string); + Procedure AssignFile(Var t:Text;p:pchar); + Procedure AssignFile(Var t:Text;c:char); + Procedure CloseFile(Var t:Text); + + { Typed file supoort } + + Procedure AssignFile(Var f:TypedFile;const Name:string); + Procedure AssignFile(Var f:TypedFile;p:pchar); + Procedure AssignFile(Var f:TypedFile;c:char); + + { ParamStr should return also an ansistring } + Function ParamStr(Param : Integer) : Ansistring; + + +{$ifdef HasResourceStrings} +Type + TResourceIterator = Function (Name,Value : AnsiString; Hash : Longint) : AnsiString; + + Function Hash(S : AnsiString) : longint; + Procedure ResetResourceTables; + Procedure SetResourceStrings (SetFunction : TResourceIterator); + Function ResourceStringTableCount : Longint; + Function ResourceStringCount(TableIndex : longint) : longint; + Function GetResourceStringName(TableIndex,StringIndex : Longint) : Ansistring; + Function GetResourceStringHash(TableIndex,StringIndex : Longint) : Longint; + Function GetResourceStringDefaultValue(TableIndex,StringIndex : Longint) : AnsiString; + Function GetResourceStringCurrentValue(TableIndex,StringIndex : Longint) : AnsiString; + Function SetResourceStringValue(TableIndex,StringIndex : longint; Value : Ansistring) : Boolean; + +{$endif} + + + implementation + +{**************************************************************************** + Compatibility routines. +****************************************************************************} + +{ Untyped file support } + +Procedure AssignFile(Var f:File;const Name:string); + +begin + System.Assign (F,Name); +end; + +Procedure AssignFile(Var f:File;p:pchar); + +begin + System.Assign (F,P); +end; + +Procedure AssignFile(Var f:File;c:char); + +begin + System.Assign (F,C); +end; + +Procedure CloseFile(Var f:File); + +begin + System.Close(f); +end; + +{ Text file support } + +Procedure AssignFile(Var t:Text;const s:string); + +begin + System.Assign (T,S); +end; + +Procedure AssignFile(Var t:Text;p:pchar); + +begin + System.Assign (T,P); +end; + +Procedure AssignFile(Var t:Text;c:char); + +begin + System.Assign (T,C); +end; + +Procedure CloseFile(Var t:Text); + +begin + Close(T); +end; + +{ Typed file supoort } + +Procedure AssignFile(Var f:TypedFile;const Name:string); + +begin + system.Assign(F,Name); +end; + +Procedure AssignFile(Var f:TypedFile;p:pchar); + +begin + system.Assign (F,p); +end; + +Procedure AssignFile(Var f:TypedFile;c:char); + +begin + system.Assign (F,C); +end; + +Function ParamStr(Param : Integer) : Ansistring; + +Var Len : longint; + +begin + if (Param>=0) and (Param#0 do + Inc(len); + SetLength(Result,Len); + If Len>0 then + Move(Argv[Param][0],Result[1],Len); + end + else + paramstr:=''; + end; + + +{$IFDEF HasResourceStrings} + +{ --------------------------------------------------------------------- + ResourceString support + ---------------------------------------------------------------------} +Type + + PResourceStringRecord = ^TResourceStringRecord; + TResourceStringRecord = Packed Record + DefaultValue, + CurrentValue : AnsiString; + HashValue : longint; + Name : AnsiString; + end; + + TResourceStringTable = Packed Record + Count : longint; + Resrec : Array[Word] of TResourceStringRecord; + end; + PResourceStringTable = ^TResourceStringTable; + + TResourceTableList = Packed Record + Count : longint; + Tables : Array[Word] of PResourceStringTable; + end; + + + +Var + ResourceStringTable : TResourceTablelist; External Name 'FPC_RESOURCESTRINGTABLES'; + +Function Hash(S : AnsiString) : longint; + +Var thehash,g,I : longint; + +begin + thehash:=0; + For I:=1 to Length(S) do { 0 terminated } + begin + thehash:=thehash shl 4; + inc(theHash,Ord(S[i])); + g:=thehash and ($f shl 28); + if g<>0 then + begin + thehash:=thehash xor (g shr 24); + thehash:=thehash xor g; + end; + end; + If theHash=0 then + Hash:=Not(0) + else + Hash:=TheHash; +end; + +Function GetResourceString(Const TheTable: TResourceStringTable;Index : longint) : AnsiString;[Public,Alias : 'FPC_GETRESOURCESTRING']; +begin + If (Index>=0) and (Index-1; + If Result then + ResourceStringTable.ResRec[Hash].CurrentValue:=Value; +end; +*) + +Procedure SetResourceStrings (SetFunction : TResourceIterator); + +Var I,J : longint; + +begin + With ResourceStringTable do + For I:=0 to Count-1 do + With Tables[I]^ do + For J:=0 to Count-1 do + With ResRec[J] do + CurrentValue:=SetFunction(Name,DefaultValue,HashValue); +end; + + +Procedure ResetResourceTables; + +Var I,J : longint; + +begin + With ResourceStringTable do + For I:=0 to Count-1 do + With Tables[I]^ do + For J:=0 to Count-1 do + With ResRec[J] do + CurrentValue:=DefaultValue; +end; + +Function ResourceStringTableCount : Longint; + +begin + Result:=ResourceStringTable.Count; +end; + +Function CheckTableIndex (Index: longint) : Boolean; +begin + Result:=(Index=0) +end; + +Function CheckStringIndex (TableIndex,Index: longint) : Boolean; +begin + Result:=(TableIndex=0) and + (Index=0) +end; + +Function ResourceStringCount(TableIndex : longint) : longint; + +begin + If not CheckTableIndex(TableIndex) then + Result:=-1 + else + Result:=ResourceStringTable.Tables[TableIndex]^.Count; +end; + +Function GetResourceStringName(TableIndex,StringIndex : Longint) : Ansistring; + +begin + If not CheckStringIndex(Tableindex,StringIndex) then + Result:='' + else + result:=ResourceStringTable.Tables[TableIndex]^.ResRec[StringIndex].Name; +end; + +Function GetResourceStringHash(TableIndex,StringIndex : Longint) : Longint; + +begin + If not CheckStringIndex(Tableindex,StringIndex) then + Result:=0 + else + result:=ResourceStringTable.Tables[TableIndex]^.ResRec[StringIndex].HashValue; +end; + +Function GetResourceStringDefaultValue(TableIndex,StringIndex : Longint) : AnsiString; + +begin + If not CheckStringIndex(Tableindex,StringIndex) then + Result:='' + else + result:=ResourceStringTable.Tables[TableIndex]^.ResRec[StringIndex].DefaultValue; +end; + +Function GetResourceStringCurrentValue(TableIndex,StringIndex : Longint) : AnsiString; + +begin + If not CheckStringIndex(Tableindex,StringIndex) then + Result:='' + else + result:=ResourceStringTable.Tables[TableIndex]^.ResRec[StringIndex].CurrentValue; +end; + +Function SetResourceStringValue(TableIndex,StringIndex : longint; Value : Ansistring) : Boolean; + +begin + Result:=CheckStringIndex(Tableindex,StringIndex); + If Result then + ResourceStringTable.Tables[TableIndex]^.ResRec[StringIndex].CurrentValue:=Value; +end; + +{$endif} + + +Initialization +{$IFDEF HasResourceStrings} + ResetResourceTables; +{$endif} + +finalization + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.48 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.47 2000/01/07 16:41:44 daniel + * copyright 2000 + + Revision 1.46 2000/01/07 16:32:29 daniel + * copyright 2000 added + + Revision 1.45 1999/12/20 11:20:35 peter + * integer is defined as longint, removed smallint which is now in system + + Revision 1.44 1999/11/06 14:41:30 peter + * truncated log + + Revision 1.43 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.42 1999/10/03 19:41:30 peter + * moved tvarrec to systemunit + + Revision 1.41 1999/09/28 21:13:33 florian + * fixed bug 626, objpas must redefine maxint! + + Revision 1.40 1999/09/17 17:14:12 peter + + new heap manager supporting delphi freemem(pointer) + + Revision 1.39 1999/08/28 13:03:23 michael + + Added Hash function to interface + + Revision 1.38 1999/08/27 15:54:15 michael + + Added many resourcestring methods + + Revision 1.37 1999/08/25 16:41:08 peter + * resources are working again + + Revision 1.36 1999/08/24 22:42:56 michael + * changed resourcestrings to new mechanism + + Revision 1.35 1999/08/24 12:02:29 michael + + Changed external var for resourcestrings + + Revision 1.34 1999/08/20 10:50:55 michael + + Fixed memory leak + + Revision 1.33 1999/08/19 19:52:26 michael + * Fixed freemem bug; reported by Sebastian Guenther + + Revision 1.32 1999/08/15 21:28:57 michael + + Pass hash also for speed reasons. + + Revision 1.31 1999/08/15 21:02:56 michael + + Changed resource string mechanism to use names. + + Revision 1.30 1999/08/15 18:56:13 michael + + Delphi-style getmem and freemem + + Revision 1.29 1999/07/23 23:13:54 peter + * array[cardinal] is buggy, use array[word] + * small fix in getresourcestring + + Revision 1.28 1999/07/23 22:51:11 michael + * Added HasResourceStrings check + +} diff --git a/befpc/rtl/objpas/stre.inc b/befpc/rtl/objpas/stre.inc new file mode 100644 index 0000000..ddcfd21 --- /dev/null +++ b/befpc/rtl/objpas/stre.inc @@ -0,0 +1,76 @@ +{ + $Id: stre.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This file implements english error message strings + + 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. + + **********************************************************************} + +{ + English string constants for any messages issued by the sysutils unit. + Please have them ordered by constant name. +} + +Const + + { Error messages for exceptions } + + SAbstractError = 'Abstract method called'; + SAccessDenied = 'Access denied'; + SAccessViolation = 'Access violation'; + SArgumentMissing = 'Missing argument in format "%s"'; + SAssertError = '%s (%s, line %d)'; + SAssertionFailed = 'Assertion failed'; + SDiskFull = 'Disk Full'; + SDivByZero = 'Division by zero'; + SEndOfFile = 'Read past end of file'; + SFileNotFound = 'File not found'; + SFileNotAssigned = 'File not assigned'; + SFileNotOpen = 'File not open'; + SFileNotOpenForInput = 'File not open for input'; + SFileNotOpenForOutput = 'File not open for output'; + SInvalidArgIndex = 'Invalid argument index in format "%s"'; + SInvalidDrive = 'Invalid drive specified'; + SInvalidFileHandle = 'Invalid file handle'; + SInValidFileName = 'Invalid filename'; + SInvalidFloat = '"%s" is an invalid float'; + SInvalidFormat = 'Invalid format specifier : "%s"'; + SInvalidInput = 'Invalid input'; + SInvalidInteger = '"%s" is an invalid integer'; + SInvalidPointer = 'Invalid pointer operation'; + SOutOfMemory = 'Out of memory'; + SRangeError = 'Range check error'; + SInvalidCast = 'Invalid type cast'; + STooManyOpenFiles = 'Too many open files'; + SUnKnownRunTimeError = 'Unknown Run-Time error : %3.3d'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SIntOverflow = 'Arithmetic overflow'; + SInvalidOp = 'Invalid floating point operation'; + SAbortError = 'Operation aborted'; + SExceptionErrorMessage = 'exception at %p'; +{ + $Log: not supported by cvs2svn $ + Revision 1.11 2000/06/22 18:05:18 michael + + Added ExceptObject, ExceptAddr,ExceptionErrorMessage + ShowException Abort; OutOfMemoryError; Beep; + + Revision 1.10 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.9 2000/01/07 16:41:44 daniel + * copyright 2000 + + Revision 1.8 1999/08/28 14:53:27 florian + * bug 471 fixed: run time error 2 is now converted into a file not + found exception + +} \ No newline at end of file diff --git a/befpc/rtl/objpas/strg.inc b/befpc/rtl/objpas/strg.inc new file mode 100644 index 0000000..efeaff4 --- /dev/null +++ b/befpc/rtl/objpas/strg.inc @@ -0,0 +1,49 @@ +{ + $Id: strg.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + This file implements english error message strings + + 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. + + **********************************************************************} + +{ + German string constants for any messages issued by the sysutils unit. + Please have them ordered by constant name. +} + +Const + + { Error messages for exceptions } + + SAccessDenied = 'Zugriff verweigert'; + SDiskFull = 'Plattenspeichermedium voll'; + SEndOfFile = 'Lesezugriff hinter Dateiende'; + SInValidFileName = 'Ungltiger Dateiname'; + SInvalidInput = 'Ungltige Eingabe'; + SInvalidPointer = 'Ungltiger Zeigeroperation'; + SOutOfMemory = 'Speicher voll'; + STooManyOpenFiles = 'Zu viele offene Dateien'; + SUnKnownRunTimeError = 'Unbekannter Laufzeitfehler : %3.3d'; + SFileNotFound = 'Datei nicht gefunden'; + +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.4 2000/01/07 16:41:44 daniel + * copyright 2000 + + Revision 1.3 1999/08/28 14:53:27 florian + * bug 471 fixed: run time error 2 is now converted into a file not + found exception + +} diff --git a/befpc/rtl/objpas/sysinth.inc b/befpc/rtl/objpas/sysinth.inc new file mode 100644 index 0000000..6b01694 --- /dev/null +++ b/befpc/rtl/objpas/sysinth.inc @@ -0,0 +1,130 @@ +{ + $Id: sysinth.inc,v 1.1.1.1 2001-07-23 17:17:41 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + International settings for Sysutils unit. + + 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. + + **********************************************************************} + +{ + All the variables presented here must be set by the InitInternational + routine. They must be set to match the 'local' settings, although + most have an initial value. + + + These routines are OS-dependent. +} + +{ --------------------------------------------------------------------- + Upper/lowercase translations + ---------------------------------------------------------------------} + +type + TCaseTranslationTable = array[0..255] of char; + +var + { Tables with upper and lowercase forms of character sets. + MUST be initialized with the correct code-pages } + UpperCaseTable: TCaseTranslationTable; + LowerCaseTable: TCaseTranslationTable; + +{ --------------------------------------------------------------------- + Date formatting settings + ---------------------------------------------------------------------} + +Const + + { Character to be put between date, month and year } + DateSeparator: char = '-'; + + { Format used for short date notation } + ShortDateFormat: string = 'd/m/y'; + + { Format used for long date notation } + LongDateFormat: string = 'dd" "mmmm" "yyyy'; + + + { Short names of months. } + ShortMonthNames: array[1..12] of string[128] = + ('Jan','Feb','Mar','Apr','May','Jun', + 'Jul','Aug','Sep','Oct','Nov','Dec'); + + { Long names of months. } + LongMonthNames: array[1..12] of string[128] = + ('January','February','March','April','May','June', + 'July','August','September','October','November','December'); + + { Short names of days } + ShortDayNames: array[1..7] of string[128] = + ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); + + { Full names of days } + LongDayNames: array[1..7] of string[128] = + ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'); + + { Format used for short time notation } + ShortTimeFormat: string = 'hh:nn'; + + { Format used for long time notation } + LongTimeFormat: string = 'hh:nn:ss'; + + { Character to be put between hours and minutes } + TimeSeparator: char = ':'; + + { String to indicate AM time when using 12 hour clock. } + TimeAMString: string[7] = 'AM'; + + { String to indicate PM time when using 12 hour clock. } + TimePMString: string[7] = 'PM'; + + + +{ --------------------------------------------------------------------- + Number formatting constants + ---------------------------------------------------------------------} + + + { Character that comes between integer and fractional part of a number } + DecimalSeparator : Char = '.'; + + { Character that is put every 3 numbers in a currency } + ThousandSeparator : Char = ','; + + { Number of decimals to use when formatting a currency. } + CurrencyDecimals : Byte = 2; + + { Format to use when formatting currency : + 0 = $1 + 1 = 1$ + 2 = $ 1 + 3 = 1 $ + 4 = Currency string replaces decimal indicator. e.g. 1$50 + } + CurrencyFormat : Byte = 1; + + { Same as above, only for negative currencies: + 0 = ($1) + 1 = -$1 + 2 = $-1 + 3 = $1- + 4 = (1$) + 5 = -1$ + 6 = 1-$ + 7 = 1$- + 8 = -1 $ + 9 = -$ 1 + 10 = $ 1- + } + NegCurrFormat : Byte = 5; + + { Currency notation. Default is $ for dollars. } + CurrencyString : String[7] = '$'; + diff --git a/befpc/rtl/objpas/syspch.inc b/befpc/rtl/objpas/syspch.inc new file mode 100644 index 0000000..3e56617 --- /dev/null +++ b/befpc/rtl/objpas/syspch.inc @@ -0,0 +1,134 @@ +{ + ********************************************************************* + $Id: syspch.inc,v 1.1.1.1 2001-07-23 17:17:42 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +{ PChar functions } + +type + pbyte = ^byte; + CharArray = array[0..0] of char; + +{ Processor dependent part, shared withs strings unit } +{$i strings.inc } + +{ Processor independent part, shared with strings unit } +{$i stringsi.inc } + +{ StrPas converts a PChar to a pascal string } + +function StrPas(Str: PChar): string; +begin + SetLength(result, StrLen(Str)); + Move(Str^, result[1], Length(result)); +end ; + +{ StrAlloc allocates a buffer of Size + 4 + the size of the allocated buffer is stored at result - 4 + StrDispose should be used to destroy the buffer } + +function StrAlloc(Size: cardinal): PChar; +begin + inc(size,sizeof(cardinal)); + getmem(result,size); + cardinal(pointer(result)^):=size; + inc(result,sizeof(cardinal)); +end; + + +{ Allocates a new string using StrAlloc, you need StrDispose to dispose the + string } + +function strnew(p : pchar) : pchar; +var + len : longint; +begin + strnew:=nil; + if (p=nil) or (p^=#0) then + exit; + len:=strlen(p)+1; + StrNew:=StrAlloc(Len); + if strnew<>nil then + strmove(strnew,p,len); +end; + + +{ StrPCopy copies the pascal string Source to Dest and returns Dest } + +function StrPCopy(Dest: PChar; Source: string): PChar; +begin + result := StrMove(Dest, PChar(Source), length(Source)+1); +end ; + +{ StrPLCopy copies MaxLen or less characters from the pascal string + Source to Dest and returns Dest } + +function StrPLCopy(Dest: PChar; Source: string; MaxLen: cardinal): PChar; +var Count: cardinal; +begin +result := Dest; +if (Result <> Nil) and (MaxLen <> 0) then begin + Count := Length(Source); + if Count > MaxLen then + Count := MaxLen; + StrMove(Dest, PChar(Source), Count); + CharArray(result^)[Count] := #0; { terminate ! } + end ; +end ; + + +{ StrDispose clears the memory allocated with StrAlloc } + +procedure StrDispose(Str: PChar); +begin + if (Str <> Nil) then + begin + dec(Str,sizeof(cardinal)); + Freemem(str,cardinal(pointer(str)^)); + end; +end; + +{ StrBufSize returns the amount of memory allocated for pchar Str allocated with StrAlloc } + +function StrBufSize(Str: PChar): cardinal; +begin + if Str <> Nil then + result := cardinal(pointer(Str - SizeOf(cardinal))^)-sizeof(cardinal) + else + result := 0; +end ; + +{ + $Log: not supported by cvs2svn $ + Revision 1.9 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.8 1999/12/10 15:02:12 peter + * strnew is ofcourse also different between sysutils and strings, just + like stralloc/strdispose. + + Revision 1.7 1999/11/06 14:41:31 peter + * truncated log + + Revision 1.6 1999/08/24 13:14:50 peter + * disposestr allocstr compatible with delphi + +} diff --git a/befpc/rtl/objpas/syspchh.inc b/befpc/rtl/objpas/syspchh.inc new file mode 100644 index 0000000..b560e83 --- /dev/null +++ b/befpc/rtl/objpas/syspchh.inc @@ -0,0 +1,61 @@ +{ + ********************************************************************* + $Id: syspchh.inc,v 1.1.1.1 2001-07-23 17:17:42 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +{ shared with strings unit } +function strlen(p : pchar) : longint; +function strcopy(dest,source : pchar) : pchar; +function strlcopy(dest,source : pchar;maxlen : longint) : pchar; +function strecopy(dest,source : pchar) : pchar; +function strend(p : pchar) : pchar; +function strcat(dest,source : pchar) : pchar; +function strcomp(str1,str2 : pchar) : longint; +function strlcomp(str1,str2 : pchar;l : longint) : longint; +function stricomp(str1,str2 : pchar) : longint; +function strmove(dest,source : pchar;l : longint) : pchar; +function strlcat(dest,source : pchar;l : longint) : pchar; +function strscan(p : pchar;c : char) : pchar; +function strrscan(p : pchar;c : char) : pchar; +function strlower(p : pchar) : pchar; +function strupper(p : pchar) : pchar; +function strlicomp(str1,str2 : pchar;l : longint) : longint; +function strpos(str1,str2 : pchar) : pchar; +function strnew(p : pchar) : pchar; + +{ Different from strings unit - ansistrings or different behaviour } +function StrPas(Str: PChar): string; +function StrPCopy(Dest: PChar; Source: string): PChar; +function StrPLCopy(Dest: PChar; Source: string; MaxLen: cardinal): PChar; +function StrAlloc(Size: cardinal): PChar; +function StrBufSize(Str: PChar): cardinal; +procedure StrDispose(Str: PChar); + +{ + $Log: not supported by cvs2svn $ + Revision 1.5 2000/02/09 16:59:32 peter + * truncated log + + Revision 1.4 1999/08/24 13:14:51 peter + * disposestr allocstr compatible with delphi + +} + diff --git a/befpc/rtl/objpas/sysstr.inc b/befpc/rtl/objpas/sysstr.inc new file mode 100644 index 0000000..052174c --- /dev/null +++ b/befpc/rtl/objpas/sysstr.inc @@ -0,0 +1,1218 @@ +{ + ********************************************************************* + $Id: sysstr.inc,v 1.1.1.1 2001-07-23 17:17:43 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +{ NewStr creates a new PString and assigns S to it + if length(s) = 0 NewStr returns Nil } + +function NewStr(const S: string): PString; +begin + if (S='') then + Result:=nil + else + begin + getmem(Result,length(s)+1); + if (Result<>nil) then + Result^:=s; + end; +end; + +{ DisposeStr frees the memory occupied by S } + +procedure DisposeStr(S: PString); +begin + if S <> Nil then + begin + Freemem(S,Length(S^)+1); + S:=nil; + end; +end; + +{ AssignStr assigns S to P^ } + +procedure AssignStr(var P: PString; const S: string); +begin + P^ := s; +end ; + +{ AppendStr appends S to Dest } + +procedure AppendStr(var Dest: String; const S: string); +begin +Dest := Dest + S; +end ; + +{ UpperCase returns a copy of S where all lowercase characters ( from a to z ) + have been converted to uppercase } + +function UpperCase(const S: string): string; +var i: integer; +begin +result := S; +i := Length(S); +while i <> 0 do begin + if (result[i] in ['a'..'z']) then result[i] := char(byte(result[i]) - 32); + Dec(i); + end; +end; + +{ LowerCase returns a copy of S where all uppercase characters ( from A to Z ) + have been converted to lowercase } + +function LowerCase(const S: string): string; +var i: integer; +begin +result := S; +i := Length(result); +while i <> 0 do begin + if (result[i] in ['A'..'Z']) then result[i] := char(byte(result[i]) + 32); + dec(i); + end; +end; + +{ CompareStr compares S1 and S2, the result is the based on + substraction of the ascii values of the characters in S1 and S2 + case result + S1 < S2 < 0 + S1 > S2 > 0 + S1 = S2 = 0 } + +function CompareStr(const S1, S2: string): Integer; +var count, count1, count2: integer; +begin +result := 0; +Count1 := Length(S1); +Count2 := Length(S2); +if Count1 > Count2 then Count := Count2 +else Count := Count1; +result := CompareMemRange(Pointer(S1),Pointer(S2), Count); +if (result = 0) and (Count1 <> Count2) then begin + if Count1 > Count2 then result := ord(s1[Count1 + 1]) + else result := -ord(s2[Count2 + 1]); + end ; +end ; + +{ CompareMemRange returns the result of comparison of Length bytes at P1 and P2 + case result + P1 < P2 < 0 + P1 > P2 > 0 + P1 = P2 = 0 } + +function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer; +var i: integer; +begin +i := 0; +result := 0; +while (result = 0) and (i < length) do begin + result := byte(P1^) - byte(P2^); + P1 := P1 + 1; + P2 := P2 + 1; + i := i + 1; + end ; +end ; + +function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean; +var + i: Integer; +begin + for i := 0 to Length - 1 do + begin + if Byte(P1^) <> Byte(P2^) then + begin + Result := False; + exit; + end; + Inc(P1); + Inc(P2); + end; + Result := True; +end; + + +{ CompareText compares S1 and S2, the result is the based on + substraction of the ascii values of characters in S1 and S2 + comparison is case-insensitive + case result + S1 < S2 < 0 + S1 > S2 > 0 + S1 = S2 = 0 } + +function CompareText(const S1, S2: string): integer; +var i, count, count1, count2: integer; Chr1, Chr2: byte; +begin +result := 0; +Count1 := Length(S1); +Count2 := Length(S2); +if Count1 > Count2 then Count := Count2 +else Count := Count1; +i := 0; +while (result = 0) and (i < count) do begin + inc (i); + Chr1 := byte(s1[i]); + Chr2 := byte(s2[i]); + if Chr1 in [97..122] then dec(Chr1,32); + if Chr2 in [97..122] then dec(Chr2,32); + result := Chr1 - Chr2; + end ; +if (result = 0) then + result:=(count1-count2); +end ; + +{==============================================================================} +{ Ansi string functions } +{ these functions rely on the character set loaded by the OS } +{==============================================================================} + + +function AnsiUpperCase(const s: string): string; +var len, i: integer; +begin +len := length(s); +SetLength(result, len); +for i := 1 to len do + result[i] := UpperCaseTable[ord(s[i])]; +end ; + +function AnsiLowerCase(const s: string): string; +var len, i: integer; +begin +len := length(s); +SetLength(result, len); +for i := 1 to len do + result[i] := LowerCaseTable[ord(s[i])]; +end ; + +function AnsiCompareStr(const S1, S2: string): integer; + +Var I,L1,L2 : Longint; + +begin + Result:=0; + L1:=Length(S1); + L2:=Length(S2); + I:=1; + While (Result=0) and ((I<=L1) and (I<=L2)) do + begin + Result:=Ord(S1[I])-Ord(S2[I]); //!! Must be replaced by ansi characters !! + Inc(I); + end; + If Result=0 Then + Result:=L1-L2; +end; + +function AnsiCompareText(const S1, S2: string): integer; +Var I,L1,L2 : Longint; + +begin + Result:=0; + L1:=Length(S1); + L2:=Length(S2); + I:=1; + While (Result=0) and ((I<=L1) and (I<=L2)) do + begin + Result:=Ord(LowerCaseTable[Ord(S1[I])])-Ord(LowerCaseTable[Ord(S2[I])]); //!! Must be replaced by ansi characters !! + Inc(I); + end; + If Result=0 Then + Result:=L1-L2; +end; + +function AnsiStrComp(S1, S2: PChar): integer; + +begin + Result:=0; + If S1=Nil then + begin + If S2=Nil Then Exit; + result:=-1; + end; + If S2=Nil then + begin + Result:=1; + exit; + end; + Repeat + Result:=Ord(S1[0])-Ord(S2[0]); //!! Must be replaced by ansi characters !! + Inc(S1); + Inc(S2); + Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) +end; + +function AnsiStrIComp(S1, S2: PChar): integer; + +begin + Result:=0; + If S1=Nil then + begin + If S2=Nil Then Exit; + result:=-1; + end; + If S2=Nil then + begin + Result:=1; + exit; + end; + Repeat + Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !! + Inc(S1); + Inc(S2); + Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) +end; + +function AnsiStrLComp(S1, S2: PChar; MaxLen: cardinal): integer; + +Var I : longint; + +begin + Result:=0; + If MaxLen=0 then exit; + If S1=Nil then + begin + If S2=Nil Then Exit; + result:=-1; + end; + If S2=Nil then + begin + Result:=1; + exit; + end; + I:=0; + Repeat + Result:=Ord(S1[0])-Ord(S2[0]); //!! Must be replaced by ansi characters !! + Inc(S1); + Inc(S2); + Inc(I); + Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen) +end ; + +function AnsiStrLIComp(S1, S2: PChar; MaxLen: cardinal): integer; + +Var I : longint; + +begin + Result:=0; + If MaxLen=0 then exit; + If S1=Nil then + begin + If S2=Nil Then Exit; + result:=-1; + end; + If S2=Nil then + begin + Result:=1; + exit; + end; + I:=0; + Repeat + Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !! + Inc(S1); + Inc(S2); + Inc(I); + Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen) +end ; + +function AnsiStrLower(Str: PChar): PChar; +begin +result := Str; +if Str <> Nil then begin + while Str^ <> #0 do begin + Str^ := LowerCaseTable[byte(Str^)]; + Str := Str + 1; + end ; + end ; +end ; + +function AnsiStrUpper(Str: PChar): PChar; +begin +result := Str; +if Str <> Nil then begin + while Str^ <> #0 do begin + Str^ := UpperCaseTable[byte(Str^)]; + Str := Str + 1; + end ; + end ; +end ; + +function AnsiLastChar(const S: string): PChar; + +begin + //!! No multibyte yet, so we return the last one. + result:=StrEnd(Pchar(S)); + Dec(Result); +end ; + +function AnsiStrLastChar(Str: PChar): PChar; +begin + //!! No multibyte yet, so we return the last one. + result:=StrEnd(Str); + Dec(Result); +end ; + +{==============================================================================} +{ End of Ansi functions } +{==============================================================================} + +{ Trim returns a copy of S with blanks characters on the left and right stripped off } + +Const WhiteSpace = [' ',#10,#13,#9]; + +function Trim(const S: string): string; +var Ofs, Len: integer; +begin + len := Length(S); + while (Len>0) and (S[Len] in WhiteSpace) do + dec(Len); + Ofs := 1; + while (Ofs<=Len) and (S[Ofs] in WhiteSpace) do + Inc(Ofs); + result := Copy(S, Ofs, 1 + Len - Ofs); +end ; + +{ TrimLeft returns a copy of S with all blank characters on the left stripped off } + +function TrimLeft(const S: string): string; +var i,l:integer; +begin + l := length(s); + i := 1; + while (i<=l) and (s[i] in whitespace) do + inc(i); + Result := copy(s, i, l); +end ; + +{ TrimRight returns a copy of S with all blank characters on the right stripped off } + +function TrimRight(const S: string): string; +var l:integer; +begin + l := length(s); + while (l>0) and (s[l] in whitespace) do + dec(l); + result := copy(s,1,l); +end ; + +{ QuotedStr returns S quoted left and right and every single quote in S + replaced by two quotes } + +function QuotedStr(const S: string): string; +begin +result := AnsiQuotedStr(s, ''''); +end ; + +{ AnsiQuotedStr returns S quoted left and right by Quote, + and every single occurance of Quote replaced by two } + +function AnsiQuotedStr(const S: string; Quote: char): string; +var i, j, count: integer; +begin +result := '' + Quote; +count := length(s); +i := 0; +j := 0; +while i < count do begin + i := i + 1; + if S[i] = Quote then begin + result := result + copy(S, 1 + j, i - j) + Quote; + j := i; + end ; + end ; +if i <> j then + result := result + copy(S, 1 + j, i - j); +result := result + Quote; +end ; + +{ AnsiExtractQuotedStr returns a copy of Src with quote characters + deleted to the left and right and double occurances + of Quote replaced by a single Quote } + +function AnsiExtractQuotedStr(Const Src: PChar; Quote: Char): string; +var i: integer; P, Q: PChar; +begin +P := Src; +if Src^ = Quote then P := P + 1; +Q := StrEnd(P); +if PChar(Q - 1)^ = Quote then Q := Q - 1; +SetLength(result, Q - P); +i := 0; +while P <> Q do begin + i := i + 1; + result[i] := P^; + if (P^ = Quote) and (PChar(P + 1)^ = Quote) then + P := P + 1; + P := P + 1; + end ; +SetLength(result, i); +end ; + +{ AdjustLineBreaks returns S with all CR characters not followed by LF + replaced with CR/LF } +// under Linux all CR characters or CR/LF combinations should be replaced with LF + +function AdjustLineBreaks(const S: string): string; +var i, j, count: integer; +begin +result := ''; +i := 0; +j := 0; +count := Length(S); +while i < count do begin + i := i + 1; +{$ifndef linux} + if (S[i] = #13) and ((i = count) or (S[i + 1] <> #10)) then + begin + result := result + Copy(S, 1 + j, i - j) + #10; + j := i; + end; +{$else} + If S[i]=#13 then + begin + Result:= Result+Copy(S,J+1,i-j-1)+#10; + If I<>Count Then + If S[I+1]=#10 then inc(i); + J :=I; + end; +{$endif} + end ; +if j <> i then + result := result + copy(S, 1 + j, i - j); +end ; + +{ IsValidIdent returns true if the first character of Ident is in: + 'A' to 'Z', 'a' to 'z' or '_' and the following characters are + on of: 'A' to 'Z', 'a' to 'z', '0'..'9' or '_' } + +function IsValidIdent(const Ident: string): boolean; +var i, len: integer; +begin +result := false; +len := length(Ident); +if len <> 0 then begin + result := Ident[1] in ['A'..'Z', 'a'..'z', '_']; + i := 1; + while (result) and (i < len) do begin + i := i + 1; + result := result and (Ident[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_']); + end ; + end ; +end ; + +{ IntToStr returns a string representing the value of Value } + +function IntToStr(Value: integer): string; +begin +System.Str(Value, result); +end ; + +{ IntToHex returns a string representing the hexadecimal value of Value } + +const + HexDigits: array[0..15] of char = '0123456789ABCDEF'; + +function IntToHex(Value: integer; Digits: integer): string; +var i: integer; +begin +SetLength(result, digits); +for i := 0 to digits - 1 do begin + result[digits - i] := HexDigits[value and 15]; + value := value shr 4; + end ; +end ; + +{ StrToInt converts the string S to an integer value, + if S does not represent a valid integer value EConvertError is raised } + +function StrToInt(const S: string): integer; + +var Error: word; + +begin + Val(S, result, Error); + if Error <> 0 then raise EConvertError.createfmt(SInValidInteger,[S]); +end ; + +{ StrToIntDef converts the string S to an integer value, + Default is returned in case S does not represent a valid integer value } + +function StrToIntDef(const S: string; Default: integer): integer; +var Error: word; +begin +Val(S, result, Error); +if Error <> 0 then result := Default; +end ; + +{ LoadStr returns the string resource Ident. } + +function LoadStr(Ident: integer): string; +begin + result:=''; +end ; + +{ FmtLoadStr returns the string resource Ident and formats it accordingly } + + +function FmtLoadStr(Ident: integer; const Args: array of const): string; +begin + result:=''; +end; + +Const + feInvalidFormat = 1; + feMissingArgument = 2; + feInvalidArgIndex = 3; + +{$ifdef fmtdebug} +Procedure Log (Const S: String); +begin + Writeln (S); +end; +{$endif} + + +Procedure DoFormatError (ErrCode : Longint); +Var + S : String; +begin + //!! must be changed to contain format string... + S:=''; + Case ErrCode of + feInvalidFormat : raise EConvertError.Createfmt(SInvalidFormat,[s]); + feMissingArgument : raise EConvertError.Createfmt(SArgumentMissing,[s]); + feInvalidArgIndex : raise EConvertError.Createfmt(SInvalidArgIndex,[s]); + end; +end; + + +Function Format (Const Fmt : String; const Args : Array of const) : String; + +Var ChPos,OldPos,ArgPos,DoArg,Len : Longint; + Hs,ToAdd : String; + Index,Width,Prec : Longint; + Left : Boolean; + Fchar : char; + + { + ReadFormat reads the format string. It returns the type character in + uppercase, and sets index, Width, Prec to their correct values, + or -1 if not set. It sets Left to true if left alignment was requested. + In case of an error, DoFormatError is called. + } + + Function ReadFormat : Char; + + Var Value : longint; + + Procedure ReadInteger; + + Var Code : Word; + + begin + If Value<>-1 then exit; // Was already read. + OldPos:=chPos; + While (Chpos<=Len) and + (Pos(Fmt[chpos],'1234567890')<>0) do inc(chpos); + If Chpos>len then + DoFormatError(feInvalidFormat); + If Fmt[Chpos]='*' then + begin + If (Chpos>OldPos) or (ArgPos>High(Args)) + or (Args[ArgPos].Vtype<>vtInteger) then + DoFormatError(feInvalidFormat); + Value:=Args[ArgPos].VInteger; + Inc(ArgPos); + Inc(chPos); + end + else + begin + If (OldPos0 then DoFormatError (feInvalidFormat); + end + else + Value:=-1; + end; + end; + + Procedure ReadIndex; + + begin + ReadInteger; + If Fmt[ChPos]=':' then + begin + If Value=-1 then DoFormatError(feMissingArgument); + Index:=Value; + Value:=-1; + Inc(Chpos); + end; +{$ifdef fmtdebug} + Log ('Read index'); +{$endif} + end; + + Procedure ReadLeft; + + begin + If Fmt[chpos]='-' then + begin + left:=True; + Inc(chpos); + end + else + Left:=False; +{$ifdef fmtdebug} + Log ('Read Left'); +{$endif} + end; + + Procedure ReadWidth; + + begin + ReadInteger; + If Value<>-1 then + begin + Width:=Value; + Value:=-1; + end; +{$ifdef fmtdebug} + Log ('Read width'); +{$endif} + end; + + Procedure ReadPrec; + + begin + If Fmt[chpos]='.' then + begin + inc(chpos); + ReadInteger; + If Value=-1 then DoFormaterror(feMissingArgument); + prec:=Value; + end; +{$ifdef fmtdebug} + Log ('Read precision'); +{$endif} + end; + + begin +{$ifdef fmtdebug} + Log ('Start format'); +{$endif} + Index:=-1; + Width:=-1; + Prec:=-1; + Value:=-1; + inc(chpos); + If Fmt[Chpos]='%' then exit('%'); + ReadIndex; + ReadLeft; + ReadWidth; + ReadPrec; + ReadFormat:=Upcase(Fmt[ChPos]); +{$ifdef fmtdebug} + Log ('End format'); +{$endif} +end; + + +{$ifdef fmtdebug} +Procedure DumpFormat (C : char); +begin + Write ('Fmt : ',fmt:10); + Write (' Index : ',Index:3); + Write (' Left : ',left:5); + Write (' Width : ',Width:3); + Write (' Prec : ',prec:3); + Writeln (' Type : ',C); +end; +{$endif} + + +function Checkarg (AT : Longint;err:boolean):boolean; +{ + Check if argument INDEX is of correct type (AT) + If Index=-1, ArgPos is used, and argpos is augmented with 1 + DoArg is set to the argument that must be used. +} +begin + result:=false; + if Index=-1 then + begin + DoArg:=Argpos; + inc(ArgPos); + end + else + DoArg:=Index; + If (Doarg>High(Args)) or (Args[Doarg].Vtype<>AT) then + begin + if err then + DoFormatError(feInvalidArgindex); + dec(ArgPos); + exit; + end; + result:=true; +end; + +Const Zero = '000000000000000000000000000000000000000000000000000000000000000'; + +begin + Result:=''; + Len:=Length(Fmt); + Chpos:=1; + OldPos:=1; + ArgPos:=0; + While chpos<=len do + begin + While (ChPos<=Len) and (Fmt[chpos]<>'%') do + inc(chpos); + If ChPos>OldPos Then + Result:=Result+Copy(Fmt,OldPos,Chpos-Oldpos); + If ChPos64 then Index:=64; + ToAdd:=Copy(Zero,1,Index)+ToAdd; + end; + end; + 'E' : begin + CheckArg(vtExtended,true); + ToAdd:=FloatToStrF(Args[doarg].VExtended^,ffexponent,Prec,3); + end; + 'F' : begin + CheckArg(vtExtended,true); + ToAdd:=FloatToStrF(Args[doarg].VExtended^,ffFixed,9999,Prec); + end; + 'G' : begin + CheckArg(vtExtended,true); + ToAdd:=FloatToStrF(Args[doarg].VExtended^,ffGeneral,Prec,3); + end; + 'N' : begin + CheckArg(vtExtended,true); + ToAdd:=FloatToStrF(Args[doarg].VExtended^,ffNumber,9999,Prec); + end; + 'M' : begin + CheckArg(vtExtended,true); + ToAdd:=FloatToStrF(Args[doarg].VExtended^,ffCurrency,9999,Prec); + end; + 'S' : begin + if CheckArg(vtString,false) then + hs:=Args[doarg].VString^ + else + if CheckArg(vtChar,false) then + hs:=Args[doarg].VChar + else + if CheckArg(vtPChar,false) then + hs:=Args[doarg].VPChar + else + if CheckArg(vtAnsiString,true) then + hs:=ansistring(Args[doarg].VAnsiString); + Index:=Length(hs); + If (Prec<>-1) and (Index>Prec) then + Index:=Prec; + ToAdd:=Copy(hs,1,Index); + end; + 'P' : Begin + CheckArg(vtpointer,true); + ToAdd:=HexStr(Longint(Args[DoArg].VPointer),8); + // Insert ':'. Is this needed in 32 bit ? No it isn't. + // Insert(':',ToAdd,5); + end; + 'X' : begin + Checkarg(vtinteger,true); + If Prec>15 then + ToAdd:=HexStr(Args[Doarg].VInteger,15) + else + begin + // determine minimum needed number of hex digits. + Index:=1; + While (DWord(1 shl (Index*4))<=DWord(Args[DoArg].VInteger)) and (index<8) do + inc(Index); + If Index>Prec then + Prec:=Index; + ToAdd:=HexStr(Args[DoArg].VInteger,Prec); + end; + end; + '%': ToAdd:='%'; + end; + If Width<>-1 then + If Length(ToAdd)Buflen then + Result:=Length(S) + else + Result:=Buflen; + Move(S[1],Buffer,Result); +end; + +Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const); + +begin + Res:=Format(fmt,Args); +end; + +Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar; + +begin + Buffer[FormatBuf(Buffer^,Maxint,Fmt^,strlen(fmt),args)]:=#0; + Result:=Buffer; +end; + +Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar; + +begin + Buffer[FormatBuf(Buffer^,MaxLen,Fmt^,strlen(fmt),args)]:=#0; + Result:=Buffer; +end; + + +function StrToFloat(Value: string): Extended; + +var Error: word; + +begin + Val(Value, result, Error); + if Error <> 0 then raise + EConvertError.createfmt(SInValidFLoat,[Value]); +end ; + +Function FloatToStr(Value: Extended): String; +Begin + Result := FloatToStrF(Value, ffGeneral, 15, 0); +End; + +Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint; +Var + Tmp: String[40]; +Begin + Tmp := FloatToStrF(Value, format, Precision, Digits); + Result := Length(Tmp); + Move(Tmp[1], Buffer[0], Result); +End; + + +Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String; +Var + P: Integer; + Negative, TooSmall, TooLarge: Boolean; + + +Begin + Case format Of + + ffGeneral: + + Begin + If (Precision = -1) Or (Precision > 15) Then Precision := 15; + TooSmall := (Abs(Value) < 0.00001) and (Value>0.0); + If Not TooSmall Then + Begin + Str(Value:0:999, Result); + P := Pos('.', Result); + Result[P] := DecimalSeparator; + TooLarge := P > Precision + 1; + End; + + If TooSmall Or TooLarge Then + begin + Result := FloatToStrF(Value, ffExponent, Precision, Digits); + // Strip unneeded zeroes. + P:=Pos('E',result)-1; + If P<>-1 then + While (P>1) and (Result[P]='0') do + begin + system.Delete(Result,P,1); + Dec(P); + end; + end + else + begin + P := Length(Result); + While Result[P] = '0' Do Dec(P); + If Result[P] = DecimalSeparator Then Dec(P); + SetLength(Result, P); + end; + End; + + ffExponent: + + Begin + If (Precision = -1) Or (Precision > 15) Then Precision := 15; + Str(Value:Precision + 8, Result); + Result[3] := DecimalSeparator; + P:=4; + While (P>0) and (Digits < P) And (Result[Precision + 5] = '0') do + Begin + If P<>1 then + system.Delete(Result, Precision + 5, 1) + else + system.Delete(Result, Precision + 3, 3); + Dec(P); + end; + If Result[1] = ' ' Then + System.Delete(Result, 1, 1); + End; + + ffFixed: + + Begin + If Digits = -1 Then Digits := 2 + Else If Digits > 15 Then Digits := 15; + Str(Value:0:Digits, Result); + If Result[1] = ' ' Then + System.Delete(Result, 1, 1); + P := Pos('.', Result); + If P <> 0 Then Result[P] := DecimalSeparator; + End; + + ffNumber: + + Begin + If Digits = -1 Then Digits := 2 + Else If Digits > 15 Then Digits := 15; + Str(Value:0:Digits, Result); + If Result[1] = ' ' Then System.Delete(Result, 1, 1); + P := Pos('.', Result); + If P <> 0 Then Result[P] := DecimalSeparator; + Dec(P, 3); + While (P > 1) Do + Begin + If Result[P - 1] <> '-' Then Insert(ThousandSeparator, Result, P); + Dec(P, 3); + End; + End; + + ffCurrency: + + Begin + If Value < 0 Then + Begin + Negative := True; + Value := -Value; + End + Else Negative := False; + + If Digits = -1 Then Digits := CurrencyDecimals + Else If Digits > 18 Then Digits := 18; + Str(Value:0:Digits, Result); + If Result[1] = ' ' Then System.Delete(Result, 1, 1); + P := Pos('.', Result); + If P <> 0 Then Result[P] := DecimalSeparator; + Dec(P, 3); + While (P > 1) Do + Begin + Insert(ThousandSeparator, Result, P); + Dec(P, 3); + End; + + If Not Negative Then + Begin + Case CurrencyFormat Of + 0: Result := CurrencyString + Result; + 1: Result := Result + CurrencyString; + 2: Result := CurrencyString + ' ' + Result; + 3: Result := Result + ' ' + CurrencyString; + End + End + Else + Begin + Case NegCurrFormat Of + 0: Result := '(' + CurrencyString + Result + ')'; + 1: Result := '-' + CurrencyString + Result; + 2: Result := CurrencyString + '-' + Result; + 3: Result := CurrencyString + Result + '-'; + 4: Result := '(' + Result + CurrencyString + ')'; + 5: Result := '-' + Result + CurrencyString; + 6: Result := Result + '-' + CurrencyString; + 7: Result := Result + CurrencyString + '-'; + 8: Result := '-' + Result + ' ' + CurrencyString; + 9: Result := '-' + CurrencyString + ' ' + Result; + 10: Result := CurrencyString + ' ' + Result + '-'; + End; + End; + End; + End; +End; + +{==============================================================================} +{ extra functions } +{==============================================================================} + +{ LeftStr returns Count left-most characters from S } + +function LeftStr(const S: string; Count: integer): string; +begin + result := Copy(S, 1, Count); +end ; + +{ RightStr returns Count right-most characters from S } + +function RightStr(const S: string; Count: integer): string; +begin + If Count>Length(S) then + Count:=Length(S); + result := Copy(S, 1 + Length(S) - Count, Count); +end; + +{ BCDToInt converts the BCD value Value to an integer } + +function BCDToInt(Value: integer): integer; +var i, j: integer; +begin +result := 0; +j := 1; +for i := 0 to SizeOf(Value) shr 1 - 1 do begin + result := result + j * (Value and 15); + j := j * 10; + Value := Value shr 4; + end ; +end ; + +{ + Case Translation Tables + Can be used in internationalization support. + + Although these tables can be obtained through system calls + it is better to not use those, since most implementation are not 100% + WARNING: + before modifying a translation table make sure that the current codepage + of the OS corresponds to the one you make changes to +} + +const + { upper case translation table for character set 850 } + CP850UCT: array[128..255] of char = + ('', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', 'Y', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', ''); + + { lower case translation table for character set 850 } + CP850LCT: array[128..255] of char = + ('', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', + '', '', '', '', '', '', '', '', '', '', '', '', '', '', '', ''); + + { upper case translation table for character set ISO 8859/1 Latin 1 } + CPISO88591UCT: array[192..255] of char = + ( #192, #193, #194, #195, #196, #197, #198, #199, + #200, #201, #202, #203, #204, #205, #206, #207, + #208, #209, #210, #211, #212, #213, #214, #215, + #216, #217, #218, #219, #220, #221, #222, #223, + #192, #193, #194, #195, #196, #197, #198, #199, + #200, #201, #202, #203, #204, #205, #206, #207, + #208, #209, #210, #211, #212, #213, #214, #247, + #216, #217, #218, #219, #220, #221, #222, #89 ); + + { lower case translation table for character set ISO 8859/1 Latin 1 } + CPISO88591LCT: array[192..255] of char = + ( #224, #225, #226, #227, #228, #229, #230, #231, + #232, #233, #234, #235, #236, #237, #238, #239, + #240, #241, #242, #243, #244, #245, #246, #215, + #248, #249, #250, #251, #252, #253, #254, #223, + #224, #225, #226, #227, #228, #229, #230, #231, + #232, #233, #234, #235, #236, #237, #238, #239, + #240, #241, #242, #243, #244, #245, #246, #247, + #248, #249, #250, #251, #252, #253, #254, #255 ); + +{ + $Log: not supported by cvs2svn $ + Revision 1.35 2000/07/04 17:12:46 peter + * fixed hex printing for $10 with %x + + Revision 1.34 2000/05/08 17:03:02 sg + * Changed CompareMem to CompareMemRange and added new (Delphi compatible) + CompareMem. (CompareMem needs a Boolean as result type, not Integer) + + Revision 1.33 2000/05/08 13:26:42 peter + * vtchar support for %s + * define debug -> define fmtdebug + + Revision 1.32 2000/04/03 06:40:37 michael + * TRim(right|Left) more Delphi compatible + + Revision 1.31 2000/02/09 16:59:33 peter + * truncated log + + Revision 1.30 2000/02/01 12:53:23 peter + * fixed rangecheck error in format() + + Revision 1.29 1999/11/06 14:41:31 peter + * truncated log + + Revision 1.28 1999/10/12 19:16:27 florian + * bug 645 fixed: format('%x',...) should writes unsigned hexadecimals, also + prec fixed: max. value in delphi is 15 (and not 32) + + Revision 1.27 1999/10/03 19:42:40 peter + * fixed comparetext + + Revision 1.26 1999/09/04 20:48:34 florian + * format('%g',[0.0]) returned long format string, fixed + + Revision 1.25 1999/08/25 13:13:58 michael + fixed Formaterror, added missing raise + + Revision 1.24 1999/08/16 22:38:53 peter + * fixed newstr/disposestr + +} + diff --git a/befpc/rtl/objpas/sysstrh.inc b/befpc/rtl/objpas/sysstrh.inc new file mode 100644 index 0000000..9542dde --- /dev/null +++ b/befpc/rtl/objpas/sysstrh.inc @@ -0,0 +1,105 @@ +{ + ********************************************************************* + $Id: sysstrh.inc,v 1.1.1.1 2001-07-23 17:17:43 memson Exp $ + Copyright (C) 1997, 1998 Gertjan Schouten + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ********************************************************************* + + System Utilities For Free Pascal +} + +{==============================================================================} +{ standard functions } +{==============================================================================} + +type + PString = ^String; + + { For FloatToText } + TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency); + + +function NewStr(const S: string): PString; +procedure DisposeStr(S: PString); +procedure AssignStr(var P: PString; const S: string); +procedure AppendStr(var Dest: String; const S: string); +function UpperCase(const s: string): string; +function LowerCase(const s: string): string; +function CompareStr(const S1, S2: string): Integer; +function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer; +function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean; +function CompareText(const S1, S2: string): integer; + +function AnsiUpperCase(const s: string): string; +function AnsiLowerCase(const s: string): string; +function AnsiCompareStr(const S1, S2: string): integer; +function AnsiCompareText(const S1, S2: string): integer; +function AnsiStrComp(S1, S2: PChar): integer; +function AnsiStrIComp(S1, S2: PChar): integer; +function AnsiStrLComp(S1, S2: PChar; MaxLen: cardinal): integer; +function AnsiStrLIComp(S1, S2: PChar; MaxLen: cardinal): integer; +function AnsiStrLower(Str: PChar): PChar; +function AnsiStrUpper(Str: PChar): PChar; +function AnsiLastChar(const S: string): PChar; +function AnsiStrLastChar(Str: PChar): PChar; + +function Trim(const S: string): string; +function TrimLeft(const S: string): string; +function TrimRight(const S: string): string; +function QuotedStr(const S: string): string; +function AnsiQuotedStr(const S: string; Quote: char): string; +function AnsiExtractQuotedStr(Const Src: PChar; Quote: Char): string; +function AdjustLineBreaks(const S: string): string; +function IsValidIdent(const Ident: string): boolean; +function IntToStr(Value: integer): string; +// function IntToStr(Value: Int64): string; +function IntToHex(Value: integer; Digits: integer): string; +// function IntToHex(Value: Int64; Digits: integer): string; +function StrToInt(const s: string): integer; +// function StrToInt64(const s: string): int64; +function StrToIntDef(const S: string; Default: integer): integer; +// function StrToInt64Def(const S: string; Default: int64): int64; +function LoadStr(Ident: integer): string; +// function FmtLoadStr(Ident: integer; const Args: array of const): string; +Function Format (Const Fmt : String; const Args : Array of const) : String; +Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal; Const Args : Array of const) : Cardinal; +Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar; +Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar; +Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const); +Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String; +Function FloatToStr(Value: Extended): String; +Function StrToFloat(Value : String) : Extended; +Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint; + +{==============================================================================} +{ extra functions } +{==============================================================================} + +function LeftStr(const S: string; Count: integer): string; +function RightStr(const S: string; Count: integer): string; +function BCDToInt(Value: integer): integer; + +{ + $Log: not supported by cvs2svn $ + Revision 1.10 2000/05/08 17:03:02 sg + * Changed CompareMem to CompareMemRange and added new (Delphi compatible) + CompareMem. (CompareMem needs a Boolean as result type, not Integer) + + Revision 1.9 2000/02/09 16:59:33 peter + * truncated log + +} + diff --git a/befpc/rtl/objpas/sysutils.pp b/befpc/rtl/objpas/sysutils.pp new file mode 100644 index 0000000..06bc5fb --- /dev/null +++ b/befpc/rtl/objpas/sysutils.pp @@ -0,0 +1,458 @@ +{ + $Id: sysutils.pp,v 1.1.1.1 2001-07-23 17:17:43 memson Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + 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 sysutils; +interface + +{$MODE objfpc} +{ force ansistrings } +{$H+} + + uses + {$ifdef linux} + linux + {$endif} + {$ifdef win32} + dos,windows + {$endif} + {$ifdef go32v1} + go32,dos + {$endif} + {$ifdef go32v2} + go32,dos + {$endif} + {$ifdef os2} + doscalls,dos + {$endif} + ; + + +type + { some helpful data types } + + tprocedure = procedure; + + tfilename = string; + + tsyscharset = set of char; + + longrec = packed record + lo,hi : word; + end; + + wordrec = packed record + lo,hi : byte; + end; + + TMethod = packed record + Code, Data: Pointer; + end; + + + { exceptions } + exception = class(TObject) + private + fmessage : string; + fhelpcontext : longint; + public + constructor create(const msg : string); + constructor createfmt(const msg : string; const args : array of const); + constructor createres(ident : longint); + { !!!! } + property helpcontext : longint read fhelpcontext write fhelpcontext; + property message : string read fmessage write fmessage; + end; + + exceptclass = class of exception; + + { integer math exceptions } + EInterror = Class(Exception); + EDivByZero = Class(EIntError); + ERangeError = Class(EIntError); + EIntOverflow = Class(EIntError); + + { General math errors } + EMathError = Class(Exception); + EInvalidOp = Class(EMathError); + EZeroDivide = Class(EMathError); + EOverflow = Class(EMathError); + EUnderflow = Class(EMathError); + + { Run-time and I/O Errors } + EInOutError = class(Exception) + public + ErrorCode : Longint; + end; + EInvalidPointer = Class(Exception); + EOutOfMemory = Class(Exception); + EAccessViolation = Class(Exception); + EInvalidCast = Class(Exception); + + + { String conversion errors } + EConvertError = class(Exception); + + { Other errors } + EAbort = Class(Exception); + EAbstractError = Class(Exception); + EAssertionFailed = Class(Exception); + + { Exception handling routines } + function ExceptObject: TObject; + function ExceptAddr: Pointer; + function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + procedure Abort; + procedure OutOfMemoryError; + procedure Beep; + +Var + OnShowException : Procedure (Msg : ShortString); + + { FileRec/TextRec } + {$i filerec.inc} + {$i textrec.inc} + + { Read internationalization settings } + {$i sysinth.inc} + + { Read date & Time function declarations } + {$i datih.inc} + + { Read String Handling functions declaration } + {$i sysstrh.inc} + + { Read pchar handling functions declration } + {$i syspchh.inc} + + { Read filename handling functions declaration } + {$i finah.inc} + + { Read other file handling function declarations } + {$i filutilh.inc} + + { Read disk function declarations } + {$i diskh.inc} + + implementation + + { Read message string definitions } + { + Add a language with IFDEF LANG_NAME + just befor the final ELSE. This way English will always be the default. + } + + {$IFDEF LANG_GERMAN} + {$i strg.inc} // Does not exist yet !! + {$ELSE} + {$i stre.inc} + {$ENDIF} + + { Read filename handling functions implementation } + {$i fina.inc} + + { Read String Handling functions implementation } + {$i sysstr.inc} + + { Read other file handling function implementations } + {$i filutil.inc} + + { Read disk function implementations } + {$i disk.inc} + + { Read date & Time function implementations } + {$i dati.inc} + + { Read pchar handling functions implementation } + {$i syspch.inc} + + + constructor exception.create(const msg : string); + + begin + inherited create; + fmessage:=msg; + end; + + + constructor exception.createfmt(const msg : string; const args : array of const); + + begin + inherited create; + fmessage:=Format(msg,args); + end; + + + constructor exception.createres(ident : longint); + + begin + inherited create; + {!!!!!} + end; + + +{$ifopt S+} +{$define STACKCHECK_WAS_ON} +{$S-} +{$endif OPT S } +Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer); +Var + Message : String; +begin + Writeln(stdout,'An unhandled exception occurred at 0x',HexStr(Longint(Addr),8),' :'); + if Obj is exception then + begin + Message:=Exception(Obj).Message; + Writeln(stdout,Message); + end + else + Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.'); + { to get a nice symify } + Writeln(stdout,BackTraceStrFunc(Longint(Addr))); + Dump_Stack(stdout,longint(frame)); + Writeln(stdout,''); + Halt(217); +end; + + +Var OutOfMemory : EOutOfMemory; + InValidPointer : EInvalidPointer; + + +Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer); + +Var E : Exception; + S : String; + +begin + Case Errno of + 1,203 : E:=OutOfMemory; + 204 : E:=InvalidPointer; + 2,3,4,5,6,100,101,102,103,105,106 : { I/O errors } + begin + Case Errno of + 2 : S:=SFileNotFound; + 3 : S:=SInvalidFileName; + 4 : S:=STooManyOpenFiles; + 5 : S:=SAccessDenied; + 6 : S:=SInvalidFileHandle; + 15 : S:=SInvalidDrive; + 100 : S:=SEndOfFile; + 101 : S:=SDiskFull; + 102 : S:=SFileNotAssigned; + 103 : S:=SFileNotOpen; + 104 : S:=SFileNotOpenForInput; + 105 : S:=SFileNotOpenForOutput; + 106 : S:=SInvalidInput; + end; + E:=EinOutError.Create (S); + EInoutError(E).ErrorCode:=IOresult; // Clears InOutRes !! + end; + // We don't set abstracterrorhandler, but we do it here. + // Unless the use sets another handler we'll get here anyway... + 200 : E:=EDivByZero.Create(SDivByZero); + 201 : E:=ERangeError.Create(SRangeError); + 205 : E:=EOverflow.Create(SOverflow); + 206 : E:=EOverflow.Create(SUnderflow); + 207 : E:=EInvalidOp.Create(SInvalidOp); + 211 : E:=EAbstractError.Create(SAbstractError); + 215 : E:=EIntOverflow.Create(SIntOverflow); + 216 : E:=EAccessViolation.Create(SAccessViolation); + 219 : E:=EInvalidCast.Create(SInvalidCast); + 227 : E:=EAssertionFailed.Create(SAssertionFailed); + else + E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]); + end; + Raise E at longint(Address){$ifdef ENHANCEDRAISE},longint(Frame){$endif}; +end; + + +Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo,TheAddr : Longint); +Var + S : String; +begin + If Msg='' then + S:=SAssertionFailed + else + S:=Msg; + Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]); // at Pointer(theAddr); +end; + +{$ifdef STACKCHECK_WAS_ON} +{$S+} +{$endif} + +Procedure InitExceptions; +{ + Must install uncaught exception handler (ExceptProc) + and install exceptions for system exceptions or signals. + (e.g: SIGSEGV -> ESegFault or so.) +} +begin + ExceptProc:=@CatchUnhandledException; + // Create objects that may have problems when there is no memory. + OutOfMemory:=EOutOfMemory.Create(SOutOfMemory); + InvalidPointer:=EInvalidPointer.Create(SInvalidPointer); + AssertErrorProc:=@AssertErrorHandler; + ErrorProc:=@RunErrorToExcept; + OnShowException:=Nil; +end; + +{ Exception handling routines } + +function ExceptObject: TObject; + +begin + If RaiseList=Nil then + Result:=Nil + else + Result:=RaiseList^.FObject; +end; + +function ExceptAddr: Pointer; + +begin + If RaiseList=Nil then + Result:=Nil + else + Result:=RaiseList^.Addr; +end; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + +Var + S : AnsiString; + Len : Integer; + +begin + S:=Format(SExceptionErrorMessage,[ExceptObject.ClassName,ExceptAddr]); + If ExceptObject is Exception then + S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]); + Len:=Length(S); + If S[Len]<>'.' then + begin + S:=S+'.'; + Inc(len); + end; + If Len>Size then + Len:=Size; + Move(S[1],Buffer^,Len); + Result:=Len; +end; + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + +// use shortstring. On exception, the heap may be corrupt. + +Var + Buf : ShortString; + +begin + SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255)); + If IsConsole Then + writeln(Buf) + else + If Assigned(OnShowException) Then + OnShowException (Buf); +end; + +procedure Abort; + +begin + Raise EAbort.Create(SAbortError) at Get_Caller_addr(Get_Frame) +end; + +procedure OutOfMemoryError; + +begin + Raise OutOfMemory; +end; + +procedure Beep; + +begin + {$ifdef win32} + MessageBeep(0); + {$else} + + {$endif} +end; + +{ Initialization code. } + +Initialization + InitExceptions; { Initialize exceptions. OS independent } + InitInternational; { Initialize internationalization settings } +Finalization + OutOfMemory.Free; + InValidPointer.Free; +end. +{ + $Log: not supported by cvs2svn $ + Revision 1.47 2000/06/22 18:05:18 michael + + Added ExceptObject, ExceptAddr,ExceptionErrorMessage + ShowException Abort; OutOfMemoryError; Beep; + + Revision 1.46 2000/06/11 07:07:23 peter + + TSysCharSet + + Revision 1.45 2000/04/24 13:34:29 peter + * added enhancedraise define + + Revision 1.43 2000/03/30 13:54:15 pierre + No stack check inside CatchUnhandledException + + Revision 1.42 2000/02/10 22:56:43 florian + * quick hack for stack trace in the case of an unhandled exception + + Revision 1.41 2000/02/09 16:59:33 peter + * truncated log + + Revision 1.40 2000/01/16 19:10:25 hajny + * 'uses Dos' added for OS/2 target + + Revision 1.39 2000/01/07 16:41:44 daniel + * copyright 2000 + + Revision 1.38 1999/12/26 19:30:53 hajny + * OS/2 target added to the uses clause + + Revision 1.36 1999/11/15 21:49:47 peter + * exception address fixes + + Revision 1.35 1999/11/06 14:41:31 peter + * truncated log + + Revision 1.34 1999/10/30 17:39:05 peter + * memorymanager expanded with allocmem/reallocmem + + Revision 1.33 1999/10/26 12:29:07 peter + * assert handler must use shortstring + + Revision 1.32 1999/09/15 20:26:30 florian + * patch from Sebastian Guenther applied: TMethod implementation + + Revision 1.31 1999/08/28 14:53:27 florian + * bug 471 fixed: run time error 2 is now converted into a file not + found exception + + Revision 1.30 1999/08/18 11:28:24 michael + * Fixed reallocmem bug 535 + + Revision 1.29 1999/07/27 13:01:12 peter + + filerec,textrec declarations + +} \ No newline at end of file diff --git a/befpc/rtl/objpas/typinfo.pp b/befpc/rtl/objpas/typinfo.pp new file mode 100644 index 0000000..2c6a3cf --- /dev/null +++ b/befpc/rtl/objpas/typinfo.pp @@ -0,0 +1,930 @@ +{ + $Id: typinfo.pp,v 1.1.1.1 2001-07-23 17:17:43 memson Exp $ + This file is part of the Free Pascal run time library. + + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + 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. + + **********************************************************************} + +{ This unit provides the same functionality as the TypInfo Unit } +{ of Delphi } + +unit typinfo; + + interface + +{$MODE objfpc} + + uses sysutils; + + +// temporary types: + + type + PShortString =^ShortString; + PByte =^Byte; + PWord =^Word; + PLongint =^Longint; + PBoolean =^Boolean; + PSingle =^Single; + PDouble =^Double; + PExtended =^Extended; + PComp =^Comp; +{$ifdef HASFIXED} + PFixed16 =^Fixed16; +{$endif HASFIXED} + { Doesn't exist ? + PFIxed32 = ^Fixed32; + } + Variant = Pointer; + +{$MINENUMSIZE 1 this saves a lot of memory } + // if you change one of the following enumeration types + // you have also to change the compiler in an appropriate way ! + TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration, + tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString, + tkWString,tkVariant,tkArray,tkRecord,tkInterface, + tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord); + + TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong); + + TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr, + ftFixed16,ftFixed32); + TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor, + mkClassProcedure, mkClassFunction); + TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut); + TIntfFlags = set of (ifHasGuid,ifDispInterface,ifDispatch); + +{$MINENUMSIZE DEFAULT} + + const + ptField = 0; + ptStatic = 1; + ptVirtual = 2; + ptConst = 3; + + tkString = tkSString; + + type + TTypeKinds = set of TTypeKind; + +{$PACKRECORDS 1} + TTypeInfo = record + Kind : TTypeKind; + Name : ShortString; + // here the type data follows as TTypeData record + end; + + PTypeInfo = ^TTypeInfo; + PPTypeInfo = ^PTypeInfo; + + PTypeData = ^TTypeData; + TTypeData = packed record + case TTypeKind of + tkUnKnown,tkLString,tkWString,tkAString,tkVariant: + (); + tkInteger,tkChar,tkEnumeration,tkWChar: + (OrdType : TTOrdType; + case TTypeKind of + tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : ( + MinValue,MaxValue : Longint; + case TTypeKind of + tkEnumeration: + ( + BaseType : PTypeInfo; + NameList : ShortString) + ); + tkSet: + (CompType : PTypeInfo) + ); + tkFloat: + (FloatType : TFloatType); + tkSString: + (MaxLength : Byte); + tkClass: + (ClassType : TClass; + ParentInfo : PTypeInfo; + PropCount : SmallInt; + UnitName : ShortString + // here the properties follow as array of TPropInfo + ); + tkMethod: + (MethodKind : TMethodKind; + ParamCount : Byte; + ParamList : array[0..1023] of Char + {in reality ParamList is a array[1..ParamCount] of: + record + Flags : TParamFlags; + ParamName : ShortString; + TypeName : ShortString; + end; + followed by + ResultType : ShortString} + ); + tkInt64: + (MinInt64Value, MaxInt64Value: Int64); + tkQWord: + (MinQWordValue, MaxQWordValue: QWord); + tkInterface: + ({!!!!!!!} + ); + end; + + // unsed, just for completeness + TPropData = packed record + PropCount : Word; + PropList : record end; + end; + + PPropInfo = ^TPropInfo; + TPropInfo = packed record + PropType : PTypeInfo; + GetProc : Pointer; + SetProc : Pointer; + StoredProc : Pointer; + Index : Integer; + Default : Longint; + NameIndex : SmallInt; + + // contains the type of the Get/Set/Storedproc, see also ptxxx + // bit 0..1 GetProc + // 2..3 SetProc + // 4..5 StoredProc + // 6 : true, constant index property + PropProcs : Byte; + + Name : ShortString; + end; + + TProcInfoProc = procedure(PropInfo : PPropInfo) of object; + + PPropList = ^TPropList; + TPropList = array[0..65535] of PPropInfo; + + const + tkAny = [Low(TTypeKind)..High(TTypeKind)]; + tkMethods = [tkMethod]; + tkProperties = tkAny-tkMethods-[tkUnknown]; + + { general property handling } + // just skips the id and the name + function GetTypeData(TypeInfo : PTypeInfo) : PTypeData; + + // searches in the property PropName + function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo; + procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList); + function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; + PropList : PPropList) : Integer; + + // returns true, if PropInfo is a stored property + function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean; + + { subroutines to read/write properties } + function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint; + procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo; + Value : Longint); + + function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring; + procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo; + const Value : Ansistring); + + function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended; + procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo; + Value : Extended); + + function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant; + procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; + const Value: Variant); + + function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod; + procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo; + const Value : TMethod); + + function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64; + procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo; + const Value: Int64); + + { misc. stuff } + function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string; + function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer; + + + const + BooleanIdents: array[Boolean] of String = ('False', 'True'); + DotSep: String = '.'; + + + implementation + + type + + PMethod = ^TMethod; + + +{$ASMMODE ATT} + + function CallIntegerFunc(s: Pointer; Address: Pointer; Index, IValue: LongInt): Int64; assembler; + asm + movl S,%esi + movl Address,%edi + // ? Indexed function + movl Index,%eax + testl %eax,%eax + je .LINoPush + movl IValue,%eax + pushl %eax + .LINoPush: + push %esi + call %edi + // now the result is in EDX:EAX + end; + + function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IValue : Longint) : Integer;assembler; + asm + movl S,%esi + movl Address,%edi + // Push value to set + movl Value,%eax + pushl %eax + // ? Indexed procedure + movl Index,%eax + testl %eax,%eax + je .LIPNoPush + movl IValue,%eax + pushl %eax + .LIPNoPush: + pushl %esi + call %edi + end; + + function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler; + asm + movl S,%esi + movl Address,%edi + // ? Indexed function + movl Index,%eax + testl %eax,%eax + je .LINoPush + movl IValue,%eax + pushl %eax + .LINoPush: + push %esi + call %edi + // + end; + + function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler; + asm + movl S,%esi + movl Address,%edi + // Push value to set + leal Value,%eax + pushl (%eax) + pushl 4(%eax) + pushl 8(%eax) + // ? Indexed procedure + movl Index,%eax + testl %eax,%eax + je .LIPNoPush + movl IValue,%eax + pushl %eax + .LIPNoPush: + push %esi + call %edi + end; + + function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler; + asm + movl S,%esi + movl Address,%edi + // ? Indexed function + movl Index,%eax + testl %eax,%eax + je .LBNoPush + movl IValue,%eax + pushl %eax + .LBNoPush: + push %esi + call %edi + end; + + // Assembler functions can't have short stringreturn values. + // So we make a procedure with var parameter. + // That's not true (FK) + + Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint; + Var Res: Shortstring);assembler; + asm + movl S,%esi + movl Address,%edi + // ? Indexed function + movl Index,%eax + testl %eax,%eax + jnz .LSSNoPush + movl IValue,%eax + pushl %eax + // the result is stored in an invisible parameter + pushl Res + .LSSNoPush: + push %esi + call %edi + end; + + Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortString; INdex,IVAlue : Longint);assembler; + asm + movl S,%esi + movl Address,%edi + // Push value to set + movl Value,%eax + pushl %eax + // ? Indexed procedure + movl Index,%eax + testl %eax,%eax + jnz .LSSPNoPush + movl IValue,%eax + pushl %eax + .LSSPNoPush: + push %esi + call %edi + end; + + function GetTypeData(TypeInfo : PTypeInfo) : PTypeData; + + begin + GetTypeData:=PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^); + end; + + function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo; + + var + hp : PTypeData; + i : longint; + p : string; + + begin + P:=UpCase(PropName); + while Assigned(TypeInfo) do + begin + // skip the name + hp:=GetTypeData(Typeinfo); + + // the class info rtti the property rtti follows + // immediatly + Result:=PPropInfo(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1+SizeOF(Word)); + for i:=1 to hp^.PropCount do + begin + // found a property of that name ? + if Upcase(Result^.Name)=P then + exit; + + // skip to next property + Result:=PPropInfo(pointer(@Result^.Name)+byte(Result^.Name[0])+1); + end; + // parent class + Typeinfo:=hp^.ParentInfo; + end; + Result:=Nil; + end; + + function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean; + + begin + case (PropInfo^.PropProcs shr 4) and 3 of + ptfield: + IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^; + ptstatic: + IsStoredProp:=CallBooleanFunc(Instance,PropInfo^.StoredProc,0,0); + ptvirtual: + IsStoredProp:=CallBooleanFunc(Instance,ppointer(Pointer(Instance.ClassType)+Longint(PropInfo^.StoredProc))^,0,0); + ptconst: + IsStoredProp:=LongBool(PropInfo^.StoredProc); + end; + end; + + procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList); + { + Store Pointers to property information in the list pointed + to by proplist. PRopList must contain enough space to hold ALL + properties. + } + Type PWord = ^Word; + + Var TD : PTypeData; + TP : PPropInfo; + Count : Longint; + + begin + TD:=GetTypeData(TypeInfo); + // Get this objects TOTAL published properties count + TP:=(@TD^.UnitName+Length(TD^.UnitName)+1); + Count:=PWord(TP)^; + // Now point TP to first propinfo record. + Inc(Longint(TP),SizeOF(Word)); + While Count>0 do + begin + PropList^[0]:=TP; + Inc(Longint(PropList),SizeOf(Pointer)); + // Point to TP next propinfo record. + // Located at Name[Length(Name)+1] ! + TP:=PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1); + Dec(Count); + end; + // recursive call for parent info. + If TD^.Parentinfo<>Nil then + GetPropInfos (TD^.ParentInfo,PropList); + end; + + Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint); + + VAr I : Longint; + + begin + I:=0; + While (IPL^[I]^.Name) do Inc(I); + If I0 then + begin + GetMem(TempList,Count*SizeOf(Pointer)); + Try + GetPropInfos(TypeInfo,TempList); + For I:=0 to Count-1 do + begin + PropInfo:=TempList^[i]; + If PropInfo^.PropType^.Kind in TypeKinds then + begin + InsertProp(PropList,PropInfo,Result); + Inc(Result); + end; + end; + finally + FreeMem(TempList,Count*SizeOf(Pointer)); + end; + end; + end; + + Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint); + + begin + Index:=((P^.PropProcs shr 6) and 1); + If Index<>0 then + IValue:=P^.Index + else + IValue:=0; + end; + + function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint; + + var + value,Index,Ivalue : longint; + TypeInfo: PTypeInfo; + + begin + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs) and 3 of + ptfield: + Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ptstatic: + Value:=CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue); + ptvirtual: + Value:=CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue); + end; + { cut off unnecessary stuff } + TypeInfo := PropInfo^.PropType; + case TypeInfo^.Kind of + tkChar, tkBool: + Value:=Value and $ff; + tkWChar: + Value:=Value and $ffff; + tkInteger: + case GetTypeData(TypeInfo)^.OrdType of + otSWord,otUWord: + Value:=Value and $ffff; + otSByte,otUByte: + Value:=Value and $ff; + end; + end; + GetOrdProp:=Value; + end; + + procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo; + Value : Longint); + + var + Index,IValue : Longint; + DataSize: Integer; + + begin + { cut off unnecessary stuff } + case GetTypeData(PropInfo^.PropType)^.OrdType of + otSWord,otUWord: begin + Value:=Value and $ffff; + DataSize := 2; + end; + otSByte,otUByte: begin + Value:=Value and $ff; + DataSize := 1; + end; + else DataSize := 4; + end; + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs shr 2) and 3 of + ptfield: + case DataSize of + 1: PByte(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Byte(Value); + 2: PWord(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Word(Value); + 4: PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + end; + ptstatic: + CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue); + ptvirtual: + CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue); + end; + end; + + Function GetAStrProp(Instance : TObject;PropInfo : PPropInfo):Pointer; + + { + Dirty trick based on fact that AnsiString is just a pointer, + hence can be treated like an integer type. + } + + var + value : Pointer; + Index,Ivalue : Longint; + + begin + SetIndexValues(PropInfo,Index,IValue); + case (PropInfo^.PropProcs) and 3 of + ptfield: + Value:=Pointer(PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^); + ptstatic: + Value:=Pointer(LongInt(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue))); + ptvirtual: + Value:=Pointer(LongInt(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue))); + end; + GetAstrProp:=Value; + end; + + Function GetSStrProp(Instance : TObject;PropInfo : PPropInfo):ShortString; + + var + value : ShortString; + Index,IValue : Longint; + + begin + SetIndexValues(PropInfo,Index,IValue); + case (PropInfo^.PropProcs) and 3 of + ptfield: + Value:=PShortString(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ptstatic: + CallSStringFunc(Instance,PropInfo^.GetProc,Index,IValue,Value); + ptvirtual: + CallSSTringFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,Ivalue,Value); + end; + GetSStrProp:=Value; + end; + + function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring; + + begin + Case Propinfo^.PropType^.Kind of + tkSString : Result:=GetSStrProp(Instance,PropInfo); + tkAString : Pointer(Result):=GetAStrProp(Instance,Propinfo); + else + Result:=''; + end; + end; + + procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo; + const Value : AnsiString); + + { + Dirty trick based on fact that AnsiString is just a pointer, + hence can be treated like an integer type. + } + var + s: AnsiString; + Index,Ivalue : Longint; + begin + { Another dirty trick which is necessary to increase the reference + counter of Value... } + s := Value; + Pointer(s) := nil; + + SetIndexValues(PropInfo,Index,IValue); + case (PropInfo^.PropProcs shr 2) and 3 of + ptfield: + PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Longint(Pointer(Value)) ; + ptstatic: + CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue); + ptvirtual: + CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Longint(Pointer(Value)),Index,IValue); + end; + end; + + procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo; + const Value : ShortString); + + Var Index,IValue: longint; + + begin + SetIndexValues(PRopInfo,Index,IValue); + case (PropInfo^.PropProcs shr 2) and 3 of + ptfield: + PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + ptstatic: + CallSStringProc(Instance,PropInfo^.GetProc,Value,Index,IValue); + ptvirtual: + CallSStringProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Value,Index,IValue); + end; + end; + + procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo; + const Value : AnsiString); + + begin + Case Propinfo^.PropType^.Kind of + tkSString : SetSStrProp(Instance,PropInfo,Value); + tkAString : SetAStrProp(Instance,Propinfo,Value); + end; + end; + + function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended; + + var + Index,Ivalue : longint; + Value : Extended; + + + begin + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs) and 3 of + ptfield: + Case GetTypeData(PropInfo^.PropType)^.FloatType of + ftSingle: + Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ftDouble: + Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ftExtended: + Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ftcomp: + Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + { Uncommenting this code results in a internal error!! + ftFixed16: + Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ftfixed32: + Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + } + end; + ptstatic: + Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue); + ptvirtual: + Value:=CallExtendedFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue); + end; + Result:=Value; + end; + + procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo; + Value : Extended); + + Var IValue,Index : longint; + + begin + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs shr 2) and 3 of + ptfield: + Case GetTypeData(PropInfo^.PropType)^.FloatType of + ftSingle: + PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + ftDouble: + PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + ftExtended: + PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + ftcomp: + PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value); + { Uncommenting this code results in a internal error!! + ftFixed16: + PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + ftfixed32: + PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value; + } + end; + ptstatic: + CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue); + ptvirtual: + CallExtendedProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Value,Index,IValue); + end; + end; + + function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant; + + begin + {!!!!!!!!!!!} + Result:=nil; + end; + + procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; + const Value: Variant); + + begin + {!!!!!!!!!!!} + end; + + function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod; + + var + value: PMethod; + Index,Ivalue : longint; + + begin + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs) and 3 of + ptfield: + Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc)); + ptstatic: + Value:=PMethod(LongInt(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue))); + ptvirtual: + Value:=PMethod(LongInt(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue))); + end; + GetMethodProp:=Value^; + end; + + procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo; + const Value : TMethod); + + var + Index,IValue : Longint; + + begin + SetIndexValues(PropInfo,Index,Ivalue); + case (PropInfo^.PropProcs shr 2) and 3 of + ptfield: + PMethod(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value; + ptstatic: + CallIntegerProc(Instance,PropInfo^.SetProc,Integer(@Value), Index, IValue); + ptvirtual: + CallIntegerProc(Instance, + PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^, + Integer(@Value), Index, IValue); + end; + end; + + function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64; + var + Index, IValue: LongInt; + begin + SetIndexValues(PropInfo,Index,Ivalue); + case PropInfo^.PropProcs and 3 of + ptfield: + Result := PInt64(Pointer(Instance)+Longint(PropInfo^.GetProc))^; + ptstatic: + Result := CallIntegerFunc(Instance, PropInfo^.GetProc, Index, IValue); + ptvirtual: + Result := CallIntegerFunc(Instance, + PPointer(Pointer(Instance.ClassType) + LongInt(PropInfo^.GetProc))^, + Index, IValue); + end; + end; + + procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo; + const Value: Int64); + begin + // !!!: Implement me! + end; + + function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string; + + Var PS : PShortString; + PT : PTypeData; + + begin + PT:=GetTypeData(TypeInfo); + // ^.BaseType); + // If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1} + PS:=@PT^.NameList; + While Value>0 Do + begin + PS:=PShortString(pointer(PS)+PByte(PS)^+1); + Dec(Value); + end; + Result:=PS^; + end; + + function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer; + + Var PS : PShortString; + PT : PTypeData; + Count : longint; + + begin + If Length(Name)=0 then exit(-1); + PT:=GetTypeData(TypeInfo); + Count:=0; + Result:=-1; + PS:=@PT^.NameList; + While (Result=-1) and (PByte(PS)^<>0) do + begin + If PS^=Name then + Result:=Count; + PS:=PShortString(pointer(PS)+PByte(PS)^); + Inc(Count); + end; + end; + +end. + +{ + $Log: not supported by cvs2svn $ + Revision 1.43 2000/06/29 08:47:13 sg + * Bugfix for SetAStrProp (reference counter hasn't been increased) + * Implemented GetInt64Prop + + Revision 1.42 2000/06/22 20:02:51 peter + * qword,int64 rtti support basics + + Revision 1.41 2000/06/22 15:31:09 sg + * Fixed a small typo in my previous update + + Revision 1.40 2000/06/22 15:29:31 sg + * Added prototypes for GetInt64Prop and SetInt64Prop + * Added constants "BooleanIdents" and "DotSep" + + Revision 1.39 2000/05/18 09:42:17 michael + + GetPropInfo now case insensitive + + Revision 1.38 2000/02/15 14:39:56 florian + * disabled FIXED data type per default + + Revision 1.37 2000/02/09 16:59:33 peter + * truncated log + + Revision 1.36 2000/01/07 16:41:44 daniel + * copyright 2000 + + Revision 1.35 2000/01/07 16:32:29 daniel + * copyright 2000 added + + Revision 1.34 2000/01/06 01:08:33 sg + * _This_ is the real revision 1.32... :-) + + Revision 1.33 2000/01/06 00:23:24 pierre + * missing declarations for otChar andotWChar added + + Revision 1.32 2000/01/05 18:59:56 sg + * Fixed missing () in InsertProp which caused memory corruptions + * GetOrdProp handles Char and WChar now. (there are still some + property types missing!) + + Revision 1.31 1999/12/28 12:19:36 jonas + * replaced "movl mem,%eax; xorl %eax,%eax" with "movl mem,%eax; + testl %eax,%eax" + + Revision 1.30 1999/11/06 14:41:31 peter + * truncated log + + Revision 1.29 1999/09/16 08:59:48 florian + * GetPropInfo returns now nil if the property wasn't found + + Revision 1.28 1999/09/15 20:27:24 florian + + patch of Sebastion Guenther applied: Get/SetMethodProp implementation + + Revision 1.27 1999/09/08 16:14:43 peter + * pointer fixes + + Revision 1.26 1999/09/03 15:39:23 michael + * Fixes from Sebastian Guenther + + Revision 1.25 1999/08/29 22:21:27 michael + * Patch from Sebastian Guenther + + Revision 1.24 1999/08/06 13:21:40 michael + * Patch from Sebastian Guenther + +} \ No newline at end of file