From b96109727c01f496061c4a77d65e0f50e8498eb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A1roly=20Balogh?= Date: Mon, 30 Mar 2020 03:06:23 +0000 Subject: [PATCH] m68k-amiga: initial work on some support functions to allow the RTL to be compiled for AmigaOS 1.x git-svn-id: trunk@44427 - --- .gitattributes | 3 + rtl/amiga/m68k/legacydos.inc | 187 ++++++++++++++++++++++++++++++++++ rtl/amiga/m68k/legacyexec.inc | 136 +++++++++++++++++++++++++ rtl/amiga/m68k/legacyutil.inc | 35 +++++++ 4 files changed, 361 insertions(+) create mode 100644 rtl/amiga/m68k/legacydos.inc create mode 100644 rtl/amiga/m68k/legacyexec.inc create mode 100644 rtl/amiga/m68k/legacyutil.inc diff --git a/.gitattributes b/.gitattributes index fc5319f4d2..b5b4d8ba6b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/rtl/amiga/m68k/legacydos.inc b/rtl/amiga/m68k/legacydos.inc new file mode 100644 index 0000000000..634cf979d3 --- /dev/null +++ b/rtl/amiga/m68k/legacydos.inc @@ -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; diff --git a/rtl/amiga/m68k/legacyexec.inc b/rtl/amiga/m68k/legacyexec.inc new file mode 100644 index 0000000000..38c564013a --- /dev/null +++ b/rtl/amiga/m68k/legacyexec.inc @@ -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; diff --git a/rtl/amiga/m68k/legacyutil.inc b/rtl/amiga/m68k/legacyutil.inc new file mode 100644 index 0000000000..68bf289859 --- /dev/null +++ b/rtl/amiga/m68k/legacyutil.inc @@ -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;