paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 01:49:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

amunits: move DoMethod/DoSuperMethod to intuition, Hook Helper to Utility, exec helper to exec, commodities macros to commodities, mark amigalib as deprecated

Browse Source 
git-svn-id: trunk@36778 -
This commit is contained in:
marcus 2017-07-23 21:52:30 +00:00
parent 20f148ef89
commit 645dd2a272
5 changed files with 387 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

307
packages/amunits/src/coreunits/amigalib.pas
View File

@ -47,61 +47,60 @@
nils.sjoholm@mailbox.swipnet.se nils.sjoholm@mailbox.swipnet.se
} }
{$INLINE ON}
{$mode objfpc} {$mode objfpc}
{$I useamigasmartlink.inc} unit amigalib
{$ifdef use_amiga_smartlink} deprecated 'Unit will be removed. Functions are moved to exec, intuition, utility and commodities unit.';
{$smartlink on}
{$endif use_amiga_smartlink}
unit amigalib;
INTERFACE INTERFACE
uses exec,intuition,utility,commodities,inputevent,amigados; uses exec,intuition,utility,commodities,inputevent,amigados;
// moved to exec, use them from there
{* Exec support functions from amiga.lib *} {* Exec support functions from amiga.lib *}
procedure BeginIO (ioRequest: pIORequest); procedure BeginIO (ioRequest: pIORequest); inline;
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; inline;
procedure DeleteExtIO (ioReq: pIORequest); procedure DeleteExtIO (ioReq: pIORequest); inline;
function CreateStdIO (port: pMsgPort): pIOStdReq; function CreateStdIO (port: pMsgPort): pIOStdReq; inline;
procedure DeleteStdIO (ioReq: pIOStdReq); procedure DeleteStdIO (ioReq: pIOStdReq); inline;
function CreatePort (name: PChar; pri: longint): pMsgPort; function CreatePort (name: PChar; pri: longint): pMsgPort; inline;
procedure DeletePort (port: pMsgPort); procedure DeletePort (port: pMsgPort); inline;
function CreateTask (name: STRPTR; pri: longint; function CreateTask (name: STRPTR; pri: longint;
initPC : Pointer; initPC : Pointer;
stackSize : ULONG): pTask; stackSize : ULONG): pTask; inline;
procedure DeleteTask (task: pTask); procedure DeleteTask (task: pTask); inline;
procedure NewList (list: pList); procedure NewList (list: pList); inline;
// moved to commodities, use them from there
{* Commodities support functions from amiga.lib *} {* Commodities support functions from amiga.lib *}
procedure FreeIEvents (events: pInputEvent); procedure FreeIEvents (events: pInputEvent); inline;
function CxCustom function CxCustom
(action: pointer; (action: pointer;
id: longint): pCxObj; id: longint): pCxObj; inline;
function CxDebug (id: long): pCxObj; function CxDebug (id: long): pCxObj; inline;
function CxFilter (d: STRPTR): pCxObj; function CxFilter (d: STRPTR): pCxObj; inline;
function CxSender function CxSender
(port: pMsgPort; (port: pMsgPort;
id: longint): pCxObj; id: longint): pCxObj; inline;
function CxSignal function CxSignal
(task: pTask; (task: pTask;
sig: byte): pCxObj; sig: byte): pCxObj; inline;
function CxTranslate (ie: pInputEvent): pCxObj; function CxTranslate (ie: pInputEvent): pCxObj; inline;
// moved to intuition, use them from there
function DoMethodA(obj : pObject_; msg : APTR): ulong; function DoMethodA(obj : pObject_; msg : APTR): ulong; inline;
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline; function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline;
// moved to utility, use them from there
procedure HookEntry; procedure HookEntry;
procedure HookEntryPas; procedure HookEntryPas;
@ -171,231 +170,115 @@ IMPLEMENTATION
{* Exec support functions from amiga.lib *} {* Exec support functions from amiga.lib *}
procedure BeginIO (ioRequest: pIORequest); procedure BeginIO (ioRequest: pIORequest); inline;
begin begin
asm Exec.BeginIO(ioRequest);
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; end;
function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; function CreateExtIO (port: pMsgPort; size: Longint): pIORequest; inline;
var
IOReq: pIORequest;
begin begin
IOReq := NIL; CreateExtIO := Exec.CreateExtIO(port, size);
if port <> NIL then end;
begin
IOReq := ExecAllocMem(size, MEMF_CLEAR or MEMF_PUBLIC); procedure DeleteExtIO (ioReq: pIORequest); inline;
if IOReq <> NIL then begin
begin Exec.DeleteExtIO(ioReq);
IOReq^.io_Message.mn_Node.ln_Type := NT_REPLYMSG; end;
IOReq^.io_Message.mn_Length := size;
IOReq^.io_Message.mn_ReplyPort := port; function CreateStdIO (port: pMsgPort): pIOStdReq; inline;
end; begin
end; CreateStdIO := Exec.CreateStdIO(port)
CreateExtIO := IOReq; 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; end;
procedure DeleteExtIO (ioReq: pIORequest); procedure FreeIEvents (events: pInputEvent); inline;
begin begin
if ioReq <> NIL then Commodities.FreeIEvents(events);
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; end;
function CxCustom(action: pointer; id: longint): pCxObj; inline;
function CreateStdIO (port: pMsgPort): pIOStdReq;
begin begin
CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq))) CxCustom := Commodities.CxCustom(action, id)
end; end;
function CxDebug(id: long): pCxObj; inline;
procedure DeleteStdIO (ioReq: pIOStdReq);
begin begin
DeleteExtIO(pIORequest(ioReq)) CxDebug := Commodities.CxDebug(id)
end; end;
function CxFilter(d: STRPTR): pCxObj; inline;
function Createport(name : PChar; pri : longint): pMsgPort;
var
sigbit : Byte;
port : pMsgPort;
begin begin
sigbit := AllocSignal(-1); CxFilter := Commodities.CxFilter(d);
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;
end; end;
procedure DeletePort (port: pMsgPort); function CxSender(port: pMsgPort; id: longint): pCxObj; inline;
begin begin
if port <> NIL then CxSender := Commodities.CxSender(port, id)
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; end;
function CxSignal(task: pTask; sig: byte): pCxObj; inline;
function CreateTask (name: STRPTR; pri: longint;
initPC: pointer; stackSize: ULONG): pTask;
var
memlist : pMemList;
task : pTask;
totalsize : Longint;
begin begin
task := NIL; CxSignal:= Commodities.CxSignal(task, sig)
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)
end; end;
function CxTranslate (ie: pInputEvent): pCxObj; function CxTranslate (ie: pInputEvent): pCxObj;
begin begin
CxTranslate := CreateCxObj(CX_TRANSLATE, longint(ie), 0) CxTranslate := Commodities.CxTranslate(ie)
end; end;
function DoMethodA(obj : pObject_; msg : APTR): ulong; function DoMethodA(obj : pObject_; msg : APTR): ulong; inline;
begin begin
if assigned(obj) then begin DoMethodA := Intuition.DoMethodA(obj, msg);
DoMethodA := CallHookPkt(@THook(OCLASS(obj)^.cl_Dispatcher), obj, msg);
end else DoMethodA := 0;
end; end;
function DoMethod(obj: PObject_; Params: array of DWord): LongWord; function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline;
begin begin
DoMethod := DoMethodA(obj, @Params); DoMethod := Intuition.DoMethodA(obj, @Params);
end; end;
function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
begin begin
if assigned(obj) and assigned(cl) then DoSuperMethodA := Intuition.DoSuperMethodA(cl, obj, msg);
DoSuperMethodA := CallHookPkt(@cl^.cl_Super^.cl_Dispatcher,obj,msg)
else DoSuperMethodA := 0;
end; end;
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
begin begin
if assigned(cl) and assigned(obj) then CoerceMethodA := Intuition.CoerceMethodA(cl, obj, msg);
CoerceMethodA := CallHookPkt(@cl^.cl_Dispatcher,obj,msg)
else CoerceMethodA := 0;
end; end;
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
var
arr : array[0..2] of longint;
begin begin
arr[0] := OM_SET; SetSuperAttrsA := Intuition.SetSuperAttrsA(cl, obj, msg);
arr[1] := longint(msg);
arr[2] := 0;
SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
end; end;
{ Do *NOT* change this to nostackframe! } { Do *NOT* change this to nostackframe! }

