paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 05:49:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Amiga RTL update based on MorphOS version

Browse Source 
git-svn-id: trunk@4395 -
This commit is contained in:
Károly Balogh 2006-08-08 20:59:37 +00:00
parent 0171c4c804
commit e109bfdf35
6 changed files with 2048 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
.gitattributes vendored
View File

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

1380
rtl/amiga/doslibd.inc Normal file
View File

File diff suppressed because it is too large Load Diff

1
rtl/amiga/m68k/execf.inc Normal file
View File

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

20
rtl/amiga/os.inc
View File

@ -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}

587
rtl/amiga/sysutils.pp Normal file
View File

@ -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.

67
rtl/amiga/timerd.inc Normal file
View File

@ -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);