From 3134acd50677b4db7baee9760cbc1060eb841d9f Mon Sep 17 00:00:00 2001 From: florian Date: Wed, 24 Aug 2005 18:37:20 +0000 Subject: [PATCH] * rtl part of gba port git-svn-id: trunk@935 - --- .gitattributes | 5 + rtl/gba/Makefile.fpc | 279 ++++++++++ rtl/gba/fpc4gba.txt | 159 ++++++ rtl/gba/prt0.as | 101 ++++ rtl/gba/sysgba.pp | 1 + rtl/gba/system.pp | 295 ++++++++++ rtl/gba/unix.pp | 1250 ++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 2090 insertions(+) create mode 100644 rtl/gba/Makefile.fpc create mode 100644 rtl/gba/fpc4gba.txt create mode 100644 rtl/gba/prt0.as create mode 100644 rtl/gba/sysgba.pp create mode 100644 rtl/gba/system.pp create mode 100644 rtl/gba/unix.pp diff --git a/.gitattributes b/.gitattributes index 9d83056d64..cbd46bd4b0 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3370,6 +3370,11 @@ rtl/freebsd/unxsockh.inc svneol=native#text/plain rtl/freebsd/unxsysc.inc svneol=native#text/plain rtl/freebsd/x86_64/bsyscall.inc svneol=native#text/plain rtl/freebsd/x86_64/prt0.as -text +rtl/gba/Makefile.fpc svneol=native#text/plain +rtl/gba/prt0.as -text +rtl/gba/sysgba.pp svneol=native#text/plain +rtl/gba/system.pp svneol=native#text/plain +rtl/gba/unix.pp svneol=native#text/plain rtl/go32v2/Makefile svneol=native#text/plain rtl/go32v2/Makefile.fpc svneol=native#text/plain rtl/go32v2/classes.pp svneol=native#text/plain diff --git a/rtl/gba/Makefile.fpc b/rtl/gba/Makefile.fpc new file mode 100644 index 0000000000..ece5dd5199 --- /dev/null +++ b/rtl/gba/Makefile.fpc @@ -0,0 +1,279 @@ +# +# Makefile.fpc for Free Pascal GBA RTL +# + +[package] +main=rtl + +[target] +loaders=prt0 +units=$(SYSTEMUNIT) unixtype ctypes baseunix strings objpas macpas syscall unixutil \ + heaptrc lineinfo \ + sysutils typinfo math \ + charset getopts \ + errors \ + types dateutils sysconst \ + cthreads classes strutils rtlconsts dos objects + +rsts=math typinfo sysconst rtlconsts + +[require] +nortl=y + +[clean] +units=sysgba gba + +[install] +fpcpackage=y + +[default] +fpcdir=../.. +target=gba + +[compiler] +includedir=$(INC) $(PROCINC) $(UNIXINC) $(CPU_TARGET) +sourcedir=$(INC) $(PROCINC) $(UNIXINC) $(CPU_TARGET) +targetdir=. + +[lib] +libname=libfprtl.so +libversion=2.0.0 +libunits=$(SYSTEMUNIT) objpas strings \ + unix ports \ + dos crt objects printer \ + sysutils typinfo math \ + cpu mmx getopts heaptrc \ + errors + +[prerules] +RTL=.. +INC=$(RTL)/inc +PROCINC=$(RTL)/$(CPU_TARGET) +UNIXINC=$(RTL)/unix + +ifeq ($(CPU_TARGET),i386) +CRT21=cprt21 gprt21 +CPU_UNITS=x86 ports cpu mmx graph +else +CPU_UNITS= +endif + +UNITPREFIX=rtl + +ifeq ($(findstring 1.0.,$(FPC_VERSION)),) +SYSTEMUNIT=system +LINUXUNIT1= +ifeq ($(CPU_TARGET),i386) +CPU_UNITS+=oldlinux +endif +LINUXUNIT2=linux +else +SYSTEMUNIT=sysgba +LINUXUNIT1=gba +LINUXUNIT2= +override FPCOPT+=-dUNIX +endif + +# Use new feature from 1.0.5 version +# that generates release PPU files +# which will not be recompiled +ifdef RELEASE +override FPCOPT+=-Ur +endif + +# Paths +OBJPASDIR=$(RTL)/objpas +#GRAPHDIR=$(INC)/graph + +# Use new graph unit ? +# NEWGRAPH=YES +# Use LibGGI ? +# Use +# +ifndef USELIBGGI +USELIBGGI=NO +endif + +[rules] +# Get the $(SYSTEMUNIT) independent include file names. +# This will set the following variables : +# SYSINCNAMES +include $(INC)/makefile.inc +SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) + +# Get the processor dependent include file names. +# This will set the following variables : +# CPUINCNAMES +include $(PROCINC)/makefile.cpu +SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) + +# Put $(SYSTEMUNIT) unit dependencies together. +SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) + + +# +# Loaders +# + +prt0$(OEXT) : $(CPU_TARGET)/prt0.as + $(AS) -o $(UNITTARGETDIRPREFIX)prt0$(OEXT) $(CPU_TARGET)/prt0.as + + +# +# $(SYSTEMUNIT) Units ($(SYSTEMUNIT), Objpas, Strings) +# + +$(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pp $(SYSDEPS) + $(COMPILER) -Us -Sg $(SYSTEMUNIT).pp + +objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp + +dateutils$(PPUEXT): $(OBJPASDIR)/dateutils.pp $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/dateutils.pp + +strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\ + $(PROCINC)/strings.inc $(PROCINC)/stringss.inc\ + $(SYSTEMUNIT)$(PPUEXT) + +# +# $(SYSTEMUNIT) Dependent Units +# + +#unix$(PPUEXT) : unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \ +# unxconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \ +# unxfunc.inc + +unixtype$(PPUEXT) : $(UNIXINC)/unixtype.pp ptypes.inc $(UNIXINC)/ctypes.inc $(SYSTEMUNIT)$(PPUEXT) + +baseunix$(PPUEXT) : errno.inc ptypes.inc $(UNIXINC)/ctypes.inc \ + $(UNIXINC)/bunxh.inc \ + bunxsysc.inc $(CPU_TARGET)/syscallh.inc $(CPU_TARGET)/sysnr.inc \ + ostypes.inc osmacro.inc $(UNIXINC)/gensigset.inc \ + $(UNIXINC)/genfuncs.inc $(SYSTEMUNIT)$(PPUEXT) + +ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT) + +#dl$(PPUEXT) : $(UNIXINC)/dl.pp $(SYSTEMUNIT)$(PPUEXT) + +#dynlibs$(PPUEXT) : $(INC)/dynlibs.pp $(UNIXINC)/dynlibs.inc dl$(PPUEXT) objpas$(PPUEXT) + +# +# TP7 Compatible RTL Units +# + +dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \ + unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +#crt$(PPUEXT) : crt.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT) + +#printer$(PPUEXT) : printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +# +# Graph +# +#include $(GRAPHDIR)/makefile.inc +#GRAPHINCDEPS=$(addprefix $(GRAPHDIR)/,$(GRAPHINCNAMES)) + +#graph$(PPUEXT) : graph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ +# $(GRAPHINCDEPS) $(UNIXINC)/graph16.inc +# $(COMPILER) -I$(GRAPHDIR) $(UNIXINC)/graph.pp + +#ggigraph$(PPUEXT) : $(UNIXINC)/ggigraph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ +# $(GRAPHINCDEPS) +# $(COMPILER) -I$(GRAPHDIR) $(UNIXINC)/ggigraph.pp + +# +# Delphi Compatible Units +# + +sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \ + objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT) sysconst$(PPUEXT) + $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp + +classes$(PPUEXT) : $(UNIXINC)/classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \ + sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) + $(COMPILER) -Fi$(OBJPASDIR)/classes $(UNIXINC)/classes.pp + +typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT) sysutils$(PPUEXT) rtlconsts$(PPUEXT) + $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp + +math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/math.pp + +gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/gettext.pp + +#varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \ +# $(OBJPASDIR)/varutilh.inc varutils.pp sysutils$(PPUEXT) +# $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/varutils.pp + +#variants$(PPUEXT) : $(INC)/variants.pp sysutils$(PPUEXT) sysconst$(PPUEXT) varutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) +# $(COMPILER) -Fi$(INC) $(INC)/variants.pp + +types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/types.pp + +sysconst$(PPUEXT) : $(OBJPASDIR)/sysconst.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/sysconst.pp + +rtlconsts$(PPUEXT) : $(OBJPASDIR)/rtlconsts.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/rtlconsts.pp + +strutils$(PPUEXT) : $(OBJPASDIR)/strutils.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \ + sysutils$(PPUEXT) + $(COMPILER) $(OBJPASDIR)/strutils.pp + +# +# Mac Pascal Model +# + +#macpas$(PPUEXT) : $(INC)/macpas.pp $(SYSTEMUNIT)$(PPUEXT) +# $(COMPILER) $(INC)/macpas.pp $(REDIR) + +# +# Other $(SYSTEMUNIT)-independent RTL Units +# + +cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMUNIT)$(PPUEXT) + +#mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT) + +heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) -Sg $(INC)/heaptrc.pp + +lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) + +charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT) + +#ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +# +# Other $(SYSTEMUNIT)-dependent RTL Units +# + +#sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \ +# unixsock.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +#ipc$(PPUEXT) : ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + +#terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT) + +callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) + +cmem$(PPUEXT) : $(INC)/cmem.pp $(SYSTEMUNIT)$(PPUEXT) + +cthreads$(PPUEXT) : $(UNIXINC)/cthreads.pp $(SYSTEMUNIT)$(PPUEXT) + +#cwstring$(PPUEXT) : $(UNIXINC)/cwstring.pp $(SYSTEMUNIT)$(PPUEXT) sysutils$(PPUEXT) baseunix$(PPUEXT) unix$(PPUEXT) unixtype$(PPUEXT) ctypes$(PPUEXT) + +#gpm$(PPUEXT): gpm.pp unix$(PPUEXT) baseunix$(PPUEXT) sockets$(PPUEXT) + +ctypes$(PPUEXT) : $(INC)/ctypes.pp $(SYSTEMUNIT)$(PPUEXT) + diff --git a/rtl/gba/fpc4gba.txt b/rtl/gba/fpc4gba.txt new file mode 100644 index 0000000000..a02d714c46 --- /dev/null +++ b/rtl/gba/fpc4gba.txt @@ -0,0 +1,159 @@ ++-------------------------------------+ +| Let's build a gba compiler with fpc | ++-------------------------------------+ +| Author: Francesco Lombardi | +| Release date: 2005.08.09 | ++-------------------------------------+ + + +Tools needed +------------ +-FPC compiler for your platform, ver 2.0.0 (http://www.freepascal.org/) +-FPC sources, ver 2.0.0 (http://www.freepascal.org/) +-MSYS (http://www.mingw.org/msys.shtml) +-An emulator with integrated debugger or, at least, a memory viewer, like +Boycott Advance (http://www.ngemu.com/gba/bca.php main site does not work) +or Visual Boy Advance Development version (http://vba.ngemu.com/) + + +Foreword +-------- +I'l use MSYS, because I'm confortable with POSIX-like ambient. It is a fork of +cygwin, but more friendly for win32 users. However, feel free to use dos prompt +if you like it. Remember that MSYS includes GNU Make utility, that is needed in +order to build freepascal. +In the source files provided with this package, you can find occasionally some +comments, that explain the changes made. + + +Preparing all things +-------------------- +Install fpc compiler as usual in a directory of your choice (eg. c:\fpc); +extract fpc sources in fpc binaries directory (eg. c:\fpc\source). If you +decided for MSYS, install it. + + +Compiler modification +--------------------- +Copy the files you found in "Compiler" directory of this package, following this +scheme: + - t_gba.pas in %FreePascal%\source\compiler\systems + - i_gba.pas in %FreePascal%\source\compiler\systems + - cputarg.pas in %FreePascal%\source\compiler\arm + - compiler.pas in %FreePascal%\source\compiler + - systems.pas in %FreePascal%\source\compiler +Now open msys (or a dos prompt), go to %FreePascal%\source\compiler and run +"make PPC_TARGET=arm". +Go to %FreePascal%\bin\i386-win32, make a new directory 'arm-gba' and copy here +the new generated file ppcarm.exe. Extract and copy here the files in +win32_arm_binutils.zip (ls.exe, ld.exe, objcopy.exe and cygwin1.dll). Now add +'%FreePascal%\bin\i386-win32\arm-gba' in the search path. + + +FPCMake modification +-------------------- +Copy the files you found in "FPCMake" directory of this package in the directory + + %FreePascal%\source\utils\fpcm + +In msys (or a dos prompt), go to %FreePascal%\source\utils\fpcm and run +"make". Go to %FreePascal%\bin\i386-win32 and copy here the new generated file +fpcmake.exe. This utility is useful when you try to build the rtl, because it +generates all makefiles starting from a smuch more simple makefile.fpc. + + +RTL Modification +---------------- +Go in %FreePascal%\source\rtl, make a copy of 'linux' directory and rename it +'gba'. Go in the new created 'gba' and delete all subdirectories, except 'arm'. +Delete the files system.pp, syslinux.pp, makefile and makefile.fpc. Go in 'arm' +subdirectory and delete all .as files. +Copy the files you found in "RTL" directory of this package, following this +scheme: + - system.pp in %FreePascal%\source\rtl\gba + - sysgba.pp in %FreePascal%\source\rtl\gba + - makefile.fpc in %FreePascal%\source\rtl\gba + - prt0.as in %FreePascal%\source\rtl\gba\arm + - unix.pp in %FreePascal%\source\rtl\unix + +Go to %FreePascal%\source\rtl, open makefile.fpc and add a new target: + + ... + ... + [target] + ... + dirs_gba=gba + +In msys (or a dos prompt), go to %FreePascal%\source\rtl and run +"fpcmake -Tall -r -w": this command rebuild all makefiles. Now do a "make +distclean", then run 'make CPU_TARGET=arm OS_TARGET=gba PP=ppcarm OPT="-Tgba"' +At the end of the compiling, you can find a new directory: + + %FreePascal%\source\rtl\units\arm-gba + +Copy the directory 'arm-gba' and all its content in + + %FreePascal%\units + + +Ending +------ +Now you can try to compile some pascal code, like the examples in the package: + + ppcarm -Tgba -n -Fuc:\fpc\units\arm-gba gba.pp + +Look at compile.bat. It produces a gba.gba file, but if you try to run on a gba +emu, it does not work (you must see if 0x04000000 address contains 0x0403). + +At this point you can try a trick: remove from gba.s the following lines: + +line Asm Code +---- -------- +... +[22] bl FPC_INITIALIZEUNITS +... +[40] bl FPC_DO_EXIT +... +[57] .globl THREADVARLIST_P$GBA +[58] THREADVARLIST_P$GBA: +[59] .long 0 +[60] .Le1: +[61] .size THREADVARLIST_P$GBA, .Le1 - THREADVARLIST_P$GBA +[62] .balign 4 +[63] .globl FPC_THREADVARTABLES +[64] FPC_THREADVARTABLES: +[65] .long 2 +[66] .long THREADVARLIST_SYSTEM +[67] .long THREADVARLIST_P$GBA +[68] .Le2: +[69] .size FPC_THREADVARTABLES, .Le2 - FPC_THREADVARTABLES +[70] .balign 4 +[71] .globl FPC_RESOURCESTRINGTABLES +[72] FPC_RESOURCESTRINGTABLES: +[73] .long 0 +[74] .Le3: +[75] .size FPC_RESOURCESTRINGTABLES, .Le3 - FPC_RESOURCESTRINGTABLES +[76] .balign 4 +[77] .globl INITFINAL +[78] INITFINAL: +[79] .long 1,0 +[80] .long INIT$_SYSTEM +[81] .long FINALIZE$_SYSTEM +[82] .Le4: +[83] .size INITFINAL, .Le4 - INITFINAL +[84] .balign 4 + +This 'garbage' (sorry fpk ^_^) is initialization code added from fpc compiler, +but interferes with our initialization code. +Now run compile2.bat; the gba.gba file runs fine in the emu (flags correctly +set, rom header good). + + +Next steps? +----------- +Well, we need some further rtl hacking to handle fpc initialization code, that's +beyond my knowledge. You can try to download a pdf with fpc internals +(comparch.pdf) for more infos, but I think that an help from fpk & friends could +be better ^_^ +About prt0.s: the file provided works fine for our initial purposes, but someday +we must use a startup file more advanced for handle all gba capabilities. \ No newline at end of file diff --git a/rtl/gba/prt0.as b/rtl/gba/prt0.as new file mode 100644 index 0000000000..066517e60a --- /dev/null +++ b/rtl/gba/prt0.as @@ -0,0 +1,101 @@ +@******************************************************************** +@* crt0.s * +@ This file is a hack. It is not meant for serious work. * +@******************************************************************** + .TEXT + + .GLOBAL _start +_start: + .ALIGN + .CODE 32 + @ Start Vector +rom_header: b rom_header_end + + @ Nintendo Logo Character Data (8000004h) + .byte 0x24,0xff,0xae,0x51,0x69,0x9a,0xa2,0x21 + .byte 0x3d,0x84,0x82,0x0a,0x84,0xe4,0x09,0xad + .byte 0x11,0x24,0x8b,0x98,0xc0,0x81,0x7f,0x21 + .byte 0xa3,0x52,0xbe,0x19,0x93,0x09,0xce,0x20 + .byte 0x10,0x46,0x4a,0x4a,0xf8,0x27,0x31,0xec + .byte 0x58,0xc7,0xe8,0x33,0x82,0xe3,0xce,0xbf + .byte 0x85,0xf4,0xdf,0x94,0xce,0x4b,0x09,0xc1 + .byte 0x94,0x56,0x8a,0xc0,0x13,0x72,0xa7,0xfc + .byte 0x9f,0x84,0x4d,0x73,0xa3,0xca,0x9a,0x61 + .byte 0x58,0x97,0xa3,0x27,0xfc,0x03,0x98,0x76 + .byte 0x23,0x1d,0xc7,0x61,0x03,0x04,0xae,0x56 + .byte 0xbf,0x38,0x84,0x00,0x40,0xa7,0x0e,0xfd + .byte 0xff,0x52,0xfe,0x03,0x6f,0x95,0x30,0xf1 + .byte 0x97,0xfb,0xc0,0x85,0x60,0xd6,0x80,0x25 + .byte 0xa9,0x63,0xbe,0x03,0x01,0x4e,0x38,0xe2 + .byte 0xf9,0xa2,0x34,0xff,0xbb,0x3e,0x03,0x44 + .byte 0x78,0x00,0x90,0xcb,0x88,0x11,0x3a,0x94 + .byte 0x65,0xc0,0x7c,0x63,0x87,0xf0,0x3c,0xaf + .byte 0xd6,0x25,0xe4,0x8b,0x38,0x0a,0xac,0x72 + .byte 0x21,0xd4,0xf8,0x07 + + @ Software Titles (80000A0h) + .byte 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 + .byte 0x00,0x00,0x00,0x00 + + @ Initial Code (80000ACh) + .byte 0x00,0x00,0x00,0x00 + + @ Maker Code (80000B0h) + .byte 0x30,0x31 + + @ Fixed Value (80000B2h) + .byte 0x96 + + @ Main Unit Code (80000B3h) + .byte 0x00 + + @ Device Type (80000B4h) + .byte 0x00 + + @ Unused Data (7Byte) (80000B5h) + .byte 0x00,0x00,0x00,0x00,0x00,0x00,0x00 + + @ Software Version No (80000BCh) + .byte 0x00 + + @ Complement Check (80000BDh) + .byte 0xf0 + + @ Check Sum (80000BEh) + .byte 0x00,0x00 + +rom_header_end: + +@-------------------------------------------------------------------- +@- Reset - +@-------------------------------------------------------------------- + .EXTERN PASCALMAIN + .GLOBAL start_vector + .CODE 32 + .ALIGN +start_vector: + mov r0, #0x12 @ Switch to IRQ Mode + msr cpsr, r0 + + ldr sp, sp_irq @ Set SP_irq + + mov r0, #0x1f @ Switch to System Mode + msr cpsr, r0 + + ldr sp, sp_usr @ Set SP_usr + str r0, [r1] + + ldr r1, =PASCALMAIN @ Start & Switch to 16bit Code + mov lr, pc + bx r1 + + b start_vector @ Reset + + .ALIGN +sp_usr: .word 0x3008000 - 0x100 +sp_irq: .word 0x3008000 - 0x60 + + .ALIGN + .CODE 32 + + .END diff --git a/rtl/gba/sysgba.pp b/rtl/gba/sysgba.pp new file mode 100644 index 0000000000..4d342eaddd --- /dev/null +++ b/rtl/gba/sysgba.pp @@ -0,0 +1 @@ +{$i system.pp} diff --git a/rtl/gba/system.pp b/rtl/gba/system.pp new file mode 100644 index 0000000000..778f5cd283 --- /dev/null +++ b/rtl/gba/system.pp @@ -0,0 +1,295 @@ +{ + $Id: system.pp,v 1.25 2005/04/24 21:19:22 peter Exp $ + This file is part of the Free Pascal run time librar~y. + Copyright (c) 2000 by Marco van de Voort + member of the Free Pascal development team. + + System unit for Linux. + + 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. + + **********************************************************************} + +{ These things are set in the makefile, } +{ But you can override them here.} + + +{ If you use an aout system, set the conditional AOUT} +{.$Define AOUT} + +Unit {$ifdef VER1_0}Sysgba{$else}System{$endif}; + +Interface + +{$define FPC_IS_SYSTEM} + +{$i osdefs.inc} + +{$I sysunixh.inc} + +Implementation + + +{$I system.inc} + + +{***************************************************************************** + Misc. System Dependent Functions +*****************************************************************************} + +//procedure fpc_initializeunits;[public,alias:'FPC_INITIALIZEUNITS']; +//begin +// { dummy } +//end; + +//procedure fpc_do_exit;[public,alias:'FPC_DO_EXIT']; +//begin +// { dummy } +//end; + +//procedure halt; [public,alias:'FPC_HALT_ZERO']; +//begin +// fpc_do_exit; +//end; + + + +///-F-/// procedure haltproc(e:longint);cdecl;external name '_haltproc'; + +procedure System_exit; +begin +///-F-/// haltproc(ExitCode); +End; + + +Function ParamCount: Longint; +Begin +///-F-/// Paramcount:=argc-1 +End; + + +function BackPos(c:char; const s: shortstring): integer; +var + i: integer; +Begin + for i:=length(s) downto 0 do + if s[i] = c then break; + if i=0 then + BackPos := 0 + else + BackPos := i; +end; + + + { variable where full path and filename and executable is stored } + { is setup by the startup of the system unit. } +var + execpathstr : shortstring; + +function paramstr(l: longint) : string; + begin + { stricly conforming POSIX applications } + { have the executing filename as argv[0] } +///-F-/// if l=0 then +///-F-/// begin +///-F-/// paramstr := execpathstr; +///-F-/// end +///-F-/// else +///-F-/// paramstr:=strpas(argv[l]); + end; + +Procedure Randomize; +Begin + randseed:=longint(Fptime(nil)); +End; + + +{***************************************************************************** + SystemUnit Initialization +*****************************************************************************} + +function reenable_signal(sig : longint) : boolean; +var + e : TSigSet; + i,j : byte; +begin + fillchar(e,sizeof(e),#0); + { set is 1 based PM } + dec(sig); + i:=sig mod 32; + j:=sig div 32; + e[j]:=1 shl i; + fpsigprocmask(SIG_UNBLOCK,@e,nil); + reenable_signal:=geterrno=0; +end; + + +// signal handler is arch dependant due to processorexception to language +// exception translation + +{$i sighnd.inc} + +var + act: SigActionRec; + +Procedure InstallSignals; +begin + { Initialize the sigaction structure } + { all flags and information set to zero } + FillChar(act, sizeof(SigActionRec),0); + { initialize handler } + act.sa_handler := SigActionHandler(@SignalToRunError); + act.sa_flags:=SA_SIGINFO +{$ifdef cpux86_64} + or $4000000 +{$endif cpux86_64} + ; + FpSigAction(SIGFPE,@act,nil); + FpSigAction(SIGSEGV,@act,nil); + FpSigAction(SIGBUS,@act,nil); + FpSigAction(SIGILL,@act,nil); +end; + +procedure SetupCmdLine; +var + bufsize, + len,j, + size,i : longint; + found : boolean; + buf : pchar; + + procedure AddBuf; + begin + reallocmem(cmdline,size+bufsize); + move(buf^,cmdline[size],bufsize); + inc(size,bufsize); + bufsize:=0; + end; + +begin +///-F-/// +{ + GetMem(buf,ARG_MAX); + size:=0; + bufsize:=0; + i:=0; + while (iARG_MAX-2 then + len:=ARG_MAX-2; + found:=false; + for j:=1 to len do + if argv[i][j]=' ' then + begin + found:=true; + break; + end; + if bufsize+len>=ARG_MAX-2 then + AddBuf; + if found then + begin + buf[bufsize]:='"'; + inc(bufsize); + end; + move(argv[i]^,buf[bufsize],len); + inc(bufsize,len); + if found then + begin + buf[bufsize]:='"'; + inc(bufsize); + end; + if i0) and (execpathstr[1]='/') then + execpathstr[0]:=char(i); +end; + +function GetProcessID: SizeUInt; +begin + GetProcessID := SizeUInt (fpGetPID); +end; + + +Begin +///-F-/// IsConsole := TRUE; +///-F-/// IsLibrary := FALSE; + StackLength := InitialStkLen; + StackBottom := Sptr - StackLength; + { Set up signals handlers } + InstallSignals; + { Setup heap } + InitHeap; + SysInitExceptions; + { Arguments } +///-F-/// SetupCmdLine; + SysInitExecPath; + { Setup stdin, stdout and stderr } + SysInitStdIO; + { Reset IO Error } + InOutRes:=0; + { threading } + InitSystemThreads; +{$ifdef HASVARIANT} +///-F-/// initvariantmanager; +{$endif HASVARIANT} +{$ifdef HASWIDESTRING} +///-F-/// initwidestringmanager; +{$endif HASWIDESTRING} +End. + +{ + $Log: system.pp,v $ + Revision 1.25 2005/04/24 21:19:22 peter + * unblock signal in signalhandler, remove the sigprocmask call + from setjmp + + Revision 1.24 2005/02/14 17:13:30 peter + * truncate log + + Revision 1.23 2005/02/13 21:47:56 peter + * include file cleanup part 2 + + Revision 1.22 2005/02/06 11:20:52 peter + * threading in system unit + * removed systhrds unit + + Revision 1.21 2005/02/01 20:22:49 florian + * improved widestring infrastructure manager + +} diff --git a/rtl/gba/unix.pp b/rtl/gba/unix.pp new file mode 100644 index 0000000000..73a0794848 --- /dev/null +++ b/rtl/gba/unix.pp @@ -0,0 +1,1250 @@ +{ + $Id: unix.pp,v 1.85 2005/03/25 22:53:39 jonas Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + BSD parts (c) 2000 by Marco van de Voort + members of the Free Pascal development team. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY;without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +**********************************************************************} +Unit Unix; +Interface + +Uses BaseUnix,UnixType; + +{$i aliasptp.inc} + +{ Get Types and Constants only exported in this unit } +{$i unxconst.inc} + +// We init to zero to be able to put timezone stuff under IFDEF, and still +// keep the code working. + +var + Tzseconds : Longint {$ifndef ver1_0} = 0 {$endif}; + + +{******************** + File +********************} + +Const + P_IN = 1; // pipes (?) + P_OUT = 2; + +Const + LOCK_SH = 1; // flock constants ? + LOCK_EX = 2; + LOCK_UN = 8; + LOCK_NB = 4; + +Type + Tpipe = baseunix.tfildes; // compability. + +{****************************************************************************** + Procedure/Functions +******************************************************************************} + +{************************** + Time/Date Handling +***************************} + +var + tzdaylight : boolean; + tzname : array[boolean] of pchar; + +{$IFNDEF DONT_READ_TIMEZONE} // allows to disable linking in and trying for platforms + // it doesn't (yet) work for. + +{ timezone support } +procedure GetLocalTimezone(timer:cint;var leap_correct,leap_hit:cint); +procedure GetLocalTimezone(timer:cint); +procedure ReadTimezoneFile(fn:string); +function GetTimezoneFile:string; +{$ENDIF} + +{************************** + Process Handling +***************************} + +// +// These are much better, in nearly all ways. +// + +function FpExecLE (Const PathName:AnsiString;const S:Array Of AnsiString;MyEnv:ppchar):cint; +function FpExecL(Const PathName:AnsiString;const S:Array Of AnsiString):cint; +function FpExecLP(Const PathName:AnsiString;const S:Array Of AnsiString):cint; +function FpExecV(Const PathName:AnsiString;args:ppchar):cint; +function FpExecVP(Const PathName:AnsiString;args:ppchar):cint; +function FpExecVPE(Const PathName:AnsiString;args,env:ppchar):cint; + +Function Shell (const Command:String):cint; +Function Shell (const Command:AnsiString):cint; +Function fpSystem(const Command:AnsiString):cint; + +Function WaitProcess (Pid:cint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated} + +Function WIFSTOPPED (Status: Integer): Boolean; +Function W_EXITCODE (ReturnCode, Signal: Integer): Integer; +Function W_STOPCODE (Signal: Integer): Integer; + +{************************** + File Handling +***************************} + +{$ifndef FPC_USE_LIBC} // defined using cdecl for libc. +Function fsync (fd : cint) : cint; +Function fpFlock (fd,mode : cint) : cint ; +Function fStatFS (Fd: cint;Var Info:tstatfs):cint; +Function StatFS (Path:pchar;Var Info:tstatfs):cint; +{$endif} + +Function fpFlock (var T : text;mode : cint) : cint; +Function fpFlock (var F : File;mode : cint) : cint; + + +Function SelectText (var T:Text;TimeOut :PTimeVal):cint; +Function SelectText (var T:Text;TimeOut :cint):cint; + +{************************** + Directory Handling +***************************} + +procedure SeekDir(p:pdir;loc:clong); +function TellDir(p:pdir):clong; + +{************************** + Pipe/Fifo/Stream +***************************} + +Function AssignPipe (var pipe_in,pipe_out:cint):cint; +Function AssignPipe (var pipe_in,pipe_out:text):cint; +Function AssignPipe (var pipe_in,pipe_out:file):cint; +//Function PClose (Var F:text) : cint; +//Function PClose (Var F:file) : cint; +Function POpen (var F:text;const Prog:String;rw:char):cint; +Function POpen (var F:file;const Prog:String;rw:char):cint; +Function AssignStream(Var StreamIn,Streamout:text;Const Prog:ansiString;const args : array of ansistring) : cint; +Function AssignStream(Var StreamIn,Streamout,streamerr:text;Const Prog:ansiString;const args : array of ansistring) : cint; + +{$ifdef linux} +Function GetDomainName:String; +{$endif} +Function GetHostName:String; + + +{************************** + Memory functions +***************************} + +const + PROT_READ = $1; { page can be read } + PROT_WRITE = $2; { page can be written } + PROT_EXEC = $4; { page can be executed } + PROT_NONE = $0; { page can not be accessed } + + MAP_SHARED = $1; { Share changes } +// MAP_PRIVATE = $2; { Changes are private } + MAP_TYPE = $f; { Mask for type of mapping } + MAP_FIXED = $10; { Interpret addr exactly } +// MAP_ANONYMOUS = $20; { don't use a file } + +{$ifdef Linux} + MAP_GROWSDOWN = $100; { stack-like segment } + MAP_DENYWRITE = $800; { ETXTBSY } + MAP_EXECUTABLE = $1000; { mark it as an executable } + MAP_LOCKED = $2000; { pages are locked } + MAP_NORESERVE = $4000; { don't check for reservations } +{$else} + {$ifdef FreeBSD} + // FreeBSD defines MAP_COPY=MAP_PRIVATE=$2; + MAP_FILE = $0000; { map from file (default) } + MAP_ANON = $1000; { allocated from memory, swap space } + + MAP_RENAME = $0020; { Sun: rename private pages to file } + MAP_NORESERVE = $0040; { Sun: don't reserve needed swap area } + MAP_INHERIT = $0080; { region is retained after exec } + MAP_NOEXTEND = $0100; { for MAP_FILE, don't change file size } + MAP_HASSEMAPHORE = $0200; { region may contain semaphores } + MAP_STACK = $0400; { region grows down, like a stack } + MAP_NOSYNC = $0800; { page to but do not sync underlying file} + MAP_NOCORE = $20000;{ dont include these pages in a coredump} + {$endif} +{$endif} +{************************** + Utility functions +***************************} + +Type + TFSearchOption = (NoCurrentDirectory, + CurrentDirectoryFirst, + CurrentDirectoryLast); + +Function FSearch (const path:AnsiString;dirlist:Ansistring;CurrentDirStrategy:TFSearchOption):AnsiString; +Function FSearch (const path:AnsiString;dirlist:AnsiString):AnsiString; + +procedure SigRaise (sig:integer); + +{$ifdef FPC_USE_LIBC} + const clib = 'c'; + {$i unxdeclh.inc} +{$else} + {$i unxsysch.inc} // calls used in system and not reexported from baseunix +{$endif} + +{****************************************************************************** + Implementation +******************************************************************************} + +{$i unxovlh.inc} + +Implementation + +Uses Strings{$ifndef FPC_USE_LIBC},Syscall{$endif}; + +{$i unxovl.inc} + +{$ifndef FPC_USE_LIBC} + {$i syscallh.inc} + {$i unxsysc.inc} +{$endif} + +{ Get the definitions of textrec and filerec } +{$i textrec.inc} +{$i filerec.inc} + +{$i unxfunc.inc} { Platform specific implementations } + +Function getenv(name:string):Pchar; external name 'FPC_SYSC_FPGETENV'; + +{****************************************************************************** + Process related calls +******************************************************************************} + +{ Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly } +Function WaitProcess(Pid:cint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated} +var + r,s : cint; +begin + s:=$7F00; + + repeat + r:=fpWaitPid(Pid,@s,0); + if (r=-1) and (fpgeterrno=ESysEIntr) Then + r:=0; + until (r<>0); + if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG) + WaitProcess:=-1 // return -1 to indicate an error. fpwaitpid updated it. + else + begin + if wifexited(s) then + WaitProcess:=wexitstatus(s) + else if (s>0) then // Until now there is not use of the highest bit , but check this for the future + WaitProcess:=-s // normal case + else + WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value + end; +end; + +function intFpExecVEMaybeP (Const PathName:AnsiString;Args,MyEnv:ppchar;SearchPath:Boolean):cint; +// does an ExecVE, but still has to handle P +// execv variants call this directly, execl variants indirectly via +// intfpexecl + +Var + NewCmd : ansistring; + ThePath : AnsiString; + +Begin + If SearchPath and (pos('/',pathname)=0) Then + Begin + // The above could be better. (check if not escaped/quoted '/'s) ? + // (Jilles says this is ok) + // Stevens says only search if newcmd contains no '/' + // fsearch is not ansistring clean yet. + ThePath:=fpgetenv('PATH'); + if thepath='' then + thepath:='.'; // FreeBSD uses _PATH_DEFPATH = /usr/bin:/bin + // but a quick check showed that _PATH_DEFPATH + // varied from OS to OS + + newcmd:=FSearch(pathname,thepath,NoCurrentDirectory); + // FreeBSD libc keeps on trying till a file is successfully run. + // Stevens says "try each path prefix" + + // execp puts newcmd here. + args^:=pchar(newcmd); + End else + newcmd:=pathname; + // repeat +// if searchpath then args^:=pchar(commandtorun) + + IntFpExecVEMaybeP:=fpExecVE(newcmd,Args,MyEnv); +{ +// Code that if exec fails due to permissions, tries to run it with sh +// Should we deallocate p on fail? -> no fpexit is run no matter what +// +} +// if intfpexecvemaybep=-1 then zoekvolgende file. +// until (Goexit) or SearchExit; + + +{ + If IntFpExec=-1 Then + Begin + Error:=fpGetErrno + Case Error of + ESysE2Big : Exit(-1); + ESysELoop, + : Exit(-1); + +} +end; + +function intFpExecl (Const PathName:AnsiString;const s:array of ansistring;MyEnv:ppchar;SearchPath:Boolean):cint; +{ Handles the array of ansistring -> ppchar conversion. + Base for the the "l" variants. +} +var p:ppchar; + +begin + If PathName='' Then + Begin + fpsetErrno(ESysEnoEnt); + Exit(-1); // Errno? + End; + p:=ArrayStringToPPchar(s,1); + if p=NIL Then + Begin + GetMem(p,2*sizeof(pchar)); + if p=nil then + begin + {$ifdef xunix} + fpseterrno(ESysEnoMem); + {$endif} + fpseterrno(ESysEnoEnt); + exit(-1); + end; + p[1]:=nil; + End; + p^:=pchar(PathName); + IntFPExecL:=intFpExecVEMaybeP(PathName,p,MyEnv,SearchPath); + // If we come here, no attempts were executed successfully. + Freemem(p); +end; + +function FpExecLE (Const PathName:AnsiString;const S:Array Of AnsiString;MyEnv:ppchar):cint; + +Begin + FpExecLE:=intFPExecl(PathName,s,MyEnv,false); +End; + +function FpExecL(Const PathName:AnsiString;const S:Array Of AnsiString):cint; + +Begin + FpExecL:=intFPExecl(PathName,S,EnvP,false); +End; + +function FpExecLP(Const PathName:AnsiString;const S:Array Of AnsiString):cint; + +Begin + FpExecLP:=intFPExecl(PathName,S,EnvP,True); +End; + +function FpExecV(Const PathName:AnsiString;args:ppchar):cint; + +Begin + fpexecV:=intFpExecVEMaybeP (PathName,args,envp,false); +End; + +function FpExecVP(Const PathName:AnsiString;args:ppchar):cint; + +Begin + fpexecVP:=intFpExecVEMaybeP (PathName,args,envp,true); +End; + +function FpExecVPE(Const PathName:AnsiString;args,env:ppchar):cint; + +Begin + fpexecVPE:=intFpExecVEMaybeP (PathName,args,env,true); +End; + +// exect and execvP (ExecCapitalP) are not implement +// Non POSIX anyway. +// Exect turns on tracing for the process +// execvP has the searchpath as array of ansistring ( const char *search_path) + +{$define FPC_USE_FPEXEC} +Function Shell(const Command:String):cint; +{ + Executes the shell, and passes it the string Command. (Through /bin/sh -c) + The current environment is passed to the shell. + It waits for the shell to exit, and returns its exit status. + If the Exec call failed exit status 127 is reported. +} +{ Changed the structure: +- the previous version returns an undefinied value if fork fails +- it returns the status of Waitpid instead of the Process returnvalue (see the doc to Shell) +- it uses exit(127) not ExitProc (The Result in pp386: going on Compiling in 2 processes!) +- ShellArgs are now released +- The Old CreateShellArg gives back pointers to a local var +} +var +{$ifndef FPC_USE_FPEXEC} + p : ppchar; +{$endif} + pid : cint; +begin + {$ifndef FPC_USE_FPEXEC} + p:=CreateShellArgv(command); +{$endif} + pid:=fpfork; + if pid=0 then // We are in the Child + begin + {This is the child.} + {$ifndef FPC_USE_FPEXEC} + fpExecve(p^,p,envp); + {$else} + fpexecl('/bin/sh',['-c',Command]); + {$endif} + fpExit(127); // was Exit(127) + end + else if (pid<>-1) then // Successfull started + Shell:=WaitProcess(pid) + else // no success + Shell:=-1; // indicate an error + {$ifndef FPC_USE_FPEXEC} + FreeShellArgV(p); + {$endif} +end; + +Function Shell(const Command:AnsiString):cint; +{ + AnsiString version of Shell +} +var +{$ifndef FPC_USE_FPEXEC} + p : ppchar; +{$endif} + pid : cint; +begin { Changes as above } +{$ifndef FPC_USE_FPEXEC} + p:=CreateShellArgv(command); +{$endif} + pid:=fpfork; + if pid=0 then // We are in the Child + begin + {$ifdef FPC_USE_FPEXEC} + fpexecl('/bin/sh',['-c',Command]); + {$else} + fpExecve(p^,p,envp); + {$endif} + fpExit(127); // was exit(127)!! We must exit the Process, not the function + end + else if (pid<>-1) then // Successfull started + Shell:=WaitProcess(pid) + else // no success + Shell:=-1; + {$ifndef FPC_USE_FPEXEC} + FreeShellArgV(p); + {$ENDIF} +end; + + +{$ifdef FPC_USE_LIBC} +function xfpsystem(p:pchar):cint; cdecl; external clib name 'system'; + +Function fpSystem(const Command:AnsiString):cint; +begin + fpsystem:=xfpsystem(pchar(command)); +end; +{$else} +Function fpSystem(const Command:AnsiString):cint; +{ + AnsiString version of Shell +} +var + pid,savedpid : cint; + pstat : cint; + ign,intact, + quitact : SigactionRec; + newsigblock, + oldsigblock : tsigset; + +begin { Changes as above } + if command='' then exit(1); + ign.sa_handler:=SigActionHandler(SIG_IGN); + fpsigemptyset(ign.sa_mask); + ign.sa_flags:=0; + fpsigaction(SIGINT, @ign, @intact); + fpsigaction(SIGQUIT, @ign, @quitact); + fpsigemptyset(newsigblock); + fpsigaddset(newsigblock,SIGCHLD); + fpsigprocmask(SIG_BLOCK,{$ifdef ver1_0}@{$endif}newsigblock,{$ifdef ver1_0}@{$endif}oldsigblock); + pid:=fpfork; + if pid=0 then // We are in the Child + begin + fpsigaction(SIGINT,@intact,NIL); + fpsigaction(SIGQUIT,@quitact,NIL); + fpsigprocmask(SIG_SETMASK,@oldsigblock,NIL); + fpexecl('/bin/sh',['-c',Command]); + fpExit(127); // was exit(127)!! We must exit the Process, not the function + end + else if (pid<>-1) then // Successfull started + begin + savedpid:=pid; + repeat + pid:=fpwaitpid(savedpid,@pstat,0); + until (pid<>-1) and (fpgeterrno()<>ESysEintr); + if pid=-1 Then + fpsystem:=-1 + else + fpsystem:=pstat; + end + else // no success + fpsystem:=-1; + fpsigaction(SIGINT,@intact,NIL); + fpsigaction(SIGQUIT,@quitact,NIL); + fpsigprocmask(SIG_SETMASK,@oldsigblock,NIL); +end; +{$endif} + +Function WIFSTOPPED(Status: Integer): Boolean; +begin + WIFSTOPPED:=((Status and $FF)=$7F); +end; + +Function W_EXITCODE(ReturnCode, Signal: Integer): Integer; +begin + W_EXITCODE:=(ReturnCode shl 8) or Signal; +end; + +Function W_STOPCODE(Signal: Integer): Integer; + +begin + W_STOPCODE:=(Signal shl 8) or $7F; +end; + + +{$IFNDEF DONT_READ_TIMEZONE} +{ Include timezone handling routines which use /usr/share/timezone info } +{$i timezone.inc} +{$endif} +{****************************************************************************** + FileSystem calls +******************************************************************************} + +Function fpFlock (var T : text;mode : cint) : cint; +begin + fpFlock:=fpFlock(TextRec(T).Handle,mode); +end; + + +Function fpFlock (var F : File;mode : cint) :cint; +begin + fpFlock:=fpFlock(FileRec(F).Handle,mode); +end; + +Function SelectText(var T:Text;TimeOut :PTimeval):cint; +Var + F:TfdSet; +begin + if textrec(t).mode=fmclosed then + begin + fpseterrno(ESysEBADF); + exit(-1); + end; + FpFD_ZERO(f); + fpFD_SET(textrec(T).handle,f); + if textrec(T).mode=fminput then + SelectText:=fpselect(textrec(T).handle+1,@f,nil,nil,TimeOut) + else + SelectText:=fpselect(textrec(T).handle+1,nil,@f,nil,TimeOut); +end; + +Function SelectText(var T:Text;TimeOut :cint):cint; +var + p : PTimeVal; + tv : TimeVal; +begin + if TimeOut=-1 then + p:=nil + else + begin + tv.tv_Sec:=Timeout div 1000; + tv.tv_Usec:=(Timeout mod 1000)*1000; + p:=@tv; + end; + SelectText:=SelectText(T,p); +end; + +{****************************************************************************** + Directory +******************************************************************************} + +procedure SeekDir(p:pdir;loc:clong); +begin + if p=nil then + begin + fpseterrno(ESysEBADF); + exit; + end; + {$ifndef bsd} + p^.dd_nextoff:=fplseek(p^.dd_fd,loc,seek_set); + {$endif} + p^.dd_size:=0; + p^.dd_loc:=0; +end; + +function TellDir(p:pdir):clong; +begin + if p=nil then + begin + fpseterrno(ESysEBADF); + telldir:=-1; + exit; + end; + telldir:=fplseek(p^.dd_fd,0,seek_cur) + { We could try to use the nextoff field here, but on my 1.2.13 + kernel, this gives nothing... This may have to do with + the readdir implementation of libc... I also didn't find any trace of + the field in the kernel code itself, So I suspect it is an artifact of libc. + Michael. } +end; + +{****************************************************************************** + Pipes/Fifo +******************************************************************************} + +Procedure OpenPipe(var F:Text); +begin + case textrec(f).mode of + fmoutput : + if textrec(f).userdata[1]<>P_OUT then + textrec(f).mode:=fmclosed; + fminput : + if textrec(f).userdata[1]<>P_IN then + textrec(f).mode:=fmclosed; + else + textrec(f).mode:=fmclosed; + end; +end; + +Function IOPipe(var F:text):cint; +begin + IOPipe:=0; + case textrec(f).mode of + fmoutput : + begin + { first check if we need something to write, else we may + get a SigPipe when Close() is called (PFV) } + if textrec(f).bufpos>0 then + IOPipe:=fpwrite(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufpos); + end; + fminput : Begin + textrec(f).bufend:=fpread(textrec(f).handle,pchar(textrec(f).bufptr),textrec(f).bufsize); + IOPipe:=textrec(f).bufend; + End; + end; + textrec(f).bufpos:=0; +end; + +Function FlushPipe(var F:Text):cint; +begin + FlushPipe:=0; + if (textrec(f).mode=fmoutput) and (textrec(f).bufpos<>0) then + FlushPipe:=IOPipe(f); + textrec(f).bufpos:=0; +end; + +Function ClosePipe(var F:text):cint; +begin + textrec(f).mode:=fmclosed; + ClosePipe:=fpclose(textrec(f).handle); +end; + + +Function AssignPipe(var pipe_in,pipe_out:text):cint; +{ + Sets up a pair of file variables, which act as a pipe. The first one can + be read from, the second one can be written to. +} +var + f_in,f_out : cint; +begin + if AssignPipe(f_in,f_out)=-1 then + exit(-1); +{ Set up input } + Assign(Pipe_in,''); + Textrec(Pipe_in).Handle:=f_in; + Textrec(Pipe_in).Mode:=fmInput; + Textrec(Pipe_in).userdata[1]:=P_IN; + TextRec(Pipe_in).OpenFunc:=@OpenPipe; + TextRec(Pipe_in).InOutFunc:=@IOPipe; + TextRec(Pipe_in).FlushFunc:=@FlushPipe; + TextRec(Pipe_in).CloseFunc:=@ClosePipe; +{ Set up output } + Assign(Pipe_out,''); + Textrec(Pipe_out).Handle:=f_out; + Textrec(Pipe_out).Mode:=fmOutput; + Textrec(Pipe_out).userdata[1]:=P_OUT; + TextRec(Pipe_out).OpenFunc:=@OpenPipe; + TextRec(Pipe_out).InOutFunc:=@IOPipe; + TextRec(Pipe_out).FlushFunc:=@FlushPipe; + TextRec(Pipe_out).CloseFunc:=@ClosePipe; + AssignPipe:=0; +end; + +Function AssignPipe(var pipe_in,pipe_out:file):cint; +{ + Sets up a pair of file variables, which act as a pipe. The first one can + be read from, the second one can be written to. + If the operation was unsuccesful, +} +var + f_in,f_out : cint; +begin + if AssignPipe(f_in,f_out)=-1 then + exit(-1); +{ Set up input } + Assign(Pipe_in,''); + Filerec(Pipe_in).Handle:=f_in; + Filerec(Pipe_in).Mode:=fmInput; + Filerec(Pipe_in).recsize:=1; + Filerec(Pipe_in).userdata[1]:=P_IN; +{ Set up output } + Assign(Pipe_out,''); + Filerec(Pipe_out).Handle:=f_out; + Filerec(Pipe_out).Mode:=fmoutput; + Filerec(Pipe_out).recsize:=1; + Filerec(Pipe_out).userdata[1]:=P_OUT; + AssignPipe:=0; +end; + + +Function PCloseText(Var F:text):cint; +{ + May not use @PClose due overloading +} +begin + PCloseText:=PClose(f); +end; + + +function POpen(var F:text;const Prog:String;rw:char):cint; +{ + Starts the program in 'Prog' and makes it's input or out put the + other end of a pipe. If rw is 'w' or 'W', then whatever is written to + F, will be read from stdin by the program in 'Prog'. The inverse is true + for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be + read from 'f'. +} +var + pipi, + pipo : text; + pid : pid_t; + pl : ^cint; +{$ifndef FPC_USE_FPEXEC} + pp : ppchar; +{$endif not FPC_USE_FPEXEC} + ret : cint; +begin + rw:=upcase(rw); + if not (rw in ['R','W']) then + begin + FpSetErrno(ESysEnoent); + exit(-1); + end; + if AssignPipe(pipi,pipo)=-1 Then + Exit(-1); + pid:=fpfork; // vfork in FreeBSD. + if pid=-1 then + begin + close(pipi); + close(pipo); + exit(-1); + end; + if pid=0 then + begin + { We're in the child } + if rw='W' then + begin + close(pipo); + ret:=fpdup2(pipi,input); + close(pipi); + if ret=-1 then + halt(127); + end + else + begin + close(pipi); + ret:=fpdup2(pipo,output); + close(pipo); + if ret=-1 then + halt(127); + end; + {$ifdef FPC_USE_FPEXEC} + fpexecl('/bin/sh',['-c',Prog]); + {$else} + pp:=createshellargv(prog); + fpExecve(pp^,pp,envp); + {$endif} + halt(127); + end + else + begin + { We're in the parent } + if rw='W' then + begin + close(pipi); + f:=pipo; + textrec(f).bufptr:=@textrec(f).buffer; + end + else + begin + close(pipo); + f:=pipi; + textrec(f).bufptr:=@textrec(f).buffer; + end; + {Save the process ID - needed when closing } + pl:=@(textrec(f).userdata[2]); + pl^:=pid; + textrec(f).closefunc:=@PCloseText; + end; + ret:=0; +end; + +Function POpen(var F:file;const Prog:String;rw:char):cint; +{ + Starts the program in 'Prog' and makes it's input or out put the + other end of a pipe. If rw is 'w' or 'W', then whatever is written to + F, will be read from stdin by the program in 'Prog'. The inverse is true + for 'r' or 'R' : whatever the program in 'Prog' writes to stdout, can be + read from 'f'. +} +var + pipi, + pipo : file; + pid : cint; + pl : ^cint; +{$ifndef FPC_USE_FPEXEC} + p,pp : ppchar; + temp : string[255]; +{$endif not FPC_USE_FPEXEC} + ret : cint; +begin + rw:=upcase(rw); + if not (rw in ['R','W']) then + begin + FpSetErrno(ESysEnoent); + exit(-1); + end; + ret:=AssignPipe(pipi,pipo); + if ret=-1 then + exit(-1); + pid:=fpfork; + if pid=-1 then + begin + close(pipi); + close(pipo); + exit(-1); + end; + if pid=0 then + begin + { We're in the child } + if rw='W' then + begin + close(pipo); + ret:=fpdup2(filerec(pipi).handle,stdinputhandle); + close(pipi); + if ret=-1 then + halt(127); + end + else + begin + close(pipi); + ret:=fpdup2(filerec(pipo).handle,stdoutputhandle); + close(pipo); + if ret=1 then + halt(127); + end; + {$ifdef FPC_USE_FPEXEC} + fpexecl('/bin/sh',['-c',Prog]); + {$else} + getmem(pp,sizeof(pchar)*4); + temp:='/bin/sh'#0'-c'#0+prog+#0; + p:=pp; + p^:=@temp[1]; + inc(p); + p^:=@temp[9]; + inc(p); + p^:=@temp[12]; + inc(p); + p^:=Nil; + fpExecve(ansistring('/bin/sh'),pp,envp); + {$endif} + halt(127); + end + else + begin + { We're in the parent } + if rw='W' then + begin + close(pipi); + f:=pipo; + end + else + begin + close(pipo); + f:=pipi; + end; + {Save the process ID - needed when closing } + pl:=@(filerec(f).userdata[2]); + pl^:=pid; + end; + POpen:=0; +end; + +Function AssignStream(Var StreamIn,Streamout:text;Const Prog:ansiString;const args : array of ansistring) : cint; +{ + Starts the program in 'Prog' and makes its input and output the + other end of two pipes, which are the stdin and stdout of a program + specified in 'Prog'. + streamout can be used to write to the program, streamin can be used to read + the output of the program. See the following diagram : + Parent Child + STreamout --> Input + Streamin <-- Output + Return value is the process ID of the process being spawned, or -1 in case of failure. +} +var + pipi, + pipo : text; + pid : cint; + pl : ^cint; +begin + AssignStream:=-1; + if AssignPipe(streamin,pipo)=-1 Then + exit(-1); + if AssignPipe(pipi,streamout)=-1 Then // shouldn't this close streamin and pipo? + exit(-1); + pid:=fpfork; + if pid=-1 then + begin + close(pipi); + close(pipo); + close (streamin); + close (streamout); + exit; + end; + if pid=0 then + begin + { We're in the child } + { Close what we don't need } + close(streamout); + close(streamin); + if fpdup2(pipi,input)=-1 Then + halt(127); + close(pipi); + If fpdup2(pipo,output)=-1 Then + halt (127); + close(pipo); + fpExecl(Prog,args); + halt(127); + end + else + begin + { we're in the parent} + close(pipo); + close(pipi); + {Save the process ID - needed when closing } + pl:=@(textrec(StreamIn).userdata[2]); + pl^:=pid; + textrec(StreamIn).closefunc:=@PCloseText; + {Save the process ID - needed when closing } + pl:=@(textrec(StreamOut).userdata[2]); + pl^:=pid; + textrec(StreamOut).closefunc:=@PCloseText; + AssignStream:=Pid; + end; +end; + +Function AssignStream(Var StreamIn,Streamout,streamerr:text;Const Prog:ansiString;const args : array of ansistring) : cint; + +{ + Starts the program in 'prog' and makes its input, output and error output the + other end of three pipes, which are the stdin, stdout and stderr of a program + specified in 'prog'. + StreamOut can be used to write to the program, StreamIn can be used to read + the output of the program, StreamErr reads the error output of the program. + See the following diagram : + Parent Child + StreamOut --> StdIn (input) + StreamIn <-- StdOut (output) + StreamErr <-- StdErr (error output) +} +var + PipeIn, PipeOut, PipeErr: text; + pid: cint; + pl: ^cint; +begin + AssignStream := -1; + + // Assign pipes + if AssignPipe(StreamIn, PipeOut)=-1 Then + Exit(-1); + + If AssignPipe(StreamErr, PipeErr)=-1 Then + begin + Close(StreamIn); + Close(PipeOut); + exit(-1); + end; + + if AssignPipe(PipeIn, StreamOut)=-1 Then + begin + Close(StreamIn); + Close(PipeOut); + Close(StreamErr); + Close(PipeErr); + exit(-1); + end; + + // Fork + + pid := fpFork; + if pid=-1 then begin + Close(StreamIn); + Close(PipeOut); + Close(StreamErr); + Close(PipeErr); + Close(PipeIn); + Close(StreamOut); + exit(-1); + end; + + if pid = 0 then begin + // *** We are in the child *** + // Close what we don not need + Close(StreamOut); + Close(StreamIn); + Close(StreamErr); + // Connect pipes + if fpdup2(PipeIn, Input)=-1 Then + Halt(127); + Close(PipeIn); + if fpdup2(PipeOut, Output)=-1 Then + Halt(127); + Close(PipeOut); + if fpdup2(PipeErr, StdErr)=-1 Then + Halt(127); + Close(PipeErr); + // Execute program + fpExecl(Prog,args); + Halt(127); + end else begin + // *** We are in the parent *** + Close(PipeErr); + Close(PipeOut); + Close(PipeIn); + // Save the process ID - needed when closing + pl := @(TextRec(StreamIn).userdata[2]); + pl^ := pid; + TextRec(StreamIn).closefunc := @PCloseText; + // Save the process ID - needed when closing + pl := @(TextRec(StreamOut).userdata[2]); + pl^ := pid; + TextRec(StreamOut).closefunc := @PCloseText; + // Save the process ID - needed when closing + pl := @(TextRec(StreamErr).userdata[2]); + pl^ := pid; + TextRec(StreamErr).closefunc := @PCloseText; + AssignStream := pid; + end; +end; + +{****************************************************************************** + General information calls +******************************************************************************} + +{$ifdef Linux} +Function GetDomainName:String; { linux only!} +// domainname is a glibc extension. + +{ + Get machines domain name. Returns empty string if not set. +} +Var + Sysn : utsname; +begin + If fpUname(sysn)<>0 then + getdomainname:='' + else + getdomainname:=strpas(@Sysn.domain[0]); +end; +{$endif} + +{$ifdef BSD} + +function intGetDomainName(Name:PChar; NameLen:Cint):cint; +{$ifndef FPC_USE_LIBC} + external name 'FPC_SYSC_GETDOMAINNAME'; +{$else FPC_USE_LIBC} + cdecl; external clib name 'getdomainname'; +{$endif FPC_USE_LIBC} + +Function GetDomainName:String; { linux only!} +// domainname is a glibc extension. + +{ + Get machines domain name. Returns empty string if not set. +} + +begin + if intGetDomainName(@getdomainname[1],255)=-1 then + getdomainname:='' + else + getdomainname[0]:=chr(strlen(@getdomainname[1])); +end; +{$endif} + + +Function GetHostName:String; +{ + Get machines name. Returns empty string if not set. +} +Var + Sysn : utsname; +begin + If fpuname(sysn)=-1 then + gethostname:='' + else + gethostname:=strpas(@Sysn.nodename[0]); +end; + +{****************************************************************************** + Signal handling calls +******************************************************************************} + +procedure SigRaise(sig:integer); +begin + fpKill(fpGetPid,Sig); +end; + + +{****************************************************************************** + Utility calls +******************************************************************************} + +Function FSearch(const path:AnsiString;dirlist:Ansistring;CurrentDirStrategy:TFSearchOption):AnsiString; +{ + Searches for a file 'path' in the list of direcories in 'dirlist'. + returns an empty string if not found. Wildcards are NOT allowed. + If dirlist is empty, it is set to '.' + +This function tries to make FSearch use ansistrings, and decrease +stringhandling overhead at the same time. + +} +Var + mydir,NewDir : ansistring; + p1 : cint; + Info : Stat; + i,j : cint; + p : pchar; +Begin + + if CurrentDirStrategy=CurrentDirectoryFirst Then + Dirlist:='.:'+dirlist; {Make sure current dir is first to be searched.} + if CurrentDirStrategy=CurrentDirectoryLast Then + Dirlist:=dirlist+':.'; {Make sure current dir is last to be searched.} + +{Replace ':' and ';' with #0} + + for p1:=1 to length(dirlist) do + if (dirlist[p1]=':') or (dirlist[p1]=';') then + dirlist[p1]:=#0; + +{Check for WildCards} + If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then + FSearch:='' {No wildcards allowed in these things.} + Else + Begin + p:=pchar(dirlist); + i:=length(dirlist); + j:=1; + Repeat + mydir:=ansistring(p); + if (length(mydir)>0) and (mydir[length(mydir)]<>'/') then + mydir:=mydir+'/'; + NewDir:=mydir+Path; + if (FpStat(NewDir,Info)>=0) and + (not fpS_ISDIR(Info.st_Mode)) then + Begin + If Pos('./',NewDir)=1 Then + Delete(NewDir,1,2); + {DOS strips off an initial .\} + End + Else + NewDir:=''; + while (j<=i) and (p^<>#0) do begin inc(j); inc(p); end; + if p^=#0 then inc(p); + Until (j>=i) or (Length(NewDir) > 0); + FSearch:=NewDir; + End; +End; + +Function FSearch(const path:AnsiString;dirlist:Ansistring):AnsiString; + +Begin + FSearch:=FSearch(path,dirlist,CurrentDirectoryFirst); +End; + +{-------------------------------- + Stat.Mode Macro's +--------------------------------} + +Initialization +{$IFNDEF DONT_READ_TIMEZONE} + InitLocalTime; +{$endif} +finalization +{$IFNDEF DONT_READ_TIMEZONE} + DoneLocalTime; +{$endif} +End. + +{ + $Log: unix.pp,v $ + Revision 1.85 2005/03/25 22:53:39 jonas + * fixed several warnings and notes about unused variables (mainly) or + uninitialised use of variables/function results (a few) + + Revision 1.84 2005/02/14 17:13:31 peter + * truncate log + + Revision 1.83 2005/02/13 21:47:56 peter + * include file cleanup part 2 + + Revision 1.82 2005/02/13 20:01:38 peter + * include file cleanup + + Revision 1.81 2005/02/06 11:20:52 peter + * threading in system unit + * removed systhrds unit + + Revision 1.80 2005/01/30 18:01:15 peter + * signal cleanup for linux + * sigactionhandler instead of tsigaction for bsds + * sigcontext moved to cpu dir + + Revision 1.79 2005/01/22 20:56:11 michael + + Patch for intFpExecVEMaybeP to use the right path (From Colin Western) + +}