46
packages/amunits/src/coreunits/commodities.pas
View File

@ -262,6 +262,13 @@ PROCEDURE SetTranslate(translator : pCxObj location 'a0'; events : pInputEvent l
FUNCTION ParseIX(description : rawbytestring; ix : pInputXpression) : LONGINT; FUNCTION ParseIX(description : rawbytestring; ix : pInputXpression) : LONGINT;
PROCEDURE SetFilter(filter : pCxObj; text : rawbytestring); 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 IMPLEMENTATION
@ -276,6 +283,45 @@ begin
SetFilter(filter,pchar(text)); SetFilter(filter,pchar(text));
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: 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 const
{ Change VERSION and LIBVERSION to proper values } { Change VERSION and LIBVERSION to proper values }
VERSION : string[2] = '0'; VERSION : string[2] = '0';

165
packages/amunits/src/coreunits/exec.pas
View File

@ -1321,6 +1321,17 @@ function BitMask(no :shortint): longint;
function IsListEmpty( list : pList): boolean; function IsListEmpty( list : pList): boolean;
function IsMsgPortEmpty( mp : pMsgPort): 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 IMPLEMENTATION
function BitMask(no :shortint): longint; inline; function BitMask(no :shortint): longint; inline;
@ -1390,4 +1401,158 @@ BEGIN
RawDoFmt := RawDoFmt(PChar(RawByteString(formatString)),dataStream,putChProc,putChData); RawDoFmt := RawDoFmt(PChar(RawByteString(formatString)),dataStream,putChProc,putChData);
END; 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 *) END. (* UNIT EXEC *)

