.TITLE	ZCTRL
	.IDENT	/V1.5/
; ++
; This is the Z-machine code to handle control opcodes.
; (c) 2000 by Johnny Billquist
;
; History:
;
;	00-07-19	BQT	Initial coding started.
; Y1.0	00-08-26	BQT	First version working.
; Y1.1	00-08-29 23:30	BQT	Added a return table.
; Y1.2	00-09-08 03:00	BQT	Bugfix in stack frame. FP must be a relative
;				address, otherwise save files are not indep.
;				of game.
; V1.3	00-11-07 16:00	BQT	Code is working.
; V1.4	05-02-21 00:45	BQT	Added some error handling.
; V1.5	06-05-04 13:30	BQT	Implemented VERIFY opcode.
; --
	.INCLUDE	/ZMAC/
;
	.PSECT	CONST,D,RO
;
; Table of return values used on stack for various things.
;
RETTAB:	.WORD	RESULT		; Return a result
R.RES==0
	.WORD	DONE		; Return without result
R.DONE==2
	.WORD	RETTOP		; Return from top (main) routine
R.TOP==4
	.WORD	IOINT		; Return from I/O interrupt
R.INT==6
	.WORD	LININT		; Return from line count interrupt
R.LIN==10
;
	.PSECT	CODE,I,RO
;
; GETBA - Get branch address.
;
; Out: R0 - Offset.
;      R1 - Flags.
;
GETBA:	.GETIB	R1			; Get first byte.
	BIT	#100,R1			; Two-byte offset?
	BNE	10$			; No.
	.GETIB				; Yes. Get next byte.
	SWAB	R1			; First byte is high.
	ADD	R1,R0			; Combine.
	BIC	#140000,R0		; Clear irrelevant bits.
	SWAB	R1			; Restore R1.
	BIT	#40,R1			; Negative?
	BEQ	30$			; No.
	BIS	#400,R1			; Yes. Set flag.
	NEG	R0			; Make into positive.
	BIC	#140000,R0
30$:	RETURN
10$:	MOV	R1,R0			; Save offset in R1.
	BIC	#^C77,R0		; Clear all but offset.
	RETURN				; Done.
;
; 2OP:10 A test_attr object attribute ?(label)
;
	.ENABL	LSB
TATTR::	.INSTR	"test_attr",#2
	MOV	(R2)+,R0		; Get object number.
	CALL	FNDOBJ			; Find object.
	MOV	(R2),R1			; Get attribute number.
	CALL	FNDATR			; Find bit.
	.GETBB	R0			; Get attribute byte.
	BIT	R1,R0			; Is bit set?
	BNE	BTRUE			; Yes.
	BR	BFALSE			; No.
	.DSABL	LSB
;
; 2OP:1 1 je a b ?(label)
; JE shall jump-true if the first arg equals any of the rest.
;
	.ENABL	LSB
JE::	.INSTR	"je"
	MOV	(R2)+,R0		; Get value to compare against.
10$:	DEC	R3			; Count values left to check.
	BEQ	BFALSE			; Nothing matched. We fail.
	CMP	R0,(R2)+		; Do next value match?
	BEQ	BTRUE			; Yes. We succeed.
	BR	10$			; Repeat.
	.DSABL	LSB
;
; Conditional jump handlers.
;
	.ENABL	LSB
;
; BTRUE is the place to go to when we have a TRUE condition.
; BFALSE is the place to go to when we have a FALSE condition.
;
BTRUE::	CALL	GETBA			; Get branch info.
	BIT	#200,R1			; Shall we branch?
	BEQ	NOBR			; No.
DOBR:	SUB	#2,R0			; Yes. Offset should be - 2.
	BPL	5$			; Did we get a negiative number?
	ADD	#2,R0			; Yes. Restore value.
	JMP	DORET			; Do a return.
5$:	.DBG	#D.INST,<"Doing branch. Offsset is %O.">,R0
	BIT	#400,R1			; Back?
	BEQ	10$			; No.
	ADD	#4,R0			; Yes. Branch is actually 4 longer.
	SUB	R0,ZPC+2		; Substract from PC.
	SBC	ZPC
	RETURN
10$:	ADD	R0,ZPC+2		; Add to PC.
	ADC	ZPC
	RETURN
	.DSABL	LSB
;
BFALSE::
	CALL	GETBA			; Get branch info.
	BIT	#200,R1			; Shall we branch?
	BEQ	DOBR			; Yes.
