* First version as part of FCL

fcl/passrc/Makefile

@@ -0,0 +1,1240 @@
+#
+# Don't edit, this file is generated by FPCMake Version 1.1 [2003/03/13]
+#
+default: all
+MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx
+override PATH:=$(subst \,/,$(PATH))
+ifeq ($(findstring ;,$(PATH)),)
+inUnix=1
+SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
+else
+SEARCHPATH:=$(subst ;, ,$(PATH))
+endif
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
+ifeq ($(PWD),)
+$(error You need the GNU utils package to use this Makefile)
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=
+endif
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=.exe
+endif
+ifndef inUnix
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+else
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+else
+ifneq ($(findstring cygwin,$(MACHTYPE)),)
+inCygWin=1
+endif
+endif
+ifeq ($(OS_TARGET),freebsd)
+BSDhier=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+BSDhier=1
+endif
+ifeq ($(OS_TARGET),openbsd)
+BSDhier=1
+endif
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP:=$(subst /,\,/)
+ifdef inCygWin
+PATHSEP=/
+endif
+endif
+ifdef PWD
+BASEDIR:=$(subst \,/,$(shell $(PWD)))
+ifdef inCygWin
+ifneq ($(findstring /cygdrive/,$(BASEDIR)),)
+BASENODIR:=$(patsubst /cygdrive%,%,$(BASEDIR))
+BASEDRIVE:=$(firstword $(subst /, ,$(BASENODIR)))
+BASEDIR:=$(subst /cygdrive/$(BASEDRIVE)/,$(BASEDRIVE):/,$(BASEDIR))
+endif
+endif
+else
+BASEDIR=.
+endif
+ifdef inOS2
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+endif
+ifndef FPC
+ifdef PP
+FPC=$(PP)
+endif
+endif
+ifndef FPC
+FPCPROG:=$(strip $(wildcard $(addsuffix /fpc$(SRCEXEEXT),$(SEARCHPATH))))
+ifneq ($(FPCPROG),)
+FPCPROG:=$(firstword $(FPCPROG))
+FPC:=$(shell $(FPCPROG) -PB)
+ifneq ($(findstring Error,$(FPC)),)
+override FPC=ppc386
+endif
+else
+override FPC=ppc386
+endif
+endif
+override FPC:=$(subst $(SRCEXEEXT),,$(FPC))
+override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT)
+ifndef FPC_VERSION
+FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO)
+FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO))
+endif
+export FPC FPC_VERSION FPC_COMPILERINFO
+unexport CHECKDEPEND ALLDEPENDENCIES
+ifndef CPU_TARGET
+ifdef CPU_TARGET_DEFAULT
+CPU_TARGET=$(CPU_TARGET_DEFAULT)
+endif
+endif
+ifndef OS_TARGET
+ifdef OS_TARGET_DEFAULT
+OS_TARGET=$(OS_TARGET_DEFAULT)
+endif
+endif
+ifneq ($(words $(FPC_COMPILERINFO)),5)
+FPC_COMPILERINFO+=$(shell $(FPC) -iSP)
+FPC_COMPILERINFO+=$(shell $(FPC) -iTP)
+FPC_COMPILERINFO+=$(shell $(FPC) -iSO)
+FPC_COMPILERINFO+=$(shell $(FPC) -iTO)
+endif
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO))
+endif
+ifndef CPU_TARGET
+CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO))
+endif
+ifndef OS_SOURCE
+OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO))
+endif
+ifndef OS_TARGET
+OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
+endif
+FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
+FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
+ifneq ($(FULL_TARGET),$(FULL_SOURCE))
+CROSSCOMPILE=1
+endif
+ifeq ($(findstring makefile,$(MAKECMDGOALS)),)
+ifeq ($(findstring $(OS_TARGET),$(MAKEFILETARGETS)),)
+$(error The Makefile doesn't support target $(OS_TARGET), please run fpcmake first)
+endif
+endif
+export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE CROSSCOMPILE
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+ifdef DEFAULT_FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR:=$(subst \,/,$(DEFAULT_FPCDIR))
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=wrong
+endif
+endif
+endif
+ifeq ($(FPCDIR),wrong)
+ifdef inUnix
+override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION)
+ifeq ($(wildcard $(FPCDIR)/units),)
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+endif
+else
+override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH))))))
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=c:/pp
+endif
+endif
+endif
+endif
+ifndef CROSSDIR
+CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET)
+endif
+ifndef CROSSTARGETDIR
+CROSSTARGETDIR=$(CROSSDIR)/$(FULL_TARGET)
+endif
+ifdef CROSSCOMPILE
+UNITSDIR:=$(wildcard $(CROSSTARGETDIR)/units)
+ifeq ($(UNITSDIR),)
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
+endif
+else
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
+endif
+PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
+override PACKAGE_NAME=fcl
+override TARGET_UNITS+=pastree pscanner pparser paswrite
+override INSTALL_FPCPACKAGE=y
+override COMPILER_OPTIONS+=-S2h
+ifdef REQUIRE_UNITSDIR
+override UNITSDIR+=$(REQUIRE_UNITSDIR)
+endif
+ifdef REQUIRE_PACKAGESDIR
+override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR)
+endif
+ifdef ZIPINSTALL
+ifeq ($(OS_TARGET),linux)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),freebsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),openbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),sunos)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),qnx)
+UNIXINSTALLDIR=1
+endif
+else
+ifeq ($(OS_SOURCE),linux)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_SOURCE),freebsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_SOURCE),netbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_SOURCE),openbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),sunos)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),qnx)
+UNIXINSTALLDIR=1
+endif
+endif
+ifndef INSTALL_PREFIX
+ifdef PREFIX
+INSTALL_PREFIX=$(PREFIX)
+endif
+endif
+ifndef INSTALL_PREFIX
+ifdef UNIXINSTALLDIR
+INSTALL_PREFIX=/usr/local
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=/pp
+else
+INSTALL_BASEDIR:=/$(PACKAGE_NAME)
+endif
+endif
+endif
+export INSTALL_PREFIX
+ifdef INSTALL_FPCSUBDIR
+export INSTALL_FPCSUBDIR
+endif
+ifndef DIST_DESTDIR
+DIST_DESTDIR:=$(BASEDIR)
+endif
+export DIST_DESTDIR
+ifndef INSTALL_BASEDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION)
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/$(PACKAGE_NAME)
+endif
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)
+endif
+endif
+ifndef INSTALL_BINDIR
+ifdef UNIXINSTALLDIR
+INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
+else
+INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(OS_TARGET)
+endif
+endif
+endif
+ifndef INSTALL_UNITDIR
+ifdef CROSSCOMPILE
+INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/units
+else
+INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/units/$(OS_TARGET)
+endif
+ifdef INSTALL_FPCPACKAGE
+ifdef PACKAGE_NAME
+INSTALL_UNITDIR:=$(INSTALL_UNITDIR)/$(PACKAGE_NAME)
+endif
+endif
+endif
+ifndef INSTALL_LIBDIR
+ifdef UNIXINSTALLDIR
+INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib
+else
+INSTALL_LIBDIR:=$(INSTALL_UNITDIR)
+endif
+endif
+ifndef INSTALL_SOURCEDIR
+ifdef UNIXINSTALLDIR
+ifdef BSDhier
+SRCPREFIXDIR=share/src
+else
+SRCPREFIXDIR=src
+endif
+ifdef INSTALL_FPCPACKAGE
+ifdef INSTALL_FPCSUBDIR
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+endif
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+ifdef INSTALL_FPCSUBDIR
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(PACKAGE_NAME)
+endif
+else
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source
+endif
+endif
+endif
+ifndef INSTALL_DOCDIR
+ifdef UNIXINSTALLDIR
+ifdef BSDhier
+DOCPREFIXDIR=share/doc
+else
+DOCPREFIXDIR=doc
+endif
+ifdef INSTALL_FPCPACKAGE
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc
+endif
+endif
+endif
+ifndef INSTALL_EXAMPLEDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME)
+endif
+else
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples
+endif
+endif
+endif
+ifndef INSTALL_DATADIR
+INSTALL_DATADIR=$(INSTALL_BASEDIR)
+endif
+ifdef CROSSCOMPILE
+ifndef CROSSBINDIR
+CROSSBINDIR:=$(wildcard $(CROSSTARGETDIR)/bin/$(FULL_SOURCE))
+ifeq ($(CROSSBINDIR),)
+CROSSBINDIR:=$(wildcard $(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin/$(FULL_SOURCE))
+endif
+endif
+else
+CROSSBINDIR=
+endif
+LOADEREXT=.as
+EXEEXT=.exe
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+STATICLIBPREFIX=libp
+RSTEXT=.rst
+FPCMADE=fpcmade
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+STATICLIBPREFIX=
+FPCMADE=fpcmade.v1
+PACKAGESUFFIX=v1
+endif
+ifeq ($(OS_TARGET),go32v2)
+STATICLIBPREFIX=
+FPCMADE=fpcmade.dos
+ZIPSUFFIX=go32
+endif
+ifeq ($(OS_TARGET),linux)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.lnx
+ZIPSUFFIX=linux
+endif
+ifeq ($(OS_TARGET),freebsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.freebsd
+ZIPSUFFIX=freebsd
+endif
+ifeq ($(OS_TARGET),netbsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.netbsd
+ZIPSUFFIX=netbsd
+endif
+ifeq ($(OS_TARGET),openbsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.openbsd
+ZIPSUFFIX=openbsd
+endif
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+FPCMADE=fpcmade.w32
+ZIPSUFFIX=w32
+endif
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+AOUTEXT=.out
+SMARTEXT=.sl2
+STATICLIBPREFIX=
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+FPCMADE=fpcmade.os2
+ZIPSUFFIX=emx
+ECHO=echo
+endif
+ifeq ($(OS_TARGET),amiga)
+EXEEXT=
+PPUEXT=.ppu
+ASMEXT=.asm
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.library
+FPCMADE=fpcmade.amg
+endif
+ifeq ($(OS_TARGET),atari)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=.ttp
+FPCMADE=fpcmade.ata
+endif
+ifeq ($(OS_TARGET),beos)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.be
+ZIPSUFFIX=be
+endif
+ifeq ($(OS_TARGET),sunos)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.sun
+ZIPSUFFIX=sun
+endif
+ifeq ($(OS_TARGET),qnx)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.qnx
+ZIPSUFFIX=qnx
+endif
+ifeq ($(OS_TARGET),netware)
+STATICLIBPREFIX=
+PPUEXT=.ppn
+OEXT=.on
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.nlm
+FPCMADE=fpcmade.nw
+ZIPSUFFIX=nw
+EXEEXT=.nlm
+endif
+ifeq ($(OS_TARGET),macos)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.mcc
+endif
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO=
+else
+ECHO:=$(firstword $(ECHO))
+endif
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+ifndef GINSTALL
+GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL=
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+endif
+export GINSTALL
+ifndef CPPROG
+CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(CPPROG),)
+CPPROG=
+else
+CPPROG:=$(firstword $(CPPROG))
+endif
+endif
+export CPPROG
+ifndef RMPROG
+RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(RMPROG),)
+RMPROG=
+else
+RMPROG:=$(firstword $(RMPROG))
+endif
+endif
+export RMPROG
+ifndef MVPROG
+MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(MVPROG),)
+MVPROG=
+else
+MVPROG:=$(firstword $(MVPROG))
+endif
+endif
+export MVPROG
+ifndef ECHOREDIR
+ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO))
+endif
+ifndef COPY
+COPY:=$(CPPROG) -fp
+endif
+ifndef COPYTREE
+COPYTREE:=$(CPPROG) -rfp
+endif
+ifndef MOVE
+MOVE:=$(MVPROG) -f
+endif
+ifndef DEL
+DEL:=$(RMPROG) -f
+endif
+ifndef DELTREE
+DELTREE:=$(RMPROG) -rf
+endif
+ifndef INSTALL
+ifdef inUnix
+INSTALL:=$(GINSTALL) -c -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+ifndef INSTALLEXE
+ifdef inUnix
+INSTALLEXE:=$(GINSTALL) -c -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+ifndef MKDIR
+MKDIR:=$(GINSTALL) -m 755 -d
+endif
+export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+ifndef FPCMAKE
+FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(FPCMAKE),)
+FPCMAKE=
+else
+FPCMAKE:=$(firstword $(FPCMAKE))
+endif
+endif
+export FPCMAKE
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG))
+endif
+endif
+export ZIPPROG
+ifndef TARPROG
+TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(TARPROG),)
+TARPROG=
+else
+TARPROG:=$(firstword $(TARPROG))
+endif
+endif
+export TARPROG
+ASNAME=as
+LDNAME=ld
+ARNAME=ar
+RCNAME=rc
+ifeq ($(OS_TARGET),win32)
+ASNAME=asw
+LDNAME=ldw
+ARNAME=arw
+endif
+ifndef ASPROG
+ifdef CROSSBINDIR
+ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT)
+else
+ASPROG=$(ASNAME)
+endif
+endif
+ifndef LDPROG
+ifdef CROSSBINDIR
+LDPROG=$(CROSSBINDIR)/$(LDNAME)$(SRCEXEEXT)
+else
+LDPROG=$(LDNAME)
+endif
+endif
+ifndef RCPROG
+ifdef CROSSBINDIR
+RCPROG=$(CROSSBINDIR)/$(RCNAME)$(SRCEXEEXT)
+else
+RCPROG=$(RCNAME)
+endif
+endif
+ifndef ARPROG
+ifdef CROSSBINDIR
+ARPROG=$(CROSSBINDIR)/$(ARNAME)$(SRCEXEEXT)
+else
+ARPROG=$(ARNAME)
+endif
+endif
+AS=$(ASPROG)
+LD=$(LDPROG)
+RC=$(RCPROG)
+AR=$(ARPROG)
+PPAS=ppas$(BATCHEXT)
+ifdef inUnix
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+ZIPOPT=-9
+ZIPEXT=.zip
+ifeq ($(USETAR),bz2)
+TAROPT=vI
+TAREXT=.tar.bz2
+else
+TAROPT=vz
+TAREXT=.tar.gz
+endif
+override REQUIRE_PACKAGES=rtl 
+ifeq ($(OS_TARGET),linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),go32v2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),win32)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),os2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),freebsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),beos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),amiga)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),atari)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),sunos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),qnx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),netware)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),openbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),wdosx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),palmos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),macos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),macosx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifdef REQUIRE_PACKAGES_RTL
+PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
+ifneq ($(PACKAGEDIR_RTL),)
+ifneq ($(wildcard $(PACKAGEDIR_RTL)/$(OS_TARGET)),)
+UNITDIR_RTL=$(PACKAGEDIR_RTL)/$(OS_TARGET)
+else
+UNITDIR_RTL=$(PACKAGEDIR_RTL)
+endif
+ifdef CHECKDEPEND
+$(PACKAGEDIR_RTL)/$(FPCMADE):
+	$(MAKE) -C $(PACKAGEDIR_RTL) $(FPCMADE)
+override ALLDEPENDENCIES+=$(PACKAGEDIR_RTL)/$(FPCMADE)
+endif
+else
+PACKAGEDIR_RTL=
+UNITDIR_RTL:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /rtl/Package.fpc,$(UNITSDIR)))))
+ifneq ($(UNITDIR_RTL),)
+UNITDIR_RTL:=$(firstword $(UNITDIR_RTL))
+else
+UNITDIR_RTL=
+endif
+endif
+ifdef UNITDIR_RTL
+override COMPILER_UNITDIR+=$(UNITDIR_RTL)
+endif
+endif
+ifndef NOCPUDEF
+override FPCOPTDEF=$(CPU_TARGET)
+endif
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+ifeq ($(OS_SOURCE),openbsd)
+override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+ifdef LINKSMART
+override FPCOPT+=-XX
+endif
+ifdef CREATESMART
+override FPCOPT+=-CX
+endif
+ifdef DEBUG
+override FPCOPT+=-gl
+override FPCOPTDEF+=DEBUG
+endif
+ifdef RELEASE
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+FPCCPUOPT:=
+endif
+override FPCOPT+=-Xs $(FPCCPUOPT) -n
+override FPCOPTDEF+=RELEASE
+endif
+ifdef STRIP
+override FPCOPT+=-Xs
+endif
+ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
+override FPCOPT+=-OG2p3
+endif
+endif
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+ifdef COMPILER_OPTIONS
+override FPCOPT+=$(COMPILER_OPTIONS)
+endif
+ifdef COMPILER_UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(COMPILER_UNITDIR))
+endif
+ifdef COMPILER_LIBRARYDIR
+override FPCOPT+=$(addprefix -Fl,$(COMPILER_LIBRARYDIR))
+endif
+ifdef COMPILER_OBJECTDIR
+override FPCOPT+=$(addprefix -Fo,$(COMPILER_OBJECTDIR))
+endif
+ifdef COMPILER_INCLUDEDIR
+override FPCOPT+=$(addprefix -Fi,$(COMPILER_INCLUDEDIR))
+endif
+ifdef CROSSBINDIR
+override FPCOPT+=-FD$(CROSSBINDIR)
+endif
+ifdef COMPILER_TARGETDIR
+override FPCOPT+=-FE$(COMPILER_TARGETDIR)
+ifeq ($(COMPILER_TARGETDIR),.)
+override TARGETDIRPREFIX=
+else
+override TARGETDIRPREFIX=$(COMPILER_TARGETDIR)/
+endif
+endif
+ifdef COMPILER_UNITTARGETDIR
+override FPCOPT+=-FU$(COMPILER_UNITTARGETDIR)
+ifeq ($(COMPILER_UNITTARGETDIR),.)
+override UNITTARGETDIRPREFIX=
+else
+override UNITTARGETDIRPREFIX=$(COMPILER_UNITTARGETDIR)/
+endif
+else
+ifdef COMPILER_TARGETDIR
+override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
+override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
+endif
+endif
+ifeq ($(OS_TARGET),linux)
+ifeq ($(FPC_VERSION),1.0.6)
+override FPCOPTDEF+=HASUNIX
+endif
+endif
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef FPCOPTDEF
+override FPCOPT+=$(addprefix -d,$(FPCOPTDEF))
+endif
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+ifdef USEENV
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+override COMPILER:=$(FPC) $(FPCOPT)
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+ifeq ($(OS_SOURCE),$(OS_TARGET))
+EXECPPAS:=@$(PPAS)
+endif
+endif
+.PHONY: fpc_units
+ifdef TARGET_UNITS
+override ALLTARGET+=fpc_units
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_UNITS))
+override IMPLICITUNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_IMPLICITUNITS))
+override INSTALLPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES)
+endif
+fpc_units: $(UNITPPUFILES)
+ifdef TARGET_RSTS
+override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS))
+override CLEANRSTFILES+=$(RSTFILES)
+endif
+.PHONY: fpc_all fpc_smart fpc_debug fpc_release
+$(FPCMADE): $(ALLDEPENDENCIES) $(ALLTARGET)
+	@$(ECHOREDIR) Compiled > $(FPCMADE)
+fpc_all: $(FPCMADE)
+fpc_smart:
+	$(MAKE) all LINKSMART=1 CREATESMART=1
+fpc_debug:
+	$(MAKE) all DEBUG=1
+fpc_release:
+	$(MAKE) all RELEASE=1
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp .rc .res
+%$(PPUEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(PPUEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+%.res: %.rc
+	windres -i $< -o $@
+vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
+.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
+ifdef INSTALL_UNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS))
+endif
+ifdef INSTALL_BUILDUNIT
+override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES))
+endif
+ifdef INSTALLPPUFILES
+override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
+override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILES))
+override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILES)))
+override INSTALL_CREATEPACKAGEFPC=1
+endif
+ifdef INSTALLEXEFILES
+override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(INSTALLEXEFILES))
+endif
+fpc_install: all $(INSTALLTARGET)
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(INSTALL_BINDIR)
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(INSTALL_BINDIR)
+endif
+ifdef INSTALL_CREATEPACKAGEFPC
+ifdef FPCMAKE
+ifdef PACKAGE_VERSION
+ifneq ($(wildcard Makefile.fpc),)
+	$(FPCMAKE) -p -T$(OS_TARGET) Makefile.fpc
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) Package.fpc $(INSTALL_UNITDIR)
+endif
+endif
+endif
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(INSTALL_UNITDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(INSTALL_UNITDIR)
+endif
+ifneq ($(wildcard $(LIB_FULLNAME)),)
+	$(MKDIR) $(INSTALL_LIBDIR)
+	$(INSTALL) $(LIB_FULLNAME) $(INSTALL_LIBDIR)
+ifdef inUnix
+	ln -sf $(LIB_FULLNAME) $(INSTALL_LIBDIR)/$(LIB_NAME)
+endif
+endif
+endif
+ifdef INSTALL_FILES
+	$(MKDIR) $(INSTALL_DATADIR)
+	$(INSTALL) $(INSTALL_FILES) $(INSTALL_DATADIR)
+endif
+fpc_sourceinstall: distclean
+	$(MKDIR) $(INSTALL_SOURCEDIR)
+	$(COPYTREE) $(BASEDIR)/* $(INSTALL_SOURCEDIR)
+fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS))
+ifdef HASEXAMPLES
+	$(MKDIR) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef EXAMPLESOURCEFILES
+	$(COPY) $(EXAMPLESOURCEFILES) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef TARGET_EXAMPLEDIRS
+	$(COPYTREE) $(addsuffix /*,$(TARGET_EXAMPLEDIRS)) $(INSTALL_EXAMPLEDIR)
+endif
+.PHONY: fpc_clean fpc_cleanall fpc_distclean
+ifdef EXEFILES
+override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES))
+endif
+ifdef CLEAN_UNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS))
+endif
+ifdef CLEANPPUFILES
+override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
+override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES))
+override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)))
+endif
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES))
+endif
+ifdef CLEAN_FILES
+	-$(DEL) $(CLEAN_FILES)
+endif
+ifdef LIB_NAME
+	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
+endif
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+fpc_distclean: clean
+ifdef COMPILER_UNITTARGETDIR
+TARGETDIRCLEAN=fpc_clean
+endif
+fpc_cleanall: $(CLEANTARGET) $(TARGETDIRCLEAN)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+ifdef AOUTEXT
+	-$(DEL) *$(AOUTEXT)
+endif
+.PHONY: fpc_baseinfo
+override INFORULES+=fpc_baseinfo
+fpc_baseinfo:
+	@$(ECHO)
+	@$(ECHO)  == Package info ==
+	@$(ECHO)  Package Name..... $(PACKAGE_NAME)
+	@$(ECHO)  Package Version.. $(PACKAGE_VERSION)
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC.......... $(FPC)
+	@$(ECHO)  FPC Version.. $(FPC_VERSION)
+	@$(ECHO)  Source CPU... $(CPU_SOURCE)
+	@$(ECHO)  Target CPU... $(CPU_TARGET)
+	@$(ECHO)  Source OS.... $(OS_SOURCE)
+	@$(ECHO)  Target OS.... $(OS_TARGET)
+	@$(ECHO)  Full Source.. $(FULL_SOURCE)
+	@$(ECHO)  Full Target.. $(FULL_TARGET)
+	@$(ECHO)
+	@$(ECHO)  == Directory info ==
+	@$(ECHO)
+	@$(ECHO)  Required pkgs... $(REQUIRE_PACKAGES)
+	@$(ECHO)
+	@$(ECHO)  Basedir......... $(BASEDIR)
+	@$(ECHO)  FPCDir.......... $(FPCDIR)
+	@$(ECHO)  CrossBinDir..... $(CROSSBINDIR)
+	@$(ECHO)  UnitsDir........ $(UNITSDIR)
+	@$(ECHO)  PackagesDir..... $(PACKAGESDIR)
+	@$(ECHO)
+	@$(ECHO)  GCC library..... $(GCCLIBDIR)
+	@$(ECHO)  Other library... $(OTHERLIBDIR)
+	@$(ECHO)
+	@$(ECHO)  == Tools info ==
+	@$(ECHO)
+	@$(ECHO)  As........ $(AS)
+	@$(ECHO)  Ld........ $(LD)
+	@$(ECHO)  Ar........ $(AR)
+	@$(ECHO)  Rc........ $(RC)
+	@$(ECHO)
+	@$(ECHO)  Mv........ $(MVPROG)
+	@$(ECHO)  Cp........ $(CPPROG)
+	@$(ECHO)  Rm........ $(RMPROG)
+	@$(ECHO)  GInstall.. $(GINSTALL)
+	@$(ECHO)  Echo...... $(ECHO)
+	@$(ECHO)  Shell..... $(SHELL)
+	@$(ECHO)  Date...... $(DATE)
+	@$(ECHO)  FPCMake... $(FPCMAKE)
+	@$(ECHO)  PPUMove... $(PPUMOVE)
+	@$(ECHO)  Upx....... $(UPXPROG)
+	@$(ECHO)  Zip....... $(ZIPPROG)
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  Target Loaders........ $(TARGET_LOADERS)
+	@$(ECHO)  Target Units.......... $(TARGET_UNITS)
+	@$(ECHO)  Target Implicit Units. $(TARGET_IMPLICITUNITS)
+	@$(ECHO)  Target Programs....... $(TARGET_PROGRAMS)
+	@$(ECHO)  Target Dirs........... $(TARGET_DIRS)
+	@$(ECHO)  Target Examples....... $(TARGET_EXAMPLES)
+	@$(ECHO)  Target ExampleDirs.... $(TARGET_EXAMPLEDIRS)
+	@$(ECHO)
+	@$(ECHO)  Clean Units......... $(CLEAN_UNITS)
+	@$(ECHO)  Clean Files......... $(CLEAN_FILES)
+	@$(ECHO)
+	@$(ECHO)  Install Units....... $(INSTALL_UNITS)
+	@$(ECHO)  Install Files....... $(INSTALL_FILES)
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+	@$(ECHO)  DateStr.............. $(DATESTR)
+	@$(ECHO)  ZipPrefix............ $(ZIPPREFIX)
+	@$(ECHO)  ZipSuffix............ $(ZIPSUFFIX)
+	@$(ECHO)  Install FPC Package.. $(INSTALL_FPCPACKAGE)
+	@$(ECHO)
+	@$(ECHO)  Install base dir..... $(INSTALL_BASEDIR)
+	@$(ECHO)  Install binary dir... $(INSTALL_BINDIR)
+	@$(ECHO)  Install library dir.. $(INSTALL_LIBDIR)
+	@$(ECHO)  Install units dir.... $(INSTALL_UNITDIR)
+	@$(ECHO)  Install source dir... $(INSTALL_SOURCEDIR)
+	@$(ECHO)  Install doc dir...... $(INSTALL_DOCDIR)
+	@$(ECHO)  Install example dir.. $(INSTALL_EXAMPLEDIR)
+	@$(ECHO)  Install data dir..... $(INSTALL_DATADIR)
+	@$(ECHO)
+	@$(ECHO)  Dist destination dir. $(DIST_DESTDIR)
+	@$(ECHO)  Dist zip name........ $(DIST_ZIPNAME)
+	@$(ECHO)
+.PHONY: fpc_info
+fpc_info: $(INFORULES)
+.PHONY: fpc_makefile fpc_makefiles fpc_makefile_sub1 fpc_makefile_sub2 \
+	fpc_makefile_dirs
+fpc_makefile:
+	$(FPCMAKE) -w -T$(OS_TARGET) Makefile.fpc
+fpc_makefile_sub1:
+ifdef TARGET_DIRS
+	$(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_DIRS))
+endif
+ifdef TARGET_EXAMPLEDIRS
+	$(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_EXAMPLEDIRS))
+endif
+fpc_makefile_sub2: $(addsuffix _makefile_dirs,$(TARGET_DIRS) $(TARGET_EXAMPLEDIRS))
+fpc_makefile_dirs: fpc_makefile_sub1 fpc_makefile_sub2
+fpc_makefiles: fpc_makefile fpc_makefile_dirs
+all: fpc_all
+debug: fpc_debug
+smart: fpc_smart
+release: fpc_release
+examples:
+shared:
+install: fpc_install
+sourceinstall: fpc_sourceinstall
+exampleinstall: fpc_exampleinstall
+distinstall:
+zipinstall:
+zipsourceinstall:
+zipexampleinstall:
+zipdistinstall:
+clean: fpc_clean
+distclean: fpc_distclean
+cleanall: fpc_cleanall
+info: fpc_info
+makefiles: fpc_makefiles
+.PHONY: all debug smart release examples shared install sourceinstall exampleinstall distinstall zipinstall zipsourceinstall zipexampleinstall zipdistinstall clean distclean cleanall info makefiles
+ifneq ($(wildcard fpcmake.loc),)
+include fpcmake.loc
+endif

fcl/passrc/Makefile.fpc

@@ -0,0 +1,15 @@
+#
+#   Makefile.fpc for FCL Pascal source file parsing and writing units
+#
+
+[package]
+main=fcl
+
+[target]
+units=pastree pscanner pparser paswrite
+
+[compiler]
+options=-S2h
+
+[install]
+fpcpackage=y

fcl/passrc/pastree.pp

@@ -0,0 +1,1396 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal parse tree classes
+    Copyright (c) 2000-2003 by
+      Areca Systems GmbH / Sebastian Guenther, [email protected]
+
+    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 PasTree;
+
+interface
+
+uses Classes;
+
+resourcestring
+  // Parse tree node type names
+  SPasTreeElement = 'generic element';
+  SPasTreeSection = 'unit section';
+  SPasTreeModule = 'module';
+  SPasTreePackage = 'package';
+  SPasTreeResString = 'resource string';
+  SPasTreeType = 'generic type';
+  SPasTreePointerType = 'pointer type';
+  SPasTreeAliasType = 'alias type';
+  SPasTreeTypeAliasType = '"type" alias type';
+  SPasTreeClassOfType = '"class of" type';
+  SPasTreeRangeType = 'range type';
+  SPasTreeArrayType = 'array type';
+  SPasTreeEnumValue = 'enumeration value';
+  SPasTreeEnumType = 'enumeration type';
+  SPasTreeSetType = 'set type';
+  SPasTreeRecordType = 'record type';
+  SPasTreeObjectType = 'object';
+  SPasTreeClassType = 'class';
+  SPasTreeInterfaceType = 'interface';
+  SPasTreeArgument = 'argument';
+  SPasTreeProcedureType = 'procedure type';
+  SPasTreeResultElement = 'function result';
+  SPasTreeFunctionType = 'function type';
+  SPasTreeUnresolvedTypeRef = 'unresolved type reference';
+  SPasTreeVariable = 'variable';
+  SPasTreeConst = 'constant';
+  SPasTreeProperty = 'property';
+  SPasTreeOverloadedProcedure = 'overloaded procedure';
+  SPasTreeProcedure = 'procedure';
+  SPasTreeFunction = 'function';
+  SPasTreeConstructor = 'constructor';
+  SPasTreeDestructor = 'destructor';
+  SPasTreeProcedureImpl = 'procedure/function implementation';
+  SPasTreeConstructorImpl = 'constructor implementation';
+  SPasTreeDestructorImpl = 'destructor implementation';
+
+type
+
+  TPasModule = class;
+
+  TPasMemberVisibility = (visDefault, visPrivate, visProtected, visPublic,
+    visPublished, visAutomated);
+    
+  TPasMemberVisibilities = set of TPasMemberVisibility;
+
+
+  TPTreeElement = class of TPasElement;
+
+  TPasElement = class
+  private
+    FRefCount: LongWord;
+    FName: String;
+    FParent: TPasElement;
+  public
+    constructor Create(const AName: String; AParent: TPasElement); virtual;
+    procedure AddRef;
+    procedure Release;
+    function FullName: String;		// Name including parent's names
+    function PathName: String;		// = Module.Name + FullName
+    function GetModule: TPasModule;
+    function ElementTypeName: String; virtual;
+    function GetDeclaration(full : Boolean) : String; virtual;
+    Visibility: TPasMemberVisibility;
+    property RefCount: LongWord read FRefCount;
+    property Name: String read FName;
+    property Parent: TPasElement read FParent;
+  end;
+
+  TPasSection = class(TPasElement)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    procedure AddUnitToUsesList(const AUnitName: String);
+    UsesList: TList;		// TPasUnresolvedTypeRef or TPasModule elements
+    Declarations, ResStrings, Types, Consts, Classes,
+      Functions, Variables: TList;
+  end;
+
+  TPasModule = class(TPasElement)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    InterfaceSection, ImplementationSection: TPasSection;
+    PackageName: String;
+  end;
+
+  TPasPackage = class(TPasElement)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    Modules: TList;	// List of TPasModule objects
+  end;
+
+  TPasResString = class(TPasElement)
+  public
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : Boolean) : String; Override;
+    Value: String;
+  end;
+
+  TPasType = class(TPasElement)
+  public
+    function ElementTypeName: String; override;
+  end;
+
+  TPasPointerType = class(TPasType)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : Boolean): String; override;
+    DestType: TPasType;
+  end;
+
+  TPasAliasType = class(TPasType)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : Boolean): String; override;
+    DestType: TPasType;
+  end;
+
+  TPasTypeAliasType = class(TPasAliasType)
+  public
+    function ElementTypeName: String; override;
+  end;
+
+  TPasClassOfType = class(TPasAliasType)
+  public
+    function ElementTypeName: String; override;
+    function GetDeclaration(full: boolean) : String; override;
+  end;
+
+
+  TPasRangeType = class(TPasType)
+  public
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    RangeStart, RangeEnd: String;
+  end;
+
+  TPasArrayType = class(TPasType)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    IndexRange : String;
+    ElType: TPasType;
+  end;
+
+  TPasEnumValue = class(TPasElement)
+  public
+    function ElementTypeName: String; override;
+    IsValueUsed: Boolean;
+    Value: Integer;
+  end;
+
+  TPasEnumType = class(TPasType)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+     function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    Procedure GetEnumNames(Names : TStrings);
+    Values: TList;	// List of TPasEnumValue objects
+  end;
+
+  TPasSetType = class(TPasType)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    EnumType: TPasType;
+  end;
+
+  TPasRecordType = class(TPasType)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    IsPacked: Boolean;
+    Members: TList;	// array of TPasVariable elements
+  end;
+
+
+  TPasObjKind = (okObject, okClass, okInterface);
+
+  TPasClassType = class(TPasType)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    ObjKind: TPasObjKind;
+    AncestorType: TPasType;	// TPasClassType or TPasUnresolvedTypeRef
+    Members: TList;	// array of TPasElement objects
+  end;
+
+  TArgumentAccess = (argDefault, argConst, argVar, argOut);
+
+  TPasArgument = class(TPasElement)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    Access: TArgumentAccess;
+    ArgType: TPasType;
+    Value: String;
+  end;
+
+  TPasProcedureType = class(TPasType)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    class function TypeName: String; virtual;
+    function ElementTypeName: String; override;
+    IsOfObject: Boolean;
+    function GetDeclaration(full : boolean) : String; override;
+    procedure GetArguments(List : TStrings);
+    function CreateArgument(const AName, AUnresolvedTypeName: String):
+      TPasArgument;
+    Args: TList;	// List of TPasArgument objects
+  end;
+
+  TPasResultElement = class(TPasElement)
+  public
+    destructor Destroy; override;
+    function ElementTypeName : String; override;
+    ResultType: TPasType;
+  end;
+
+  TPasFunctionType = class(TPasProcedureType)
+  public
+    destructor Destroy; override;
+    class function TypeName: String; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(Full : boolean) : String; override;
+    ResultEl: TPasResultElement;
+  end;
+
+  TPasUnresolvedTypeRef = class(TPasType)
+  public
+    // Typerefs cannot be parented! -> AParent _must_ be NIL
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    function ElementTypeName: String; override;
+  end;
+
+  TPasTypeRef = class(TPasUnresolvedTypeRef)
+  public
+    // function GetDeclaration(full : Boolean): String; override;
+    RefType: TPasType;
+  end;
+
+  TPasVariable = class(TPasElement)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    VarType: TPasType;
+    Value: String;
+    Modifiers : string;
+  end;
+
+  TPasConst = class(TPasVariable)
+  public
+    function ElementTypeName: String; override;
+  end;
+
+  TPasProperty = class(TPasVariable)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function GetDeclaration(full : boolean) : String; override;
+    Args: TList;	// List of TPasArgument objects
+    IndexValue, ReadAccessorName, WriteAccessorName,
+      StoredAccessorName, DefaultValue: String;
+    IsDefault, IsNodefault: Boolean;
+  end;
+
+  TPasProcedureBase = class(TPasElement)
+  public
+    function TypeName: String; virtual; abstract;
+  end;
+
+  TPasOverloadedProc = class(TPasProcedureBase)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+    Overloads: TList;		// List of TPasProcedure nodes
+  end;
+
+  TPasProcedure = class(TPasProcedureBase)
+  public
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+    ProcType: TPasProcedureType;
+    function GetDeclaration(full: Boolean): String; override;
+    procedure GetModifiers(List: TStrings);
+    IsVirtual, IsDynamic, IsAbstract, IsOverride,
+      IsOverload, IsMessage: Boolean;
+  end;
+
+  TPasFunction = class(TPasProcedure)
+  public
+    function ElementTypeName: String; override;
+    function GetDeclaration (full : boolean) : String; override;
+  end;
+
+  TPasConstructor = class(TPasProcedure)
+  public
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+  end;
+
+  TPasDestructor = class(TPasProcedure)
+  public
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+  end;
+
+
+  TPasImplBlock = class;
+
+  TPasProcedureImpl = class(TPasElement)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function ElementTypeName: String; override;
+    function TypeName: String; virtual;
+    ProcType: TPasProcedureType;
+    Locals: TList;
+    Body: TPasImplBlock;
+  end;
+
+  TPasConstructorImpl = class(TPasProcedureImpl)
+  public
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+  end;
+
+  TPasDestructorImpl = class(TPasProcedureImpl)
+  public
+    function ElementTypeName: String; override;
+    function TypeName: String; override;
+  end;
+
+  TPasImplElement = class(TPasElement)
+  end;
+
+  TPasImplCommand = class(TPasImplElement)
+  public
+    Command: String;
+  end;
+
+  TPasImplCommands = class(TPasImplElement)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    Commands: TStrings;
+  end;
+
+  TPasImplIfElse = class(TPasImplElement)
+  public
+    destructor Destroy; override;
+    Condition: String;
+    IfBranch, ElseBranch: TPasImplElement;
+  end;
+
+  TPasImplForLoop = class(TPasImplElement)
+  public
+    destructor Destroy; override;
+    Variable: TPasVariable;
+    StartValue, EndValue: String;
+    Body: TPasImplElement;
+  end;
+
+  TPasImplBlock = class(TPasImplElement)
+  public
+    constructor Create(const AName: String; AParent: TPasElement); override;
+    destructor Destroy; override;
+    function AddCommand(const ACommand: String): TPasImplCommand;
+    function AddCommands: TPasImplCommands;
+    function AddIfElse(const ACondition: String): TPasImplIfElse;
+    function AddForLoop(AVar: TPasVariable;
+      const AStartValue, AEndValue: String): TPasImplForLoop;
+    Elements: TList;	// TPasImplElement objects
+  end;
+
+
+const
+  AccessNames: array[TArgumentAccess] of String[6] = ('', 'const ', 'var ', 'out ');
+  AllVisibilities: TPasMemberVisibilities = 
+     [visDefault, visPrivate, visProtected, visPublic,
+      visPublished, visAutomated];
+
+  VisibilityNames: array[TPasMemberVisibility] of String = (
+    'default', 'private', 'protected', 'public', 'published', 'automated');
+
+  ObjKindNames: array[TPasObjKind] of String = (
+    'object', 'class', 'interface');
+  
+
+implementation
+
+uses SysUtils;
+
+
+{ Parse tree element type name functions }
+
+function TPasElement.ElementTypeName: String; begin Result := SPasTreeElement end;
+function TPasSection.ElementTypeName: String; begin Result := SPasTreeSection end;
+function TPasModule.ElementTypeName: String; begin Result := SPasTreeModule end;
+function TPasPackage.ElementTypeName: String; begin Result := SPasTreePackage end;
+function TPasResString.ElementTypeName: String; begin Result := SPasTreeResString end;
+function TPasType.ElementTypeName: String; begin Result := SPasTreeType end;
+function TPasPointerType.ElementTypeName: String; begin Result := SPasTreePointerType end;
+function TPasAliasType.ElementTypeName: String; begin Result := SPasTreeAliasType end;
+function TPasTypeAliasType.ElementTypeName: String; begin Result := SPasTreeTypeAliasType end;
+function TPasClassOfType.ElementTypeName: String; begin Result := SPasTreeClassOfType end;
+function TPasRangeType.ElementTypeName: String; begin Result := SPasTreeRangeType end;
+function TPasArrayType.ElementTypeName: String; begin Result := SPasTreeArrayType end;
+function TPasEnumValue.ElementTypeName: String; begin Result := SPasTreeEnumValue end;
+function TPasEnumType.ElementTypeName: String; begin Result := SPasTreeEnumType end;
+function TPasSetType.ElementTypeName: String; begin Result := SPasTreeSetType end;
+function TPasRecordType.ElementTypeName: String; begin Result := SPasTreeRecordType end;
+function TPasArgument.ElementTypeName: String; begin Result := SPasTreeArgument end;
+function TPasProcedureType.ElementTypeName: String; begin Result := SPasTreeProcedureType end;
+function TPasResultElement.ElementTypeName: String; begin Result := SPasTreeResultElement end;
+function TPasFunctionType.ElementTypeName: String; begin Result := SPasTreeFunctionType end;
+function TPasUnresolvedTypeRef.ElementTypeName: String; begin Result := SPasTreeUnresolvedTypeRef end;
+function TPasVariable.ElementTypeName: String; begin Result := SPasTreeVariable end;
+function TPasConst.ElementTypeName: String; begin Result := SPasTreeConst end;
+function TPasProperty.ElementTypeName: String; begin Result := SPasTreeProperty end;
+function TPasOverloadedProc.ElementTypeName: String; begin Result := SPasTreeOverloadedProcedure end;
+function TPasProcedure.ElementTypeName: String; begin Result := SPasTreeProcedure end;
+function TPasFunction.ElementTypeName: String; begin Result := SPasTreeFunction end;
+function TPasConstructor.ElementTypeName: String; begin Result := SPasTreeConstructor end;
+function TPasDestructor.ElementTypeName: String; begin Result := SPasTreeDestructor end;
+function TPasProcedureImpl.ElementTypeName: String; begin Result := SPasTreeProcedureImpl end;
+function TPasConstructorImpl.ElementTypeName: String; begin Result := SPasTreeConstructorImpl end;
+function TPasDestructorImpl.ElementTypeName: String; begin Result := SPasTreeDestructorImpl end;
+
+function TPasClassType.ElementTypeName: String;
+begin
+  case ObjKind of
+    okObject: Result := SPasTreeObjectType;
+    okClass: Result := SPasTreeClassType;
+    okInterface: Result := SPasTreeInterfaceType;
+  end;
+end;
+
+
+{ All other stuff: }
+
+
+constructor TPasElement.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create;
+  FName := AName;
+  FParent := AParent;
+end;
+
+procedure TPasElement.AddRef;
+begin
+  Inc(FRefCount);
+end;
+
+procedure TPasElement.Release;
+begin
+  if FRefCount = 0 then
+    Free
+  else
+    Dec(FRefCount);
+end;
+
+function TPasElement.FullName: String;
+var
+  p: TPasElement;
+begin
+  Result := Name;
+  p := Parent;
+  while Assigned(p) and not p.InheritsFrom(TPasSection) do
+  begin
+    if (p.ClassType <> TPasOverloadedProc) and (Length(p.Name) > 0) then
+      if Length(Result) > 0 then
+        Result := p.Name + '.' + Result
+      else
+        Result := p.Name;
+    p := p.Parent;
+  end;
+end;
+
+function TPasElement.PathName: String;
+var
+  p: TPasElement;
+begin
+  Result := Name;
+  p := Parent;
+  while Assigned(p) do
+  begin
+    if (p.ClassType <> TPasOverloadedProc) and (Length(p.Name) > 0) then
+      if Length(Result) > 0 then
+        Result := p.Name + '.' + Result
+      else
+        Result := p.Name;
+    p := p.Parent;
+  end;
+end;
+
+function TPasElement.GetModule: TPasModule;
+begin
+  if ClassType = TPasPackage then
+    Result := nil
+  else
+  begin
+    Result := TPasModule(Self);
+    while Assigned(Result) and not (Result.ClassType = TPasModule) do
+      Result := TPasModule(Result.Parent);
+  end;
+end;
+
+function TPasElement.GetDeclaration (full : boolean): String;
+
+begin
+  if Full then
+    Result := Name
+  else  
+    Result := '';
+end;
+
+constructor TPasSection.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  UsesList := TList.Create;
+  Declarations := TList.Create;
+  ResStrings := TList.Create;
+  Types := TList.Create;
+  Consts := TList.Create;
+  Classes := TList.Create;
+  Functions := TList.Create;
+  Variables := TList.Create;
+end;
+
+destructor TPasSection.Destroy;
+var
+  i: Integer;
+begin
+  Variables.Free;
+  Functions.Free;
+  Classes.Free;
+  Consts.Free;
+  Types.Free;
+  ResStrings.Free;
+
+  for i := 0 to Declarations.Count - 1 do
+    TPasElement(Declarations[i]).Release;
+  Declarations.Free;
+
+  for i := 0 to UsesList.Count - 1 do
+    TPasType(UsesList[i]).Release;
+  UsesList.Free;
+
+  inherited Destroy;
+end;
+
+procedure TPasSection.AddUnitToUsesList(const AUnitName: String);
+begin
+  UsesList.Add(TPasUnresolvedTypeRef.Create(AUnitName, Self));
+end;
+
+
+destructor TPasModule.Destroy;
+begin
+  if Assigned(InterfaceSection) then
+    InterfaceSection.Release;
+  if Assigned(ImplementationSection) then
+    ImplementationSection.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasPackage.Create(const AName: String; AParent: TPasElement);
+begin
+  if (Length(AName) > 0) and (AName[1] <> '#') then
+    inherited Create('#' + AName, AParent)
+  else
+    inherited Create(AName, AParent);
+  Modules := TList.Create;
+end;
+
+destructor TPasPackage.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Modules.Count - 1 do
+    TPasModule(Modules[i]).Release;
+  Modules.Free;
+  inherited Destroy;
+end;
+
+
+destructor TPasPointerType.Destroy;
+begin
+  if Assigned(DestType) then
+    DestType.Release;
+  inherited Destroy;
+end;
+
+
+destructor TPasAliasType.Destroy;
+begin
+  if Assigned(DestType) then
+    DestType.Release;
+  inherited Destroy;
+end;
+
+
+destructor TPasArrayType.Destroy;
+begin
+  if Assigned(ElType) then
+    ElType.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasEnumType.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Values := TList.Create;
+end;
+
+destructor TPasEnumType.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Values.Count - 1 do
+    TPasEnumValue(Values[i]).Release;
+  Values.Free;
+  inherited Destroy;
+end;
+
+procedure TPasEnumType.GetEnumNames(Names: TStrings);
+var
+  i: Integer;
+begin
+  with Values do
+  begin
+    for i := 0 to Count - 2 do
+      Names.Add(TPasEnumValue(Items[i]).Name + ',');
+    if Count > 0 then
+      Names.Add(TPasEnumValue(Items[Count - 1]).Name);
+  end;  
+end;
+
+
+destructor TPasSetType.Destroy;
+begin
+  if Assigned(EnumType) then
+    EnumType.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasRecordType.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Members := TList.Create;
+end;
+
+destructor TPasRecordType.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Members.Count - 1 do
+    TPasVariable(Members[i]).Release;
+  Members.Free;
+  inherited Destroy;
+end;
+
+
+constructor TPasClassType.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Members := TList.Create;
+end;
+
+destructor TPasClassType.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Members.Count - 1 do
+    TPasElement(Members[i]).Release;
+  Members.Free;
+  if Assigned(AncestorType) then
+    AncestorType.Release;
+  inherited Destroy;
+end;
+
+
+destructor TPasArgument.Destroy;
+begin
+  if Assigned(ArgType) then
+    ArgType.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasProcedureType.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Args := TList.Create;
+end;
+
+destructor TPasProcedureType.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Args.Count - 1 do
+    TPasArgument(Args[i]).Release;
+  Args.Free;
+  inherited Destroy;
+end;
+
+function TPasProcedureType.TypeName: String;
+begin
+  Result := 'procedure';
+end;
+
+function TPasProcedureType.CreateArgument(const AName,
+  AUnresolvedTypeName: String): TPasArgument;
+begin
+  Result := TPasArgument.Create(AName, Self);
+  Args.Add(Result);
+  Result.ArgType := TPasUnresolvedTypeRef.Create(AUnresolvedTypeName, Result);
+end;
+
+
+destructor TPasResultElement.Destroy;
+begin
+  if Assigned(ResultType) then
+    ResultType.Release;
+  inherited Destroy;
+end;
+
+
+destructor TPasFunctionType.Destroy;
+begin
+  if Assigned(ResultEl) then
+    ResultEl.Release;
+  inherited Destroy;
+end;
+
+function TPasFunctionType.TypeName: String;
+begin
+  Result := 'function';
+end;
+
+
+constructor TPasUnresolvedTypeRef.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, nil);
+end;
+
+
+destructor TPasVariable.Destroy;
+begin
+  { Attention, in derived classes, VarType isn't necessarily set!
+    (e.g. in Constants) }
+  if Assigned(VarType) then
+    VarType.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasProperty.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Args := TList.Create;
+end;
+
+destructor TPasProperty.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Args.Count - 1 do
+    TPasArgument(Args[i]).Release;
+  Args.Free;
+  inherited Destroy;
+end;
+
+
+constructor TPasOverloadedProc.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Overloads := TList.Create;
+end;
+
+destructor TPasOverloadedProc.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Overloads.Count - 1 do
+    TPasProcedure(Overloads[i]).Release;
+  Overloads.Free;
+  inherited Destroy;
+end;
+
+function TPasOverloadedProc.TypeName: String;
+begin
+  if Assigned(TPasProcedure(Overloads[0]).ProcType) then
+    Result := TPasProcedure(Overloads[0]).ProcType.TypeName
+  else
+    SetLength(Result, 0);
+end;
+
+
+destructor TPasProcedure.Destroy;
+begin
+  if Assigned(ProcType) then
+    ProcType.Release;
+  inherited Destroy;
+end;
+
+function TPasProcedure.TypeName: String;
+begin
+  Result := ProcType.TypeName;
+end;
+
+
+function TPasConstructor.TypeName: String;
+begin
+  Result := 'constructor';
+end;
+
+
+function TPasDestructor.TypeName: String;
+begin
+  Result := 'destructor';
+end;
+
+
+constructor TPasProcedureImpl.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Locals := TList.Create;
+end;
+
+destructor TPasProcedureImpl.Destroy;
+var
+  i: Integer;
+begin
+  if Assigned(Body) then
+    Body.Release;
+
+  for i := 0 to Locals.Count - 1 do
+    TPasElement(Locals[i]).Release;
+  Locals.Free;
+
+  if Assigned(ProcType) then
+    ProcType.Release;
+
+  inherited Destroy;
+end;
+
+function TPasProcedureImpl.TypeName: String;
+begin
+  Result := ProcType.TypeName;
+end;
+
+
+function TPasConstructorImpl.TypeName: String;
+begin
+  Result := 'constructor';
+end;
+
+function TPasDestructorImpl.TypeName: String;
+begin
+  Result := 'destructor';
+end;
+
+
+constructor TPasImplCommands.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Commands := TStringList.Create;
+end;
+
+destructor TPasImplCommands.Destroy;
+begin
+  Commands.Free;
+  inherited Destroy;
+end;
+
+
+destructor TPasImplIfElse.Destroy;
+begin
+  if Assigned(IfBranch) then
+    IfBranch.Release;
+  if Assigned(ElseBranch) then
+    ElseBranch.Release;
+  inherited Destroy;
+end;
+
+
+destructor TPasImplForLoop.Destroy;
+begin
+  if Assigned(Variable) then
+    Variable.Release;
+  if Assigned(Body) then
+    Body.Release;
+  inherited Destroy;
+end;
+
+
+constructor TPasImplBlock.Create(const AName: String; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  Elements := TList.Create;
+end;
+
+destructor TPasImplBlock.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to Elements.Count - 1 do
+    TPasImplElement(Elements[i]).Release;
+  Elements.Free;
+  inherited Destroy;
+end;
+
+function TPasImplBlock.AddCommand(const ACommand: String): TPasImplCommand;
+begin
+  Result := TPasImplCommand.Create('', Self);
+  Elements.Add(Result);
+  Result.Command := ACommand;
+end;
+
+function TPasImplBlock.AddCommands: TPasImplCommands;
+begin
+  Result := TPasImplCommands.Create('', Self);
+  Elements.Add(Result);
+end;
+
+function TPasImplBlock.AddIfElse(const ACondition: String): TPasImplIfElse;
+begin
+  Result := TPasImplIfElse.Create('', Self);
+  Elements.Add(Result);
+  Result.Condition := ACondition;
+end;
+
+function TPasImplBlock.AddForLoop(AVar: TPasVariable; const AStartValue,
+  AEndValue: String): TPasImplForLoop;
+begin
+  Result := TPasImplForLoop.Create('', Self);
+  Elements.Add(Result);
+  Result.Variable := AVar;
+  Result.StartValue := AStartValue;
+  Result.EndValue := AEndValue;
+end;
+
+
+
+{ ---------------------------------------------------------------------
+
+  ---------------------------------------------------------------------}
+
+function TPasModule.GetDeclaration(full : boolean): String;
+begin
+  Result := 'Unit ' + Name;
+end;
+
+{
+function TPas.GetDeclaration : string;
+begin
+  Result:=Name;
+end;
+}
+
+function TPasResString.GetDeclaration (full : boolean) : string;
+begin
+  Result:=Value;
+  If Full Then
+    Result:=Name+' = '+Result;
+end;
+
+function TPasPointerType.GetDeclaration (full : boolean) : string;
+begin
+  Result:='^'+DestType.Name;
+  If Full then
+    Result:=Name+' = '+Result;
+end;
+
+function TPasAliasType.GetDeclaration (full : boolean) : string;
+begin
+  Result:=DestType.Name;
+  If Full then
+    Result:=Name+' = '+Result;
+end;
+
+function TPasClassOfType.GetDeclaration (full : boolean) : string;
+begin
+  Result:='Class of '+DestType.Name;
+  If Full then
+    Result:=Name+' = '+Result;
+end;
+
+function TPasRangeType.GetDeclaration (full : boolean) : string;
+begin
+  Result:=RangeStart+'..'+RangeEnd;
+  If Full then
+    Result:=Name+' = '+Result;  
+end;
+
+function TPasArrayType.GetDeclaration (full : boolean) : string;
+begin
+  Result:='Array['+IndexRange+'] of ';
+  If Assigned(Eltype) then
+    Result:=Result+ElType.Name
+  else
+    Result:=Result+'const';
+    If Assigned(ELtype) then
+  If Full Then
+    Result:=Name+' = '+Result;
+end;
+
+Function IndentStrings(S : TStrings; indent : Integer) : String;
+
+Var
+  I,CurrLen,CurrPos : Integer;
+  
+
+begin
+  Result:='';
+  CurrLen:=0;
+  CurrPos:=0;
+  For I:=0 to S.Count-1 do
+    begin
+    CurrLen:=Length(S[i]);
+    If (CurrLen+CurrPos)>72 then
+      begin
+      Result:=Result+LineEnding+StringOfChar(' ',Indent);
+      CurrPos:=Indent;
+      end;
+    Result:=Result+S[i];
+    CurrPos:=CurrPos+CurrLen;
+    end;
+end;
+
+function TPasEnumType.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+  i : integer;
+    
+begin
+  S:=TStringList.Create;
+  Try
+    If Full then
+      S.Add(Name+' = (')
+    else  
+      S.Add('(');
+    GetEnumNames(S);  
+    S[S.Count-1]:=S[S.Count-1]+')';
+    If Full then      
+      Result:=IndentStrings(S,Length(Name)+4)
+    else
+      Result:=IndentStrings(S,1);  
+  finally
+    S.Free;
+  end;
+end;
+
+function TPasSetType.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+  i : Integer;
+  
+begin
+  If EnumType is TPasEnumType then
+    begin
+    S:=TStringList.Create;
+    Try
+      If Full then
+        S.Add(Name+'= Set of (')
+      else  
+        S.Add('Set of (');
+      TPasEnumType(EnumType).GetEnumNames(S);
+      S[S.Count-1]:=S[S.Count-1]+')';
+      I:=Pos('(',S[0]);  
+      Result:=IndentStrings(S,i);
+    finally
+      S.Free;
+    end;
+    end
+  else
+    begin
+    Result:='Set of '+EnumType.Name;
+    If Full then
+      Result:=Name+' = '+Result;
+    end;
+end;
+
+function TPasRecordType.GetDeclaration (full : boolean) : string;
+
+Var
+  S,T : TStringList;
+  temp : String;
+  I : integer;
+    
+begin
+  S:=TStringList.Create;
+  T:=TstringList.Create;
+  Try
+    Temp:='record';
+    If IsPacked then
+      Temp:='packed '+Temp;
+    If Full then
+      Temp:=Name+' = '+Temp;
+    S.Add(Temp);
+    For I:=0 to Members.Count-1 do
+      begin
+      Temp:=TPasVariable(Members[i]).GetDeclaration(True);
+      If Pos(LineEnding,Temp)>0 then
+        begin
+        T.Text:=Temp;
+        For I:=0 to T.Count-1 do
+          S.Add('  '+T[i]+';');
+        end
+      else
+        S.Add('  '+Temp+';');
+      end;  
+    S.Add('end');
+    Result:=S.Text;  
+  finally
+    S.free;
+    T.free;
+  end;  
+end;
+
+procedure TPasProcedureType.GetArguments(List : TStrings);
+
+Var
+  T : String;
+  I : Integer;
+  
+begin
+  For I:=0 to Args.Count-1 do
+    begin
+    T:=AccessNames[TPasArgument(Args[i]).Access];
+    T:=T+TPasArgument(Args[i]).GetDeclaration(True);
+    If I=0 then
+      T:='('+T;
+    If I<Args.Count-1 then
+      List.Add(T+';')
+    else
+      List.Add(T+')');  
+    end;  
+end;    
+
+function TPasProcedureType.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+    
+begin
+  S:=TStringList.Create;
+  Try
+    If Full then 
+      S.Add(Format('%s = ',[Name]));
+    S.Add(TypeName);
+    GetArguments(S);
+    If IsOfObject then 
+      S.Add(' of object');
+    If Full then  
+      Result:=IndentStrings(S,Length(S[0])+Length(S[1])+1)
+    else
+      Result:=IndentStrings(S,Length(S[0])+1);  
+  finally
+    S.Free;
+  end;
+end;
+
+function TPasFunctionType.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+  T : String;
+    
+begin
+  S:=TStringList.Create;
+  Try
+    If Full then 
+      S.Add(Format('%s = ',[Name]));
+    S.Add(TypeName);
+    GetArguments(S);
+    If Assigned(ResultEl) then
+      begin
+      T:=' : ';
+      If (ResultEl.ResultType.Name<>'') then
+        T:=T+ResultEl.ResultType.Name
+      else
+        T:=T+ResultEl.ResultType.GetDeclaration(False);
+      S.Add(T);  
+      end;  
+    If IsOfObject then 
+      S.Add(' of object');
+    If Full then  
+      Result:=IndentStrings(S,Length(S[0])+Length(S[1])+1)
+    else
+      Result:=IndentStrings(S,Length(S[0])+1);  
+  finally
+    S.Free;
+  end;
+end;
+
+function TPasVariable.GetDeclaration (full : boolean) : string;
+
+Const
+ Seps : Array[Boolean] of String = (' = ',' : ');
+
+begin
+  If Assigned(VarType) then
+    begin
+    If VarType.Name='' then
+      Result:=VarType.GetDeclaration(False)
+    else
+      Result:=VarType.Name;
+    Result:=Result+Modifiers;
+    end
+  else
+    Result:=Value;
+  If Full then 
+    Result:=Name+Seps[Assigned(VarType)]+Result;
+end;
+
+function TPasProperty.GetDeclaration (full : boolean) : string;
+
+Var
+  S : String;
+  I : Integer;
+  
+begin
+  If Assigned(VarType) then
+    begin
+    If VarType.Name='' then
+      Result:=VarType.GetDeclaration(False)
+    else
+      Result:=VarType.Name;
+    end
+  else
+    Result:=Value;
+  S:='';
+  If Assigned(Args) and (Args.Count>0) then
+    begin
+    For I:=0 to Args.Count-1 do
+      begin
+      If (S<>'') then
+        S:=S+';';
+      S:=S+TPasElement(Args[i]).GetDeclaration(true);
+      end;
+    end;
+  If S<>'' then
+    S:='['+S+']'
+  else  
+    S:=' ';
+  If Full then 
+    Result:=Name+S+': '+Result;
+  If IsDefault then 
+    Result:=Result+'; default'
+end;
+
+Procedure TPasProcedure.GetModifiers(List : TStrings);
+ 
+  Procedure DoAdd(B : Boolean; S : String);
+  
+  begin
+    if B then
+      List.add('; '+S);
+  end;
+
+begin
+  Doadd(IsVirtual,' Virtual');
+  DoAdd(IsDynamic,' Dynamic');
+  DoAdd(IsOverride,' Override');    
+  DoAdd(IsAbstract,' Abstract');
+  DoAdd(IsOverload,' Overload');
+  DoAdd(IsMessage,' Message');
+end;
+
+function TPasProcedure.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+  Index : integer;
+begin
+  S:=TStringList.Create;
+  try
+    If Full then
+      S.Add(TypeName+' '+Name);
+    ProcType.GetArguments(S);
+    GetModifiers(S);
+    Result:=IndentStrings(S,Length(S[0]));
+  finally
+    S.Free;
+  end;
+end;
+
+function TPasFunction.GetDeclaration (full : boolean) : string;
+
+Var
+  S : TStringList;
+  T : String;
+  
+begin
+  S:=TStringList.Create;
+  try
+    If Full then
+      S.Add(TypeName+' '+Name);
+    ProcType.GetArguments(S);
+    If Assigned((Proctype as TPasFunctionType).ResultEl) then
+      With TPasFunctionType(ProcType).ResultEl.ResultType do
+        begin
+        T:=' : ';
+        If (Name<>'') then
+          T:=T+Name
+        else
+          T:=T+GetDeclaration(False);
+        S.Add(T);  
+        end;  
+    GetModifiers(S);
+    Result:=IndentStrings(S,Length(S[0]));
+  finally
+    S.Free;
+  end;
+end;
+
+
+function TPasArgument.GetDeclaration (full : boolean) : string;
+begin
+  If Assigned(ArgType) then
+    begin
+    If ArgType.Name<>'' then
+      Result:=ArgType.Name
+    else   
+      Result:=ArgType.GetDeclaration(False);
+    If Full then
+      Result:=Name+': '+Result;
+    end
+  else If Full then
+    Result:=Name
+  else    
+    Result:='';
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}

fcl/passrc/paswrite.pp

@@ -0,0 +1,622 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal tree source file writer
+    Copyright (c) 2003 by
+      Areca Systems GmbH / Sebastian Guenther, [email protected]
+
+    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 PasWrite;
+
+interface
+
+uses Classes, PasTree;
+
+type
+  TPasWriter = class
+  private
+    FStream: TStream;
+    IsStartOfLine: Boolean;
+    Indent, CurDeclSection: String;
+    DeclSectionStack: TList;
+    procedure IncIndent;
+    procedure DecIndent;
+    procedure IncDeclSectionLevel;
+    procedure DecDeclSectionLevel;
+    procedure PrepareDeclSection(const ADeclSection: String);
+  public
+    constructor Create(AStream: TStream);
+    destructor Destroy; override;
+    procedure wrt(const s: String);
+    procedure wrtln(const s: String);
+    procedure wrtln;
+
+    procedure WriteElement(AElement: TPasElement);
+    procedure WriteType(AType: TPasType);
+    procedure WriteModule(AModule: TPasModule);
+    procedure WriteSection(ASection: TPasSection);
+    procedure WriteClass(AClass: TPasClassType);
+    procedure WriteVariable(AVar: TPasVariable);
+    procedure WriteProcDecl(AProc: TPasProcedure);
+    procedure WriteProcImpl(AProc: TPasProcedureImpl);
+    procedure WriteProperty(AProp: TPasProperty);
+    procedure WriteImplBlock(ABlock: TPasImplBlock);
+    procedure WriteImplElement(AElement: TPasImplElement;
+      AAutoInsertBeginEnd: Boolean);
+    procedure WriteImplCommand(ACommand: TPasImplCommand);
+    procedure WriteImplCommands(ACommands: TPasImplCommands);
+    procedure WriteImplIfElse(AIfElse: TPasImplIfElse);
+    procedure WriteImplForLoop(AForLoop: TPasImplForLoop);
+    property Stream: TStream read FStream;
+  end;
+
+
+procedure WritePasFile(AElement: TPasElement; const AFilename: String);
+procedure WritePasFile(AElement: TPasElement; AStream: TStream);
+
+
+
+implementation
+
+uses SysUtils;
+
+type
+  PDeclSectionStackElement = ^TDeclSectionStackElement;
+  TDeclSectionStackElement = record
+    LastDeclSection, LastIndent: String;
+  end;
+
+constructor TPasWriter.Create(AStream: TStream);
+begin
+  FStream := AStream;
+  IsStartOfLine := True;
+  DeclSectionStack := TList.Create;
+end;
+
+destructor TPasWriter.Destroy;
+var
+  i: Integer;
+  El: PDeclSectionStackElement;
+begin
+  for i := 0 to DeclSectionStack.Count - 1 do
+  begin
+    El := PDeclSectionStackElement(DeclSectionStack[i]);
+    Dispose(El);
+  end;
+  DeclSectionStack.Free;
+  inherited Destroy;
+end;
+
+procedure TPasWriter.wrt(const s: String);
+begin
+  if IsStartOfLine then
+  begin
+    if Length(Indent) > 0 then
+      Stream.Write(Indent[1], Length(Indent));
+    IsStartOfLine := False;
+  end;
+  Stream.Write(s[1], Length(s));
+end;
+
+const
+  LF: String = #10;
+
+procedure TPasWriter.wrtln(const s: String);
+begin
+  wrt(s);
+  Stream.Write(LF[1], 1);
+  IsStartOfLine := True;
+end;
+
+procedure TPasWriter.wrtln;
+begin
+  Stream.Write(LF[1], 1);
+  IsStartOfLine := True;
+end;
+
+procedure TPasWriter.WriteElement(AElement: TPasElement);
+begin
+  if AElement.ClassType = TPasModule then
+    WriteModule(TPasModule(AElement))
+  else if AElement.ClassType = TPasSection then
+    WriteSection(TPasSection(AElement))
+  else if AElement.ClassType = TPasVariable then
+    WriteVariable(TPasVariable(AElement))
+  else if AElement.InheritsFrom(TPasType) then
+    WriteType(TPasType(AElement))
+  else if AElement.InheritsFrom(TPasProcedure) then
+    WriteProcDecl(TPasProcedure(AElement))
+  else if AElement.InheritsFrom(TPasProcedureImpl) then
+    WriteProcImpl(TPasProcedureImpl(AElement))
+  else if AElement.ClassType = TPasProperty then
+    WriteProperty(TPasProperty(AElement))
+  else
+    raise Exception.Create('Writing not implemented for ' +
+      AElement.ElementTypeName + ' nodes');
+end;
+
+procedure TPasWriter.WriteType(AType: TPasType);
+begin
+  if AType.ClassType = TPasUnresolvedTypeRef then
+    wrt(AType.Name)
+  else if AType.ClassType = TPasClassType then
+    WriteClass(TPasClassType(AType))
+  else
+    raise Exception.Create('Writing not implemented for ' +
+      AType.ElementTypeName + ' nodes');
+end;
+
+
+procedure TPasWriter.WriteModule(AModule: TPasModule);
+begin
+  wrtln('unit ' + AModule.Name + ';');
+  wrtln;
+  wrtln('interface');
+  wrtln;
+  WriteSection(AModule.InterfaceSection);
+  Indent := '';
+  wrtln;
+  wrtln;
+  wrtln('implementation');
+  if Assigned(AModule.ImplementationSection) then
+  begin
+    wrtln;
+    WriteSection(AModule.ImplementationSection);
+  end;
+  wrtln;
+  wrtln('end.');
+end;
+
+procedure TPasWriter.WriteSection(ASection: TPasSection);
+var
+  i: Integer;
+begin
+  if ASection.UsesList.Count > 0 then
+  begin
+    wrt('uses ');
+    for i := 0 to ASection.UsesList.Count - 1 do
+    begin
+      if i > 0 then
+        wrt(', ');
+      wrt(TPasElement(ASection.UsesList[i]).Name);
+    end;
+    wrtln(';');
+    wrtln;
+  end;
+
+  CurDeclSection := '';
+
+  for i := 0 to ASection.Declarations.Count - 1 do
+    WriteElement(TPasElement(ASection.Declarations[i]));
+end;
+
+procedure TPasWriter.WriteClass(AClass: TPasClassType);
+var
+  i: Integer;
+  Member: TPasElement;
+  LastVisibility, CurVisibility: TPasMemberVisibility;
+begin
+  PrepareDeclSection('type');
+  wrt(AClass.Name + ' = ');
+  case AClass.ObjKind of
+    okObject: wrt('object');
+    okClass: wrt('class');
+    okInterface: wrt('interface');
+  end;
+  if Assigned(AClass.AncestorType) then
+    wrtln('(' + AClass.AncestorType.Name + ')')
+  else
+    wrtln;
+  IncIndent;
+  LastVisibility := visDefault;
+  for i := 0 to AClass.Members.Count - 1 do
+  begin
+    Member := TPasElement(AClass.Members[i]);
+    CurVisibility := Member.Visibility;
+    if CurVisibility <> LastVisibility then
+    begin
+      DecIndent;
+      case CurVisibility of
+        visPrivate: wrtln('private');
+	visProtected: wrtln('protected');
+	visPublic: wrtln('public');
+	visPublished: wrtln('published');
+	visAutomated: wrtln('automated');
+      end;
+      IncIndent;
+      LastVisibility := CurVisibility;
+    end;
+    WriteElement(Member);
+  end;
+  DecIndent;
+  wrtln('end;');
+  wrtln;
+end;
+
+procedure TPasWriter.WriteVariable(AVar: TPasVariable);
+begin
+  if (AVar.Parent.ClassType <> TPasClassType) and
+    (AVar.Parent.ClassType <> TPasRecordType) then
+    PrepareDeclSection('var');
+  wrt(AVar.Name + ': ');
+  WriteType(AVar.VarType);
+  wrtln(';');
+end;
+
+procedure TPasWriter.WriteProcDecl(AProc: TPasProcedure);
+var
+  i: Integer;
+begin
+  wrt(AProc.TypeName + ' ' + AProc.Name);
+
+  if Assigned(AProc.ProcType) and (AProc.ProcType.Args.Count > 0) then
+  begin
+    wrt('(');
+    for i := 0 to AProc.ProcType.Args.Count - 1 do
+      with TPasArgument(AProc.ProcType.Args[i]) do
+      begin
+        if i > 0 then
+	  wrt('; ');
+        case Access of
+	  argConst: wrt('const ');
+	  argVar: wrt('var ');
+	end;
+	wrt(Name);
+	if Assigned(ArgType) then
+	begin
+	  wrt(': ');
+	  WriteElement(ArgType);
+	end;
+	if Value <> '' then
+	  wrt(' = ' + Value);
+      end;
+    wrt(')');
+  end;
+
+  if Assigned(AProc.ProcType) and
+    (AProc.ProcType.ClassType = TPasFunctionType) then
+  begin
+    wrt(': ');
+    WriteElement(TPasFunctionType(AProc.ProcType).ResultEl.ResultType);
+  end;
+
+  wrt(';');
+
+  if AProc.IsVirtual then
+    wrt(' virtual;');
+  if AProc.IsDynamic then
+    wrt(' dynamic;');
+  if AProc.IsAbstract then
+    wrt(' abstract;');
+  if AProc.IsOverride then
+    wrt(' override;');
+  if AProc.IsOverload then
+    wrt(' overload;');
+
+  // !!!: Not handled: Message, calling conventions
+
+  wrtln;
+end;
+
+procedure TPasWriter.WriteProcImpl(AProc: TPasProcedureImpl);
+var
+  i: Integer;
+begin
+  PrepareDeclSection('');
+  wrt(AProc.TypeName + ' ');
+
+  if AProc.Parent.ClassType = TPasClassType then
+    wrt(AProc.Parent.Name + '.');
+
+  wrt(AProc.Name);
+
+  if Assigned(AProc.ProcType) and (AProc.ProcType.Args.Count > 0) then
+  begin
+    wrt('(');
+    for i := 0 to AProc.ProcType.Args.Count - 1 do
+      with TPasArgument(AProc.ProcType.Args[i]) do
+      begin
+        if i > 0 then
+	  wrt('; ');
+        case Access of
+	  argConst: wrt('const ');
+	  argVar: wrt('var ');
+	end;
+	wrt(Name);
+	if Assigned(ArgType) then
+	begin
+	  wrt(': ');
+	  WriteElement(ArgType);
+	end;
+	if Value <> '' then
+	  wrt(' = ' + Value);
+      end;
+    wrt(')');
+  end;
+
+  if Assigned(AProc.ProcType) and
+    (AProc.ProcType.ClassType = TPasFunctionType) then
+  begin
+    wrt(': ');
+    WriteElement(TPasFunctionType(AProc.ProcType).ResultEl.ResultType);
+  end;
+
+  wrtln(';');
+  IncDeclSectionLevel;
+  for i := 0 to AProc.Locals.Count - 1 do
+  begin
+    if TPasElement(AProc.Locals[i]).InheritsFrom(TPasProcedureImpl) then
+    begin
+      IncIndent;
+      if (i = 0) or not
+        TPasElement(AProc.Locals[i - 1]).InheritsFrom(TPasProcedureImpl) then
+        wrtln;
+    end;
+
+    WriteElement(TPasElement(AProc.Locals[i]));
+
+    if TPasElement(AProc.Locals[i]).InheritsFrom(TPasProcedureImpl) then
+      DecIndent;
+  end;
+  DecDeclSectionLevel;
+
+  wrtln('begin');
+  IncIndent;
+  if Assigned(AProc.Body) then
+    WriteImplBlock(AProc.Body);
+  DecIndent;
+  wrtln('end;');
+  wrtln;
+end;
+
+procedure TPasWriter.WriteProperty(AProp: TPasProperty);
+var
+  i: Integer;
+begin
+  wrt('property ' + AProp.Name);
+  if AProp.Args.Count > 0 then
+  begin
+    wrt('[');
+    for i := 0 to AProp.Args.Count - 1 do;
+      // !!!: Create WriteArgument method and call it here
+    wrt(']');
+  end;
+  if Assigned(AProp.VarType) then
+  begin
+    wrt(': ');
+    WriteType(AProp.VarType);
+  end;
+  if AProp.ReadAccessorName <> '' then
+    wrt(' read ' + AProp.ReadAccessorName);
+  if AProp.WriteAccessorName <> '' then
+    wrt(' write ' + AProp.WriteAccessorName);
+  if AProp.StoredAccessorName <> '' then
+    wrt(' stored ' + AProp.StoredAccessorName);
+  if AProp.DefaultValue <> '' then
+    wrt(' default ' + AProp.DefaultValue);
+  if AProp.IsNodefault then
+    wrt(' nodefault');
+  if AProp.IsDefault then
+    wrt('; default');
+  wrtln(';');
+end;
+
+procedure TPasWriter.WriteImplBlock(ABlock: TPasImplBlock);
+var
+  i: Integer;
+begin
+  for i := 0 to ABlock.Elements.Count - 1 do
+  begin
+    WriteImplElement(TPasImplElement(ABlock.Elements[i]), False);
+    if TPasImplElement(ABlock.Elements[i]).ClassType = TPasImplCommand then
+      wrtln(';');
+  end;
+end;
+
+procedure TPasWriter.WriteImplElement(AElement: TPasImplElement;
+  AAutoInsertBeginEnd: Boolean);
+begin
+  if AElement.ClassType = TPasImplCommand then
+    WriteImplCommand(TPasImplCommand(AElement))
+  else if AElement.ClassType = TPasImplCommands then
+  begin
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('begin');
+    IncIndent;
+    WriteImplCommands(TPasImplCommands(AElement));
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('end;');
+    IncIndent;
+  end else if AElement.ClassType = TPasImplBlock then
+  begin
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('begin');
+    IncIndent;
+    WriteImplBlock(TPasImplBlock(AElement));
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('end;');
+    IncIndent;
+  end else if AElement.ClassType = TPasImplIfElse then
+    WriteImplIfElse(TPasImplIfElse(AElement))
+  else if AElement.ClassType = TPasImplForLoop then
+    WriteImplForLoop(TPasImplForLoop(AElement))
+  else
+    raise Exception.Create('Writing not yet implemented for ' +
+      AElement.ClassName + ' implementation elements');
+end;
+
+procedure TPasWriter.WriteImplCommand(ACommand: TPasImplCommand);
+begin
+  wrt(ACommand.Command);
+end;
+
+procedure TPasWriter.WriteImplCommands(ACommands: TPasImplCommands);
+var
+  i: Integer;
+  s: String;
+begin
+  for i := 0 to ACommands.Commands.Count - 1 do
+  begin
+    s := ACommands.Commands[i];
+    if Length(s) > 0 then
+      if (Length(s) >= 2) and (s[1] = '/') and (s[2] = '/') then
+        wrtln(s)
+      else
+	wrtln(s + ';');
+  end;
+end;
+
+procedure TPasWriter.WriteImplIfElse(AIfElse: TPasImplIfElse);
+begin
+  wrt('if ' + AIfElse.Condition + ' then');
+  if Assigned(AIfElse.IfBranch) then
+  begin
+    wrtln;
+    if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
+      (AIfElse.IfBranch.ClassType = TPasImplBlock) then
+      wrtln('begin');
+    IncIndent;
+    WriteImplElement(AIfElse.IfBranch, False);
+    DecIndent;
+    if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
+      (AIfElse.IfBranch.ClassType = TPasImplBlock) then
+      if Assigned(AIfElse.ElseBranch) then
+	wrt('end ')
+      else
+        wrtln('end;')
+    else
+      if Assigned(AIfElse.ElseBranch) then
+        wrtln;
+  end else
+    if not Assigned(AIfElse.ElseBranch) then
+      wrtln(';')
+    else
+      wrtln;
+
+  if Assigned(AIfElse.ElseBranch) then
+    if AIfElse.ElseBranch.ClassType = TPasImplIfElse then
+    begin
+      wrt('else ');
+      WriteImplElement(AIfElse.ElseBranch, True);
+    end else
+    begin
+      wrtln('else');
+      IncIndent;
+      WriteImplElement(AIfElse.ElseBranch, True);
+      if (not Assigned(AIfElse.Parent)) or
+        (AIfElse.Parent.ClassType <> TPasImplIfElse) or
+	(TPasImplIfElse(AIfElse.Parent).IfBranch <> AIfElse) then
+        wrtln(';');
+      DecIndent;
+    end;
+end;
+
+procedure TPasWriter.WriteImplForLoop(AForLoop: TPasImplForLoop);
+begin
+  wrtln('for ' + AForLoop.Variable.Name + ' := ' + AForLoop.StartValue +
+    ' to ' + AForLoop.EndValue + ' do');
+  IncIndent;
+  WriteImplElement(AForLoop.Body, True);
+  DecIndent;
+  if (AForLoop.Body.ClassType <> TPasImplBlock) and
+    (AForLoop.Body.ClassType <> TPasImplCommands) then
+      wrtln(';');
+end;
+
+procedure TPasWriter.IncIndent;
+begin
+  Indent := Indent + '  ';
+end;
+
+procedure TPasWriter.DecIndent;
+begin
+  if Indent = '' then
+    raise Exception.Create('Internal indent error');
+  SetLength(Indent, Length(Indent) - 2);
+end;
+
+procedure TPasWriter.IncDeclSectionLevel;
+var
+  El: PDeclSectionStackElement;
+begin
+  New(El);
+  DeclSectionStack.Add(El);
+  El^.LastDeclSection := CurDeclSection;
+  El^.LastIndent := Indent;
+  CurDeclSection := '';
+end;
+
+procedure TPasWriter.DecDeclSectionLevel;
+var
+  El: PDeclSectionStackElement;
+begin
+  El := PDeclSectionStackElement(DeclSectionStack[DeclSectionStack.Count - 1]);
+  DeclSectionStack.Delete(DeclSectionStack.Count - 1);
+  CurDeclSection := El^.LastDeclSection;
+  Indent := El^.LastIndent;
+  Dispose(El);
+end;
+
+procedure TPasWriter.PrepareDeclSection(const ADeclSection: String);
+begin
+  if ADeclSection <> CurDeclSection then
+  begin
+    if CurDeclsection <> '' then
+      DecIndent;
+    if ADeclSection <> '' then
+    begin
+      wrtln(ADeclSection);
+      IncIndent;
+    end;
+    CurDeclSection := ADeclSection;
+  end;
+end;
+
+
+procedure WritePasFile(AElement: TPasElement; const AFilename: String);
+var
+  Stream: TFileStream;
+begin
+  Stream := TFileStream.Create(AFilename, fmCreate);
+  try
+    WritePasFile(AElement, Stream);
+  finally
+    Stream.Free;
+  end;
+end;
+
+procedure WritePasFile(AElement: TPasElement; AStream: TStream);
+var
+  Writer: TPasWriter;
+begin
+  Writer := TPasWriter.Create(AStream);
+  try
+    Writer.WriteElement(AElement);
+  finally
+    Writer.Free;
+  end;
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}

fcl/passrc/pparser.pp

@@ -0,0 +1,1567 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal source parser
+    Copyright (c) 2000-2003 by
+      Areca Systems GmbH / Sebastian Guenther, [email protected]
+
+    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 PParser;
+
+interface
+
+uses SysUtils, PasTree;
+
+resourcestring
+  SErrNoSourceGiven = 'No source file specified';
+  SErrMultipleSourceFiles = 'Please specify only one source file';
+  SParserError = 'Error';
+  SParserErrorAtToken = '%s at token "%s"';
+  SParserUngetTokenError = 'Internal error: Cannot unget more tokens, history buffer is full';
+  SParserExpectTokenError = 'Expected "%s"';
+  SParserExpectedCommaRBracket = 'Expected "," or ")"';
+  SParserExpectedCommaSemicolon = 'Expected "," or ";"';
+  SParserExpectedCommaColon = 'Expected "," or ":"';
+  SParserExpectedLBracketColon = 'Expected "(" or ":"';
+  SParserExpectedLBracketSemicolon = 'Expected "(" or ";"';
+  SParserExpectedColonSemicolon = 'Expected ":" or ";"';
+  SParserExpectedSemiColonEnd = 'Expected ";" or "End"';
+  SParserExpectedConstVarID = 'Expected "const", "var" or identifier';
+  SParserSyntaxError = 'Syntax error';
+  SParserTypeSyntaxError = 'Syntax error in type';
+  SParserArrayTypeSyntaxError = 'Syntax error in array type';
+  SParserInterfaceTokenError = 'Invalid token in interface section of unit';
+  SParserInvalidTypeDef = 'Invalid type definition';
+
+type
+  TPasTreeContainer = class
+  protected
+    FPackage: TPasPackage;
+  public
+    function CreateElement(AClass: TPTreeElement; const AName: String;
+      AParent: TPasElement): TPasElement;
+    function CreateElement(AClass: TPTreeElement; const AName: String;
+      AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement;
+      virtual; abstract;
+    function CreateFunctionType(const AName: String; AParent: TPasElement;
+      UseParentAsResultParent: Boolean): TPasFunctionType;
+    function FindElement(const AName: String): TPasElement; virtual; abstract;
+    function FindModule(const AName: String): TPasModule; virtual;
+    property Package: TPasPackage read FPackage;
+  end;
+
+  EParserError = class(Exception)
+  private
+    FFilename: String;
+    FRow, FColumn: Integer;
+  public
+    constructor Create(const AReason, AFilename: String;
+      ARow, AColumn: Integer);
+    property Filename: String read FFilename;
+    property Row: Integer read FRow;
+    property Column: Integer read FColumn;
+  end;
+
+
+function ParseSource(AEngine: TPasTreeContainer;
+  const FPCCommandLine: String): TPasModule;
+
+
+implementation
+
+uses Classes, PScanner;
+
+type
+
+  TDeclType = (declNone, declConst, declResourcestring, declType, declVar);
+
+  TPasParser = class
+  private
+    FFileResolver: TFileResolver;
+    FScanner: TPascalScanner;
+    FEngine: TPasTreeContainer;
+    FCurToken: TToken;
+    FCurTokenString: String;
+    // UngetToken support:
+    FTokenBuffer: array[0..1] of TToken;
+    FTokenStringBuffer: array[0..1] of String;
+    FTokenBufferIndex, FTokenBufferSize: Integer;
+
+    function GetCurColumn: Integer;
+    procedure ParseExc(const Msg: String);
+  public
+    constructor Create(AFileResolver: TFileResolver; AEngine: TPasTreeContainer;
+      const AFilename: String);
+    destructor Destroy; override;
+    function CurTokenName: String;
+    function CurTokenText: String;
+    procedure NextToken;
+    procedure UngetToken;
+    procedure ExpectToken(tk: TToken);
+    function ExpectIdentifier: String;
+
+    function ParseType(Parent: TPasElement): TPasType;
+    function ParseComplexType: TPasType;
+    procedure ParseArrayType(Element: TPasArrayType);
+    function ParseExpression: String;
+    procedure AddProcOrFunction(ASection: TPasSection; AProc: TPasProcedure);
+    function CheckIfOverloaded(AOwner: TPasClassType;
+      const AName: String): TPasElement;
+
+    procedure ParseMain(var Module: TPasModule);
+    procedure ParseUnit(var Module: TPasModule);
+    procedure ParseUsesList(ASection: TPasSection);
+    function ParseConstDecl(Parent: TPasElement): TPasConst;
+    function ParseResourcestringDecl(Parent: TPasElement): TPasResString;
+    function ParseTypeDecl(Parent: TPasElement): TPasType;
+    procedure ParseInlineVarDecl(Parent: TPasElement; VarList: TList;
+      AVisibility : TPasMemberVisibility);
+    procedure ParseInlineVarDecl(Parent: TPasElement; VarList: TList);
+    procedure ParseVarDecl(Parent: TPasElement; List: TList);
+    procedure ParseArgList(Parent: TPasElement; Args: TList; EndToken: TToken);
+    procedure ParseProcedureOrFunctionHeader(Parent: TPasElement;
+      Element: TPasProcedureType; IsFunction, OfObjectPossible: Boolean);
+    function ParseProcedureOrFunctionDecl(Parent: TPasElement;
+      IsFunction: Boolean): TPasProcedure;
+    procedure ParseRecordDecl(Parent: TPasRecordType);
+    function ParseClassDecl(Parent: TPasElement; const AClassName: String;
+      AObjKind: TPasObjKind): TPasType;
+
+    property FileResolver: TFileResolver read FFileResolver;
+    property Scanner: TPascalScanner read FScanner;
+    property Engine: TPasTreeContainer read FEngine;
+
+    property CurToken: TToken read FCurToken;
+    property CurTokenString: String read FCurTokenString;
+  end;
+
+
+function TPasTreeContainer.CreateElement(AClass: TPTreeElement;
+  const AName: String; AParent: TPasElement): TPasElement;
+begin
+  Result := CreateElement(AClass, AName, AParent, visDefault);
+end;
+
+function TPasTreeContainer.CreateFunctionType(const AName: String;
+  AParent: TPasElement; UseParentAsResultParent: Boolean): TPasFunctionType;
+var
+  ResultParent: TPasElement;
+begin
+  Result := TPasFunctionType(CreateElement(TPasFunctionType, AName, AParent));
+
+  if UseParentAsResultParent then
+    ResultParent := AParent
+  else
+    ResultParent := Result;
+
+  TPasFunctionType(Result).ResultEl :=
+    TPasResultElement(CreateElement(TPasResultElement, 'Result', ResultParent));
+end;
+
+function TPasTreeContainer.FindModule(const AName: String): TPasModule;
+begin
+  Result := nil;
+end;
+
+
+constructor EParserError.Create(const AReason, AFilename: String;
+  ARow, AColumn: Integer);
+begin
+  inherited Create(AReason);
+  FFilename := AFilename;
+  FRow := ARow;
+  FColumn := AColumn;
+end;
+
+
+procedure TPasParser.ParseExc(const Msg: String);
+begin
+  raise EParserError.Create(Format(SParserErrorAtToken, [Msg, CurTokenName]),
+    Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
+end;
+
+constructor TPasParser.Create(AFileResolver: TFileResolver;
+  AEngine: TPasTreeContainer; const AFilename: String);
+begin
+  inherited Create;
+  FFileResolver := AFileResolver;
+  FEngine := AEngine;
+  FScanner := TPascalScanner.Create(FileResolver, AFilename);
+end;
+
+destructor TPasParser.Destroy;
+begin
+  Scanner.Free;
+  inherited Destroy;
+end;
+
+function TPasParser.CurTokenName: String;
+begin
+  if CurToken = tkIdentifier then
+    Result := 'Identifier ' + Scanner.CurTokenString
+  else
+    Result := TokenInfos[CurToken];
+end;
+
+function TPasParser.CurTokenText: String;
+begin
+  case CurToken of
+    tkIdentifier, tkString, tkNumber, tkChar:
+      Result := Scanner.CurTokenString;
+    else
+      Result := TokenInfos[CurToken];
+  end;
+end;
+
+procedure TPasParser.NextToken;
+begin
+  if FTokenBufferIndex < FTokenBufferSize then
+  begin
+    // Get token from buffer
+    FCurToken := FTokenBuffer[FTokenBufferIndex];
+    FCurTokenString := FTokenStringBuffer[FTokenBufferIndex];
+    Inc(FTokenBufferIndex);
+  end else
+  begin
+    { We have to fetch a new token. But first check, wether there is space left
+      in the token buffer.}
+    if FTokenBufferSize = 2 then
+    begin
+      FTokenBuffer[0] := FTokenBuffer[1];
+      FTokenStringBuffer[0] := FTokenStringBuffer[1];
+      Dec(FTokenBufferSize);
+      Dec(FTokenBufferIndex);
+    end;
+    // Fetch new token
+    repeat
+      FCurToken := Scanner.FetchToken;
+//WriteLn('Token: ', TokenInfos[CurToken], ' ', Scanner.CurTokenString);
+    until not (FCurToken in [tkWhitespace, tkComment]);
+    FCurTokenString := Scanner.CurTokenString;
+    FTokenBuffer[FTokenBufferSize] := FCurToken;
+    FTokenStringBuffer[FTokenBufferSize] := FCurTokenString;
+    Inc(FTokenBufferSize);
+    Inc(FTokenBufferIndex);
+  end;
+end;
+
+procedure TPasParser.UngetToken;
+      
+begin
+  if FTokenBufferIndex = 0 then
+    ParseExc(SParserUngetTokenError)
+  else
+    Dec(FTokenBufferIndex);
+end;
+
+
+procedure TPasParser.ExpectToken(tk: TToken);
+begin
+  NextToken;
+  if CurToken <> tk then
+    ParseExc(Format(SParserExpectTokenError, [TokenInfos[tk]]));
+end;
+
+function TPasParser.ExpectIdentifier: String;
+begin
+  ExpectToken(tkIdentifier);
+  Result := CurTokenString;
+end;
+
+function TPasParser.ParseType(Parent: TPasElement): TPasType;
+var
+  TypeToken: TToken;
+  Name, s: String;
+  EnumValue: TPasEnumValue;
+  Ref: TPasElement;
+begin
+  Result := nil; 	// !!!: Remove in the future
+  NextToken;
+  case CurToken of
+    tkIdentifier:
+      begin
+        TypeToken := CurToken;
+        Name := CurTokenString;
+        NextToken;
+        if CurToken = tkDot then
+        begin
+          ExpectIdentifier;
+          Name := CurTokenString;
+        end else
+          UngetToken;
+	Ref := nil;
+	s := UpperCase(Name);
+	if s = 'BYTE' then Name := 'Byte'
+	else if s = 'BOOLEAN' then Name := 'Boolean'
+	else if s = 'CHAR' then Name := 'Char'
+	else if s = 'INTEGER' then Name := 'Integer'
+	else if s = 'INT64' then Name := 'Int64'
+	else if s = 'LONGINT' then Name := 'LongInt'
+	else if s = 'LONGWORD' then Name := 'LongWord'
+	else if s = 'SHORTINT' then Name := 'ShortInt'
+	else if s = 'SMALLINT' then Name := 'SmallInt'
+	else if s = 'STRING' then Name := 'String'
+	else if s = 'WORD' then Name := 'Word'
+	else
+	  Ref := Engine.FindElement(Name);
+	if Assigned(Ref) then
+	begin
+	  {Result := TPasTypeRef(Engine.CreateElement(TPasTypeRef, Name, nil));
+	  TPasTypeRef(Result).RefType := Ref as TPasType;}
+	  Result := Ref as TPasType;
+	  Result.AddRef;
+	end else
+	  Result := TPasUnresolvedTypeRef(Engine.CreateElement(TPasUnresolvedTypeRef, Name, nil));
+
+	// !!!: Doesn't make sense for resolved types
+        if Name = 'String' then
+        begin
+          NextToken;
+          if CurToken = tkSquaredBraceOpen then
+          begin
+            // !!!: Parse the string length value and store it
+            repeat
+    	      NextToken;
+	    until CurToken = tkSquaredBraceClose;
+          end else
+            UngetToken;
+        end;
+      end;
+    tkCaret:
+      begin
+        Result := TPasPointerType(
+	  Engine.CreateElement(TPasPointerType, '', Parent));
+	TPasPointerType(Result).DestType := ParseType(nil);
+      end;
+    tkArray:
+      begin
+        Result := TPasArrayType(Engine.CreateElement(TPasArrayType, '', Parent));
+	ParseArrayType(TPasArrayType(Result));
+      end;
+    tkBraceOpen:
+      begin
+        Result := TPasEnumType(Engine.CreateElement(TPasEnumType, '', Parent));
+        while True do
+        begin
+          NextToken;
+	  EnumValue := TPasEnumValue(Engine.CreateElement(TPasEnumValue,
+	    CurTokenString, Result));
+	  TPasEnumType(Result).Values.Add(EnumValue);
+	  NextToken;
+          if CurToken = tkBraceClose then
+            break
+	  else if CurToken <> tkComma then
+	    ParseExc(SParserExpectedCommaRBracket);
+        end;
+      end;
+    tkRecord:
+      begin
+        Result := TPasRecordType(
+	  Engine.CreateElement(TPasRecordType, '', Parent));
+        ParseRecordDecl(TPasRecordType(Result));
+        UngetToken;
+      end;
+  
+    else
+      ParseExc(SParserTypeSyntaxError);
+  end;
+end;
+
+function TPasParser.ParseComplexType: TPasType;
+begin
+  NextToken;
+  case CurToken of
+    tkProcedure:
+      begin
+        Result := TPasProcedureType(
+	  Engine.CreateElement(TPasProcedureType, '', nil));
+	ParseProcedureOrFunctionHeader(Result,
+	  TPasProcedureType(Result), False, True);
+	UngetToken;	// Unget semicolon
+      end;
+    tkFunction:
+      begin
+        Result := Engine.CreateFunctionType('', nil, False);
+	ParseProcedureOrFunctionHeader(Result,
+	  TPasFunctionType(Result), True, True);
+	UngetToken;	// Unget semicolon
+      end;
+    else
+    begin
+      UngetToken;
+      Result := ParseType(nil);
+      exit;
+    end;
+  end;
+end;
+
+procedure TPasParser.ParseArrayType(Element: TPasArrayType);
+
+Var
+  S : String;
+
+begin
+  NextToken;
+  S:='';
+  case CurToken of
+    tkSquaredBraceOpen:
+      begin
+        repeat
+          NextToken;
+          if CurToken<>tkSquaredBraceClose then
+            S:=S+CurTokenText;
+        until CurToken = tkSquaredBraceClose;
+      Element.IndexRange:=S;  
+	ExpectToken(tkOf);
+	Element.ElType := ParseType(nil);
+      end;
+    tkOf:
+      begin
+	NextToken;
+	if CurToken = tkConst then
+//	  ArrayEl.AppendChild(Doc.CreateElement('const'))
+	else
+	begin
+	  UngetToken;
+  	  Element.ElType := ParseType(nil);
+	end
+      end
+    else
+      ParseExc(SParserArrayTypeSyntaxError);
+  end;
+end;
+
+function TPasParser.ParseExpression: String;
+var
+  BracketLevel: Integer;
+  MayAppendSpace, AppendSpace, NextAppendSpace: Boolean;
+begin
+  SetLength(Result, 0);
+  BracketLevel := 0;
+  MayAppendSpace := False;
+  AppendSpace := False;
+  while True do
+  begin
+    NextToken;
+    { !!!: Does not detect when normal brackets and square brackets are mixed
+      in a wrong way. }
+    if CurToken in [tkBraceOpen, tkSquaredBraceOpen] then
+      Inc(BracketLevel)
+    else if CurToken in [tkBraceClose, tkSquaredBraceClose] then
+    begin
+      if BracketLevel = 0 then
+        break;
+      Dec(BracketLevel);
+    end else if (CurToken in [tkComma, tkSemicolon, tkColon, tkSquaredBraceClose,
+      tkDotDot]) and (BracketLevel = 0) then
+      break;
+
+    if MayAppendSpace then
+    begin
+      NextAppendSpace := False;
+      case CurToken of
+        tkBraceOpen, tkBraceClose, tkDivision, tkEqual, tkCaret, tkAnd, tkAs,
+	  tkDiv, tkIn, tkIs, tkMinus, tkMod, tkMul, tkNot, tkOf, tkOn,
+	  tkOr, tkPlus, tkSHL, tkSHR, tkXOR:
+{        tkPlus.._ASSIGNMENT, _UNEQUAL, tkPlusASN.._XORASN, _AS, _AT, _IN, _IS,
+	  tkOf, _ON, _OR, _AND, _DIV, _MOD, _NOT, _SHL, _SHR, _XOR:}
+	  begin
+	    AppendSpace := True;
+	    NextAppendSpace := True;
+	  end;
+      end;
+      if AppendSpace then
+        Result := Result + ' ';
+      AppendSpace := NextAppendSpace;
+    end else
+      MayAppendSpace := True;
+    Result := Result + CurTokenText;
+  end;
+  UngetToken;
+end;
+
+procedure TPasParser.AddProcOrFunction(ASection: TPasSection;
+  AProc: TPasProcedure);
+var
+  i: Integer;
+  Member: TPasElement;
+  OverloadedProc: TPasOverloadedProc;
+begin
+  for i := 0 to ASection.Functions.Count - 1 do
+  begin
+    Member := TPasElement(ASection.Functions[i]);
+    if CompareText(Member.Name, AProc.Name) = 0 then
+    begin
+      if Member.ClassType = TPasOverloadedProc then
+        TPasOverloadedProc(Member).Overloads.Add(AProc)
+      else
+      begin
+        OverloadedProc := TPasOverloadedProc.Create(AProc.Name, ASection);
+        OverloadedProc.Overloads.Add(Member);
+        OverloadedProc.Overloads.Add(AProc);
+        ASection.Functions[i] := OverloadedProc;
+	ASection.Declarations[ASection.Declarations.IndexOf(Member)] :=
+	  OverloadedProc;
+      end;
+      exit;
+    end;
+  end;
+
+  // Not overloaded, so just add the proc/function to the lists
+  ASection.Declarations.Add(AProc);
+  ASection.Functions.Add(AProc);
+end;
+
+
+// Returns the parent for an element which is to be created
+function TPasParser.CheckIfOverloaded(AOwner: TPasClassType;
+  const AName: String): TPasElement;
+var
+  i: Integer;
+  Member: TPasElement;
+begin
+  for i := 0 to AOwner.Members.Count - 1 do
+  begin
+    Member := TPasElement(AOwner.Members[i]);
+    if CompareText(Member.Name, AName) = 0 then
+    begin
+      if Member.ClassType = TPasOverloadedProc then
+        Result := Member
+      else
+      begin
+        Result := TPasOverloadedProc.Create(AName, AOwner);
+        Result.Visibility := Member.Visibility;
+        TPasOverloadedProc(Result).Overloads.Add(Member);
+        AOwner.Members[i] := Result;
+      end;
+      exit;
+    end;
+  end;
+  Result := AOwner;
+end;
+
+
+procedure TPasParser.ParseMain(var Module: TPasModule);
+begin
+  NextToken;
+  case CurToken of
+    tkUnit: ParseUnit(Module);
+    else
+      ParseExc(Format(SParserExpectTokenError, ['unit']));
+  end;
+end;
+
+// Starts after the "unit" token
+procedure TPasParser.ParseUnit(var Module: TPasModule);
+var
+  CurBlock: TDeclType;
+  Section: TPasSection;
+  ConstEl: TPasConst;
+  ResStrEl: TPasResString;
+  TypeEl: TPasType;
+  ClassEl: TPasClassType;
+  List: TList;
+  i: Integer;
+  VarEl: TPasVariable;
+begin
+  Module := nil;
+  Module := TPasModule(Engine.
+    CreateElement(TPasModule, ExpectIdentifier, Engine.Package));
+  if Assigned(Engine.Package) then
+  begin
+    Module.PackageName := Engine.Package.Name;
+    Engine.Package.Modules.Add(Module);
+  end;
+  ExpectToken(tkSemicolon);
+  ExpectToken(tkInterface);
+  Section := TPasSection(Engine.CreateElement(TPasSection, '', Module));
+  Module.InterfaceSection := Section;
+  CurBlock := declNone;
+  while True do
+  begin
+    NextToken;
+    if CurToken = tkImplementation then
+      break;
+    case CurToken of
+      tkUses:
+	ParseUsesList(Section);
+      tkConst:
+        CurBlock := declConst;
+      tkResourcestring:
+        CurBlock := declResourcestring;
+      tkType:
+        CurBlock := declType;
+      tkVar:
+        CurBlock := declVar;
+      tkProcedure:
+        begin
+	  AddProcOrFunction(Section, ParseProcedureOrFunctionDecl(Section, False));
+	  CurBlock := declNone;
+	end;
+      tkFunction:
+        begin
+	  AddProcOrFunction(Section, ParseProcedureOrFunctionDecl(Section, True));
+	  CurBlock := declNone;
+	end;
+      tkOperator:
+        begin
+	  // !!!: Not supported yet
+	  i := 0;
+	  repeat
+	    NextToken;
+	    if CurToken = tkBraceOpen then
+	      Inc(i)
+	    else if CurToken = tkBraceClose then
+	      Dec(i);
+	  until (CurToken = tkSemicolon) and (i = 0);
+	  CurBlock := declNone;
+	end;
+      tkIdentifier:
+        begin
+	  case CurBlock of
+	    declConst:
+	      begin
+	        ConstEl := ParseConstDecl(Section);
+	        Section.Declarations.Add(ConstEl);
+		Section.Consts.Add(ConstEl);
+	      end;
+	    declResourcestring:
+	      begin
+	        ResStrEl := ParseResourcestringDecl(Section);
+	        Section.Declarations.Add(ResStrEl);
+		Section.ResStrings.Add(ResStrEl);
+	      end;
+	    declType:
+	      begin
+	        TypeEl := ParseTypeDecl(Section);
+		if Assigned(TypeEl) then	// !!!
+		begin
+	          Section.Declarations.Add(TypeEl);
+		  if TypeEl.ClassType = TPasClassType then
+		  begin
+		    // Remove previous forward declarations, if necessary
+		    for i := 0 to Section.Classes.Count - 1 do
+		    begin
+		      ClassEl := TPasClassType(Section.Classes[i]);
+		      if CompareText(ClassEl.Name, TypeEl.Name) = 0 then
+		      begin
+		        Section.Classes.Delete(i);
+			for i := 0 to Section.Declarations.Count - 1 do
+			  if CompareText(TypeEl.Name,
+			    TPasElement(Section.Declarations[i]).Name) = 0 then
+			  begin
+			    Section.Declarations.Delete(i);
+			    break;
+			  end;
+			ClassEl.Release;
+			break;
+		      end;
+		    end;
+		    // Add the new class to the class list
+		    Section.Classes.Add(TypeEl)
+		  end else
+		    Section.Types.Add(TypeEl);
+		end;
+	      end;
+	    declVar:
+	      begin
+	        List := TList.Create;
+		try
+		  ParseVarDecl(Section, List);
+		  for i := 0 to List.Count - 1 do
+		  begin
+		    VarEl := TPasVariable(List[i]);
+		    Section.Declarations.Add(VarEl);
+		    Section.Variables.Add(VarEl);
+		  end;
+		finally
+		  List.Free;
+		end;
+	      end;
+	  else
+	    ParseExc(SParserSyntaxError);
+	  end;
+	end;
+    else
+      ParseExc(SParserInterfaceTokenError);
+    end;
+  end;
+end;
+
+// Starts after the "uses" token
+procedure TPasParser.ParseUsesList(ASection: TPasSection);
+var
+  UnitName: String;
+  Element: TPasElement;
+begin
+  while True do
+  begin
+    UnitName := ExpectIdentifier;
+
+    Element := Engine.FindModule(UnitName);
+    if Assigned(Element) then
+      Element.AddRef
+    else
+      Element := TPasType(Engine.CreateElement(TPasUnresolvedTypeRef,
+	UnitName, ASection));
+    ASection.UsesList.Add(Element);
+
+    NextToken;
+    if CurToken = tkSemicolon then
+      break
+    else if CurToken <> tkComma then
+      ParseExc(SParserExpectedCommaSemicolon);
+  end;
+end;
+
+// Starts after the variable name
+function TPasParser.ParseConstDecl(Parent: TPasElement): TPasConst;
+begin
+  Result := TPasConst(Engine.CreateElement(TPasConst, CurTokenString, Parent));
+
+  NextToken;
+  if CurToken = tkColon then
+    Result.VarType := ParseType(nil)
+  else
+    UngetToken;
+
+  ExpectToken(tkEqual);
+  Result.Value := ParseExpression;
+  ExpectToken(tkSemicolon);
+end;
+
+// Starts after the variable name
+function TPasParser.ParseResourcestringDecl(Parent: TPasElement): TPasResString;
+begin
+  Result := TPasResString(
+    Engine.CreateElement(TPasResString, CurTokenString, Parent));
+  ExpectToken(tkEqual);
+  ExpectToken(tkString);
+  Result.Value := CurTokenString;
+  ExpectToken(tkSemicolon);
+end;
+
+// Starts after the type name
+function TPasParser.ParseTypeDecl(Parent: TPasElement): TPasType;
+var
+  TypeName: String;
+
+  procedure ParseRange;
+  begin
+    Result := TPasRangeType(Engine.CreateElement(TPasRangeType, TypeName, Parent));
+    TPasRangeType(Result).RangeStart := ParseExpression;
+    ExpectToken(tkDotDot);
+    TPasRangeType(Result).RangeEnd := ParseExpression;
+    ExpectToken(tkSemicolon);
+  end;
+
+var
+  EnumValue: TPasEnumValue;
+begin
+  TypeName := CurTokenString;
+  ExpectToken(tkEqual);
+  NextToken;
+  case CurToken of
+    tkRecord:
+      begin
+        Result := TPasRecordType(
+	  Engine.CreateElement(TPasRecordType, TypeName, Parent));
+        ParseRecordDecl(TPasRecordType(Result));
+      end;
+    tkPacked:
+      begin
+        Result := TPasRecordType(
+	  Engine.CreateElement(TPasRecordType, TypeName, Parent));
+	TPasRecordType(Result).IsPacked := True;
+        ExpectToken(tkRecord);
+	ParseRecordDecl(TPasRecordType(Result));
+      end;
+    tkObject:
+      Result := ParseClassDecl(Parent, TypeName, okObject);
+    tkClass:
+      Result := ParseClassDecl(Parent, TypeName, okClass);
+    tkInterface:
+      Result := ParseClassDecl(Parent, TypeName, okInterface);
+    tkCaret:
+      begin
+        Result := TPasPointerType(
+	  Engine.CreateElement(TPasPointerType, TypeName, Parent));
+	TPasPointerType(Result).DestType := ParseType(nil);
+	ExpectToken(tkSemicolon);
+      end;
+    tkIdentifier:
+      begin
+	NextToken;
+	if CurToken = tkSemicolon then
+	begin
+	  UngetToken;
+	  UngetToken;
+          Result := TPasAliasType(
+	    Engine.CreateElement(TPasAliasType, TypeName, Parent));
+	  TPasAliasType(Result).DestType := ParseType(nil);
+	  ExpectToken(tkSemicolon);
+	end else
+	begin
+	  UngetToken;
+	  UngetToken;
+	  ParseRange;
+	end;
+      end;
+{    _STRING, _FILE:
+      begin
+        Result := TPasAliasType(
+	  Engine.CreateElement(TPasAliasType, TypeName, Parent));
+	UngetToken;
+	TPasAliasType(Result).DestType := ParseType(nil);
+	ExpectToken(tkSemicolon);
+      end;}
+    tkArray:
+      begin
+        Result := TPasArrayType(
+	  Engine.CreateElement(TPasArrayType, TypeName, Parent));
+	ParseArrayType(TPasArrayType(Result));
+	ExpectToken(tkSemicolon);
+      end;
+    tkSet:
+      begin
+        Result := TPasSetType(
+	  Engine.CreateElement(TPasSetType, TypeName, Parent));
+	ExpectToken(tkOf);
+	TPasSetType(Result).EnumType := ParseType(Result);
+	ExpectToken(tkSemicolon);
+      end;
+    tkBraceOpen:
+      begin
+        Result := TPasEnumType(
+	  Engine.CreateElement(TPasEnumType, TypeName, Parent));
+        while True do
+        begin
+          NextToken;
+	  EnumValue := TPasEnumValue(
+	    Engine.CreateElement(TPasEnumValue, CurTokenString, Result));
+	  TPasEnumType(Result).Values.Add(EnumValue);
+	  NextToken;
+          if CurToken = tkBraceClose then
+            break
+	  else if CurToken <> tkComma then
+	    ParseExc(SParserExpectedCommaRBracket);
+        end;
+	ExpectToken(tkSemicolon);
+      end;
+    tkProcedure:
+      begin
+        Result := TPasProcedureType(
+	  Engine.CreateElement(TPasProcedureType, TypeName, Parent));
+	ParseProcedureOrFunctionHeader(Result,
+	  TPasProcedureType(Result), False, True);
+      end;
+    tkFunction:
+      begin
+        Result := Engine.CreateFunctionType(TypeName, Parent, False);
+	ParseProcedureOrFunctionHeader(Result,
+	  TPasFunctionType(Result), True, True);
+      end;
+    tkType:
+      begin
+        Result := TPasTypeAliasType(
+	  Engine.CreateElement(TPasTypeAliasType, TypeName, Parent));
+	TPasTypeAliasType(Result).DestType := ParseType(nil);
+	ExpectToken(tkSemicolon);
+      end;
+    else
+    begin
+      UngetToken;
+      ParseRange;
+    end;
+  end;
+end;
+
+// Starts after the variable name
+
+procedure TPasParser.ParseInlineVarDecl(Parent: TPasElement; VarList: TList);
+
+begin
+  ParseInlineVarDecl(Parent,Varlist,visDefault);
+end;
+
+procedure TPasParser.ParseInlineVarDecl(Parent: TPasElement; VarList: TList;
+  AVisibility : TPasMemberVisibility);
+var
+  VarNames: TStringList;
+  i: Integer;
+  VarType: TPasType;
+  VarEl: TPasVariable;
+begin
+  VarNames := TStringList.Create;
+  try
+    while True do
+    begin
+      VarNames.Add(CurTokenString);
+      NextToken;
+      if CurToken = tkColon then
+        break
+      else if CurToken <> tkComma then
+        ParseExc(SParserExpectedCommaColon);
+      ExpectIdentifier;
+    end;
+    VarType := ParseType(nil);
+    for i := 0 to VarNames.Count - 1 do
+    begin
+      VarEl := TPasVariable(
+        Engine.CreateElement(TPasVariable, VarNames[i], Parent, AVisibility));
+      VarEl.VarType := VarType;
+      if i > 0 then
+        VarType.AddRef;
+      VarList.Add(VarEl);
+    end;
+    NextToken;
+    // Records may be terminated with end, no semicolon
+    If (CurToken<>tkEnd) and (CurToken<>tkSemicolon) then
+      ParseExc(SParserExpectedSemiColonEnd)
+  finally
+    VarNames.Free;
+  end;
+end;
+
+// Starts after the variable name
+procedure TPasParser.ParseVarDecl(Parent: TPasElement; List: TList);
+var
+  i: Integer;
+  VarType: TPasType;
+  Value, S: String;
+  U,M: string;
+begin
+  while True do
+  begin
+    List.Add(Engine.CreateElement(TPasVariable, CurTokenString, Parent));
+    NextToken;
+    if CurToken = tkColon then
+      break
+    else if CurToken <> tkComma then
+      ParseExc(SParserExpectedCommaColon);
+    ExpectIdentifier;
+  end;
+  VarType := ParseComplexType;
+  for i := 0 to List.Count - 1 do
+  begin
+    TPasVariable(List[i]).VarType := VarType;
+    if i > 0 then
+      VarType.AddRef;
+  end;
+  NextToken;
+  If CurToken=tkEqual then
+    begin
+    Value := ParseExpression;
+    for i := 0 to List.Count - 1 do
+      TPasVariable(List[i]).Value := Value;
+    end
+  else
+    UngetToken;
+
+  NextToken;
+  if CurToken = tkAbsolute then
+  begin
+    // !!!: Store this information
+    ExpectIdentifier;
+  end else
+    UngetToken;
+
+  ExpectToken(tkSemicolon);
+  M := '';
+  while True do
+  begin
+    NextToken;
+    if CurToken = tkIdentifier then
+    begin
+      s := UpperCase(CurTokenText);
+      if s = 'CVAR' then
+      begin
+	M := M + '; cvar';
+	ExpectToken(tkSemicolon);
+      end else if (s = 'EXTERNAL') or (s = 'PUBLIC') or (s = 'EXPORT') then
+      begin
+        M := M + ';' + CurTokenText;
+        if s = 'EXTERNAL' then
+        begin
+          NextToken;
+	  if (CurToken = tkString) or (CurToken = tkIdentifier) then
+	  begin
+	    // !!!: Is this really correct for tkString?
+            M := M + ' ' + CurTokenText;
+            NextToken;
+          end;
+        end else
+          NextToken;
+
+	if (CurToken = tkIdentifier) and (UpperCase(CurTokenText) = 'NAME') then
+        begin
+          M := M + ' name ';
+          NextToken;
+          if (CurToken = tkString) or (CurToken = tkIdentifier) then
+	    // !!!: Is this really correct for tkString?
+            M := M + CurTokenText
+          else
+            ParseExc(SParserSyntaxError);  
+          ExpectToken(tkSemicolon);
+        end else if CurToken <> tkSemicolon then
+          ParseExc(SParserSyntaxError);  
+      end else
+      begin
+	UngetToken;
+	break;
+      end
+    end else
+    begin
+      UngetToken;
+      break;
+    end;
+  end; // while
+
+  if M <> '' then
+    for i := 0 to List.Count - 1 do
+      TPasVariable(List[i]).Modifiers := M;
+end;
+
+// Starts after the opening bracket token
+procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TList; EndToken: TToken);
+var
+  ArgNames: TStringList;
+  IsUntyped: Boolean;
+  Name, Value: String;
+  i: Integer;
+  Arg: TPasArgument;
+  Access: TArgumentAccess;
+  ArgType: TPasType;
+begin
+  while True do
+  begin
+    ArgNames := TStringList.Create;
+    Access := argDefault;
+    IsUntyped := False;
+    ArgType := nil;
+    while True do
+    begin
+      NextToken;
+      if CurToken = tkConst then
+      begin
+        Access := argConst;
+	Name := ExpectIdentifier;
+      end else if CurToken = tkVar then
+      begin
+        Access := ArgVar;
+	Name := ExpectIdentifier;
+      end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then
+      begin
+        Access := ArgOut;
+	Name := ExpectIdentifier;
+      end else if CurToken = tkIdentifier then
+        Name := CurTokenString
+      else
+        ParseExc(SParserExpectedConstVarID);
+      ArgNames.Add(Name);
+      NextToken;
+      if CurToken = tkColon then
+        break
+      else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and
+        (Access <> argDefault) then
+      begin
+	// found an untyped const or var argument
+	UngetToken;
+	IsUntyped := True;
+	break
+      end
+      else if CurToken <> tkComma then
+        ParseExc(SParserExpectedCommaColon);
+    end;
+    SetLength(Value, 0);
+    if not IsUntyped then
+    begin
+      ArgType := ParseType(nil);
+      NextToken;
+      if CurToken = tkEqual then
+      begin
+        Value := ParseExpression;
+      end else
+        UngetToken;
+    end;
+
+    for i := 0 to ArgNames.Count - 1 do
+    begin
+      Arg := TPasArgument(
+        Engine.CreateElement(TPasArgument, ArgNames[i], Parent));
+      Arg.Access := Access;
+      Arg.ArgType := ArgType;
+      if (i > 0) and Assigned(ArgType) then
+        ArgType.AddRef;
+      Arg.Value := Value;
+      Args.Add(Arg);
+    end;
+
+    ArgNames.Free;
+    NextToken;
+    if CurToken = EndToken then
+      break;
+  end;
+end;
+
+// Next token is expected to be a "(", ";" or for a function ":". The caller
+// will get the token after the final ";" as next token.
+procedure TPasParser.ParseProcedureOrFunctionHeader(Parent: TPasElement;
+  Element: TPasProcedureType; IsFunction, OfObjectPossible: Boolean);
+begin
+  NextToken;
+  if IsFunction then
+  begin
+    if CurToken = tkBraceOpen then
+    begin
+      ParseArgList(Parent, Element.Args, tkBraceClose);
+      ExpectToken(tkColon);
+    end else if CurToken <> tkColon then
+      ParseExc(SParserExpectedLBracketColon);
+    if Assigned(Element) then	// !!!
+      TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent)
+    else
+      ParseType(nil);
+  end else
+  begin
+    if CurToken = tkBraceOpen then
+    begin
+      ParseArgList(Element, Element.Args, tkBraceClose);
+    end else if (CurToken = tkSemicolon) or (OfObjectPossible and (CurToken = tkOf)) then
+      UngetToken
+    else
+      ParseExc(SParserExpectedLBracketSemicolon);
+  end;
+
+  NextToken;
+  if OfObjectPossible and (CurToken = tkOf) then
+  begin
+    ExpectToken(tkObject);
+    Element.IsOfObject := True;
+  end else
+    UngetToken;
+
+  ExpectToken(tkSemicolon);
+
+  while True do
+  begin
+    NextToken;
+    if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'CDECL') then
+    begin
+{      El['calling-conv'] := 'cdecl';}
+      ExpectToken(tkSemicolon);
+    end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'STDCALL') then
+    begin
+{      El['calling-conv'] := 'stdcall';}
+      ExpectToken(tkSemicolon);
+    end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'EXTERNAL') then
+    begin
+      repeat
+        NextToken
+      until CurToken = tkSemicolon;
+    end else if Parent.InheritsFrom(TPasProcedure) and
+      (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OVERLOAD') then
+    begin
+      TPasProcedure(Parent).IsOverload := True;
+      ExpectToken(tkSemicolon);
+    end else
+    begin
+      UngetToken;
+      break;
+    end;
+  end;
+end;
+
+// Starts after the "procedure" or "function" token
+function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement;
+  IsFunction: Boolean): TPasProcedure;
+var
+  Name: String;
+begin
+  Name := ExpectIdentifier;
+  if IsFunction then
+  begin
+    Result := TPasFunction(Engine.CreateElement(TPasFunction, Name, Parent));
+    Result.ProcType := Engine.CreateFunctionType('', Result, True);
+  end else
+  begin
+    Result := TPasProcedure(Engine.CreateElement(TPasProcedure, Name, Parent));
+    Result.ProcType := TPasProcedureType(
+      Engine.CreateElement(TPasProcedureType, '', Result));
+  end;
+
+  ParseProcedureOrFunctionHeader(Result, Result.ProcType, IsFunction, False);
+end;
+
+// Starts after the "record" token
+
+procedure TPasParser.ParseRecordDecl(Parent: TPasRecordType);
+
+Var 
+  CCount : Integer;
+
+begin
+  while True do
+  begin
+    if CurToken = tkEnd then
+      break;
+    NextToken;
+    if CurToken = tkEnd then
+      break
+    else if CurToken = tkCase then
+      begin
+      CCount:=0;
+      Repeat
+        NextToken;
+        If CurToken=tkBraceOpen then
+          inc(CCount)
+        else If CurToken=tkBraceClose then
+          Dec(CCount)
+      until (CCount=0) and (CurToken=tkEnd);
+      Break;
+      end
+    else  
+      ParseInlineVarDecl(Parent, Parent.Members);
+    end;
+  ExpectToken(tkSemicolon);
+end;
+
+// Starts after the "class" token
+function TPasParser.ParseClassDecl(Parent: TPasElement;
+  const AClassName: String; AObjKind: TPasObjKind): TPasType;
+var
+  CurVisibility: TPasMemberVisibility;
+
+  procedure ProcessMethod(const MethodTypeName: String; HasReturnValue: Boolean);
+  var
+    Owner: TPasElement;
+    Proc: TPasProcedure;
+    s: String;
+  begin
+    ExpectIdentifier;
+    Owner := CheckIfOverloaded(TPasClassType(Result), CurTokenString);
+    if HasReturnValue then
+    begin
+      Proc := TPasFunction(
+        Engine.CreateElement(TPasFunction, CurTokenString, Owner, CurVisibility));
+      Proc.ProcType := Engine.CreateFunctionType( '', Proc, True);
+    end else
+    begin
+      // !!!: The following is more than ugly
+      if MethodTypeName = 'constructor' then
+        Proc := TPasConstructor(
+	  Engine.CreateElement(TPasConstructor, CurTokenString, Owner, CurVisibility))
+      else if MethodTypeName = 'destructor' then
+        Proc := TPasDestructor(
+	  Engine.CreateElement(TPasDestructor, CurTokenString, Owner, CurVisibility))
+      else
+        Proc := TPasProcedure(
+	  Engine.CreateElement(TPasProcedure, CurTokenString, Owner, CurVisibility));
+      Proc.ProcType := TPasProcedureType(
+        Engine.CreateElement(TPasProcedureType, '', Proc, CurVisibility));
+    end;
+    if Owner.ClassType = TPasOverloadedProc then
+      TPasOverloadedProc(Owner).Overloads.Add(Proc)
+    else
+      TPasClassType(Result).Members.Add(Proc);
+
+    ParseProcedureOrFunctionHeader(Proc, Proc.ProcType, HasReturnValue, False);
+
+    while True do
+    begin
+      NextToken;
+      if CurToken = tkIdentifier then
+      begin
+        s := UpperCase(CurTokenString);
+	if s = 'VIRTUAL' then
+	  Proc.IsVirtual := True
+	else if s = 'DYNAMIC' then
+	  Proc.IsDynamic := True
+	else if s = 'ABSTRACT' then
+	  Proc.IsAbstract := True
+	else if s = 'OVERRIDE' then
+	  Proc.IsOverride := True
+	else if s = 'OVERLOAD' then
+	  Proc.IsOverload := True
+	else if s = 'MESSAGE' then
+	begin
+	  Proc.IsMessage := True;
+	  repeat
+	    NextToken;
+	  until CurToken = tkSemicolon;
+	  UngetToken;
+	end else if s = 'CDECL' then
+{      El['calling-conv'] := 'cdecl';}
+	else if s = 'STDCALL' then
+{      El['calling-conv'] := 'stdcall';}
+	else
+	begin
+	  UngetToken;
+	  break;
+	end;
+	ExpectToken(tkSemicolon);
+      end else
+      begin
+        UngetToken;
+        break;
+      end;
+    end;
+  end;
+
+  function GetAccessorName: String;
+  begin
+    ExpectIdentifier;
+    Result := CurTokenString;
+    while True do
+    begin
+      NextToken;
+      if CurToken = tkDot then
+      begin
+        ExpectIdentifier;
+	Result := Result + '.' + CurTokenString;
+      end else
+        break;
+    end;
+    UngetToken;
+  end;
+
+var
+  s: String;
+  i: Integer;
+  VarList: TList;
+  Element: TPasElement;
+begin
+
+  NextToken;
+
+  if (AObjKind = okClass) and (CurToken = tkOf) then
+  begin
+    Result := TPasClassOfType(
+      Engine.CreateElement(TPasClassOfType, AClassName, Parent));
+    ExpectIdentifier;
+    UngetToken;		// Only names are allowed as following type
+    TPasClassOfType(Result).DestType := ParseType(Result);
+    ExpectToken(tkSemicolon);
+    exit;
+  end;
+
+
+  Result := TPasClassType(
+    Engine.CreateElement(TPasClassType, AClassName, Parent));
+  TPasClassType(Result).ObjKind := AObjKind;
+
+  if CurToken = tkBraceOpen then
+  begin
+    TPasClassType(Result).AncestorType := ParseType(nil);
+    while True do
+    begin
+      NextToken;
+      if CurToken = tkBraceClose then
+        break;
+      UngetToken;
+      ExpectToken(tkComma);
+      ExpectIdentifier;
+      // !!!: Store interface name
+    end;
+    NextToken;
+  end;
+
+  if CurToken <> tkSemicolon then
+  begin
+    CurVisibility := visDefault;
+    while CurToken <> tkEnd do
+    begin
+      case CurToken of
+        tkIdentifier:
+	  begin
+	    s := LowerCase(CurTokenString);
+	    if s = 'private' then
+	      CurVisibility := visPrivate
+	    else if s = 'protected' then
+	      CurVisibility := visProtected
+	    else if s = 'public' then
+	      CurVisibility := visPublic
+	    else if s = 'published' then
+	      CurVisibility := visPublished
+	    else if s = 'automated' then
+	      CurVisibility := visAutomated
+	    else
+	    begin
+	      VarList := TList.Create;
+	      try
+	        ParseInlineVarDecl(Result, VarList, CurVisibility);
+	        for i := 0 to VarList.Count - 1 do
+		begin
+		  Element := TPasElement(VarList[i]);
+		  Element.Visibility := CurVisibility;
+		  TPasClassType(Result).Members.Add(Element);
+		end;
+	      finally
+	        VarList.Free;
+	      end;
+	    end;
+	  end;
+	tkProcedure:
+	  ProcessMethod('procedure', False);
+	tkFunction:
+	  ProcessMethod('function', True);
+	tkConstructor:
+	  ProcessMethod('constructor', False);
+	tkDestructor:
+	  ProcessMethod('destructor', False);
+	tkProperty:
+	  begin
+	    ExpectIdentifier;
+	    Element := Engine.CreateElement(TPasProperty,
+	      CurTokenString, Result, CurVisibility);
+	    TPasClassType(Result).Members.Add(Element);
+	    NextToken;
+	    // !!!: Parse array properties correctly
+	    if CurToken = tkSquaredBraceOpen then
+	    begin
+	      ParseArgList(Element, TPasProperty(Element).Args, tkSquaredBraceClose);
+	      NextToken;
+	    end;
+
+	    if CurToken = tkColon then
+	    begin
+  	      TPasProperty(Element).VarType := ParseType(Element);
+	      NextToken;
+	      if CurToken <> tkSemicolon then
+	      begin
+	        if (CurToken = tkIdentifier) and (UpperCase(CurTokenText) = 'READ') then
+	          TPasProperty(Element).ReadAccessorName := GetAccessorName
+	        else
+		  UngetToken;
+
+		NextToken;
+		if CurToken <> tkSemicolon then
+		begin
+	          if (CurToken = tkIdentifier) and (UpperCase(CurTokenText) = 'WRITE') then
+	            TPasProperty(Element).WriteAccessorName := GetAccessorName
+		  else
+		    UngetToken;
+
+		  NextToken;
+		  if CurToken <> tkSemicolon then
+		  begin
+		    if (CurToken = tkIdentifier) and (UpperCase(CurTokenText) = 'STORED') then
+		    begin
+		      NextToken;
+		      if CurToken = tkTrue then
+		        TPasProperty(Element).StoredAccessorName := 'True'
+		      else if CurToken = tkFalse then
+		        TPasProperty(Element).StoredAccessorName := 'False'
+		      else if CurToken = tkIdentifier then
+	                TPasProperty(Element).StoredAccessorName := CurTokenString
+		      else
+		        ParseExc(SParserSyntaxError);
+		    end else
+		      UngetToken;
+		  end;
+		end;
+	      end;
+	    end;
+	    NextToken;
+	    if (CurToken = tkIdentifier) and (UpperCase(CurTokenText) = 'DEFAULT') then
+	    begin
+	      NextToken;
+	      if CurToken = tkSemicolon then
+	      begin
+		TPasProperty(Element).IsDefault := True;
+		UngetToken;
+	      end else
+	      begin
+		UngetToken;
+	        TPasProperty(Element).DefaultValue := ParseExpression;
+	      end;
+	    end else
+	      UngetToken;
+	  end;
+      end;
+      NextToken;
+    end;
+    // Eat semicolon after class...end
+    ExpectToken(tkSemicolon);
+  end;
+end;
+
+
+function ParseSource(AEngine: TPasTreeContainer;
+  const FPCCommandLine: String): TPasModule;
+var
+  FileResolver: TFileResolver;
+  Parser: TPasParser;
+  Start, CurPos: PChar;
+  Filename: String;
+
+  procedure ProcessCmdLinePart;
+  var
+    l: Integer;
+    s: String;
+  begin
+    l := CurPos - Start;
+    SetLength(s, l);
+    if l > 0 then
+      Move(Start^, s[1], l)
+    else
+      exit;
+    if s[1] = '-' then
+    begin
+      if s[2] = 'F' then
+        if s[3] = 'i' then
+	  FileResolver.AddIncludePath(Copy(s, 4, Length(s)));
+    end else
+      if Filename <> '' then
+        raise Exception.Create(SErrMultipleSourceFiles)
+      else
+        Filename := s;
+  end;
+
+begin
+  FileResolver := TFileResolver.Create;
+  try
+    Filename := '';
+    Start := @FPCCommandLine[1];
+    CurPos := Start;
+    while CurPos[0] <> #0 do
+    begin
+      if CurPos[0] = ' ' then
+      begin
+        ProcessCmdLinePart;
+	Start := CurPos + 1;
+      end;
+      Inc(CurPos);
+    end;
+    ProcessCmdLinePart;
+
+    if Filename = '' then
+      raise Exception.Create(SErrNoSourceGiven);
+
+    Parser := TPasParser.Create(FileResolver, AEngine, Filename);
+    Parser.ParseMain(Result);
+    Parser.Free;
+  finally
+    FileResolver.Free;
+  end;
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}

fcl/passrc/pscanner.pp

@@ -0,0 +1,821 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal source lexical scanner
+    Copyright (c) 2003 by
+      Areca Systems GmbH / Sebastian Guenther, [email protected]
+
+    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 PScanner;
+
+interface
+
+uses SysUtils, Classes;
+
+resourcestring
+  SErrInvalidCharacter = 'Invalid character ''%s''';
+  SErrOpenString = 'String exceeds end of line';
+  SErrIncludeFileNotFound = 'Could not find include file ''%s''';
+
+type
+
+  TToken = (
+    tkEOF,
+    tkWhitespace,
+    tkComment,
+    tkIdentifier,
+    tkString,
+    tkNumber,
+    tkChar,
+    // Simple (one-character) tokens
+    tkBraceOpen,	// '('
+    tkBraceClose,	// ')'
+    tkMul,		// '*'
+    tkPlus,		// '+'
+    tkComma,		// ','
+    tkMinus,		// '-'
+    tkDot,		// '.'
+    tkDivision,		// '/'
+    tkColon,		// ':'
+    tkSemicolon,	// ';'
+    tkEqual,		// '='
+    tkSquaredBraceOpen,	// '['
+    tkSquaredBraceClose,// ']'
+    tkCaret,		// '^'
+    // Two-character tokens
+    tkDotDot,		// '..'
+    tkAssign,		// ':='
+    // Reserved words
+    tkabsolute,
+    tkand,
+    tkarray,
+    tkas,
+    tkasm,
+    tkbegin,
+    tkbreak,
+    tkcase,
+    tkclass,
+    tkconst,
+    tkconstructor,
+    tkcontinue,
+    tkdestructor,
+    tkdispose,
+    tkdiv,
+    tkdo,
+    tkdownto,
+    tkelse,
+    tkend,
+    tkexcept,
+    tkexit,
+    tkexports,
+    tkfalse,
+    tkfinalization,
+    tkfinally,
+    tkfor,
+    tkfunction,
+    tkgoto,
+    tkif,
+    tkimplementation,
+    tkin,
+    tkinherited,
+    tkinitialization,
+    tkinline,
+    tkinterface,
+    tkis,
+    tklabel,
+    tklibrary,
+    tkmod,
+    tknew,
+    tknil,
+    tknot,
+    tkobject,
+    tkof,
+    tkon,
+    tkoperator,
+    tkor,
+    tkpacked,
+    tkprocedure,
+    tkprogram,
+    tkproperty,
+    tkraise,
+    tkrecord,
+    tkrepeat,
+    tkResourceString,
+    tkself,
+    tkset,
+    tkshl,
+    tkshr,
+//    tkstring,
+    tkthen,
+    tkto,
+    tktrue,
+    tktry,
+    tktype,
+    tkunit,
+    tkuntil,
+    tkuses,
+    tkvar,
+    tkwhile,
+    tkwith,
+    tkxor);
+
+  TLineReader = class
+  public
+    function IsEOF: Boolean; virtual; abstract;
+    function ReadLine: String; virtual; abstract;
+  end;
+
+  TFileLineReader = class(TLineReader)
+  private
+    FTextFile: Text;
+    FileOpened: Boolean;
+  public
+    constructor Create(const AFilename: String);
+    destructor Destroy; override;
+    function IsEOF: Boolean; override;
+    function ReadLine: String; override;
+  end;
+
+  TFileResolver = class
+  private
+    FIncludePaths: TStringList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure AddIncludePath(const APath: String);
+    function FindSourceFile(const AName: String): TLineReader;
+    function FindIncludeFile(const AName: String): TLineReader;
+  end;
+
+  EScannerError = class(Exception);
+
+  TPascalScanner = class
+  private
+    FFileResolver: TFileResolver;
+    FCurSourceFile: TLineReader;
+    FCurFilename: String;
+    FCurRow: Integer;
+    FCurToken: TToken;
+    FCurTokenString: String;
+    FCurLine: String;
+    TokenStr: PChar;
+    FIncludeStack: TList;
+    function GetCurColumn: Integer;
+  protected
+    procedure Error(const Msg: String);
+    procedure Error(const Msg: String; Args: array of Const);
+    function DoFetchToken: TToken;
+  public
+    constructor Create(AFileResolver: TFileResolver; const AFilename: String);
+    destructor Destroy; override;
+    function FetchToken: TToken;
+
+    property FileResolver: TFileResolver read FFileResolver;
+    property CurSourceFile: TLineReader read FCurSourceFile;
+    property CurFilename: String read FCurFilename;
+
+    property CurLine: String read FCurLine;
+    property CurRow: Integer read FCurRow;
+    property CurColumn: Integer read GetCurColumn;
+
+    property CurToken: TToken read FCurToken;
+    property CurTokenString: String read FCurTokenString;
+  end;
+
+const
+  TokenInfos: array[TToken] of String = (
+    'EOF',
+    'Whitespace',
+    'Comment',
+    'Identifier',
+    'String',
+    'Number',
+    'Character',
+    '(',
+    ')',
+    '*',
+    '+',
+    ',',
+    '-',
+    '.',
+    '/',
+    ':',
+    ';',
+    '=',
+    '[',
+    ']',
+    '^',
+    '..',
+    ':=',
+    // Reserved words
+    'absolute',
+    'and',
+    'array',
+    'as',
+    'asm',
+    'begin',
+    'break',
+    'case',
+    'class',
+    'const',
+    'constructor',
+    'continue',
+    'destructor',
+    'dispose',
+    'div',
+    'do',
+    'downto',
+    'else',
+    'end',
+    'except',
+    'exit',
+    'exports',
+    'false',
+    'finalization',
+    'finally',
+    'for',
+    'function',
+    'goto',
+    'if',
+    'implementation',
+    'in',
+    'inherited',
+    'initialization',
+    'inline',
+    'interface',
+    'is',
+    'label',
+    'library',
+    'mod',
+    'new',
+    'nil',
+    'not',
+    'object',
+    'of',
+    'on',
+    'operator',
+    'or',
+    'packed',
+    'procedure',
+    'program',
+    'property',
+    'raise',
+    'record',
+    'repeat',
+    'resourcestring',
+    'self',
+    'set',
+    'shl',
+    'shr',
+//    'string',
+    'then',
+    'to',
+    'true',
+    'try',
+    'type',
+    'unit',
+    'until',
+    'uses',
+    'var',
+    'while',
+    'with',
+    'xor'
+  );
+
+
+implementation
+
+type
+  TIncludeStackItem = class
+    SourceFile: TLineReader;
+    Filename: String;
+    Token: TToken;
+    TokenString: String;
+    Line: String;
+    Row: Integer;
+    TokenStr: PChar;
+  end;
+
+
+constructor TFileLineReader.Create(const AFilename: String);
+begin
+  inherited Create;
+  Assign(FTextFile, AFilename);
+  Reset(FTextFile);
+  FileOpened := True;
+end;
+
+destructor TFileLineReader.Destroy;
+begin
+  if FileOpened then
+    Close(FTextFile);
+  inherited Destroy;
+end;
+
+function TFileLineReader.IsEOF: Boolean;
+begin
+  Result := EOF(FTextFile);
+end;
+
+function TFileLineReader.ReadLine: String;
+begin
+  ReadLn(FTextFile, Result);
+end;
+
+
+constructor TFileResolver.Create;
+begin
+  inherited Create;
+  FIncludePaths := TStringList.Create;
+end;
+
+destructor TFileResolver.Destroy;
+begin
+  FIncludePaths.Free;
+  inherited Destroy;
+end;
+
+procedure TFileResolver.AddIncludePath(const APath: String);
+begin
+  FIncludePaths.Add(IncludeTrailingPathDelimiter(APath));
+end;
+
+function TFileResolver.FindSourceFile(const AName: String): TLineReader;
+begin
+  try
+    Result := TFileLineReader.Create(AName);
+  except
+    Result := nil;
+  end;
+end;
+
+function TFileResolver.FindIncludeFile(const AName: String): TLineReader;
+var
+  i: Integer;
+begin
+  Result := nil;
+  try
+    Result := TFileLineReader.Create(AName);
+  except
+    for i := 0 to FIncludePaths.Count - 1 do
+      try
+        Result := TFileLineReader.Create(FIncludePaths[i] + AName);
+	break;
+      except
+      end;
+  end;
+end;
+
+
+constructor TPascalScanner.Create(AFileResolver: TFileResolver;
+  const AFilename: String);
+begin
+  inherited Create;
+  FFileResolver := AFileResolver;
+  FCurSourceFile := FileResolver.FindSourceFile(AFilename);
+  FCurFilename := AFilename;
+  FIncludeStack := TList.Create;
+end;
+
+destructor TPascalScanner.Destroy;
+begin
+  // Dont' free the first element, because it is CurSourceFile
+  while FIncludeStack.Count > 1 do
+    TFileResolver(FIncludeStack[1]).Free;
+  FIncludeStack.Free;
+
+  CurSourceFile.Free;
+  inherited Destroy;
+end;
+
+function TPascalScanner.FetchToken: TToken;
+var
+  IncludeStackItem: TIncludeStackItem;
+begin
+  while True do
+  begin
+    Result := DoFetchToken;
+    if FCurToken = tkEOF then
+      if FIncludeStack.Count > 0 then
+      begin
+        CurSourceFile.Free;
+	IncludeStackItem :=
+	  TIncludeStackItem(FIncludeStack[FIncludeStack.Count - 1]);
+	FIncludeStack.Delete(FIncludeStack.Count - 1);
+	FCurSourceFile := IncludeStackItem.SourceFile;
+	FCurFilename := IncludeStackItem.Filename;
+	FCurToken := IncludeStackItem.Token;
+	FCurTokenString := IncludeStackItem.TokenString;
+	FCurLine := IncludeStackItem.Line;
+	FCurRow := IncludeStackItem.Row;
+	TokenStr := IncludeStackItem.TokenStr;
+	IncludeStackItem.Free;
+	Result := FCurToken;
+      end else
+        break
+    else
+      break;
+  end;
+end;
+
+procedure TPascalScanner.Error(const Msg: String);
+begin
+  raise EScannerError.Create(Msg);
+end;
+
+procedure TPascalScanner.Error(const Msg: String; Args: array of Const);
+begin
+  raise EScannerError.CreateFmt(Msg, Args);
+end;
+
+function TPascalScanner.DoFetchToken: TToken;
+
+  function FetchLine: Boolean;
+  begin
+    if CurSourceFile.IsEOF then
+    begin
+      FCurLine := '';
+      TokenStr := nil;
+      Result := False;
+    end else
+    begin
+      FCurLine := CurSourceFile.ReadLine;
+      TokenStr := PChar(CurLine);
+      Result := True;
+      Inc(FCurRow);
+    end;
+  end;
+
+var
+  TokenStart, CurPos: PChar;
+  i: TToken;
+  OldLength, SectionLength, NestingLevel: Integer;
+  Directive, Param: String;
+  IncludeStackItem: TIncludeStackItem;
+begin
+  if TokenStr = nil then
+    if not FetchLine then
+    begin
+      Result := tkEOF;
+      FCurToken := Result;
+      exit;
+    end;
+
+  FCurTokenString := '';
+
+  case TokenStr[0] of
+    #0:		// Empty line
+      begin
+        FetchLine;
+        Result := tkWhitespace;
+      end;
+    #9, ' ':
+      begin
+	Result := tkWhitespace;
+        repeat
+	  Inc(TokenStr);
+	  if TokenStr[0] = #0 then
+	    if not FetchLine then
+	    begin
+	      FCurToken := Result;
+	      exit;
+	    end;
+	until not (TokenStr[0] in [#9, ' ']);
+      end;
+    '#':
+      begin
+        TokenStart := TokenStr;
+	Inc(TokenStr);
+	if TokenStr[0] = '$' then
+	begin
+	  Inc(TokenStr);
+	  repeat
+	    Inc(TokenStr);
+	  until not (TokenStr[0] in ['0'..'9', 'A'..'F', 'a'..'F']);
+	end else
+	  repeat
+	    Inc(TokenStr);
+	  until not (TokenStr[0] in ['0'..'9']);
+
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkChar;
+      end;
+    '$':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['0'..'9', 'A'..'F', 'a'..'F']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkNumber;
+      end;
+    '''':
+      begin
+        Inc(TokenStr);
+        TokenStart := TokenStr;
+	OldLength := 0;
+	FCurTokenString := '';
+
+	while True do
+	begin
+	  if TokenStr[0] = '''' then
+	    if TokenStr[1] = '''' then
+	    begin
+	      SectionLength := TokenStr - TokenStart + 1;
+	      SetLength(FCurTokenString, OldLength + SectionLength);
+	      if SectionLength > 1 then
+	        Move(TokenStart^, FCurTokenString[OldLength + 1],
+		  SectionLength);
+	      Inc(OldLength, SectionLength);
+	      Inc(TokenStr);
+	      TokenStart := TokenStr;
+	    end else
+	      break;
+
+	  if TokenStr[0] = #0 then
+	    Error(SErrOpenString);
+
+	  Inc(TokenStr);
+	end;
+
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, OldLength + SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
+
+	Inc(TokenStr);
+	Result := tkString;
+      end;
+    '(':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '*' then
+	begin
+	  // Old-style multi-line comment
+	  Inc(TokenStr);
+          while (TokenStr[0] <> '*') or (TokenStr[1] <> ')') do
+	  begin
+	    if TokenStr[0] = #0 then
+	    begin
+	      if not FetchLine then
+	      begin
+	        Result := tkEOF;
+	        FCurToken := Result;
+	        exit;
+	      end;
+	    end else
+	      Inc(TokenStr);
+	  end;
+	  Inc(TokenStr, 2);
+	  Result := tkComment;
+        end else
+	  Result := tkBraceOpen;
+      end;
+    ')':
+      begin
+        Inc(TokenStr);
+	Result := tkBraceClose;
+      end;
+    '*':
+      begin
+        Inc(TokenStr);
+	Result := tkMul;
+      end;
+    '+':
+      begin
+        Inc(TokenStr);
+	Result := tkPlus;
+      end;
+    ',':
+      begin
+        Inc(TokenStr);
+	Result := tkComma;
+      end;
+    '-':
+      begin
+        Inc(TokenStr);
+	Result := tkMinus;
+      end;
+    '.':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '.' then
+	begin
+	  Inc(TokenStr);
+	  Result := tkDotDot;
+	end else
+	  Result := tkDot;
+      end;
+    '/':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '/' then	// Single-line comment
+	begin
+	  Inc(TokenStr);
+	  TokenStart := TokenStr;
+	  FCurTokenString := '';
+          while TokenStr[0] <> #0 do
+	    Inc(TokenStr);
+	  SectionLength := TokenStr - TokenStart;
+	  SetLength(FCurTokenString, SectionLength);
+	  if SectionLength > 0 then
+	    Move(TokenStart^, FCurTokenString[1], SectionLength);
+	  Result := tkComment;
+	  //WriteLn('Einzeiliger Kommentar: "', CurTokenString, '"');
+	end else
+	  Result := tkDivision;
+      end;
+    '0'..'9':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['0'..'9', '.', 'e', 'E']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkNumber;
+      end;
+    ':':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '=' then
+	begin
+	  Inc(TokenStr);
+	  Result := tkAssign;
+	end else
+          Result := tkColon;
+      end;
+    ';':
+      begin
+        Inc(TokenStr);
+        Result := tkSemicolon;
+      end;
+    '=':
+      begin
+        Inc(TokenStr);
+        Result := tkEqual;
+      end;
+    '[':
+      begin
+        Inc(TokenStr);
+	Result := tkSquaredBraceOpen;
+      end;
+    ']':
+      begin
+        Inc(TokenStr);
+	Result := tkSquaredBraceClose;
+      end;
+    '^':
+      begin
+        Inc(TokenStr);
+	Result := tkCaret;
+      end;
+    '{':	// Multi-line comment
+      begin
+        Inc(TokenStr);
+	TokenStart := TokenStr;
+	FCurTokenString := '';
+	OldLength := 0;
+	NestingLevel := 0;
+        while (TokenStr[0] <> '}') or (NestingLevel > 0) do
+	begin
+	  if TokenStr[0] = #0 then
+	  begin
+	    SectionLength := TokenStr - TokenStart + 1;
+	    SetLength(FCurTokenString, OldLength + SectionLength);
+	    if SectionLength > 1 then
+	      Move(TokenStart^, FCurTokenString[OldLength + 1],
+	        SectionLength - 1);
+	    Inc(OldLength, SectionLength);
+	    FCurTokenString[OldLength] := #10;
+	    if not FetchLine then
+	    begin
+	      Result := tkEOF;
+	      FCurToken := Result;
+	      exit;
+	    end;
+	    TokenStart := TokenStr;
+	  end else
+	  begin
+	    if TokenStr[0] = '{' then
+	      Inc(NestingLevel)
+	    else if TokenStr[0] = '}' then
+	      Dec(NestingLevel);
+	    Inc(TokenStr);
+	  end;
+	end;
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, OldLength + SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
+	Inc(TokenStr);
+	Result := tkComment;
+	//WriteLn('Kommentar: "', CurTokenString, '"');
+	if (Length(CurTokenString) > 0) and (CurTokenString[1] = '$') then
+	begin
+	  TokenStart := @CurTokenString[2];
+	  CurPos := TokenStart;
+	  while (CurPos[0] <> ' ') and (CurPos[0] <> #0) do
+	    Inc(CurPos);
+	  SectionLength := CurPos - TokenStart;
+	  SetLength(Directive, SectionLength);
+	  if SectionLength > 0 then
+	  begin
+	    Move(TokenStart^, Directive[1], SectionLength);
+	    Directive := UpperCase(Directive);
+	    if CurPos[0] <> #0 then
+	    begin
+	      TokenStart := CurPos + 1;
+	      CurPos := TokenStart;
+	      while CurPos[0] <> #0 do
+	        Inc(CurPos);
+	      SectionLength := CurPos - TokenStart;
+	      SetLength(Param, SectionLength);
+	      if SectionLength > 0 then
+	        Move(TokenStart^, Param[1], SectionLength);
+	    end else
+	      Param := '';
+  	    // WriteLn('Direktive: "', Directive, '", Param: "', Param, '"');
+	    if (Directive = 'I') or (Directive = 'INCLUDE') then
+	    begin
+	      IncludeStackItem := TIncludeStackItem.Create;
+	      IncludeStackItem.SourceFile := CurSourceFile;
+	      IncludeStackItem.Filename := CurFilename;
+	      IncludeStackItem.Token := CurToken;
+	      IncludeStackItem.TokenString := CurTokenString;
+	      IncludeStackItem.Line := CurLine;
+	      IncludeStackItem.Row := CurRow;
+	      IncludeStackItem.TokenStr := TokenStr;
+	      FIncludeStack.Add(IncludeStackItem);
+	      FCurSourceFile := FileResolver.FindIncludeFile(Param);
+	      if not Assigned(CurSourceFile) then
+	        Error(SErrIncludeFileNotFound, [Param]);
+	      FCurFilename := Param;
+	      FCurRow := 0;
+	    end;
+	  end else
+	    Directive := '';
+	end;
+      end;
+    'A'..'Z', 'a'..'z', '_':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+
+	// Check if this is a keyword or identifier
+	// !!!: Optimize this!
+	for i := tkAbsolute to tkXOR do
+	  if CompareText(CurTokenString, TokenInfos[i]) = 0 then
+	  begin
+	    Result := i;
+	    FCurToken := Result;
+	    exit;
+	  end;
+
+	Result := tkIdentifier;
+      end;
+  else
+    Error(SErrInvalidCharacter, [TokenStr[0]]);
+  end;
+
+  FCurToken := Result;
+end;
+
+function TPascalScanner.GetCurColumn: Integer;
+begin
+  Result := TokenStr - PChar(CurLine);
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}