home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / HISOFTPASCAL2,0-2.DMS / in.adf / Units / Amiga.pas next >
Encoding:
Pascal/Delphi Source File  |  1992-05-20  |  9.3 KB  |  497 lines
  1. unit Amiga;
  2.  
  3. INTERFACE
  4. {$ifdef WORKBENCH_2}
  5. Uses Exec, AmigaDOS, Graphics, Hardware, Intuition, Timer, Utility;
  6. {$else}
  7. Uses Exec, AmigaDOS, Graphics, Hardware, Timer;
  8. {$endif}
  9.  
  10.  
  11. (* String conversion *)
  12. function PtrToPas (c: STRPTR): string;
  13. function StringToC (var p: string): STRPTR;
  14.  
  15. (* Exec support *)
  16. procedure BeginIO (ioRequest: pIORequest);
  17. function CreateExtIO (port: pMsgPort; size: integer): pIORequest;
  18. function CreatePort (name: STRPTR; pri: integer): pMsgPort;
  19. function CreateStdIO (port: pMsgPort): pIOStdReq;
  20. function CreateTask (name: STRPTR; pri: longint;
  21.         initPC: pointer; stackSize: longint): pTask;
  22. procedure DeleteExtIO (ioReq: pIORequest);
  23. procedure DeletePort (port: pMsgPort);
  24. procedure DeleteStdIO (ioReq: pIOStdReq);
  25. procedure DeleteTask (task: pTask);
  26. procedure NewList (list: pList);
  27.  
  28. (* Graphics support *)
  29. procedure AddTOF (i: pIsrvstr; p: pointer; a: longint);
  30. procedure RemTOF (i: pIsrvstr);
  31.  
  32. (* AmigaDOS support *)
  33. function DOSPacket (pid: pMsgPort; action: longint;
  34.         var args; nargs: integer): longint;
  35.  
  36. (* Timer support *)
  37. function TimeDelay (unit_: longint; secs, microsecs: long): longint;
  38.  
  39. (* 2.0 only BOOPSI support *)
  40. {$ifdef WORKBENCH_2}
  41. function CallHookA (hook: pHook; object, paramPacket: pointer): long;
  42. function CoerceMethodA (cl, obj: pointer; message: Msg): long;
  43. function DoMethodA (obj: pointer; message: Msg): long;
  44. function DoSuperMethodA (cl, obj: pointer; message: Msg): long;
  45. procedure HookEntry (hook: pHook; object, paramPacket: pointer);
  46. {$endif}
  47.  
  48.  
  49. IMPLEMENTATION
  50. (* String conversion *)
  51. function PtrToPas (c: STRPTR): string; xassembler;
  52. asm
  53.     movem.l    4(sp),a0-a1
  54.     addq.l    #1,a1
  55.     move.w    #254,d0
  56. @1:
  57.     move.b    (a0)+,d1
  58.     beq        @2
  59.     move.b    d1,(a1)+
  60.     dbra    d0,@1
  61. @2:
  62.     addq.b    #1,d0
  63.     not.b    d0
  64.     move.l    8(sp),a0
  65.     move.b    d0,(a0)
  66. end;
  67.  
  68.  
  69. function StringToC (var p: string): STRPTR; xassembler;
  70. asm
  71.     move.l    4(sp),a0
  72.     move.l    a0,8(sp)
  73.     moveq    #0,d0
  74.     move.b    (a0),d0
  75.     bra        @2
  76. @1:
  77.     move.b    1(a0),(a0)+
  78. @2:
  79.     dbra    d0,@1
  80.     clr.b    (a0)
  81. end;
  82.  
  83.  
  84. (* Exec support *)
  85. procedure BeginIO (ioRequest: pIORequest); xassembler;
  86. asm
  87.     move.l    4(sp),a1
  88.     move.l    a6,-(sp)
  89.     move.l    tIORequest.io_Device(a1),a6
  90.     jsr        DEV_BEGINIO(a6)
  91.     move.l    (sp)+,a6
  92. end;
  93.  
  94.  
  95. function CreateExtIO (port: pMsgPort; size: integer): pIORequest;
  96. var IOReq: pIORequest;
  97. begin
  98.     CreateExtIO := NIL;
  99.     if port <> NIL then
  100.     begin
  101.         IOReq := AllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
  102.         if IOReq <> NIL then
  103.             with IOReq^.io_Message, mn_Node do
  104.             begin
  105.                 ln_Type            := NT_Message;
  106.                 mn_Length        := size;
  107.                 mn_ReplyPort    := port;
  108.                 CreateExtIO        := IOReq
  109.             end
  110.     end
  111. end;
  112.  
  113.  
  114. procedure DeleteExtIO (ioReq: pIORequest);
  115. begin
  116.     with IOReq^, io_Message do
  117.     begin
  118.         mn_Node.ln_Type    := $FF;
  119.         mn_ReplyPort    := pMsgPort(-1);
  120.         io_Device        := pDevice(-1);
  121.         FreeMem_(IOReq, mn_Length)
  122.     end
  123. end;
  124.  
  125.  
  126. function CreateStdIO (port: pMsgPort): pIOStdReq;
  127. begin
  128.     CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq)))
  129. end;
  130.  
  131.  
  132. procedure DeleteStdIO (ioReq: pIOStdReq);
  133. begin
  134.     DeleteExtIO(pIORequest(ioReq))
  135. end;
  136.  
  137.  
  138. function CreatePort (name: STRPTR; pri: integer): pMsgPort;
  139. var port: pMsgPort; sigbit: shortint;
  140. begin
  141.     CreatePort    := NIL;
  142.     sigbit        := AllocSignal(-1);
  143.     if sigbit <> -1 then
  144.     begin
  145.         port := AllocMem(sizeof(tMsgPort), MEMF_CLEAR or MEMF_PUBLIC);
  146.         if port = NIL then
  147.             FreeSignal(sigbit)
  148.         else
  149.             with port^, mp_Node do
  150.             begin
  151.                 ln_Name        := name;
  152.                 ln_Pri        := pri;
  153.                 ln_Type        := NT_MSGPORT;
  154.  
  155.                 mp_Flags    := PA_SIGNAL;
  156.                 mp_SigBit    := sigbit;
  157.                 mp_SigTask    := FindTask(NIL);
  158.  
  159.                 if name <> NIL then
  160.                     AddPort(port)
  161.                 else
  162.                     NewList(@mp_MsgList);
  163.                 CreatePort := port
  164.             end
  165.     end
  166. end;
  167.  
  168.  
  169. procedure DeletePort (port: pMsgPort);
  170. begin
  171.     with port^, mp_MsgList do
  172.     begin
  173.         if mp_Node.ln_Name <> NIL then
  174.             RemPort(port);
  175.  
  176.         mp_SigTask    := pTask(-1);
  177.         lh_Head        := pNode(-1);
  178.         FreeSignal(mp_SigBit);
  179.         FreeMem_(port, sizeof(tMsgPort))
  180.     end
  181. end;
  182.  
  183.  
  184. function CreateTask (name: STRPTR; pri: longint;
  185.         initPC: pointer; stackSize: longint): pTask;
  186. type
  187.     mementrynum = (ME_TASK, ME_STACK, NUMENTRIES);
  188.     pfakememlist = ^tfakememlist;
  189.     tfakememlist = record
  190.             list:    tMemList;
  191.             entry:    array [ME_TASK..ME_STACK] of tMemEntry;
  192.         end;
  193. var
  194.     fakememlist:    tfakememlist;
  195.     ml:                pfakememlist;
  196.     newtask:        pTask;
  197.     namelen:        integer;
  198.  
  199. begin
  200.     CreateTask    := NIL;
  201.     stacksize    := (stacksize + 3) and not 3;
  202.  
  203. {allocate the memory}
  204.     with fakememlist, list do
  205.     begin
  206.         FillChar(ml_Node, sizeof(ml), 0);
  207.         ml_NumEntries                := integer(NUMENTRIES);
  208.         entry[ME_TASK].me_Reqs        := MEMF_PUBLIC | MEMF_CLEAR;
  209.         entry[ME_TASK].me_Length    := sizeof(tTask);
  210.         entry[ME_STACK].me_Reqs        := 0;
  211.         entry[ME_STACK].me_Length    := stacksize;
  212.  
  213.         ml := pfakememlist(AllocEntry(@list));
  214.         if ml = NIL then exit;
  215.  
  216.         newtask := pTask(ml^.entry[ME_TASK].me_Addr)
  217.     end;
  218.  
  219. {initialise the task structure}
  220.     with newtask^, tc_Node, ml^ do
  221.     begin
  222.         ln_Type        := NT_TASK;
  223.         ln_Pri        := pri;
  224.         ln_Name        := name;
  225.  
  226.         tc_SPLower    := entry[ME_STACK].me_Addr;
  227.         tc_SPUpper    := pointer(longint(tc_SPLower) + stacksize);
  228.         tc_SPReg    := tc_SPUpper;
  229.  
  230.         NewList(@tc_MemEntry);
  231.         AddHead(@tc_MemEntry, pNode(ml))
  232.     end;
  233.  
  234. {add the task to the system}
  235.     initpc := AddTask(newtask, initpc, NIL);    {throw away result}
  236.     CreateTask := newtask
  237. end;
  238.  
  239.  
  240. procedure DeleteTask (task: pTask);
  241. begin
  242.     RemTask(task)
  243. end;
  244.  
  245.  
  246. procedure NewList (list: pList);
  247. begin
  248.     with list^ do
  249.     begin
  250.         lh_Head        := pNode(@lh_Tail);
  251.         lh_Tail        := NIL;
  252.         lh_TailPred    := pNode(@lh_Head)
  253.     end
  254. end;
  255.  
  256.  
  257. (* Graphics support *)
  258. procedure ttskasm; xassembler;
  259. asm
  260.     move.l    d2,-(sp)
  261.     move.l    tIsrvstr.ccode(a1),a0
  262.     move.l    tIsrvstr.Carg(a1),-(sp)
  263.     jsr        (a0)
  264.     move.l    (sp)+,d2
  265.     moveq    #0,d0
  266. end;
  267.  
  268.  
  269. procedure AddTOF (i: pIsrvstr; p: pointer; a: longint);
  270. begin
  271. { note: TOF interrupt routines should be procedures }
  272. { and should accept a single longint parameter }
  273.     with i^ do
  274.     begin
  275.         Iptr    := i;
  276.         code    := @ttskasm;
  277.         ccode    := p;
  278.         Carg    := a
  279.     end;
  280.     AddintServer(INTB_VERTB, pinterrupt(i))
  281. end;
  282.  
  283.  
  284. procedure RemTOF (i: pIsrvstr);
  285. begin
  286.     RemintServer(INTB_VERTB, pinterrupt(i))
  287. end;
  288.  
  289.  
  290. (* AmigaDOS support *)
  291. function DOSPacket (pid: pMsgPort; action: longint;
  292.         var args; nargs: integer): longint;
  293. var
  294.     replyport: pMsgPort; packet: pStandardPacket; i: integer; junkp: pointer;
  295.  
  296. begin
  297.     DOSPacket    := 0;
  298.     replyport    := CreatePort(NIL, 0);
  299.     if replyport <> NIL then
  300.     begin
  301.         packet := AllocMem(sizeof(tStandardPacket), MEMF_CLEAR or MEMF_PUBLIC);
  302.         if packet <> NIL then
  303.         begin
  304.             with packet^, sp_Pkt do
  305.             begin
  306.                 sp_Msg.mn_node.ln_Name := @sp_Pkt;
  307.                 dp_Link        := @sp_Msg;
  308.                 dp_port        := replyport;
  309.                 dp_type        := action;
  310.                 Move(args, dp_Arg1, nargs * sizeof(longint));
  311.                 PutMsg(pid, @sp_Msg);
  312.                 junkp        := WaitPort(replyPort);
  313.                 DOSPacket    := dp_res1
  314.              end;
  315.             FreeMem_(packet, sizeof(tStandardPacket))
  316.         end;
  317.         DeletePort(replyport)
  318.     end
  319. end;
  320.  
  321.  
  322. (* Timer support *)
  323. procedure DoTimer_; xassembler;
  324. asm
  325.     movem.l    d2-d3/a2-a4/a6,-(sp)
  326.     move.l    SysBase,a6
  327.     move.l    a0,a4
  328.     move.l    d0,d2
  329.     move.l    d1,d3
  330.     lea        -$4A(sp),sp
  331.     move.l    sp,a3
  332.     lea        $28(a3),a2
  333.     move.b    #4,8(a2)
  334.     clr.b    9(a2)
  335.     clr.l    $A(a2)
  336.     clr.b    $E(a2)
  337.  
  338.     moveq    #-1,d0
  339.     jsr        -$14A(a6)        { AllocSignal }
  340.     cmp.b    #$FF,d0
  341.     beq        @3
  342.     move.b    d0,$F(a2)
  343.     sub.l    a1,a1
  344.     jsr        -$126(a6)        { FindTask }
  345.     move.l    d0,$10(a2)
  346.     lea        $14(a2),a0
  347.     move.l    a0,8(a0)
  348.     addq.l    #4,a0
  349.     clr.l    (a0)
  350.     move.l    a0,-(a0)
  351.  
  352.     lea        @4(pc),a0
  353.     move.l    a3,a1
  354.     move.l    d2,d0
  355.     moveq    #0,d1
  356.     jsr        -$1BC(a6)        { OpenDevice }
  357.     tst.l    d0
  358.     bne        @2
  359.  
  360.     move.l    a2,$E(a3)
  361.     move.l    a3,a1
  362.     move.w    d3,$1C(a1)
  363.     move.l    (a4),$20(a1)
  364.     move.l    4(a4),$24(a1)
  365.     jsr        -$1C8(a6)        { DoIO }
  366.     move.l    $20(a3),(a4)
  367.     move.l    $24(a3),4(a4)
  368.  
  369.     move.l    a3,a1
  370.     jsr        -$1C2(a6)        { CloseDevice }
  371.     moveq    #0,d0
  372.     move.b    $F(a2),d0        { FreeSignal }
  373.     jsr        -$150(a6)
  374.     bra        @1
  375.  
  376. @4:
  377.     dc.b    'timer.device',0
  378.  
  379. @2:
  380.     moveq    #0,d0
  381.     move.b    $F(a2),d0
  382.     jsr        -$150(a6)        { FreeSignal }
  383. @3:
  384.     moveq    #-1,d0
  385. @1:
  386.     lea        $4A(sp),sp
  387.     movem.l    (sp)+,d2-d3/a2-a4/a6
  388. end;
  389.  
  390.  
  391. function TimeDelay (unit_: longint;
  392.         secs, microsecs: long): longint; assembler;
  393. asm
  394.     move.l    unit_,d0
  395.     moveq    #TR_ADDREQUEST,d1
  396.     move.l    microsecs,-(sp)
  397.     move.l    secs,-(sp)
  398.     move.l    sp,a0
  399.     jsr        DoTimer_
  400.     move.l    d0,@result
  401.     addq.l    #8,sp
  402. end;
  403.  
  404.  
  405. (* BOOPSI support *)
  406. {$ifdef WORKBENCH_2}
  407. function CallHookA (hook: pHook;
  408.         object, paramPacket: pointer): long; xassembler;
  409. asm
  410.     move.l    a2,-(sp)
  411.     lea        $C(sp),a0
  412.     move.l    (a0)+,a1
  413.     move.l    (a0)+,a2
  414.     move.l    (a0),a0
  415.     pea        @2(pc)
  416.     move.l    tHook.h_SubEntry(a0),-(sp)
  417.     rts
  418. @2:
  419.     move.l    (sp)+,a2
  420.     move.l    d0,16(sp)
  421. end;
  422.  
  423.  
  424. procedure HookEntry (hook: pHook;
  425.         object, paramPacket: pointer); xassembler;
  426. asm
  427.     subq.l    #4,sp
  428.     move.l    a0,-(sp)
  429.     move.l    a2,-(sp)
  430.     move.l    a1,-(sp)
  431.     move.l    tHook.h_SubEntry(a0),a0
  432.     jsr        (a0)
  433.     move.l    (sp)+,d0
  434. end;
  435.  
  436.  
  437. function DoMethodA (obj: pointer; message: pMsg): long; xassembler;
  438. asm
  439.     move.l    a2,-(sp)
  440.     move.l    12(sp),a2        { object }
  441.     move.l    a2,d0
  442.     beq        @2
  443.     move.l    8(sp),a1        { message }
  444.     move.l    -4(a2),a0        { class ptr precedes object }
  445.  
  446.     pea        @2(pc)
  447.     move.l    tHook.h_Entry(a0),-(sp)
  448.     rts
  449. @2:
  450.     move.l    (sp)+,a2
  451.     move.l    d0,12(sp)
  452. end;
  453.  
  454.  
  455. function DoSuperMethodA (cl, obj: pointer;
  456.         message: pMsg): long; xassembler;
  457. asm
  458.     move.l    a2,-(sp)
  459.     movem.l    8(sp),a1-a2        { message, object }
  460.     move.l    a2,d0
  461.     beq        @2
  462.     move.l    16(sp),d0        { class }
  463.     beq        @2
  464.     move.l    d0,a0
  465.     move.l    tIClass.cl_Super(a0),a0
  466.  
  467.     pea        @2(pc)
  468.     move.l    tHook.h_Entry(a0),-(sp)
  469.     rts
  470. @2:
  471.     move.l    (sp)+,a2
  472.     move.l    d0,16(sp)
  473. end;
  474.  
  475.  
  476. function CoerceMethodA (cl, obj: pointer;
  477.         message: pMsg): long; xassembler;
  478. asm
  479.     move.l    a2,-(sp)
  480.     movem.l    8(sp),a1-a2        { message, object }
  481.     move.l    a2,d0
  482.     beq        @2
  483.     move.l    16(sp),d0        { class }
  484.     beq        @2
  485.     move.l    d0,a0
  486.  
  487.     pea        @2(pc)
  488.     move.l    tHook.h_Entry(a0),-(sp)
  489.     rts
  490. @2:
  491.     move.l    (sp)+,a2
  492.     move.l    d0,16(sp)
  493. end;
  494. {$endif}
  495.  
  496. end.
  497.