fpc/rtl/aros/i386/execf.inc

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 2006 Karoly Balogh

    exec functions for AROS/i386

    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.

 **********************************************************************}

var
  LocalExecBase   : Pointer; external name '_ExecBase';

procedure Forbid; syscall AOS_ExecBase 22;
procedure Permit; syscall AOS_ExecBase 23;
function execAllocMem(byteSize: PtrUInt; requirements: Cardinal): Pointer; syscall LocalExecBase 33;
procedure execFreeMem(memoryBlock: Pointer; byteSize: PtrUInt); syscall LocalExecBase 35;
function FindTask(name: PAnsiChar): PTask; syscall LocalExecBase 49;
function SetSignal(newSignals: Cardinal; signalSet : Cardinal): Cardinal; syscall LocalExecBase 51;
function Wait(SignalSet: LongWord): LongWord; syscall AOS_ExecBase 53;
procedure Signal(Task: PTask; SignalSet: LongWord); syscall AOS_ExecBase 54;
function AllocSignal(signalNum: LongInt): ShortInt; syscall LocalExecBase 55;
procedure FreeSignal(signalNum: LongInt); syscall LocalExecBase 56;
procedure AddPort(port: PMsgPort); syscall LocalExecBase 59;
procedure RemPort(port: PMsgPort); syscall LocalExecBase 60;
procedure PutMsg(Port: PMsgPort; Message: PMessage); syscall AOS_ExecBase 61;
function GetMsg(port: PMsgPort): PMessage; syscall LocalExecBase 62;
procedure ReplyMsg(message : pMessage); syscall LocalExecBase 63;
function WaitPort(port: PMsgPort): PMessage; syscall LocalExecBase 64;
procedure CloseLibrary(libHandle: PLibrary); syscall LocalExecBase 69;
function OpenDevice(devName: PAnsiChar; numunit: Cardinal; ioRequest: pIORequest; flags: Cardinal): ShortInt; syscall LocalExecBase 74;
procedure CloseDevice(ioRequest: PIORequest); syscall LocalExecBase 75;
function DoIO(ioRequest: PIORequest): ShortInt; syscall LocalExecBase 76;
function OpenLibrary(libname: PAnsiChar; libver : Cardinal): Pointer; syscall LocalExecBase 92;
procedure InitSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 93;
procedure ObtainSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 94;
procedure ReleaseSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 95;
function AttemptSemaphore(SigSem: PSignalSemaphore): LongWord; syscall AOS_ExecBase 96;
function CreateMsgPort: PMsgPort; syscall AOS_ExecBase 111;
procedure DeleteMsgPort(Port: PMsgPort); syscall AOS_ExecBase 112;
procedure ObtainSemaphoreShared(SigSem: PSignalSemaphore); syscall AOS_ExecBase 113;
function AllocVec(ByteSize: PtrUInt; Requirements: DWord): Pointer; syscall AOS_ExecBase 114;
procedure FreeVec(MemoryBlock: Pointer); syscall AOS_ExecBase 115;
function CreatePool(requirements: Cardinal; puddleSize: PtrUInt; threshSize: PtrUInt): Pointer; syscall LocalExecBase 116;
procedure DeletePool(poolHeader: Pointer); syscall LocalExecBase 117;
function AllocPooled(poolHeader: Pointer; memSize: PtrUInt): Pointer; syscall LocalExecBase 118;
function FreePooled(poolHeader: Pointer; memory: Pointer; memSize: PtrUInt): Pointer; syscall LocalExecBase 119;
procedure StackSwap(NewStack: PStackSwapStruct); syscall AOS_ExecBase 122;
function NewStackSwap(NewStack: PStackSwapStruct; Function_: Pointer; Args: PStackSwapArgs): Pointer; syscall AOS_ExecBase 134;
procedure RawPutChar(c: AnsiChar); syscall AOS_ExecBase 86;

//function RawDoFmt(const formatString : PAnsiChar;const dataStream : POINTER; putChProc : tPROCEDURE; putChData : POINTER): pointer;
function RawDoFmt(const formatString : PAnsiChar;const dataStream : POINTER; putChProc : POINTER; putChData : POINTER): pointer; syscall LocalExecBase 87;

// Debugbase
function DecodeLocation(Addr1: Pointer; Tags: Pointer): Integer; syscall SysDebugBase 7;

function GetLibAdress(Base: Pointer; Offset: LongInt): Pointer; inline;
begin
  if Base = nil then
  begin
    RawDoFmt('FPC_FILE_DEBUG: Error! Illegal library access with not opened library: %d !'+#10,@Offset,pointer(1),nil);
    Debugln('Illegal library access with not opened library');
    Halt(1);
  end;
  GetLibAdress := Pointer((Base -(Offset * SizeOf(Pointer)))^);
end;

procedure Debug(s: shortstring);
type
  TkPrintf = function(Msg: PAnsiChar): Integer; cdecl;
var
  kPrintf: TkPrintf;
  d: shortstring;
  i: Integer;
begin
  if Assigned(AOS_ExecBase) then
  begin
    if Assigned(PExecBase(AOS_ExecBase)^.DebugArosBase) then
    begin
      kPrintf := TKPrintF(PExecBase(AOS_ExecBase)^.DebugArosBase^.kprintfPtr);
      if Assigned(kPrintf) then
      begin
        d := s + #0;
        i := kPrintf(@d[1]);
      end;
    end;
  end;
end;

procedure Debugln(s: shortstring);
begin
  Debug(s + #10);
end;