mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-15 19:19:24 +02:00
amunits: move DoMethod/DoSuperMethod to intuition, Hook Helper to Utility, exec helper to exec, commodities macros to commodities, mark amigalib as deprecated
git-svn-id: trunk@36778 -
This commit is contained in:
marcus
parent
20f148ef89
commit
645dd2a272
@ -47,61 +47,60 @@
|
||||
|
||||
nils.sjoholm@mailbox.swipnet.se
|
||||
}
|
||||
|
||||
{$INLINE ON}
|
||||
{$mode objfpc}
|
||||
{$I useamigasmartlink.inc}
|
||||
{$ifdef use_amiga_smartlink}
|
||||
{$smartlink on}
|
||||
{$endif use_amiga_smartlink}
|
||||
|
||||
unit amigalib;
|
||||
unit amigalib
|
||||
deprecated 'Unit will be removed. Functions are moved to exec, intuition, utility and commodities unit.';
|
||||
|
||||
|
||||
INTERFACE
|
||||
|
||||
uses exec,intuition,utility,commodities,inputevent,amigados;
|
||||
|
||||
// moved to exec, use them from there
|
||||
{* Exec support functions from amiga.lib *}
|
||||
|
||||
procedure BeginIO (ioRequest: pIORequest);
|
||||
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
|
||||
procedure DeleteExtIO (ioReq: pIORequest);
|
||||
function CreateStdIO (port: pMsgPort): pIOStdReq;
|
||||
procedure DeleteStdIO (ioReq: pIOStdReq);
|
||||
function CreatePort (name: PChar; pri: longint): pMsgPort;
|
||||
procedure DeletePort (port: pMsgPort);
|
||||
procedure BeginIO (ioRequest: pIORequest); inline;
|
||||
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; inline;
|
||||
procedure DeleteExtIO (ioReq: pIORequest); inline;
|
||||
function CreateStdIO (port: pMsgPort): pIOStdReq; inline;
|
||||
procedure DeleteStdIO (ioReq: pIOStdReq); inline;
|
||||
function CreatePort (name: PChar; pri: longint): pMsgPort; inline;
|
||||
procedure DeletePort (port: pMsgPort); inline;
|
||||
function CreateTask (name: STRPTR; pri: longint;
|
||||
initPC : Pointer;
|
||||
stackSize : ULONG): pTask;
|
||||
procedure DeleteTask (task: pTask);
|
||||
procedure NewList (list: pList);
|
||||
stackSize : ULONG): pTask; inline;
|
||||
procedure DeleteTask (task: pTask); inline;
|
||||
procedure NewList (list: pList); inline;
|
||||
|
||||
// moved to commodities, use them from there
|
||||
{* Commodities support functions from amiga.lib *}
|
||||
procedure FreeIEvents (events: pInputEvent);
|
||||
procedure FreeIEvents (events: pInputEvent); inline;
|
||||
function CxCustom
|
||||
(action: pointer;
|
||||
id: longint): pCxObj;
|
||||
id: longint): pCxObj; inline;
|
||||
|
||||
function CxDebug (id: long): pCxObj;
|
||||
function CxFilter (d: STRPTR): pCxObj;
|
||||
function CxDebug (id: long): pCxObj; inline;
|
||||
function CxFilter (d: STRPTR): pCxObj; inline;
|
||||
function CxSender
|
||||
(port: pMsgPort;
|
||||
id: longint): pCxObj;
|
||||
id: longint): pCxObj; inline;
|
||||
|
||||
function CxSignal
|
||||
(task: pTask;
|
||||
sig: byte): pCxObj;
|
||||
sig: byte): pCxObj; inline;
|
||||
|
||||
function CxTranslate (ie: pInputEvent): pCxObj;
|
||||
function CxTranslate (ie: pInputEvent): pCxObj; inline;
|
||||
|
||||
|
||||
function DoMethodA(obj : pObject_; msg : APTR): ulong;
|
||||
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
|
||||
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
|
||||
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
|
||||
// moved to intuition, use them from there
|
||||
function DoMethodA(obj : pObject_; msg : APTR): ulong; inline;
|
||||
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
|
||||
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
|
||||
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
|
||||
|
||||
function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline;
|
||||
|
||||
// moved to utility, use them from there
|
||||
procedure HookEntry;
|
||||
procedure HookEntryPas;
|
||||
|
||||
@ -171,231 +170,115 @@ IMPLEMENTATION
|
||||
|
||||
{* Exec support functions from amiga.lib *}
|
||||
|
||||
procedure BeginIO (ioRequest: pIORequest);
|
||||
procedure BeginIO (ioRequest: pIORequest); inline;
|
||||
begin
|
||||
asm
|
||||
move.l a6,-(a7)
|
||||
move.l ioRequest,a1 ; get IO Request
|
||||
move.l 20(a1),a6 ; extract Device ptr
|
||||
jsr -30(a6) ; call BEGINIO directly
|
||||
move.l (a7)+,a6
|
||||
end;
|
||||
Exec.BeginIO(ioRequest);
|
||||
end;
|
||||
|
||||
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
|
||||
var
|
||||
IOReq: pIORequest;
|
||||
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; inline;
|
||||
begin
|
||||
IOReq := NIL;
|
||||
if port <> NIL then
|
||||
begin
|
||||
IOReq := ExecAllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
|
||||
if IOReq <> NIL then
|
||||
begin
|
||||
IOReq^.io_Message.mn_Node.ln_Type := NT_REPLYMSG;
|
||||
IOReq^.io_Message.mn_Length := size;
|
||||
IOReq^.io_Message.mn_ReplyPort := port;
|
||||
end;
|
||||
end;
|
||||
CreateExtIO := IOReq;
|
||||
CreateExtIO := Exec.CreateExtIO(port, size);
|
||||
end;
|
||||
|
||||
procedure DeleteExtIO (ioReq: pIORequest); inline;
|
||||
begin
|
||||
Exec.DeleteExtIO(ioReq);
|
||||
end;
|
||||
|
||||
function CreateStdIO (port: pMsgPort): pIOStdReq; inline;
|
||||
begin
|
||||
CreateStdIO := Exec.CreateStdIO(port)
|
||||
end;
|
||||
|
||||
procedure DeleteStdIO (ioReq: pIOStdReq); inline;
|
||||
begin
|
||||
Exec.DeleteStdIO(ioReq)
|
||||
end;
|
||||
|
||||
function Createport(name : PChar; pri : longint): pMsgPort; inline;
|
||||
begin
|
||||
Createport := Exec.Createport(name, pri);
|
||||
end;
|
||||
|
||||
procedure DeletePort (port: pMsgPort); inline;
|
||||
begin
|
||||
Exec.DeletePort(port);
|
||||
end;
|
||||
|
||||
function CreateTask (name: STRPTR; pri: longint; initPC: pointer; stackSize: ULONG): pTask; inline;
|
||||
begin
|
||||
CreateTask := Exec.CreateTask(name, pri, initPC, stacksize);
|
||||
end;
|
||||
|
||||
procedure DeleteTask (task: pTask); inline;
|
||||
begin
|
||||
Exec.DeleteTask(task)
|
||||
end;
|
||||
|
||||
procedure NewList (list: pList); inline;
|
||||
begin
|
||||
Exec.NewList(list);
|
||||
end;
|
||||
|
||||
|
||||
procedure DeleteExtIO (ioReq: pIORequest);
|
||||
procedure FreeIEvents (events: pInputEvent); inline;
|
||||
begin
|
||||
if ioReq <> NIL then
|
||||
begin
|
||||
ioReq^.io_Message.mn_Node.ln_Type := $FF;
|
||||
ioReq^.io_Message.mn_ReplyPort := pMsgPort(-1);
|
||||
ioReq^.io_Device := pDevice(-1);
|
||||
ExecFreeMem(ioReq, ioReq^.io_Message.mn_Length);
|
||||
end
|
||||
Commodities.FreeIEvents(events);
|
||||
end;
|
||||
|
||||
|
||||
function CreateStdIO (port: pMsgPort): pIOStdReq;
|
||||
function CxCustom(action: pointer; id: longint): pCxObj; inline;
|
||||
begin
|
||||
CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq)))
|
||||
CxCustom := Commodities.CxCustom(action, id)
|
||||
end;
|
||||
|
||||
|
||||
procedure DeleteStdIO (ioReq: pIOStdReq);
|
||||
function CxDebug(id: long): pCxObj; inline;
|
||||
begin
|
||||
DeleteExtIO(pIORequest(ioReq))
|
||||
CxDebug := Commodities.CxDebug(id)
|
||||
end;
|
||||
|
||||
|
||||
function Createport(name : PChar; pri : longint): pMsgPort;
|
||||
var
|
||||
sigbit : Byte;
|
||||
port : pMsgPort;
|
||||
function CxFilter(d: STRPTR): pCxObj; inline;
|
||||
begin
|
||||
sigbit := AllocSignal(-1);
|
||||
if sigbit = -1 then CreatePort := nil;
|
||||
port := ExecAllocmem(sizeof(tMsgPort),MEMF_CLEAR or MEMF_PUBLIC);
|
||||
if port = nil then begin
|
||||
FreeSignal(sigbit);
|
||||
CreatePort := nil;
|
||||
end;
|
||||
with port^ do begin
|
||||
if assigned(name) then
|
||||
mp_Node.ln_Name := name
|
||||
else mp_Node.ln_Name := nil;
|
||||
mp_Node.ln_Pri := pri;
|
||||
mp_Node.ln_Type := NT_MsgPort;
|
||||
mp_Flags := PA_Signal;
|
||||
mp_SigBit := sigbit;
|
||||
mp_SigTask := FindTask(nil);
|
||||
end;
|
||||
if assigned(name) then AddPort(port)
|
||||
else NewList(addr(port^.mp_MsgList));
|
||||
CreatePort := port;
|
||||
CxFilter := Commodities.CxFilter(d);
|
||||
end;
|
||||
|
||||
procedure DeletePort (port: pMsgPort);
|
||||
function CxSender(port: pMsgPort; id: longint): pCxObj; inline;
|
||||
begin
|
||||
if port <> NIL then
|
||||
begin
|
||||
if port^.mp_Node.ln_Name <> NIL then
|
||||
RemPort(port);
|
||||
|
||||
port^.mp_Node.ln_Type := $FF;
|
||||
port^.mp_MsgList.lh_Head := pNode(-1);
|
||||
FreeSignal(port^.mp_SigBit);
|
||||
ExecFreeMem(port, sizeof(tMsgPort));
|
||||
end;
|
||||
CxSender := Commodities.CxSender(port, id)
|
||||
end;
|
||||
|
||||
|
||||
function CreateTask (name: STRPTR; pri: longint;
|
||||
initPC: pointer; stackSize: ULONG): pTask;
|
||||
var
|
||||
memlist : pMemList;
|
||||
task : pTask;
|
||||
totalsize : Longint;
|
||||
function CxSignal(task: pTask; sig: byte): pCxObj; inline;
|
||||
begin
|
||||
task := NIL;
|
||||
stackSize := (stackSize + 3) and not 3;
|
||||
totalsize := sizeof(tMemList) + sizeof(tTask) + stackSize;
|
||||
|
||||
memlist := ExecAllocMem(totalsize, MEMF_PUBLIC + MEMF_CLEAR);
|
||||
if memlist <> NIL then begin
|
||||
memlist^.ml_NumEntries := 1;
|
||||
memlist^.ml_ME[0].me_Un.meu_Addr := Pointer(memlist + 1);
|
||||
memlist^.ml_ME[0].me_Length := totalsize - sizeof(tMemList);
|
||||
|
||||
task := pTask(memlist + sizeof(tMemList) + stackSize);
|
||||
task^.tc_Node.ln_Pri := pri;
|
||||
task^.tc_Node.ln_Type := NT_TASK;
|
||||
task^.tc_Node.ln_Name := name;
|
||||
task^.tc_SPLower := Pointer(memlist + sizeof(tMemList));
|
||||
task^.tc_SPUpper := Pointer(task^.tc_SPLower + stackSize);
|
||||
task^.tc_SPReg := task^.tc_SPUpper;
|
||||
|
||||
NewList(@task^.tc_MemEntry);
|
||||
AddTail(@task^.tc_MemEntry,@memlist^.ml_Node);
|
||||
|
||||
AddTask(task,initPC,NIL)
|
||||
end;
|
||||
CreateTask := task;
|
||||
end;
|
||||
|
||||
|
||||
procedure DeleteTask (task: pTask);
|
||||
begin
|
||||
RemTask(task)
|
||||
end;
|
||||
|
||||
|
||||
procedure NewList (list: pList);
|
||||
begin
|
||||
with list^ do
|
||||
begin
|
||||
lh_Head := pNode(@lh_Tail);
|
||||
lh_Tail := NIL;
|
||||
lh_TailPred := pNode(@lh_Head)
|
||||
end
|
||||
end;
|
||||
|
||||
procedure FreeIEvents (events: pInputEvent);
|
||||
begin
|
||||
while events <> NIL do
|
||||
begin
|
||||
FreeMem (events, sizeof (tInputEvent));
|
||||
events := events^.ie_NextEvent
|
||||
end
|
||||
end;
|
||||
|
||||
function CxCustom
|
||||
(action: pointer;
|
||||
id: longint): pCxObj;
|
||||
begin
|
||||
CxCustom := CreateCxObj(CX_CUSTOM, longint(action), id)
|
||||
end;
|
||||
|
||||
function CxDebug (id: long): pCxObj;
|
||||
begin
|
||||
CxDebug := CreateCxObj(CX_DEBUG, id, 0)
|
||||
end;
|
||||
|
||||
function CxFilter (d: STRPTR): pCxObj;
|
||||
begin
|
||||
CxFilter := CreateCxObj(CX_FILTER, longint(d), 0)
|
||||
end;
|
||||
|
||||
function CxSender
|
||||
(port: pMsgPort;
|
||||
id: longint): pCxObj;
|
||||
begin
|
||||
CxSender := CreateCxObj(CX_SEND, longint(port), id)
|
||||
end;
|
||||
|
||||
function CxSignal
|
||||
(task: pTask;
|
||||
sig: byte): pCxObj;
|
||||
begin
|
||||
CxSignal:= CreateCxObj(CX_SIGNAL, longint(task), sig)
|
||||
CxSignal:= Commodities.CxSignal(task, sig)
|
||||
end;
|
||||
|
||||
function CxTranslate (ie: pInputEvent): pCxObj;
|
||||
begin
|
||||
CxTranslate := CreateCxObj(CX_TRANSLATE, longint(ie), 0)
|
||||
CxTranslate := Commodities.CxTranslate(ie)
|
||||
end;
|
||||
|
||||
function DoMethodA(obj : pObject_; msg : APTR): ulong;
|
||||
function DoMethodA(obj : pObject_; msg : APTR): ulong; inline;
|
||||
begin
|
||||
if assigned(obj) then begin
|
||||
DoMethodA := CallHookPkt(@THook(OCLASS(obj)^.cl_Dispatcher), obj, msg);
|
||||
end else DoMethodA := 0;
|
||||
DoMethodA := Intuition.DoMethodA(obj, msg);
|
||||
end;
|
||||
|
||||
function DoMethod(obj: PObject_; Params: array of DWord): LongWord;
|
||||
function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline;
|
||||
begin
|
||||
DoMethod := DoMethodA(obj, @Params);
|
||||
DoMethod := Intuition.DoMethodA(obj, @Params);
|
||||
end;
|
||||
|
||||
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
|
||||
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
|
||||
begin
|
||||
if assigned(obj) and assigned(cl) then
|
||||
DoSuperMethodA := CallHookPkt(@cl^.cl_Super^.cl_Dispatcher,obj,msg)
|
||||
else DoSuperMethodA := 0;
|
||||
DoSuperMethodA := Intuition.DoSuperMethodA(cl, obj, msg);
|
||||
end;
|
||||
|
||||
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
|
||||
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
|
||||
begin
|
||||
if assigned(cl) and assigned(obj) then
|
||||
CoerceMethodA := CallHookPkt(@cl^.cl_Dispatcher,obj,msg)
|
||||
else CoerceMethodA := 0;
|
||||
CoerceMethodA := Intuition.CoerceMethodA(cl, obj, msg);
|
||||
end;
|
||||
|
||||
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
|
||||
var
|
||||
arr : array[0..2] of longint;
|
||||
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
|
||||
begin
|
||||
arr[0] := OM_SET;
|
||||
arr[1] := longint(msg);
|
||||
arr[2] := 0;
|
||||
SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
|
||||
SetSuperAttrsA := Intuition.SetSuperAttrsA(cl, obj, msg);
|
||||
end;
|
||||
|
||||
{ Do *NOT* change this to nostackframe! }
|
||||
|
||||
@ -262,6 +262,13 @@ PROCEDURE SetTranslate(translator : pCxObj location 'a0'; events : pInputEvent l
|
||||
FUNCTION ParseIX(description : rawbytestring; ix : pInputXpression) : LONGINT;
|
||||
PROCEDURE SetFilter(filter : pCxObj; text : rawbytestring);
|
||||
|
||||
procedure FreeIEvents(Events: PInputEvent);
|
||||
function CxCustom(Action: Pointer; Id: LongInt): PCxObj;
|
||||
function CxDebug(Id: LongInt): PCxObj;
|
||||
function CxFilter(d: STRPTR): PCxObj;
|
||||
function CxSender(Port: PMsgPort; Id: LongInt): PCxObj;
|
||||
function CxSignal(Task: PTask; Sig: Byte): PCxObj;
|
||||
function CxTranslate(Ie: PInputEvent): PCxObj;
|
||||
|
||||
IMPLEMENTATION
|
||||
|
||||
@ -276,6 +283,45 @@ begin
|
||||
SetFilter(filter,pchar(text));
|
||||
end;
|
||||
|
||||
procedure FreeIEvents(Events: PInputEvent);
|
||||
begin
|
||||
while Events <> nil do
|
||||
begin
|
||||
FreeMem(Events, SizeOf(TInputEvent));
|
||||
Events := Events^.ie_NextEvent;
|
||||
end
|
||||
end;
|
||||
|
||||
function CxCustom(Action: Pointer; Id: LongInt): PCxObj;
|
||||
begin
|
||||
CxCustom := CreateCxObj(CX_CUSTOM, LongInt(Action), Id);
|
||||
end;
|
||||
|
||||
function CxDebug(Id: LongInt): PCxObj;
|
||||
begin
|
||||
CxDebug := CreateCxObj(CX_DEBUG, Id, 0);
|
||||
end;
|
||||
|
||||
function CxFilter(d: STRPTR): PCxObj;
|
||||
begin
|
||||
CxFilter := CreateCxObj(CX_FILTER, LongInt(d), 0);
|
||||
end;
|
||||
|
||||
function CxSender(Port: PMsgPort; Id: LongInt): PCxObj;
|
||||
begin
|
||||
CxSender := CreateCxObj(CX_SEND, LongInt(Port), Id);
|
||||
end;
|
||||
|
||||
function CxSignal(Task: PTask; Sig: Byte): PCxObj;
|
||||
begin
|
||||
CxSignal:= CreateCxObj(CX_SIGNAL, LongInt(Task), Sig);
|
||||
end;
|
||||
|
||||
function CxTranslate(Ie: PInputEvent): PCxObj;
|
||||
begin
|
||||
CxTranslate := CreateCxObj(CX_TRANSLATE, LongInt(Ie), 0);
|
||||
end;
|
||||
|
||||
const
|
||||
{ Change VERSION and LIBVERSION to proper values }
|
||||
VERSION : string[2] = '0';
|
||||
|
||||
@ -1321,6 +1321,17 @@ function BitMask(no :shortint): longint;
|
||||
function IsListEmpty( list : pList): boolean;
|
||||
function IsMsgPortEmpty( mp : pMsgPort): boolean;
|
||||
|
||||
procedure BeginIO(IORequest: PIORequest);
|
||||
function CreateExtIO(Port: PMsgPort; Size: LongInt): PIORequest;
|
||||
procedure DeleteExtIO(IOReq: PIORequest);
|
||||
function CreateStdIO(Port: PMsgPort): PIOStdReq;
|
||||
procedure DeleteStdIO(IOReq: PIOStdReq);
|
||||
function CreatePort(Name: PChar; Pri: LongInt): PMsgPort;
|
||||
procedure DeletePort(Port: PMsgPort);
|
||||
function CreateTask(Name: STRPTR; Pri: LongInt; InitPC: Pointer; StackSize: LongWord): PTask;
|
||||
procedure DeleteTask(Task: PTask);
|
||||
procedure NewList(List: PList);
|
||||
|
||||
IMPLEMENTATION
|
||||
|
||||
function BitMask(no :shortint): longint; inline;
|
||||
@ -1390,4 +1401,158 @@ BEGIN
|
||||
RawDoFmt := RawDoFmt(PChar(RawByteString(formatString)),dataStream,putChProc,putChData);
|
||||
END;
|
||||
|
||||
|
||||
procedure BeginIO(IORequest: PIORequest);
|
||||
begin
|
||||
asm
|
||||
move.l a6,-(a7)
|
||||
move.l ioRequest,a1 ; get IO Request
|
||||
move.l 20(a1),a6 ; extract Device ptr
|
||||
jsr -30(a6) ; call BEGINIO directly
|
||||
move.l (a7)+,a6
|
||||
end;
|
||||
end;
|
||||
|
||||
function CreateExtIO(Port: PMsgPort; Size: LongInt): PIORequest;
|
||||
var
|
||||
IOReq: PIORequest;
|
||||
begin
|
||||
IOReq := nil;
|
||||
if port <> nil then
|
||||
begin
|
||||
IOReq := ExecAllocMem(Size, MEMF_CLEAR or MEMF_PUBLIC);
|
||||
if IOReq <> nil then
|
||||
begin
|
||||
IOReq^.io_Message.mn_Node.ln_Type := NT_REPLYMSG;
|
||||
IOReq^.io_Message.mn_Length := Size;
|
||||
IOReq^.io_Message.mn_ReplyPort := Port;
|
||||
end;
|
||||
end;
|
||||
CreateExtIO := IOReq;
|
||||
end;
|
||||
|
||||
|
||||
procedure DeleteExtIO(IOReq: PIORequest);
|
||||
begin
|
||||
if IOReq <> nil then
|
||||
begin
|
||||
IOReq^.io_Message.mn_Node.ln_Type := $FF;
|
||||
IOReq^.io_Message.mn_ReplyPort := PMsgPort(-1);
|
||||
IOReq^.io_Device := PDevice(-1);
|
||||
ExecFreeMem(IOReq, IOReq^.io_Message.mn_Length);
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
function CreateStdIO(Port: PMsgPort): PIOStdReq;
|
||||
begin
|
||||
CreateStdIO := PIOStdReq(CreateExtIO(Port, SizeOf(TIOStdReq)))
|
||||
end;
|
||||
|
||||
|
||||
procedure DeleteStdIO(IOReq: PIOStdReq);
|
||||
begin
|
||||
DeleteExtIO(PIORequest(IOReq))
|
||||
end;
|
||||
|
||||
|
||||
function CreatePort(Name: PChar; Pri: LongInt): PMsgPort;
|
||||
var
|
||||
SigBit: Byte;
|
||||
Port: PMsgPort;
|
||||
begin
|
||||
SigBit := AllocSignal(-1);
|
||||
if SigBit = -1 then
|
||||
begin
|
||||
CreatePort := nil;
|
||||
Exit;
|
||||
end;
|
||||
Port := ExecAllocmem(SizeOf(TMsgPort), MEMF_CLEAR or MEMF_PUBLIC);
|
||||
if Port = nil then
|
||||
begin
|
||||
FreeSignal(SigBit);
|
||||
CreatePort := nil;
|
||||
Exit;
|
||||
end;
|
||||
with Port^ do
|
||||
begin
|
||||
if Assigned(Name) then
|
||||
mp_Node.ln_Name := Name
|
||||
else
|
||||
mp_Node.ln_Name := nil;
|
||||
mp_Node.ln_Pri := Pri;
|
||||
mp_Node.ln_Type := NT_MsgPort;
|
||||
mp_Flags := PA_Signal;
|
||||
mp_SigBit := SigBit;
|
||||
mp_SigTask := FindTask(nil);
|
||||
end;
|
||||
if Assigned(Name) then
|
||||
AddPort(Port)
|
||||
else
|
||||
NewList(Addr(Port^.mp_MsgList));
|
||||
CreatePort := Port;
|
||||
end;
|
||||
|
||||
procedure DeletePort(Port: PMsgPort);
|
||||
begin
|
||||
if Port <> nil then
|
||||
begin
|
||||
if Port^.mp_Node.ln_Name <> nil then
|
||||
RemPort(port);
|
||||
Port^.mp_Node.ln_Type := $FF;
|
||||
Port^.mp_MsgList.lh_Head := PNode(-1);
|
||||
FreeSignal(Port^.mp_SigBit);
|
||||
ExecFreeMem(Port, SizeOf(TMsgPort));
|
||||
end;
|
||||
end;
|
||||
|
||||
function CreateTask(Name: STRPTR; Pri: LongInt; InitPC: Pointer; StackSize: LongWord): PTask;
|
||||
var
|
||||
Memlist: PMemList;
|
||||
Task: PTask;
|
||||
TotalSize: LongInt;
|
||||
begin
|
||||
task := nil;
|
||||
StackSize := (StackSize + 3) and not 3;
|
||||
TotalSize := SizeOf(TMemList) + SizeOf(TTask) + StackSize;
|
||||
|
||||
Memlist := ExecAllocMem(TotalSize, MEMF_PUBLIC + MEMF_CLEAR);
|
||||
if MemList <> nil then
|
||||
begin
|
||||
MemList^.ml_NumEntries := 1;
|
||||
MemList^.ml_ME[0].me_Un.meu_Addr := Pointer(MemList + 1);
|
||||
MemList^.ml_ME[0].me_Length := TotalSize - SizeOf(TMemList);
|
||||
|
||||
Task := PTask(MemList + SizeOf(TMemList) + StackSize);
|
||||
Task^.tc_Node.ln_Pri := Pri;
|
||||
Task^.tc_Node.ln_Type := NT_TASK;
|
||||
Task^.tc_Node.ln_Name := Name;
|
||||
Task^.tc_SPLower := Pointer(MemList + SizeOf(TMemList));
|
||||
Task^.tc_SPUpper := Pointer(Task^.tc_SPLower + StackSize);
|
||||
Task^.tc_SPReg := Task^.tc_SPUpper;
|
||||
|
||||
NewList(@Task^.tc_MemEntry);
|
||||
AddTail(@Task^.tc_MemEntry,@MemList^.ml_Node);
|
||||
|
||||
AddTask(Task, InitPC, nil)
|
||||
end;
|
||||
CreateTask := Task;
|
||||
end;
|
||||
|
||||
procedure DeleteTask (task: pTask);
|
||||
begin
|
||||
RemTask(task)
|
||||
end;
|
||||
|
||||
|
||||
procedure NewList (list: pList);
|
||||
begin
|
||||
with list^ do
|
||||
begin
|
||||
lh_Head := pNode(@lh_Tail);
|
||||
lh_Tail := NIL;
|
||||
lh_TailPred := pNode(@lh_Head)
|
||||
end
|
||||
end;
|
||||
|
||||
END. (* UNIT EXEC *)
|
||||
|
||||
@ -4227,6 +4227,13 @@ PROCEDURE SetDefaultPubScreen(const name : string);
|
||||
FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN;
|
||||
PROCEDURE UnlockPubScreen(const name : string; screen : pScreen);
|
||||
|
||||
function DoMethodA(Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
function DoSuperMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
function CoerceMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
function SetSuperAttrsA(Cl: PIClass; Obj: PObject_; Msg : APTR): PtrUInt;
|
||||
|
||||
function DoMethod(Obj: PObject_; Params: array of PtrUInt): LongWord; inline;
|
||||
|
||||
IMPLEMENTATION
|
||||
|
||||
function OpenScreenTags(newScreen : pNewScreen; tagList : array of PtrUInt) : pScreen;
|
||||
@ -4413,6 +4420,48 @@ begin
|
||||
UnlockPubScreen(PChar(RawByteString(name)),screen);
|
||||
end;
|
||||
|
||||
|
||||
function DoMethodA(Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
begin
|
||||
if Assigned(Obj) then
|
||||
begin
|
||||
DoMethodA := CallHookPkt(@THook(OCLASS(Obj)^.cl_Dispatcher), Obj, Msg);
|
||||
end
|
||||
else
|
||||
DoMethodA := 0;
|
||||
end;
|
||||
|
||||
function DoMethod(Obj: PObject_; Params: array of PtrUInt): PtrUInt;
|
||||
begin
|
||||
DoMethod := DoMethodA(Obj, @Params);
|
||||
end;
|
||||
|
||||
function DoSuperMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
begin
|
||||
if Assigned(Obj) and Assigned(Cl) then
|
||||
DoSuperMethodA := CallHookPkt(@Cl^.cl_Super^.cl_Dispatcher, Obj, Msg)
|
||||
else
|
||||
DoSuperMethodA := 0;
|
||||
end;
|
||||
|
||||
function CoerceMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
begin
|
||||
if Assigned(Cl) and Assigned(Obj) then
|
||||
CoerceMethodA := CallHookPkt(@Cl^.cl_Dispatcher, Obj, Msg)
|
||||
else
|
||||
CoerceMethodA := 0;
|
||||
end;
|
||||
|
||||
function SetSuperAttrsA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
|
||||
var
|
||||
arr: array[0..2] of PtrUInt;
|
||||
begin
|
||||
arr[0] := OM_SET;
|
||||
arr[1] := PtrUInt(Msg);
|
||||
arr[2] := 0;
|
||||
SetSuperAttrsA := DoSuperMethodA(Cl, Obj, @arr);
|
||||
end;
|
||||
|
||||
initialization
|
||||
IntuitionBase := pIntuitionBase(_IntuitionBase);
|
||||
END. (* UNIT INTUITION *)
|
||||
|
||||
@ -403,6 +403,9 @@ function AsTag(value: boolean): PtrUInt; overload; inline;
|
||||
function AsTag(value: LongInt): PtrUInt; overload; inline;
|
||||
function AsTag(Value: LongWord): PtrUInt; overload; inline;
|
||||
|
||||
procedure HookEntry;
|
||||
procedure HookEntryPas;
|
||||
|
||||
IMPLEMENTATION
|
||||
|
||||
function AllocNamedObject(name : STRPTR; Const argv : array of PtrUInt) : pNamedObject;
|
||||
@ -507,6 +510,35 @@ begin
|
||||
AsTag := PtrUInt(Value);
|
||||
end;
|
||||
|
||||
{ Do *NOT* change this to nostackframe! }
|
||||
{ The compiler will build a stackframe with link/unlk. So that will actually correct
|
||||
the stackpointer for both Pascal/StdCall and Cdecl functions, so the stackpointer
|
||||
will be correct on exit. It also needs no manual RTS. The argument push order is
|
||||
also correct for both. (KB) }
|
||||
procedure HookEntry; assembler;
|
||||
asm
|
||||
move.l a1,-(a7) // Msg
|
||||
move.l a2,-(a7) // Obj
|
||||
move.l a0,-(a7) // PHook
|
||||
move.l 12(a0),a0 // h_SubEntry = Offset 12
|
||||
jsr (a0) // Call the SubEntry
|
||||
end;
|
||||
|
||||
{ This is to be used with when the subentry function uses FPC's register calling
|
||||
convention, also see the comments above HookEntry. It is advised to actually
|
||||
declare Hook functions with cdecl instead of using this function, especially
|
||||
when writing code which is platform independent. (KB) }
|
||||
procedure HookEntryPas; assembler;
|
||||
asm
|
||||
move.l a2,-(a7)
|
||||
move.l a1,-(a7) // Msg
|
||||
move.l a2,a1 // Obj
|
||||
// PHook is in a0 already
|
||||
move.l 12(a0),a2 // h_SubEntry = Offset 12
|
||||
jsr (a2) // Call the SubEntry
|
||||
move.l (a7)+,a2
|
||||
end;
|
||||
|
||||
initialization
|
||||
UtilityBase := _UtilityBase;
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user