paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 10:07:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

m68k-amiga: initial work on some support functions to allow the RTL to be compiled for AmigaOS 1.x

Browse Source 
git-svn-id: trunk@44427 -
This commit is contained in:
Károly Balogh 2020-03-30 03:06:23 +00:00
parent f69c099cfe
commit b96109727c
4 changed files with 361 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -10065,6 +10065,9 @@ rtl/amiga/doslibd.inc svneol=native#text/plain
rtl/amiga/m68k/doslibf.inc svneol=native#text/plain
rtl/amiga/m68k/execd.inc svneol=native#text/plain
rtl/amiga/m68k/execf.inc svneol=native#text/plain
rtl/amiga/m68k/legacydos.inc svneol=native#text/plain
rtl/amiga/m68k/legacyexec.inc svneol=native#text/plain
rtl/amiga/m68k/legacyutil.inc svneol=native#text/plain
rtl/amiga/m68k/m68kamiga.inc svneol=native#text/plain
rtl/amiga/m68k/prt0.as svneol=native#text/plain
rtl/amiga/m68k/si_prc.pp svneol=native#text/plain

187
rtl/amiga/m68k/legacydos.inc Normal file
View File

@ -0,0 +1,187 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 Karoly Balogh, Free Pascal Development team
Amiga dos.library legacy (OS 1.x/2.x) support 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.
**********************************************************************}
{
This unit implements some missing functions of OS 1.x (and some OS 2.x)
dos.library, so the legacy OS support can be implemented with minimal
changes to the normal system unit and common Amiga-like code
Please note that this code doesn't aim to be API feature complete, just
functional enough for the RTL code.
}
function CreateNewProc(tags: PTagItem): PProcess;
begin
{$warning CreateNewProc unimplemented!}
CreateNewProc:=nil;
end;
function NameFromLock(lock : LongInt;
buffer: PChar;
len : LongInt): LongBool;
var
fib_area: array[1..sizeof(TFileInfoBlock) + sizeof(longint)] of byte;
fib: pfileinfoblock;
namelen: longint;
blen: longint;
begin
NameFromLock:=false;
if len <= 0 then
exit;
if (lock = 0) and (len >= 5) then
begin
buffer:='SYS:';
NameFromLock:=true;
exit;
end;
fib:=align(@fib_area[1],sizeof(longint));
buffer[0]:=#0;
dec(len); // always preserve one byte for zero term
blen:=0;
repeat
if Examine(lock,fib) <> 0 then
begin
namelen:=strlen(@fib^.fib_FileName[0]);
if (namelen+1) > (len-blen) then
exit;
move(buffer[0],buffer[namelen+1],blen);
move(fib^.fib_FileName[0],buffer[0],namelen);
lock:=ParentDir(lock);
if lock = 0 then
buffer[namelen]:=':'
else
buffer[namelen]:='/';
inc(blen,namelen+1);
buffer[blen]:=#0;
end
else
exit;
until lock = 0;
if buffer[blen-1]='/' then
buffer[blen-1]:=#0;
NameFromLock:=true;
end;
function NameFromFH(fh : BPTR;
buffer: PChar;
len : LongInt): LongBool;
begin
{$warning NameFromFH unimplemented!}
NameFromFH:=false;
end;
function ExamineFH(fh : BPTR;
fib: PFileInfoBlock): LongBool;
begin
{$warning ExamineFH unimplemented!}
ExamineFH:=false;
end;
function LockDosList(flags: Cardinal): PDosList;
begin
{$warning LockDosList unimplemented!}
LockDosList:=nil;
end;
procedure UnLockDosList(flags: Cardinal);
begin
{$warning UnlockDosList unimplemented!}
end;
function NextDosEntry(dlist: PDosList;
flags: Cardinal): PDosList;
begin
{$warning NextDosEntry unimplemented!}
NextDosEntry:=nil;
end;
function MatchFirst(pat : PChar;
anchor: PAnchorPath): LongInt;
begin
{$warning MatchFirst unimplemented!}
MatchFirst:=-1;
end;
function MatchNext(anchor: PAnchorPath): LongInt;
begin
{$warning MatchNext unimplemented!}
MatchNext:=-1;
end;
procedure MatchEnd(anchor: PAnchorPath);
begin
{$warning MatchEnd unimplemented!}
end;
function SystemTagList(command: PChar;
tags : PTagItem): LongInt;
begin
{$warning SystemTagList unimplemented!}
SystemTagList:=-1;
end;
function GetVar(name : PChar;
buffer: PChar;
size : LongInt;
flags : LongInt): LongInt;
begin
{$warning GetVar unimplemented!}
GetVar:=-1;
end;
function SetFileDate(name: PChar;
date: PDateStamp): LongBool;
begin
{$warning SetFileDate unimplemented!}
SetFileDate:=false;
end;
function SetFileSize(fh : LongInt;
pos : LongInt;
mode: LongInt): LongInt;
begin
{$warning SetFileSize unimplemented!}
SetFileSize:=-1;
end;
function GetProgramDir: LongInt;
begin
{$warning GetProgramDir unimplemented!}
GetProgramDir:=0;
end;
function GetProgramName(buf: PChar;
len: LongInt): LongBool;
begin
{$warning GetProgramName unimplemented!}
GetProgramName:=false;
end;
var
__fpc_global_args: pchar; external name '__fpc_args';
function GetArgStr: PChar;
begin
GetArgStr:=__fpc_global_args;
end;

