unit Amiga;

INTERFACE
{$ifdef WORKBENCH_2}
Uses Exec, AmigaDOS, Graphics, Hardware, Intuition, Timer, Utility;
{$else}
Uses Exec, AmigaDOS, Graphics, Hardware, Timer;
{$endif}


(* String conversion *)
function PtrToPas (c: STRPTR): string;
function StringToC (var p: string): STRPTR;

(* Exec support *)
procedure BeginIO (ioRequest: pIORequest);
function CreateExtIO (port: pMsgPort; size: integer): pIORequest;
function CreatePort (name: STRPTR; pri: integer): pMsgPort;
function CreateStdIO (port: pMsgPort): pIOStdReq;
function CreateTask (name: STRPTR; pri: longint;
		initPC: pointer; stackSize: longint): pTask;
procedure DeleteExtIO (ioReq: pIORequest);
procedure DeletePort (port: pMsgPort);
procedure DeleteStdIO (ioReq: pIOStdReq);
procedure DeleteTask (task: pTask);
procedure NewList (list: pList);

(* Graphics support *)
procedure AddTOF (i: pIsrvstr; p: pointer; a: longint);
procedure RemTOF (i: pIsrvstr);

(* AmigaDOS support *)
function DOSPacket (pid: pMsgPort; action: longint;
		var args; nargs: integer): longint;

(* Timer support *)
function TimeDelay (unit_: longint; secs, microsecs: long): longint;

(* 2.0 only BOOPSI support *)
{$ifdef WORKBENCH_2}
function CallHookA (hook: pHook; object, paramPacket: pointer): long;
function CoerceMethodA (cl, obj: pointer; message: Msg): long;
function DoMethodA (obj: pointer; message: Msg): long;
function DoSuperMethodA (cl, obj: pointer; message: Msg): long;
procedure HookEntry (hook: pHook; object, paramPacket: pointer);
{$endif}


IMPLEMENTATION
(* String conversion *)
function PtrToPas (c: STRPTR): string; xassembler;
asm
	movem.l	4(sp),a0-a1
	addq.l	#1,a1
	move.w	#254,d0
@1:
	move.b	(a0)+,d1
	beq		@2
	move.b	d1,(a1)+
	dbra	d0,@1
@2:
	addq.b	#1,d0
	not.b	d0
	move.l	8(sp),a0
	move.b	d0,(a0)
end;


function StringToC (var p: string): STRPTR; xassembler;
asm
	move.l	4(sp),a0
	move.l	a0,8(sp)
	moveq	#0,d0
	move.b	(a0),d0
	bra		@2
@1:
	move.b	1(a0),(a0)+
@2:
	dbra	d0,@1
	clr.b	(a0)
end;


(* Exec support *)
procedure BeginIO (ioRequest: pIORequest); xassembler;
asm
	move.l	4(sp),a1
	move.l	a6,-(sp)
	move.l	tIORequest.io_Device(a1),a6
	jsr		DEV_BEGINIO(a6)
	move.l	(sp)+,a6
end;


function CreateExtIO (port: pMsgPort; size: integer): pIORequest;
var IOReq: pIORequest;
begin
	CreateExtIO := NIL;
	if port <> NIL then
	begin
		IOReq := AllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
		if IOReq <> NIL then
			with IOReq^.io_Message, mn_Node do
			begin
				ln_Type			:= NT_Message;
				mn_Length		:= size;
				mn_ReplyPort	:= port;
				CreateExtIO		:= IOReq
			end
	end
end;


procedure DeleteExtIO (ioReq: pIORequest);
begin
	with IOReq^, io_Message do
	begin
		mn_Node.ln_Type	:= $FF;
		mn_ReplyPort	:= pMsgPort(-1);
		io_Device		:= pDevice(-1);
		FreeMem_(IOReq, 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: STRPTR; pri: integer): pMsgPort;
var port: pMsgPort; sigbit: shortint;
begin
	CreatePort	:= NIL;
	sigbit		:= AllocSignal(-1);
	if sigbit <> -1 then
	begin
		port := AllocMem(sizeof(tMsgPort), MEMF_CLEAR or MEMF_PUBLIC);
		if port = NIL then
			FreeSignal(sigbit)
		else
			with port^, mp_Node do
			begin
				ln_Name		:= name;
				ln_Pri		:= pri;
				ln_Type		:= NT_MSGPORT;

				mp_Flags	:= PA_SIGNAL;
				mp_SigBit	:= sigbit;
				mp_SigTask	:= FindTask(NIL);

				if name <> NIL then
					AddPort(port)
				else
					NewList(@mp_MsgList);
				CreatePort := port
			end
	end