NOBR:	RETURN				; No. Get next instr.
;
; 2OP:2 2 jl a b ?(label)
; JL shall jump if arg1 < arg2
;
	.ENABL	LSB
JL::	.INSTR	"jl",#2
	CMP	(R2),2(R2)
	BLT	BTRUE
	BR	BFALSE
	.DSABL	LSB
;
; 2OP:3 3 jg a b ?(label)
; JG shall jump if arg1 > arg2
;
	.ENABL	LSB
JG::	.INSTR	"jg",#2
	CMP	(R2),2(R2)
	BGT	10$
	JMP	BFALSE
10$:	JMP	BTRUE
	.DSABL	LSB
;
; 1OP:128 0 jz a ?(label)
; JZ shall jump of arg1 = 0
;
	.ENABL	LSB
JZ::	.INSTR	"jz",#1
	TST	(R2)
	BEQ	BTRUE
	BR	BFALSE
	.DSABL	LSB
;
; 2OP:6 6 jin obj1 obj2 ?(label)
; Jump if obj arg1 is in obj arg2 - V1-V3 objects.
;
	.ENABL	LSB
JIN1::	.INSTR	"jin",#2
	MOV	(R2)+,R0		; Get object number.
	CALL	FNDOBJ			; Find object address.
	ADD	#4,R0			; Add offset to parent.
	.GETBB	R0			; Read parent.
	CMP	R0,(R2)			; Is parent arg2?
	BEQ	10$
	JMP	BFALSE			; No.
10$:	JMP	BTRUE			; Yes.
	.DSABL	LSB
;
; 2OP:6 6 jin obj1 obj2 ?(label)
; Jump if obj arg1 is in obj arg2 - V4-V8 objects.
;
	.ENABL	LSB
JIN4::	.INSTR	"jin",#2
	MOV	(R2)+,R0		; Get object.
	CALL	FNDOBJ			; Find object.
	ADD	#6,R0			; Point at parent field.
	.GETWB	R0			; Read parent.
	CMP	R0,(R2)			; Is parent arg2?
	BEQ	10$
	JMP	BFALSE			; No.
10$:	JMP	BTRUE			; Yes.
	.DSABL	LSB
;
; 2OP:28 1C 5/6 throw value stack-frame
; Throw. Restore frame pointer to where previous catch told us,
; and then do a return from that point, with the result given here.
;
	.ENABL	LSB
THROW::	.INSTR	"throw",#2
	MOV	(R2)+,R0		; Get return value.
	MOV	STKTOP,R4
	SUB	(R2),R4			; Set frame pointer.
	JMP	DORET			; That's it!
	.DSABL	LSB
;
; 1OP:139 B ret value
;
	.ENABL	LSB
RET::	.INSTR	"ret",#1
	MOV	(R2),R0				; Get return value.
;
; Do a return. The return value is given in R0.
;
DORET:	MOV	R4,R5				; Set SP to FP.
	.DBG	#D.INST!D.STK,<"Doing RET. SP is %P.">,R5
	ADD	(R5),R5				; Then drop locals.
	TST	(R5)+
	MOV	STKTOP,R4
	SUB	(R5)+,R4			; Restore old FP.
	MOV	(R5)+,ZPC			; Restore old PC.
	MOV	(R5)+,ZPC+2
	MOV	(R5)+,R1			; Get continuation function.
	JMP	@RETTAB(R1)			; And continue somewhere.
	.DSABL	LSB
;
; 1OP:140 C jump ?(label)
; JUMP does an unconditional relative jump.
;
	.ENABL	LSB
JUMP::	.INSTR	"jump",#1
	MOV	(R2),R0				; Get offset.
	SUB	#2,R0				; - 2.
	BPL	10$				; Positive.
	NEG	R0				; Negative. Make offset positive
	SUB	R0,ZPC+2			; Do jump.
	SBC	ZPC
	RETURN
10$:	ADD	R0,ZPC+2			; Do jump.
	ADC	ZPC
	RETURN
	.DSABL	LSB
;
; 0OP:176 0 rtrue
;
	.ENABL	LSB
RTRUE::	.INSTR	"rtrue",#0
	MOV	#1,R0
	JMP	DORET
;
; 0OP:177 1 rfalse
;
	.ENABL	LSB
RFALSE::
	.INSTR	"rfalse",#0
	CLR	R0
	JMP	DORET
;
; 0OP:180 4 1/- nop
;
	.ENABL	LSB
