+ some basic system unit. morphos one with _lot_ of commented out parts

git-svn-id: trunk@2392 -

.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

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;
+
+
+

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;
+

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;

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;
+
+
+
+

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;
+
+
+

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. <www.genesi.lu>
+
+    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.

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;
+
+