From fe6637884dba4d2d133c5a2464a3fc1baaa84203 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A1roly=20Balogh?= Date: Wed, 1 Feb 2006 15:21:29 +0000 Subject: [PATCH] + some basic system unit. morphos one with _lot_ of commented out parts git-svn-id: trunk@2392 - --- .gitattributes | 7 + rtl/amiga/sysdir.inc | 99 +++++++++++ rtl/amiga/sysfile.inc | 400 ++++++++++++++++++++++++++++++++++++++++++ rtl/amiga/sysheap.inc | 51 ++++++ rtl/amiga/sysos.inc | 145 +++++++++++++++ rtl/amiga/sysosh.inc | 33 ++++ rtl/amiga/system.pp | 353 +++++++++++++++++++++++++++++++++++++ rtl/amiga/systhrd.inc | 25 +++ 8 files changed, 1113 insertions(+) create mode 100644 rtl/amiga/sysdir.inc create mode 100644 rtl/amiga/sysfile.inc create mode 100644 rtl/amiga/sysheap.inc create mode 100644 rtl/amiga/sysos.inc create mode 100644 rtl/amiga/sysosh.inc create mode 100644 rtl/amiga/system.pp create mode 100644 rtl/amiga/systhrd.inc diff --git a/.gitattributes b/.gitattributes index 17279fd1e8..d5beac0519 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3585,6 +3585,13 @@ rtl/amiga/os.inc svneol=native#text/plain rtl/amiga/powerpc/prt0.as -text rtl/amiga/printer.pp svneol=native#text/plain rtl/amiga/readme -text +rtl/amiga/sysdir.inc -text +rtl/amiga/sysfile.inc -text +rtl/amiga/sysheap.inc -text +rtl/amiga/sysos.inc -text +rtl/amiga/sysosh.inc -text +rtl/amiga/system.pp -text +rtl/amiga/systhrd.inc -text rtl/arm/arm.inc svneol=native#text/plain rtl/arm/int64p.inc svneol=native#text/plain rtl/arm/makefile.cpu -text diff --git a/rtl/amiga/sysdir.inc b/rtl/amiga/sysdir.inc new file mode 100644 index 0000000000..e8a329a2a4 --- /dev/null +++ b/rtl/amiga/sysdir.inc @@ -0,0 +1,99 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski + member of the Free Pascal development team. + + FPC Pascal system unit for the Win32 API. + + 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. + + **********************************************************************} + + +{***************************************************************************** + Directory Handling +*****************************************************************************} +procedure mkdir(const s : string);[IOCheck]; +var + tmpStr : array[0..255] of char; + tmpLock: LongInt; +begin + checkCTRLC; + if (s='') or (InOutRes<>0) then exit; + tmpStr:=PathConv(s)+#0; +// tmpLock:=dosCreateDir(@tmpStr); + if tmpLock=0 then begin +// dosError2InOut(IoErr); + exit; + end; +// UnLock(tmpLock); +end; + +procedure rmdir(const s : string);[IOCheck]; +var + tmpStr : array[0..255] of Char; +begin + checkCTRLC; + if (s='.') then InOutRes:=16; + If (s='') or (InOutRes<>0) then exit; + tmpStr:=PathConv(s)+#0; +// if not dosDeleteFile(@tmpStr) then +// dosError2InOut(IoErr); +end; + +procedure chdir(const s : string);[IOCheck]; +var + tmpStr : array[0..255] of Char; + tmpLock: LongInt; +// FIB : PFileInfoBlock; +begin + checkCTRLC; + If (s='') or (InOutRes<>0) then exit; + tmpStr:=PathConv(s)+#0; + tmpLock:=0; + + { Changing the directory is a pretty complicated affair } + { 1) Obtain a lock on the directory } + { 2) CurrentDir the lock } +// tmpLock:=Lock(@tmpStr,SHARED_LOCK); + if tmpLock=0 then begin +// dosError2InOut(IoErr); + exit; + end; +{ + FIB:=nil; + new(FIB); + + if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin + tmpLock:=CurrentDir(tmpLock); + if MOS_OrigDir=0 then begin + MOS_OrigDir:=tmpLock; + tmpLock:=0; + end; + end; + + if tmpLock<>0 then Unlock(tmpLock); + if assigned(FIB) then dispose(FIB); +} +end; + +procedure GetDir (DriveNr: byte; var Dir: ShortString); +var tmpbuf: array[0..255] of char; +begin + checkCTRLC; + Dir:=''; + { + if not GetCurrentDirName(tmpbuf,256) then + dosError2InOut(IoErr) + else + Dir:=strpas(tmpbuf); + } +end; + + + diff --git a/rtl/amiga/sysfile.inc b/rtl/amiga/sysfile.inc new file mode 100644 index 0000000000..c74d485abc --- /dev/null +++ b/rtl/amiga/sysfile.inc @@ -0,0 +1,400 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2005 by Free Pascal development team + + Low level file functions + + 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. + + **********************************************************************} + +{ Enable this for file handling debug } +{DEFINE MOSFPC_FILEDEBUG} + +{***************************************************************************** + MorphOS File-handling Support Functions +*****************************************************************************} +type + { AmigaOS does not automatically close opened files on exit back to } + { the operating system, therefore as a precuation we close all files } + { manually on exit. } + PFileList = ^TFileList; + TFileList = record { no packed, must be correctly aligned } + handle : LongInt; { Handle to file } + next : PFileList; { Next file in list } + buffered : boolean; { used buffered I/O? } + end; + +var + MOS_fileList: PFileList; public name 'MOS_FILELIST'; { List pointer to opened files } + +{ Function to be called at program shutdown, to close all opened files } +procedure CloseList(l: PFileList); +var + tmpNext : PFileList; + tmpHandle : LongInt; +begin + if l=nil then exit; + + { First, close all tracked files } + tmpNext:=l^.next; + while tmpNext<>nil do begin + tmpHandle:=tmpNext^.handle; + if (tmpHandle<>StdInputHandle) and (tmpHandle<>StdOutputHandle) + and (tmpHandle<>StdErrorHandle) then begin +// dosClose(tmpHandle); + end; + tmpNext:=tmpNext^.next; + end; + + { Next, erase the linked list } + while l<>nil do begin + tmpNext:=l; + l:=l^.next; + dispose(tmpNext); + end; +end; + +{ Function to be called to add a file to the opened file list } +procedure AddToList(var l: PFileList; h: LongInt); alias: 'ADDTOLIST'; [public]; +var + p : PFileList; + inList: Boolean; +begin + inList:=False; + if l<>nil then begin + { if there is a valid filelist, search for the value } + { in the list to avoid double additions } + p:=l; + while (p^.next<>nil) and (not inList) do + if p^.next^.handle=h then inList:=True + else p:=p^.next; + p:=nil; + end else begin + { if the list is not yet allocated, allocate it. } + New(l); + l^.next:=nil; + end; + + if not inList then begin + New(p); + p^.handle:=h; + p^.buffered:=False; + p^.next:=l^.next; + l^.next:=p; + end +{$IFDEF MOSFPC_FILEDEBUG} + else + RawDoFmt('FPC_FILE_DEBUG: Error! Trying add filehandle a filehandle twice: $%lx !'+#10,@h,pointer(1),nil); +{$ENDIF} + ; +end; + +{ Function to be called to remove a file from the list } +function RemoveFromList(var l: PFileList; h: LongInt): boolean; alias: 'REMOVEFROMLIST'; [public]; +var + p : PFileList; + inList : Boolean; + tmpList: PFileList; +begin + inList:=False; + if l=nil then begin + RemoveFromList:=inList; + exit; + end; + + p:=l; + while (p^.next<>nil) and (not inList) do + if p^.next^.handle=h then inList:=True + else p:=p^.next; + + if inList then begin + tmpList:=p^.next^.next; + dispose(p^.next); + p^.next:=tmpList; + end +{$IFDEF MOSFPC_FILEDEBUG} + else + RawDoFmt('FPC_FILE_DEBUG: Error! Trying to remove not existing filehandle: $%lx !'+#10,@h,pointer(1),nil); +{$ENDIF} + ; + + RemoveFromList:=inList; +end; + +{ Function to check if file is in the list } +function CheckInList(var l: PFileList; h: LongInt): pointer; alias: 'CHECKINLIST'; [public]; +var + p : PFileList; + inList : Pointer; + tmpList: PFileList; + +begin + inList:=nil; + if l=nil then begin + CheckInList:=inList; + exit; + end; + + p:=l; + while (p^.next<>nil) and (inList=nil) do + if p^.next^.handle=h then inList:=p^.next + else p:=p^.next; + +{$IFDEF MOSFPC_FILEDEBUG} + if inList=nil then + RawDoFmt('FPC_FILE_DEBUG: Warning! Check for not existing filehandle: $%lx !'+#10,@h,pointer(1),nil); +{$ENDIF} + + CheckInList:=inList; +end; + + +{**************************************************************************** + Low level File Routines + All these functions can set InOutRes on errors +****************************************************************************} + +{ close a file from the handle value } +procedure do_close(handle : longint); +begin + if RemoveFromList(MOS_fileList,handle) then begin + { Do _NOT_ check CTRL_C on Close, because it will conflict + with System_Exit! } +// if not dosClose(handle) then +// dosError2InOut(IoErr); + end; +end; + +procedure do_erase(p : pchar); +var + tmpStr: array[0..255] of Char; +begin + tmpStr:=PathConv(strpas(p))+#0; +// checkCTRLC; +// if not dosDeleteFile(@tmpStr) then +// dosError2InOut(IoErr); +end; + +procedure do_rename(p1,p2 : pchar); +{ quite stack-effective code, huh? :) damn path conversions... (KB) } +var + tmpStr1: array[0..255] of Char; + tmpStr2: array[0..255] of Char; +begin + tmpStr1:=PathConv(strpas(p1))+#0; + tmpStr2:=PathConv(strpas(p2))+#0; +// checkCTRLC; +// if not dosRename(@tmpStr1,@tmpStr2) then +// dosError2InOut(IoErr); +end; + +function do_write(h: longint; addr: pointer; len: longint) : longint; +var dosResult: LongInt; +begin +// checkCTRLC; + do_write:=0; + if (len<=0) or (h<=0) then exit; + +{$IFDEF MOSFPC_FILEDEBUG} + if not ((h=StdOutputHandle) or (h=StdInputHandle) or + (h=StdErrorHandle)) then CheckInList(MOS_fileList,h); +{$ENDIF} + +// dosResult:=dosWrite(h,addr,len); +// if dosResult<0 then begin +// dosError2InOut(IoErr); +// end else begin +// do_write:=dosResult; +// end; +end; + +function do_read(h: longint; addr: pointer; len: longint) : longint; +var dosResult: LongInt; +begin + checkCTRLC; + do_read:=0; + if (len<=0) or (h<=0) then exit; + +{$IFDEF MOSFPC_FILEDEBUG} + if not ((h=StdOutputHandle) or (h=StdInputHandle) or + (h=StdErrorHandle)) then CheckInList(MOS_fileList,h); +{$ENDIF} +{ + dosResult:=dosRead(h,addr,len); + if dosResult<0 then begin + dosError2InOut(IoErr); + end else begin + do_read:=dosResult; + end + } +end; + +function do_filepos(handle: longint) : longint; +var dosResult: LongInt; +begin +// checkCTRLC; + do_filepos:=-1; + if CheckInList(MOS_fileList,handle)<>nil then begin + + { Seeking zero from OFFSET_CURRENT to find out where we are } +{ + dosResult:=dosSeek(handle,0,OFFSET_CURRENT); + if dosResult<0 then begin + dosError2InOut(IoErr); + end else begin + do_filepos:=dosResult; + end; +} + end; +end; + +procedure do_seek(handle, pos: longint); +begin +// checkCTRLC; + if CheckInList(MOS_fileList,handle)<>nil then begin + + { Seeking from OFFSET_BEGINNING } +{ + if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then + dosError2InOut(IoErr); +} + end; +end; + +function do_seekend(handle: longint):longint; +var dosResult: LongInt; +begin +// checkCTRLC; + do_seekend:=-1; + if CheckInList(MOS_fileList,handle)<>nil then begin + + { Seeking to OFFSET_END } +{ + dosResult:=dosSeek(handle,0,OFFSET_END); + if dosResult<0 then begin + dosError2InOut(IoErr); + end else begin + do_seekend:=dosResult; + end; +} + end; +end; + +function do_filesize(handle : longint) : longint; +var currfilepos: longint; +begin +// checkCTRLC; + do_filesize:=-1; + if CheckInList(MOS_fileList,handle)<>nil then begin + + currfilepos:=do_filepos(handle); + { We have to do this twice, because seek returns the OLD position } + do_filesize:=do_seekend(handle); + do_filesize:=do_seekend(handle); + do_seek(handle,currfilepos); + + end; +end; + +{ truncate at a given position } +procedure do_truncate(handle, pos: longint); +begin +// checkCTRLC; + if CheckInList(MOS_fileList,handle)<>nil then begin + + { Seeking from OFFSET_BEGINNING } +{ + if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then + dosError2InOut(IoErr); +} + end; +end; + +procedure do_open(var f;p:pchar;flags:longint); +{ + filerec and textrec have both handle and mode as the first items so + they could use the same routine for opening/creating. + when (flags and $10) the file will be append + when (flags and $100) the file will be truncate/rewritten + when (flags and $1000) there is no check for close (needed for textfiles) +} +var + handle : LongInt; + openflags: LongInt; + tmpStr : array[0..255] of Char; +begin + tmpStr:=PathConv(strpas(p))+#0; + + { close first if opened } + if ((flags and $10000)=0) then begin + case filerec(f).mode of + fminput,fmoutput,fminout : Do_Close(filerec(f).handle); + fmclosed : ; + else begin + inoutres:=102; {not assigned} + exit; + end; + end; + end; + + { reset file handle } + filerec(f).handle:=UnusedHandle; + + { convert filemode to filerec modes } + { READ/WRITE on existing file } + { RESET/APPEND } +// openflags:=MODE_OLDFILE; + case (flags and 3) of + 0 : filerec(f).mode:=fminput; + 1 : filerec(f).mode:=fmoutput; + 2 : filerec(f).mode:=fminout; + end; + + { rewrite (create a new file) } +// if (flags and $1000)<>0 then openflags:=MODE_NEWFILE; + + { empty name is special } + if p[0]=#0 then begin + case filerec(f).mode of + fminput : + filerec(f).handle:=StdInputHandle; + fmappend, + fmoutput : begin + filerec(f).handle:=StdOutputHandle; + filerec(f).mode:=fmoutput; {fool fmappend} + end; + end; + exit; + end; +{ + handle:=Open(@tmpStr,openflags); + if handle=0 then begin + dosError2InOut(IoErr); + end else begin + AddToList(MOS_fileList,handle); + filerec(f).handle:=handle; + end; +} + { append mode } + if ((Flags and $100)<>0) and + (FileRec(F).Handle<>UnusedHandle) then begin + do_seekend(filerec(f).handle); + filerec(f).mode:=fmoutput; {fool fmappend} + end; +end; + +function do_isdevice(handle: longint): boolean; +begin + if (handle=StdOutputHandle) or (handle=StdInputHandle) or + (handle=StdErrorHandle) then + do_isdevice:=True + else + do_isdevice:=False; +end; + diff --git a/rtl/amiga/sysheap.inc b/rtl/amiga/sysheap.inc new file mode 100644 index 0000000000..f8769d8448 --- /dev/null +++ b/rtl/amiga/sysheap.inc @@ -0,0 +1,51 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2005 by Free Pascal development team + + Low level memory functions + + 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. + + **********************************************************************} + +{ Enable this for memory allocation debugging } +{DEFINE MOSFPC_MEMDEBUG} + +{***************************************************************************** + OS Memory allocation / deallocation + ****************************************************************************} + +function SysOSAlloc(size: ptrint): pointer; +{$IFDEF MOSFPC_MEMDEBUG} +var values: array[0..2] of dword; +{$ENDIF} +begin +{ result:=AllocPooled(MOS_heapPool,size);} +{$IFDEF MOSFPC_MEMDEBUG} + values[0]:=dword(result); + values[1]:=dword(size); + values[2]:=DWord(Sptr-StackBottom); + RawDoFmt('FPC_MEM_DEBUG: $%lx:=SysOSAlloc(%ld), free stack: %ld bytes'+#10,@values,pointer(1),nil); +{$ENDIF} +end; + +{$define HAS_SYSOSFREE} + +procedure SysOSFree(p: pointer; size: ptrint); +{$IFDEF MOSFPC_MEMDEBUG} +var values: array[0..2] of dword; +{$ENDIF} +begin +{ FreePooled(MOS_heapPool,p,size);} +{$IFDEF MOSFPC_MEMDEBUG} + values[0]:=dword(p); + values[1]:=dword(size); + values[2]:=DWord(Sptr-StackBottom); + RawDoFmt('FPC_MEM_DEBUG: SysOSFree($%lx,%ld), free stack: %ld bytes'+#10,@values,pointer(1),nil); +{$ENDIF} +end; diff --git a/rtl/amiga/sysos.inc b/rtl/amiga/sysos.inc new file mode 100644 index 0000000000..3a5935e036 --- /dev/null +++ b/rtl/amiga/sysos.inc @@ -0,0 +1,145 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2001 by Free Pascal development team + + This file implements all the base types and limits required + for a minimal POSIX compliant subset required to port the compiler + to a new OS. + + 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. + + **********************************************************************} + +{***************************************************************************** + MorphOS structures +*****************************************************************************} + +{include execd.inc} +{include timerd.inc} +{include doslibd.inc} + + +{***************************************************************************** + MorphOS functions +*****************************************************************************} + +{ exec.library functions } + +{include execf.inc} +{include doslibf.inc} + + +{***************************************************************************** + System Dependent Structures/Consts +*****************************************************************************} + +const + CTRL_C = 20; { Error code on CTRL-C press } + +{ Used for CTRL_C checking in I/O calls } +procedure checkCTRLC; +begin +{ + if BreakOn then begin + if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin + { Clear CTRL-C signal } + SetSignal(0,SIGBREAKF_CTRL_C); + Halt(CTRL_C); + end; + end; + } +end; + + +{ Converts a MorphOS dos.library error code to a TP compatible error code } +{ Based on 1.0.x Amiga RTL } +procedure dosError2InOut(errno: LongInt); +begin +{ + case errno of + ERROR_BAD_NUMBER, + ERROR_ACTION_NOT_KNOWN, + ERROR_NOT_IMPLEMENTED : InOutRes := 1; + + ERROR_OBJECT_NOT_FOUND : InOutRes := 2; + ERROR_DIR_NOT_FOUND : InOutRes := 3; + ERROR_DISK_WRITE_PROTECTED : InOutRes := 150; + ERROR_OBJECT_WRONG_TYPE : InOutRes := 151; + + ERROR_OBJECT_EXISTS, + ERROR_DELETE_PROTECTED, + ERROR_WRITE_PROTECTED, + ERROR_READ_PROTECTED, + ERROR_OBJECT_IN_USE, + ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5; + + ERROR_NO_MORE_ENTRIES : InOutRes := 18; + ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17; + ERROR_DISK_FULL : InOutRes := 101; + ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153; + ERROR_BAD_HUNK : InOutRes := 153; + ERROR_NOT_A_DOS_DISK : InOutRes := 157; + + ERROR_NO_DISK, + ERROR_DISK_NOT_VALIDATED, + ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152; + + ERROR_SEEK_ERROR : InOutRes := 156; + + ERROR_LOCK_COLLISION, + ERROR_LOCK_TIMEOUT, + ERROR_UNLOCK_ERROR, + ERROR_INVALID_LOCK, + ERROR_INVALID_COMPONENT_NAME, + ERROR_BAD_STREAM_NAME, + ERROR_FILE_NOT_OBJECT : InOutRes := 6; + else + InOutres := errno; + end; + } +end; + + +{ Converts an Unix-like path to Amiga-like path } +function PathConv(path: string): string; alias: 'PATHCONV'; [public]; +var tmppos: longint; +begin + { check for short paths } + if length(path)<=2 then begin + if (path='.') or (path='./') then path:='' else + if path='..' then path:='/' else + if path='*' then path:='#?'; + end else begin + { convert parent directories } + tmppos:=pos('../',path); + while tmppos<>0 do begin + { delete .. to have / as parent dir sign } + delete(path,tmppos,2); + tmppos:=pos('../',path); + end; + { convert current directories } + tmppos:=pos('./',path); + while tmppos<>0 do begin + { delete ./ since we doesn't need to sign current directory } + delete(path,tmppos,2); + tmppos:=pos('./',path); + end; + { convert wildstart to #? } + tmppos:=pos('*',path); + while tmppos<>0 do begin + delete(path,tmppos,1); + insert('#?',path,tmppos); + tmppos:=pos('*',path); + end; + end; + PathConv:=path; +end; + + + + diff --git a/rtl/amiga/sysosh.inc b/rtl/amiga/sysosh.inc new file mode 100644 index 0000000000..dbb22bdc87 --- /dev/null +++ b/rtl/amiga/sysosh.inc @@ -0,0 +1,33 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2001 by Free Pascal development team + + This file implements all the base types and limits required + for a minimal POSIX compliant subset required to port the compiler + to a new OS. + + 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. + + **********************************************************************} + +{Platform specific information} +type +{$ifdef CPU64} + THandle = Int64; +{$else CPU64} + THandle = Longint; +{$endif CPU64} + TThreadID = THandle; + + PRTLCriticalSection = ^TRTLCriticalSection; + TRTLCriticalSection = record + Locked: boolean + end; + + + diff --git a/rtl/amiga/system.pp b/rtl/amiga/system.pp new file mode 100644 index 0000000000..b0418f94d5 --- /dev/null +++ b/rtl/amiga/system.pp @@ -0,0 +1,353 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l. + + System unit for MorphOS/PowerPC + + Uses parts of the Commodore Amiga/68k port by Carl Eric Codere + and Nils Sjoholm + + MorphOS port was done on a free Pegasos II/G4 machine + provided by Genesi S.a.r.l. + + 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 System; + +interface + +{$define FPC_IS_SYSTEM} + +{$I systemh.inc} + +const + LineEnding = #10; + LFNSupport = True; + DirectorySeparator = '/'; + DriveSeparator = ':'; + PathSeparator = ';'; + maxExitCode = 255; + MaxPathLen = 256; + +const + UnusedHandle : LongInt = -1; + StdInputHandle : LongInt = 0; + StdOutputHandle : LongInt = 0; + StdErrorHandle : LongInt = 0; + + FileNameCaseSensitive : Boolean = False; + CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *) + + sLineBreak : string[1] = LineEnding; + DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF; + + BreakOn : Boolean = True; + + +var + MOS_ExecBase : Pointer; external name '_ExecBase'; + MOS_DOSBase : Pointer; + MOS_UtilityBase: Pointer; + + MOS_heapPool : Pointer; { pointer for the OS pool for growing the heap } + MOS_origDir : LongInt; { original directory on startup } + MOS_ambMsg : Pointer; + MOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT'; + MOS_ConHandle: LongInt; + + argc: LongInt; + argv: PPChar; + envp: PPChar; + + +implementation + +{$I system.inc} + +{$IFDEF MOSFPC_FILEDEBUG} +{$WARNING Compiling with file debug enabled!} +{$ENDIF} + +{$IFDEF MOSFPC_MEMDEBUG} +{$WARNING Compiling with memory debug enabled!} +{$ENDIF} + + +{***************************************************************************** + Misc. System Dependent Functions +*****************************************************************************} + +procedure haltproc(e:longint);cdecl;external name '_haltproc'; + +procedure System_exit; +begin +{ + { We must remove the CTRL-C FLAG here because halt } + { may call I/O routines, which in turn might call } + { halt, so a recursive stack crash } + if BreakOn then begin + if (SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then + SetSignal(0,SIGBREAKF_CTRL_C); + end; + + { Closing opened files } + CloseList(MOS_fileList); + + { Changing back to original directory if changed } + if MOS_origDir<>0 then begin + CurrentDir(MOS_origDir); + end; + + if MOS_UtilityBase<>nil then CloseLibrary(MOS_UtilityBase); + if MOS_DOSBase<>nil then CloseLibrary(MOS_DOSBase); + if MOS_heapPool<>nil then DeletePool(MOS_heapPool); + haltproc(ExitCode); + } +end; + +{ Generates correct argument array on startup } +procedure GenerateArgs; +var + argvlen : longint; + + procedure allocarg(idx,len:longint); + var + i,oldargvlen : longint; + begin + if idx>=argvlen then + begin + oldargvlen:=argvlen; + argvlen:=(idx+8) and (not 7); + sysreallocmem(argv,argvlen*sizeof(pointer)); + for i:=oldargvlen to argvlen-1 do + argv[i]:=nil; + end; + ArgV [Idx] := SysAllocMem (Succ (Len)); + end; + +var + count: word; + start: word; + localindex: word; + p : pchar; + temp : string; + +begin +// p:=GetArgStr; + argvlen:=0; + + { Set argv[0] } + temp:=paramstr(0); + allocarg(0,length(temp)); + move(temp[1],argv[0]^,length(temp)); + argv[0][length(temp)]:=#0; + + { check if we're started from Ambient } + if MOS_ambMsg<>nil then + begin + argc:=0; + exit; + end; + + { Handle the other args } + count:=0; + { first index is one } + localindex:=1; + while (p[count]<>#0) do + begin + while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count); + start:=count; + while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count); + if (count-start>0) then + begin + allocarg(localindex,count-start); + move(p[start],argv[localindex]^,count-start); + argv[localindex][count-start]:=#0; + inc(localindex); + end; + end; + argc:=localindex; +end; + +function GetProgDir: String; +var + s1 : String; + alock : LongInt; + counter: Byte; +begin + GetProgDir:=''; + FillChar(s1,255,#0); + { GetLock of program directory } + { + alock:=GetProgramDir; + if alock<>0 then begin + if NameFromLock(alock,@s1[1],255) then begin + counter:=1; + while (s1[counter]<>#0) and (counter<>0) do Inc(counter); + s1[0]:=Char(counter-1); + GetProgDir:=s1; + end; + end; + } +end; + +function GetProgramName: String; +{ Returns ONLY the program name } +var + s1 : String; + counter: Byte; +begin + GetProgramName:=''; + FillChar(s1,255,#0); +{ + if GetProgramName(@s1[1],255) then begin + { now check out and assign the length of the string } + counter := 1; + while (s1[counter]<>#0) and (counter<>0) do Inc(counter); + s1[0]:=Char(counter-1); + + { now remove any component path which should not be there } + for counter:=length(s1) downto 1 do + if (s1[counter] = '/') or (s1[counter] = ':') then break; + { readjust counterv to point to character } + if counter<>1 then Inc(counter); + + GetProgramName:=copy(s1,counter,length(s1)); + end; +} +end; + + +{***************************************************************************** + ParamStr/Randomize +*****************************************************************************} + +{ number of args } +function paramcount : longint; +begin + if MOS_ambMsg<>nil then + paramcount:=0 + else + paramcount:=argc-1; +end; + +{ argument number l } +function paramstr(l : longint) : string; +var + s1: String; +begin + paramstr:=''; + if MOS_ambMsg<>nil then exit; + + if l=0 then begin + s1:=GetProgDir; + if s1[length(s1)]=':' then paramstr:=s1+GetProgramName + else paramstr:=s1+'/'+GetProgramName; + end else begin + if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]); + end; +end; + +{ set randseed to a new pseudo random value } +procedure randomize; +//var tmpTime: TDateStamp; +begin +// DateStamp(@tmpTime); +// randseed:=tmpTime.ds_tick; +end; + + +{ MorphOS specific startup } +procedure SysInitMorphOS; +//var self: PProcess; +begin +{ + self:=PProcess(FindTask(nil)); + if self^.pr_CLI=0 then begin + { if we're running from Ambient/Workbench, we catch its message } + WaitPort(@self^.pr_MsgPort); + MOS_ambMsg:=GetMsg(@self^.pr_MsgPort); + end; + + MOS_DOSBase:=OpenLibrary('dos.library',50); + if MOS_DOSBase=nil then Halt(1); + MOS_UtilityBase:=OpenLibrary('utility.library',50); + if MOS_UtilityBase=nil then Halt(1); + + { Creating the memory pool for growing heap } + MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1); + if MOS_heapPool=nil then Halt(1); + + if MOS_ambMsg=nil then begin + StdInputHandle:=dosInput; + StdOutputHandle:=dosOutput; + end else begin + MOS_ConHandle:=Open(MOS_ConName,MODE_OLDFILE); + if MOS_ConHandle<>0 then begin + StdInputHandle:=MOS_ConHandle; + StdOutputHandle:=MOS_ConHandle; + end else + Halt(1); + end; +} +end; + + +procedure SysInitStdIO; +begin + OpenStdIO(Input,fmInput,StdInputHandle); + OpenStdIO(Output,fmOutput,StdOutputHandle); + OpenStdIO(StdOut,fmOutput,StdOutputHandle); + + { * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * } + + StdErrorHandle:=StdOutputHandle; + // OpenStdIO(StdErr,fmOutput,StdErrorHandle); + // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle); +end; + +function GetProcessID: SizeUInt; +begin +// GetProcessID:=SizeUInt(FindTask(NIL)); +end; + +function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; +begin + result := stklen; +end; + + +begin + SysResetFPU; + IsConsole := TRUE; + IsLibrary := FALSE; + StackLength := CheckInitialStkLen(InitialStkLen); + StackBottom := Sptr - StackLength; +{ OS specific startup } + MOS_ambMsg:=nil; + MOS_origDir:=0; + MOS_fileList:=nil; + envp:=nil; + SysInitMorphOS; +{ Set up signals handlers } +// InstallSignals; +{ Setup heap } + InitHeap; + SysInitExceptions; +{ Setup stdin, stdout and stderr } + SysInitStdIO; +{ Reset IO Error } + InOutRes:=0; +{ Arguments } + GenerateArgs; + InitSystemThreads; + initvariantmanager; + initwidestringmanager; +end. diff --git a/rtl/amiga/systhrd.inc b/rtl/amiga/systhrd.inc new file mode 100644 index 0000000000..a2350329cd --- /dev/null +++ b/rtl/amiga/systhrd.inc @@ -0,0 +1,25 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2002 by Peter Vreman, + member of the Free Pascal development team. + + Linux (pthreads) threading support implementation + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +Procedure InitSystemThreads; +begin + { This should be changed to a real value during + thread driver initialization if appropriate. } + ThreadID := 1; + SetNoThreadManager; +end; + +