136
rtl/amiga/m68k/legacyexec.inc Normal file
View File

@ -0,0 +1,136 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 Karoly Balogh, Free Pascal Development team
Amiga exec.library legacy (OS 1.x/2.x) support 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.
**********************************************************************}
{
This unit implements some missing functions of OS 1.x (and some OS 2.x)
exec.library, so the legacy OS support can be implemented with minimal
changes to the normal system unit and common Amiga-like code
Please note that this code doesn't aim to be API feature complete, just
functional enough for the RTL code.
}
function AllocVec(byteSize : Cardinal;
requirements: Cardinal): Pointer;
var
p: pointer;
begin
p:=execAllocMem(byteSize + sizeof(DWord), requirements);
if p <> nil then
begin
PDWord(p)^:=byteSize + sizeof(DWord);
inc(p, sizeof(DWord));
end;
AllocVec:=p;
end;
procedure FreeVec(memoryBlock: Pointer);
begin
if memoryBlock <> nil then
begin
dec(memoryBlock, sizeof(DWord));
execFreeMem(memoryBlock,PDWord(memoryBlock)^);
end;
end;
type
TAmigaLegacyPoolEntry = record
pe_node: TMinNode;
pe_size: dword;
end;
PAmigaLegacyPoolEntry = ^TAmigaLegacyPoolEntry;
TAmigaLegacyPool = record
pool_requirements: cardinal;
pool_chain: PAmigaLegacyPoolEntry;
end;
PAmigaLegacyPool = ^TAmigaLegacyPool;
function CreatePool(requirements: Cardinal;
puddleSize : Cardinal;
threshSize : Cardinal): Pointer;
var
p: PAmigaLegacyPool;
begin
p:=execAllocMem(sizeof(TAmigaLegacyPool),requirements);
if p <> nil then
begin
p^.pool_requirements:=requirements;
p^.pool_chain:=nil;
end;
CreatePool:=p;
end;
procedure DeletePool(poolHeader: Pointer);
begin
{$warning DeletePool unimplemented!}
end;
function AllocPooled(poolHeader: Pointer;
memSize : Cardinal): Pointer;
var
p: PAmigaLegacyPoolEntry;
ph: PAmigaLegacyPool absolute poolHeader;
begin
p:=execAllocMem(memSize + sizeof(TAmigaLegacyPoolEntry), ph^.pool_requirements);
if p <> nil then
begin
if ph^.pool_chain <> nil then
ph^.pool_chain^.pe_node.mln_Pred:=PMinNode(p);
p^.pe_node.mln_Succ:=PMinNode(ph^.pool_chain);
p^.pe_node.mln_Pred:=nil;
p^.pe_size:=memSize + sizeof(TAmigaLegacyPoolEntry);
ph^.pool_chain:=p;
inc(pointer(p),sizeof(TAmigaLegacyPoolEntry));
end;
AllocPooled:=p;
end;
procedure FreePooled(poolHeader: Pointer;
memory : Pointer;
memSize : Cardinal);
var
p: PAmigaLegacyPoolEntry;
ph: PAmigaLegacyPool absolute poolHeader;
begin
if memory <> nil then
begin
p:=PAmigaLegacyPoolEntry(memory-sizeof(TAmigaLegacyPoolEntry));
if p^.pe_node.mln_Succ <> nil then
PAmigaLegacyPoolEntry(p^.pe_node.mln_Succ)^.pe_node.mln_Pred:=p^.pe_node.mln_Pred;
if p^.pe_node.mln_Pred <> nil then
PAmigaLegacyPoolEntry(p^.pe_node.mln_Pred)^.pe_node.mln_Succ:=p^.pe_node.mln_Succ;
if p = ph^.pool_chain then
ph^.pool_chain:=PAmigaLegacyPoolEntry(p^.pe_node.mln_Succ);
execFreeMem(p,p^.pe_size);
end;
end;
procedure StackSwap(newStack: PStackSwapStruct);
begin
{$warning StackSwap unimplemented!}
end;
procedure ObtainSemaphoreShared(sigSem: PSignalSemaphore);
begin
{ NOTE: this still needs v33+ (OS v1.2 or later) }
{ ObtainSemaphoreShared is used by athreads, and simply replacing
it by ObtainSemaphore works, just with a slight performance hit,
at least in the way it's currently used in athreads. }
ObtainSemaphore(sigSem);
end;

35
rtl/amiga/m68k/legacyutil.inc Normal file
View File

@ -0,0 +1,35 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 Karoly Balogh, Free Pascal Development team
Amiga utility.library legacy (OS 1.x/2.x) support 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.
**********************************************************************}
{
This unit implements some of the utility.library functions for OS 1.x,
where this library is missing, so the legacy OS support can be implemented
with minimal changes to the normal system unit and common Amiga-like code
Please note that this code doesn't aim to be API feature complete, just
functional enough for the RTL code.
}
procedure Amiga2Date(seconds: Cardinal;
result : PClockData);
begin
{$warning Amiga2Date unimplemented!}
end;
function Date2Amiga(date: PClockData): Cardinal;
begin
{$warning Date2Amiga unimplemented!}
Date2Amiga:=0;
end;