end;


procedure DeletePort (port: pMsgPort);
begin
	with port^, mp_MsgList do
	begin
		if mp_Node.ln_Name <> NIL then
			RemPort(port);

		mp_SigTask	:= pTask(-1);
		lh_Head		:= pNode(-1);
		FreeSignal(mp_SigBit);
		FreeMem_(port, sizeof(tMsgPort))
	end
end;


function CreateTask (name: STRPTR; pri: longint;
		initPC: pointer; stackSize: longint): pTask;
type
	mementrynum = (ME_TASK, ME_STACK, NUMENTRIES);
	pfakememlist = ^tfakememlist;
	tfakememlist = record
			list:	tMemList;
			entry:	array [ME_TASK..ME_STACK] of tMemEntry;
		end;
var
	fakememlist:	tfakememlist;
	ml:				pfakememlist;
	newtask:		pTask;
	namelen:		integer;

begin
	CreateTask	:= NIL;
	stacksize	:= (stacksize + 3) and not 3;

{allocate the memory}
	with fakememlist, list do
	begin
		FillChar(ml_Node, sizeof(ml), 0);
		ml_NumEntries				:= integer(NUMENTRIES);
		entry[ME_TASK].me_Reqs		:= MEMF_PUBLIC | MEMF_CLEAR;
		entry[ME_TASK].me_Length	:= sizeof(tTask);
		entry[ME_STACK].me_Reqs		:= 0;
		entry[ME_STACK].me_Length	:= stacksize;

		ml := pfakememlist(AllocEntry(@list));
		if ml = NIL then exit;

		newtask := pTask(ml^.entry[ME_TASK].me_Addr)
	end;

{initialise the task structure}
	with newtask^, tc_Node, ml^ do
	begin
		ln_Type		:= NT_TASK;
		ln_Pri		:= pri;
		ln_Name		:= name;

		tc_SPLower	:= entry[ME_STACK].me_Addr;
		tc_SPUpper	:= pointer(longint(tc_SPLower) + stacksize);
		tc_SPReg	:= tc_SPUpper;

		NewList(@tc_MemEntry);
		AddHead(@tc_MemEntry, pNode(ml))
	end;

{add the task to the system}
	initpc := AddTask(newtask, initpc, NIL);	{throw away result}
	CreateTask := newtask
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;


(* Graphics support *)
procedure ttskasm; xassembler;
asm
	move.l	d2,-(sp)
	move.l	tIsrvstr.ccode(a1),a0
	move.l	tIsrvstr.Carg(a1),-(sp)
	jsr		(a0)
	move.l	(sp)+,d2
	moveq	#0,d0
end;


procedure AddTOF (i: pIsrvstr; p: pointer; a: longint);
begin
{ note: TOF interrupt routines should be procedures }
{ and should accept a single longint parameter }
	with i^ do
	begin
		Iptr	:= i;
		code	:= @ttskasm;
		ccode	:= p;
		Carg	:= a
	end;
	AddintServer(INTB_VERTB, pinterrupt(i))
end;


procedure RemTOF (i: pIsrvstr);
begin
	RemintServer(INTB_VERTB, pinterrupt(i))
end;


(* AmigaDOS support *)
function DOSPacket (pid: pMsgPort; action: longint;
		var args; nargs: integer): longint;
var
	replyport: pMsgPort; packet: pStandardPacket; i: integer; junkp: pointer;

begin
	DOSPacket	:= 0;
	replyport	:= CreatePort(NIL, 0);
	if replyport <> NIL then
	begin
		packet := AllocMem(sizeof(tStandardPacket), MEMF_CLEAR or MEMF_PUBLIC);
		if packet <> NIL then
		begin
			with packet^, sp_Pkt do
			begin
				sp_Msg.mn_node.ln_Name := @sp_Pkt;
				dp_Link		:= @sp_Msg;
				dp_port		:= replyport;
				dp_type		:= action;
				Move(args, dp_Arg1, nargs * sizeof(longint));
				PutMsg(pid, @sp_Msg);
				junkp		:= WaitPort(replyPort);
				DOSPacket	:= dp_res1
		 	end;
			FreeMem_(packet, sizeof(tStandardPacket))
		end;
		DeletePort(replyport)
	end
end;


