+ Amiga RTL update based on MorphOS version

git-svn-id: trunk@4395 -

.gitattributes

@@ -3966,17 +3966,20 @@ rtl/amiga/Makefile svneol=native#text/plain
 rtl/amiga/Makefile.fpc svneol=native#text/plain
 rtl/amiga/crt.pp svneol=native#text/plain
 rtl/amiga/dos.pp svneol=native#text/plain
-rtl/amiga/m68k/prt0.as -text
-rtl/amiga/os.inc svneol=native#text/plain
-rtl/amiga/powerpc/prt0.as -text
+rtl/amiga/doslibd.inc svneol=native#text/plain
+rtl/amiga/m68k/execf.inc svneol=native#text/plain
+rtl/amiga/m68k/prt0.as svneol=native#text/plain
+rtl/amiga/powerpc/prt0.as svneol=native#text/plain
 rtl/amiga/printer.pp svneol=native#text/plain
-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/amiga/sysdir.inc svneol=native#text/plain
+rtl/amiga/sysfile.inc svneol=native#text/plain
+rtl/amiga/sysheap.inc svneol=native#text/plain
+rtl/amiga/sysos.inc svneol=native#text/plain
+rtl/amiga/sysosh.inc svneol=native#text/plain
+rtl/amiga/system.pp svneol=native#text/plain
+rtl/amiga/systhrd.inc svneol=native#text/plain
+rtl/amiga/sysutils.pp svneol=native#text/plain
+rtl/amiga/timerd.inc svneol=native#text/plain
 rtl/arm/arm.inc svneol=native#text/plain
 rtl/arm/int64p.inc svneol=native#text/plain
 rtl/arm/makefile.cpu -text

rtl/amiga/m68k/execf.inc

@@ -0,0 +1 @@
+{$FATAL Not implemented for AmigaOS/m68k yet}

rtl/amiga/os.inc