ZNOP::	.INSTR	"nop",#0
	RETURN
	.DSABL	LSB
;
; 0OP:184 8 ret_popped
;
	.ENABL	LSB
RETPOP::
	.INSTR	"ret_popped",#0
	MOV	(R5)+,R0
	JMP	DORET
	.DSABL	LSB
;
; 0OP:186 A quit
;
	.ENABL	LSB
QUIT::	.INSTR	"quit",#0
	JMP	ZEND
	.DSABL	LSB
;
; 0OP:185 9 5/6 catch -> (result)
;
; Catch. Return frame pointer for later throw.
;
	.ENABL	LSB
CATCH::	.INSTR	"catch",#0
	MOV	STKTOP,R0
	SUB	R4,R0			; Get frame pointer.
	CALLR	RESULT
	.DSABL	LSB
;
; 0OP:189 D 3 verify ?(label)
;
; This opcode isn't as easy as it might look.
; We cannot use the normal memory access stuff to do the actual
; checksumming. Instead we must read the blocks from the file.
;
	.ENABL	LSB
VERIFY::
	.INSTR	"verify",#0
	.GETWB	#32,R1			; Read game length
	BNE	10$			; Length of zero is funny.
	JMP	BTRUE			; So we are just happy.
10$:					; We have a length. Let's figure
					; out actual length.
	CLR	R0			; High part.
	MOV	#1,R2			; Assume size is *2
	CMP	#3,ZVER
	ADC	R2			; If it's >V3 bump multiplier to 4
	CMP	#5,ZVER
	ADC	R2			; If it's >V5 bump multiplier to 8
	ASHC	R2,R0			; Adjust size.
	SUB	#100,R1			; Adjust size.
	SBC	R0
	MOV	R4,-(SP)		; Save registers.
	MOV	R5,-(SP)
	CLR	-(SP)			; Make room on stack for value.
	CLR	R3			; Block counter.
	MOV	#IOBUF2+100,R4		; Address where to start reading.
	MOV	#700,R5			; Count of chars left in buf.
	CLR	R2			; Initial checksum.
100$:	.BLK	#IOBUF2,R3		; Get block.
110$:	MOVB	(R4)+,(SP)		; Save byte.
	ADD	(SP),R2			; Checksum.
	SUB	#1,R1			; Perform counting.
	SBC	R0
	BNE	120$			; Not done yet.
	TST	R1
	BEQ	130$			; We have done all.
120$:	SOB	R5,110$			; And loop through block.
	INC	R3			; Next block.
	MOV	#IOBUF2,R4		; Pointer reset.
	MOV	#1000,R5		; Size reset.
	BR	100$			; Loop.
130$:	TST	(SP)+			; Clean stack.
	MOV	(SP)+,R5		; Yes. Restore registers.
	MOV	(SP)+,R4
	.GETWB	#34
	CMP	R0,R2			; Do checksum match?
	BNE	200$
	JMP	BTRUE			; Yes.
200$:	JMP	BFALSE			; No.
	.DSABL	LSB
;
; 0OP:191 F 5/- piracy ?(label)
;
	.ENABL	LSB
PIRACY::
	.INSTR	"piracy",#0
	JMP	BTRUE
	.DSABL	LSB
;
; 1OP:143 F 5 call_1n routine
; 2OP:26 1A 5 call_2n routine arg1
; VAR:249 19 5 call_vn routine ...up to 3 args...
; VAR:250 1A 5 call_vn2 routine ...up to 7 args...
;
; CALL_VN and CALL_VN2 are handled the exact same way.
;
	.ENABL	LSB
CALVN2::
CALL1N::
CALL2N::
CALLVN::
	.INSTR	"calln"
	MOV	#R.DONE,-(R5)			; Continuation address.
	JMP	DOCALL				; Perform call.
	.DSABL	LSB
