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

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

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;

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;

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;