49
packages/amunits/src/coreunits/intuition.pas
View File

@ -4227,6 +4227,13 @@ PROCEDURE SetDefaultPubScreen(const name : string);
FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN; FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN;
PROCEDURE UnlockPubScreen(const name : string; screen : pScreen); 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 IMPLEMENTATION
function OpenScreenTags(newScreen : pNewScreen; tagList : array of PtrUInt) : pScreen; function OpenScreenTags(newScreen : pNewScreen; tagList : array of PtrUInt) : pScreen;
@ -4413,6 +4420,48 @@ begin
UnlockPubScreen(PChar(RawByteString(name)),screen); UnlockPubScreen(PChar(RawByteString(name)),screen);
end; 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 initialization
IntuitionBase := pIntuitionBase(_IntuitionBase); IntuitionBase := pIntuitionBase(_IntuitionBase);
END. (* UNIT INTUITION *) END. (* UNIT INTUITION *)

32
packages/amunits/src/coreunits/utility.pas
View File

@ -403,6 +403,9 @@ function AsTag(value: boolean): PtrUInt; overload; inline;
function AsTag(value: LongInt): PtrUInt; overload; inline; function AsTag(value: LongInt): PtrUInt; overload; inline;
function AsTag(Value: LongWord): PtrUInt; overload; inline; function AsTag(Value: LongWord): PtrUInt; overload; inline;
procedure HookEntry;
procedure HookEntryPas;
IMPLEMENTATION IMPLEMENTATION
function AllocNamedObject(name : STRPTR; Const argv : array of PtrUInt) : pNamedObject; function AllocNamedObject(name : STRPTR; Const argv : array of PtrUInt) : pNamedObject;
@ -507,6 +510,35 @@ begin
AsTag := PtrUInt(Value); AsTag := PtrUInt(Value);
end; 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 initialization
UtilityBase := _UtilityBase; UtilityBase := _UtilityBase;
end. end.