@@ -1,20 +0,0 @@
-{
-    This file is part of the Free Pascal run time library.
-    Copyright (c) 1999-2000 by the Free Pascal development team.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-{$define amiga}
-{$undef go32v2}
-{$undef os2}
-{$undef linux}
-{$undef win32}
-{$undef macos}
-{$undef atari}
-

rtl/amiga/sysutils.pp

@@ -0,0 +1,587 @@
+{
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2004 by Karoly Balogh
+
+    Sysutils unit for MorphOS
+
+    Based on Amiga version by Carl Eric Codere, and other
+    parts of the RTL
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit sysutils;
+
+interface
+
+{$MODE objfpc}
+{ force ansistrings }
+{$H+}
+
+{ Include platform independent interface part }
+{$i sysutilh.inc}
+
+{ Platform dependent calls }
+
+Procedure AddDisk(const path:string);
+
+
+implementation
+
+uses dos,sysconst;
+
+{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
+{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
+
+{ Include platform independent implementation part }
+{$i sysutils.inc}
+
+
+{ * Include MorphOS specific includes * }
+{$include execd.inc}
+{$include execf.inc}
+{$include timerd.inc}
+{$include doslibd.inc}
+{$include doslibf.inc}
+{$include utilf.inc}
+
+{ * Followings are implemented in the system unit! * }
+function PathConv(path: shortstring): shortstring; external name 'PATHCONV';
+procedure AddToList(var l: Pointer; h: LongInt); external name 'ADDTOLIST';
+function RemoveFromList(var l: Pointer; h: LongInt): boolean; external name 'REMOVEFROMLIST';
+function CheckInList(var l: Pointer; h: LongInt): pointer; external name 'CHECKINLIST';
+
+var
+  MOS_fileList: Pointer; external name 'AOS_FILELIST';
+
+
+{****************************************************************************
+                              File Functions
+****************************************************************************}
+{$I-}{ Required for correct usage of these routines }
+
+
+(****** non portable routines ******)
+
+function FileOpen(const FileName: string; Mode: Integer): LongInt;
+var
+  dosResult: LongInt;
+  tmpStr   : array[0..255] of char;
+begin
+  {$WARNING FIX ME! To do: FileOpen Access Modes}
+  tmpStr:=PathConv(FileName)+#0;
+  dosResult:=Open(@tmpStr,MODE_OLDFILE);
+  if dosResult=0 then
+    dosResult:=-1
+  else
+    AddToList(MOS_fileList,dosResult);
+
+  FileOpen:=dosResult;
+end;
+
+
+function FileGetDate(Handle: LongInt) : LongInt;
+begin
+end;
+
+
+function FileSetDate(Handle, Age: LongInt) : LongInt;
+begin
+  // Impossible under unix from FileHandle !!
+  FileSetDate:=-1;
+end;
+
+
+function FileCreate(const FileName: string) : LongInt;
+var
+  dosResult: LongInt;
+  tmpStr   : array[0..255] of char;
+begin
+ tmpStr:=PathConv(FileName)+#0;
+ dosResult:=Open(@tmpStr,MODE_NEWFILE);
+ if dosResult=0 then
+   dosResult:=-1
+ else
+   AddToList(MOS_fileList,dosResult);
+
+ FileCreate:=dosResult;
+end;
+
+
+function FileCreate(const FileName: string; Mode: integer): LongInt;
+begin
+  {$WARNING FIX ME! To do: FileCreate Access Modes}
+  FileCreate:=FileCreate(FileName);
+end;
+
+
+function FileRead(Handle: LongInt; var Buffer; Count: LongInt): LongInt;
+begin
+  FileRead:=-1;
+  if (Count<=0) or (Handle<=0) then exit;
+
+  FileRead:=dosRead(Handle,@Buffer,Count);
+end;
+
+
+function FileWrite(Handle: LongInt; const Buffer; Count: LongInt): LongInt;
+begin
+  FileWrite:=-1;
+  if (Count<=0) or (Handle<=0) then exit;
+
+  FileWrite:=dosWrite(Handle,@Buffer,Count);
+end;
+
+
+function FileSeek(Handle, FOffset, Origin: LongInt) : LongInt;
+var
+  seekMode: LongInt;
+begin
+  FileSeek:=-1;
+  if (Handle<=0) then exit;
+
+  case Origin of
+    fsFromBeginning: seekMode:=OFFSET_BEGINNING;
+    fsFromCurrent  : seekMode:=OFFSET_CURRENT;
+    fsFromEnd      : seekMode:=OFFSET_END;
+  end;
+
+  FileSeek:=dosSeek(Handle, FOffset, seekMode);
+end;
+
+function FileSeek(Handle: LongInt; FOffset, Origin: Int64): Int64;
+begin
+  {$WARNING Need to add 64bit call }
+  FileSeek:=FileSeek(Handle,LongInt(FOffset),LongInt(Origin));
+end;
+
+
+procedure FileClose(Handle: LongInt);
+begin
+  if (Handle<=0) then exit;
+
+  dosClose(Handle);
+  RemoveFromList(MOS_fileList,Handle);
+end;
+
+
+function FileTruncate(Handle, Size: LongInt): Boolean;
+var
+  dosResult: LongInt;
+begin
+  FileTruncate:=False;
+  if (Handle<=0) then exit;
+
+  dosResult:=SetFileSize(Handle, Size, OFFSET_BEGINNING);
+  if (dosResult<0) then exit;
+
+  FileTruncate:=True;
+end;
+
+
+function DeleteFile(const FileName: string) : Boolean;
+var
+  tmpStr: array[0..255] of char;
+begin
+  tmpStr:=PathConv(FileName)+#0;
+
+  DeleteFile:=dosDeleteFile(@tmpStr);
+end;
+
+
+function RenameFile(const OldName, NewName: string): Boolean;
+var
+  tmpOldName, tmpNewName: array[0..255] of char;
+begin
+  tmpOldName:=PathConv(OldName)+#0;
+  tmpNewName:=PathConv(NewName)+#0;
+
+  RenameFile:=dosRename(tmpOldName, tmpNewName);
+end;
+
+
+(****** end of non portable routines ******)
+
+
+Function FileAge (Const FileName : String): Longint;
+
+var F: file;
+    Time: longint;
+begin
+   Assign(F,FileName);
+   dos.GetFTime(F,Time);
+   { Warning this is not compatible with standard routines
+     since Double are not supported on m68k by default!
+   }
+   FileAge:=Time;
+end;
+
+
+Function FileExists (Const FileName : String) : Boolean;
+Var
+ F: File;
+ OldMode : Byte;
+Begin
+  OldMode := FileMode;
+  FileMode := fmOpenRead;
+  Assign(F,FileName);
+  Reset(F,1);
+  FileMode := OldMode;
+  If IOResult <> 0 then
+    FileExists := FALSE
+  else
+    Begin
+      FileExists := TRUE;
+      Close(F);
+    end;
+end;
+
+type
+  PDOSSearchRec = ^SearchRec;
+
+Function FindFirst (Const Path : String; Attr : Longint; Out Rslt : TSearchRec) : Longint;
+Const
+  faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
+var
+  p : pDOSSearchRec;
+  dosattr: word;
+  DT: Datetime;
+begin
+ dosattr:=0;
+ if Attr and faHidden <> 0 then
+   dosattr := dosattr or Hidden;
+ if Attr and faSysFile <> 0 then
+   dosattr := dosattr or SysFile;
+ if Attr and favolumeID <> 0 then
+   dosattr := dosattr or VolumeID;
+ if Attr and faDirectory <> 0 then
+   dosattr := dosattr or Directory;
+ New(p);
+ Rslt.FindHandle :=  THandle(p);
+ dos.FindFirst(path,dosattr,p^);
+ if DosError <> 0 then
+    begin
+      FindFirst := -1;
+    end
+ else
+   begin
+     Rslt.Name := p^.Name;
+     { Not compatible with other platforms! }
+     Rslt.Time:=p^.Time;
+     Rslt.Attr := p^.Attr;
+     Rslt.ExcludeAttr := not p^.Attr;
+     Rslt.Size := p^.Size;
+     FindFirst := 0;
+   end;
+end;
+
+
+Function FindNext (Var Rslt : TSearchRec) : Longint;
+var
+ p : pDOSSearchRec;
+ DT: Datetime;
+begin
+  p:= PDOsSearchRec(Rslt.FindHandle);
+  if not assigned(p) then
+     begin
+       FindNext := -1;
+       exit;
+     end;
+  Dos.FindNext(p^);
+ if DosError <> 0 then
+    begin
+      FindNext := -1;
+    end
+ else
+   begin
+     Rslt.Name := p^.Name;
+     UnpackTime(p^.Time, DT);
+     { Warning: Not compatible with other platforms }
+     Rslt.time := p^.Time;
+     Rslt.Attr := p^.Attr;
+     Rslt.ExcludeAttr := not p^.Attr;
+     Rslt.Size := p^.Size;
+     FindNext := 0;
+   end;
+end;
+
+Procedure FindClose (Var F : TSearchrec);
+Var
+  p : PDOSSearchRec;
+
+begin
+  p:=PDOSSearchRec(f.FindHandle);
+  if not assigned(p) then
+       exit;
+  Dos.FindClose(p^);
+  if assigned(p) then
+     Dispose(p);
+  f.FindHandle := THandle(nil);
+end;
+
+Function FileGetAttr (Const FileName : String) : Longint;
+var
+ F: file;
+ attr: word;
+begin
+ Assign(F,FileName);
+ dos.GetFAttr(F,attr);
+ if DosError <> 0 then
+    FileGetAttr := -1
+ else
+    FileGetAttr := Attr;
+end;
+
+
+Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
+var
+ F: file;
+begin
+ Assign(F, FileName);
+ Dos.SetFAttr(F, Attr and $ffff);
+ FileSetAttr := DosError;
+end;
+
+
+
+{****************************************************************************
+                              Disk Functions
+****************************************************************************}
+
+{
+  The Diskfree and Disksize functions need a file on the specified drive, since this
+  is required for the statfs system call.
+  These filenames are set in drivestr[0..26], and have been preset to :
+   0 - '.'      (default drive - hence current dir is ok.)
+   1 - '/fd0/.'  (floppy drive 1 - should be adapted to local system )
+   2 - '/fd1/.'  (floppy drive 2 - should be adapted to local system )
+   3 - '/'       (C: equivalent of dos is the root partition)
+   4..26          (can be set by you're own applications)
+  ! Use AddDisk() to Add new drives !
+  They both return -1 when a failure occurs.
+}
+Const
+  FixDriveStr : array[0..3] of pchar=(
+    '.',
+    '/fd0/.',
+    '/fd1/.',
+    '/.'
+    );
+var
+  Drives   : byte;
+  DriveStr : array[4..26] of pchar;
+
+Procedure AddDisk(const path:string);
+begin
+  if not (DriveStr[Drives]=nil) then
+   FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
+  GetMem(DriveStr[Drives],length(Path)+1);
+  StrPCopy(DriveStr[Drives],path);
+  inc(Drives);
+  if Drives>26 then
+   Drives:=4;
+end;
+
+
+
+Function DiskFree(Drive: Byte): int64;
+Begin
+  DiskFree := dos.diskFree(Drive);
+End;
+
+
+Function DiskSize(Drive: Byte): int64;
+Begin
+  DiskSize := dos.DiskSize(Drive);
+End;
+
+
+Function GetCurrentDir : String;
+begin
+  GetDir (0,Result);
+end;
+
+
+Function SetCurrentDir (Const NewDir : String) : Boolean;
+begin
+   ChDir(NewDir);
+  result := (IOResult = 0);
+end;
+
+
+Function CreateDir (Const NewDir : String) : Boolean;
+begin
+   MkDir(NewDir);
+  result := (IOResult = 0);
+end;
+
+
+Function RemoveDir (Const Dir : String) : Boolean;
+begin
+   RmDir(Dir);
+  result := (IOResult = 0);
+end;
+
+
+function DirectoryExists(const Directory: string): Boolean;
+var
+  tmpStr : array[0..255] of Char;
+  tmpLock: LongInt;
+  FIB    : PFileInfoBlock;
+begin
+  DirectoryExists:=False;
+  If (Directory='') or (InOutRes<>0) then exit;
+  tmpStr:=PathConv(Directory)+#0;
+  tmpLock:=0;
+
+  tmpLock:=Lock(@tmpStr,SHARED_LOCK);
+  if tmpLock=0 then exit;
+
+  FIB:=nil; new(FIB);
+
+  if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
+    DirectoryExists:=True;
+  end;
+
+  if tmpLock<>0 then Unlock(tmpLock);
+  if assigned(FIB) then dispose(FIB);
+end;
+
+
+
+{****************************************************************************
+                              Misc Functions
+****************************************************************************}
+
+procedure Beep;
+begin
+end;
+
+
+{****************************************************************************
+                              Locale Functions
+****************************************************************************}
+
+Procedure GetLocalTime(var SystemTime: TSystemTime);
+var
+ dayOfWeek: word;
+begin
+  dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second,SystemTime.Millisecond);
+  dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, DayOfWeek);
+end ;
+
+
+Procedure InitAnsi;
+Var
+  i : longint;
+begin
+  {  Fill table entries 0 to 127  }
+  for i := 0 to 96 do
+    UpperCaseTable[i] := chr(i);
+  for i := 97 to 122 do
+    UpperCaseTable[i] := chr(i - 32);
+  for i := 123 to 191 do
+    UpperCaseTable[i] := chr(i);
+  Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
+
+  for i := 0 to 64 do
+    LowerCaseTable[i] := chr(i);
+  for i := 65 to 90 do
+    LowerCaseTable[i] := chr(i + 32);
+  for i := 91 to 191 do
+    LowerCaseTable[i] := chr(i);
+  Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
+end;
+
+
+Procedure InitInternational;
+begin
+  InitInternationalGeneric; 
+  InitAnsi;
+end;
+
+function SysErrorMessage(ErrorCode: Integer): String;
+
+begin
+{  Result:=StrError(ErrorCode);}
+end;
+
+{****************************************************************************
+                              OS utility functions
+****************************************************************************}
+
+Function GetEnvironmentVariable(Const EnvVar : String) : String;
+
+begin
+  Result:=Dos.Getenv(shortstring(EnvVar));
+end;
+Function GetEnvironmentVariableCount : Integer;
+
+begin
+  // Result:=FPCCountEnvVar(EnvP);
+  Result:=Dos.envCount;
+end;
+
+Function GetEnvironmentString(Index : Integer) : String;
+
+begin
+  // Result:=FPCGetEnvStrFromP(Envp,Index);
+  Result:=Dos.EnvStr(Index);
+end;
+
+function ExecuteProcess (const Path: AnsiString; const ComLine: AnsiString):
+                                                                       integer;
+var
+  CommandLine: AnsiString;
+  E: EOSError;
+
+begin
+  Dos.Exec (Path, ComLine);
+  if DosError <> 0 then begin
+
+    if ComLine = '' then
+      CommandLine := Path
+    else
+      CommandLine := Path + ' ' + ComLine;
+
+    E := EOSError.CreateFmt (SExecuteProcessFailed, [CommandLine, DosError]);
+    E.ErrorCode := DosError;
+    raise E;
+  end;
+end;
+
+function ExecuteProcess (const Path: AnsiString;
+                                  const ComLine: array of AnsiString): integer;
+var
+  CommandLine: AnsiString;
+  I: integer;
+
+begin
+  Commandline := '';
+  for I := 0 to High (ComLine) do
+   if Pos (' ', ComLine [I]) <> 0 then
+    CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
+   else
+    CommandLine := CommandLine + ' ' + Comline [I];
+  ExecuteProcess := ExecuteProcess (Path, CommandLine);
+end;
+
+
+{****************************************************************************
+                              Initialization code
+****************************************************************************}
+
+Initialization
+  InitExceptions;
+  InitInternational;    { Initialize internationalization settings }
+Finalization
+  DoneExceptions;
+end.

rtl/amiga/timerd.inc

@@ -0,0 +1,67 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    timer.device definitions (V50) for MorphOS/PowerPC
+    Copyright (c) 2002-3 The MorphOS Development Team, All Rights Reserved.
+
+    Free Pascal conversion
+    Copyright (c) 2004 Karoly Balogh for 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.
+
+ **********************************************************************}
+
+
+{ * timer.device definitions (V50)
+  *********************************************************************
+  * }
+
+
+const
+  UNIT_MICROHZ      = 0;
+  UNIT_VBLANK       = 1;
+  UNIT_ECLOCK       = 2;
+  UNIT_WAITUNTIL    = 3;
+  UNIT_WAITECLOCK   = 4;
+  { *** V50 *** }
+  UNIT_CPUCLOCK     = 5;
+  UNIT_WAITCPUCLOCK = 6;
+
+const
+  TIMERNAME = 'timer.device';
+
+
+type
+  PTimeVal = ^TTimeVal;
+  TTimeVal = packed record
+    tv_secs : DWord;
+    tv_micro: DWord;
+  end;
+
+type
+  PEClockVal = ^TEClockVal;
+  TEClockVal = packed record
+    ev_hi: DWord;
+    ev_lo: DWord;
+  end;
+
+type
+  PTimeRequest = ^TTimeRequest;
+  TTimeRequest = packed record
+    tr_node: TIORequest;
+    tr_time: TTimeVal;
+  end;
+
+
+const
+   TR_ADDREQUEST = (CMD_NONSTD);
+   TR_GETSYSTIME = (CMD_NONSTD + 1);
+   TR_SETSYSTIME = (CMD_NONSTD + 2);
+
+
+