;
; VAR:224 0 1 call routine ...up to 3 args... -> (result)
; 1OP:136 8 4 call_1s routine -> (result)
; 2OP:25 19 4 call_2s routine arg1 -> (result)
; VAR:224 0 4 call_vs routine ...up to 3 args... -> (result)
; VAR:236 C 4 call_vs2 routine ...up to 7 args... -> (result)
;
; This is the first instruction implemented, since it's the
; first instruction executed on ZORK1, which is our first
; test case.
;
; The plain CALL opcode existed until version 3, and the action
; is to save the old PC and frame pointer on the stack.
; Set a new PC, allocate local variables, and set them with
; the correct values.
; We'll also save the continuation routine which to call when
; the code does a RET.
;
; In version 4 and onward, we have several models of CALL,
; but they work the same way as the original call in most
; ways. Some variants throw away the result, and
; the routine entry cannot set initial values of
; local variables in version 5 and later, but the rest is the same.
;
; Stack frame (illustrated):
;
; +----+
; |    |	CALL type (tells what kind of possible store on return)
; |    |	Old PC
; |    |	Old PC
; |    |	Old framepointer (relative to top of stack)
; :    :
; :    :	Local variables
; :    :
; |    |	Number of local variables*2	<- FP
; |    |	Number of arguments in call	<- SP
; +----+
;
; To throw away stack:
; SP <- FP - 2
;
; To do a return:
; SP <- FP
; SP <- SP + (FP)
; FP <- (SP)+
; PC <- (SP)+
; PC <- (SP)+
; TMP <- (SP)+
;
; Then proceed to routine indicated by TMP
;
	.ENABL	LSB
CALVS2::
ZCALL::
CALL1S::
CALL2S::
CALLVS::
	.INSTR	"call"
;
;
; First, set up a continuation routine.
;
	MOV	#R.RES,-(R5)			; Routine to store return val.
;
; Perform the actual call.
; Start with checking for call to address zero.
;
DOCALL::
	TST	R3				; Any arguments?
	BEQ	101$				; No. It't as a call to 0.
	TST	(R2)				; Call to address 0?
	BNE	1000$
101$:	CLR	R0				; Yes. Return 0.
	MOV	(R5)+,R1			; Get continuation routine.
	JMP	@RETTAB(R1)			; Continue...
;
; Then save the current PC and FP.
;
1000$:	MOV	ZPC+2,-(R5)
	MOV	ZPC,-(R5)
	MOV	STKTOP,-(R5)
	SUB	R4,(R5)
;
; Now find out the correct entry address.
;
	MOV	(R2)+,R1			; Get first argument (address)
	DEC	R3
	CALL	@APACK				; Get actual address.
	MOV	R0,ZPC				; High part.
	MOV	R1,ZPC+2			; Low part.
;
; Now find out the number of local variables.
;
	.GETIB					; That's the number!
	MOV	R0,-(SP)			; Save number of locals.
	MOV	R5,-(SP)			; Save pointer to top.
	ASL	R0				; * 2.
	SUB	R0,R5				; Create frame.
	MOV	R0,-(R5)			; Save local size.
	MOV	R5,R4				; Set new frame pointer.
	.DBG	#D.STK,<"Doing call. SP is now %P.">,R5
	CLR	-(R5)				; Default to no arguments
;
; Now we clear all variables.
;
	MOV	(SP)+,R1			; Point at top of locals.
	ASR	R0				; Get #.
	BEQ	8$				; No variables exist...
1$:	CLR	-(R1)				; Clear variables.
	SOB	R0,1$
	CMP	ZVER,#4				; Version > 4?
	BHI	5$				; Yes.
;
; In version 1-4 we now set initial values...
;
	MOV	(SP),R0				; Get count.
2$:	.GETIW	(R1)+				; Get word.
	SOB	R0,2$				; Loop.
;
; We now have a local frame set up. Let's copy parameters.
;
5$:	MOV	(SP),R0				; Get local vars.
	CMP	R3,R0				; Copy min(argc,loc#)
	BHIS	6$
	MOV	R3,R0				; Actual args are fewer...
6$:	TST	R0
	BEQ	8$				; No args...?
	MOV	R0,(R5)				; Save # of args.
	MOV	R4,R1				; No. Point at list.
	ADD	#2,R1
7$:	MOV	(R2)+,(R1)+			; Copy argument.
	SOB	R0,7$				; Loop.
8$:	ADD	#2,SP				; Drop stack.
DONE:	RETURN					; Fetch next instr.
	.DSABL	LSB
;
; VAR:255 1F 5 check_arg_count argument-number
;
; Check argument count.
; The number of arguments are at -2(R4)
; *** Note. It checks that *atleast* this number of args are present. ***
;
	.ENABL	LSB
CKACNT::
	.INSTR	"check_arg_count",#1
	CMP	-2(R4),(R2)		; Checking...
	BGE	10$
	JMP	BFALSE
10$:	JMP	BTRUE
	.DSABL	LSB
;
	.END