execf.inc 4.0 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2006 Karoly Balogh
  4. exec functions (V40) for Amiga/PowerPC
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. var
  12. LocalExecBase : Pointer; external name '_ExecBase';
  13. procedure Forbid; syscall AOS_ExecBase 22;
  14. procedure Permit; syscall AOS_ExecBase 23;
  15. function execAllocMem(byteSize: Cardinal; requirements: Cardinal): Pointer; syscall LocalExecBase 33;
  16. procedure execFreeMem(memoryBlock: Pointer; byteSize: Cardinal); syscall LocalExecBase 35;
  17. function FindTask(name: PChar): PTask; syscall LocalExecBase 49;
  18. function SetSignal(newSignals: Cardinal; signalSet : Cardinal): Cardinal; syscall LocalExecBase 51;
  19. function Wait(SignalSet: LongWord): LongWord; syscall AOS_ExecBase 53;
  20. procedure Signal(Task: PTask; SignalSet: LongWord); syscall AOS_ExecBase 54;
  21. function AllocSignal(signalNum: LongInt): ShortInt; syscall LocalExecBase 55;
  22. procedure FreeSignal(signalNum: LongInt); syscall LocalExecBase 56;
  23. procedure AddPort(port: PMsgPort); syscall LocalExecBase 59;
  24. procedure RemPort(port: PMsgPort); syscall LocalExecBase 60;
  25. function GetMsg(port: PMsgPort): PMessage; syscall LocalExecBase 62;
  26. procedure ReplyMsg(message : pMessage); syscall LocalExecBase 63;
  27. function WaitPort(port: PMsgPort): PMessage; syscall LocalExecBase 64;
  28. procedure CloseLibrary(libHandle: PLibrary); syscall LocalExecBase 69;
  29. function OpenDevice(devName: PChar; numunit: Cardinal; ioRequest: pIORequest; flags: Cardinal): ShortInt; syscall LocalExecBase 74;
  30. procedure CloseDevice(ioRequest: PIORequest); syscall LocalExecBase 75;
  31. function DoIO(ioRequest: PIORequest): ShortInt; syscall LocalExecBase 76;
  32. function OpenLibrary(libname: PChar; libver : Cardinal): Pointer; syscall LocalExecBase 92;
  33. procedure InitSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 93;
  34. procedure ObtainSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 94;
  35. procedure ReleaseSemaphore(SigSem: PSignalSemaphore); syscall AOS_ExecBase 95;
  36. function AttemptSemaphore(SigSem: PSignalSemaphore): LongWord; syscall AOS_ExecBase 96;
  37. function CreatePool(requirements: Cardinal; puddleSize: Cardinal; threshSize: Cardinal): Pointer; syscall LocalExecBase 116;
  38. procedure DeletePool(poolHeader: Pointer); syscall LocalExecBase 117;
  39. function AllocPooled(poolHeader: Pointer; memSize: Cardinal): Pointer; syscall LocalExecBase 118;
  40. function FreePooled(poolHeader: Pointer; memory: Pointer; memSize: Cardinal): Pointer; syscall LocalExecBase 119;
  41. procedure StackSwap(NewStack: PStackSwapStruct); syscall AOS_ExecBase 122;
  42. //function RawDoFmt(const formatString : pCHAR;const dataStream : POINTER; putChProc : tPROCEDURE; putChData : POINTER): pointer;
  43. function RawDoFmt(const formatString : pCHAR;const dataStream : POINTER; putChProc : POINTER; putChData : POINTER): pointer; syscall LocalExecBase 87;
  44. function GetLibAdress(Base: Pointer; Offset: LongInt): Pointer; inline;
  45. begin
  46. if Base = nil then
  47. begin
  48. RawDoFmt('FPC_FILE_DEBUG: Error! Illegal library access with not opened library: %d !'+#10,@Offset,pointer(1),nil);
  49. Debugln('Illegal library access with not opened library');
  50. Halt(1);
  51. end;
  52. GetLibAdress := Pointer((Base -(Offset * SizeOf(Pointer)))^);
  53. end;
  54. procedure Debug(s: string);
  55. type
  56. TkPrintf = function(Msg: PChar): Integer; cdecl;
  57. var
  58. kPrintf: TkPrintf;
  59. d: string;
  60. i: Integer;
  61. begin
  62. if Assigned(AOS_ExecBase) then
  63. begin
  64. if Assigned(PExecBase(AOS_ExecBase)^.DebugArosBase) then
  65. begin
  66. kPrintf := TKPrintF(PExecBase(AOS_ExecBase)^.DebugArosBase^.kprintfPtr);
  67. if Assigned(kPrintf) then
  68. begin
  69. d := s + #0;
  70. i := kPrintf(@d[1]);
  71. end;
  72. end;
  73. end;
  74. end;
  75. procedure Debugln(s: string);
  76. begin
  77. Debug(s + #10);
  78. end;