(* Timer support *)
procedure DoTimer_; xassembler;
asm
	movem.l	d2-d3/a2-a4/a6,-(sp)
	move.l	SysBase,a6
	move.l	a0,a4
	move.l	d0,d2
	move.l	d1,d3
	lea		-$4A(sp),sp
	move.l	sp,a3
	lea		$28(a3),a2
	move.b	#4,8(a2)
	clr.b	9(a2)
	clr.l	$A(a2)
	clr.b	$E(a2)

	moveq	#-1,d0
	jsr		-$14A(a6)		{ AllocSignal }
	cmp.b	#$FF,d0
	beq		@3
	move.b	d0,$F(a2)
	sub.l	a1,a1
	jsr		-$126(a6)		{ FindTask }
	move.l	d0,$10(a2)
	lea		$14(a2),a0
	move.l	a0,8(a0)
	addq.l	#4,a0
	clr.l	(a0)
	move.l	a0,-(a0)

	lea		@4(pc),a0
	move.l	a3,a1
	move.l	d2,d0
	moveq	#0,d1
	jsr		-$1BC(a6)		{ OpenDevice }
	tst.l	d0
	bne		@2

	move.l	a2,$E(a3)
	move.l	a3,a1
	move.w	d3,$1C(a1)
	move.l	(a4),$20(a1)
	move.l	4(a4),$24(a1)
	jsr		-$1C8(a6)		{ DoIO }
	move.l	$20(a3),(a4)
	move.l	$24(a3),4(a4)

	move.l	a3,a1
	jsr		-$1C2(a6)		{ CloseDevice }
	moveq	#0,d0
	move.b	$F(a2),d0		{ FreeSignal }
	jsr		-$150(a6)
	bra		@1

@4:
	dc.b	'timer.device',0

@2:
	moveq	#0,d0
	move.b	$F(a2),d0
	jsr		-$150(a6)		{ FreeSignal }
@3:
	moveq	#-1,d0
@1:
	lea		$4A(sp),sp
	movem.l	(sp)+,d2-d3/a2-a4/a6
end;


function TimeDelay (unit_: longint;
		secs, microsecs: long): longint; assembler;
asm
	move.l	unit_,d0
	moveq	#TR_ADDREQUEST,d1
	move.l	microsecs,-(sp)
	move.l	secs,-(sp)
	move.l	sp,a0
	jsr		DoTimer_
	move.l	d0,@result
	addq.l	#8,sp
end;


(* BOOPSI support *)
{$ifdef WORKBENCH_2}
function CallHookA (hook: pHook;
		object, paramPacket: pointer): long; xassembler;
asm
	move.l	a2,-(sp)
	lea		$C(sp),a0
	move.l	(a0)+,a1
	move.l	(a0)+,a2
	move.l	(a0),a0
	pea		@2(pc)
	move.l	tHook.h_SubEntry(a0),-(sp)
	rts
@2:
	move.l	(sp)+,a2
	move.l	d0,16(sp)
end;


procedure HookEntry (hook: pHook;
		object, paramPacket: pointer); xassembler;
asm
	subq.l	#4,sp
	move.l	a0,-(sp)
	move.l	a2,-(sp)
	move.l	a1,-(sp)
	move.l	tHook.h_SubEntry(a0),a0
	jsr		(a0)
	move.l	(sp)+,d0
end;


function DoMethodA (obj: pointer; message: pMsg): long; xassembler;
asm
	move.l	a2,-(sp)
	move.l	12(sp),a2		{ object }
	move.l	a2,d0
	beq		@2
	move.l	8(sp),a1		{ message }
	move.l	-4(a2),a0		{ class ptr precedes object }

	pea		@2(pc)
	move.l	tHook.h_Entry(a0),-(sp)
	rts
@2:
	move.l	(sp)+,a2
	move.l	d0,12(sp)
end;


function DoSuperMethodA (cl, obj: pointer;
		message: pMsg): long; xassembler;
asm
	move.l	a2,-(sp)
	movem.l	8(sp),a1-a2		{ message, object }
	move.l	a2,d0
	beq		@2
	move.l	16(sp),d0		{ class }
	beq		@2
	move.l	d0,a0
	move.l	tIClass.cl_Super(a0),a0

	pea		@2(pc)
	move.l	tHook.h_Entry(a0),-(sp)
	rts
@2:
	move.l	(sp)+,a2
	move.l	d0,16(sp)
end;


function CoerceMethodA (cl, obj: pointer;
		message: pMsg): long; xassembler;
asm
	move.l	a2,-(sp)
	movem.l	8(sp),a1-a2		{ message, object }
	move.l	a2,d0
	beq		@2
	move.l	16(sp),d0		{ class }
	beq		@2
	move.l	d0,a0

	pea		@2(pc)
	move.l	tHook.h_Entry(a0),-(sp)
	rts
@2:
	move.l	(sp)+,a2
	move.l	d0,16(sp)
end;
{$endif}

end.