********************************************************************************
********************************************************************************
*
* INPUT / OUTPUT stuff
*

DUART		EQU	$effc01
MR1A		EQU	0
MR2A		EQU	0
SRA		EQU	2
CRA		EQU	4
CSRA		EQU	2
TBA		EQU	6
RBA		EQU	6
IMR		EQU	10
TBB		EQU	$16
CRB		EQU	$14
MR1B		EQU	$10
MR2B		EQU	$10
SRB		EQU	$12


LINEFEED	EQU	10
CARR_RETURN	EQU	13


BUFFER		DS.L	100
BUFFER_T	DS.L	1


OPS_TAB		DS.L	LAST_OP
OPN_TAB		DS.L	LAST_OP
OPP1_TAB	DS.L	LAST_OP
OPP2_TAB	DS.L	LAST_OP


********************************************************************************
*
* function: void INIT_IO( )
*
* description:
*   Initializes the Dual UART Device
*
* registers affected: none
*

INIT_IO:	LEA	DUART,A0
		MOVE.B	#%00010000,CRA(A0)	reset MRxA pointer
		MOVE.B	#%00000011,MR1A(A0)	8 data bits
		MOVE.B	#%00000000,MR2A(A0)	normal mode
		MOVE.B	#%10111011,CSRA(A0)	set clock to 9600
		MOVE.B  #%00000101,CRA(A0)      enable Rx and Tx
		MOVE.L  #OPS_TAB,A0
                MOVE.L  #S_PUSH_S,PUSH_S(A0)
                MOVE.L  #S_PUSH_ES,PUSH_ES(A0)
                MOVE.L  #S_LINK,LINK(A0)
                MOVE.L  #S_MKFRAME,MKFRAME(A0)
                MOVE.L  #S_FREE,FREE(A0)
                MOVE.L  #S_BRC,BRC(A0)
                MOVE.L  #S_CALL,CALL(A0)
                MOVE.L  #S_ARGS,ARGS(A0)
                MOVE.L  #S_RET,RET(A0)
                MOVE.L  #S_AP,AP(A0)
                MOVE.L  #S_CREATE_CLOS,CREATE_CLOS(A0)
                MOVE.L  #S_PLUS,PLUS(A0)
                MOVE.L  #S_MINUS,MINUS(A0)
                MOVE.L  #S_MULT,MULT(A0)
                MOVE.L  #S_EQ,EQ(A0)
                MOVE.L  #S_GT,GT(A0)
                MOVE.L  #S_DONE,DONE(A0)

		MOVE.L  #OPN_TAB,A0
                MOVE.L  #1,PUSH_S(A0)
                MOVE.L  #2,PUSH_ES(A0)
                MOVE.L  #1,LINK(A0)
                MOVE.L  #1,MKFRAME(A0)
                MOVE.L  #1,FREE(A0)
                MOVE.L  #2,BRC(A0)
                MOVE.L  #1,CALL(A0)
                MOVE.L  #1,ARGS(A0)
                MOVE.L  #0,RET(A0)
                MOVE.L  #1,AP(A0)
                MOVE.L  #2,CREATE_CLOS(A0)
                MOVE.L  #0,PLUS(A0)
                MOVE.L  #0,MINUS(A0)
                MOVE.L  #0,MULT(A0)
                MOVE.L  #0,EQ(A0)
                MOVE.L  #0,GT(A0)
                MOVE.L  #0,DONE(A0)

		MOVE.L  #OPP1_TAB,A0
                MOVE.L  #PUT_NUM,PUSH_S(A0)
                MOVE.L  #PUT_NUM,PUSH_ES(A0)
                MOVE.L  #PUT_NUM,LINK(A0)
                MOVE.L  #PUT_NUM,MKFRAME(A0)
                MOVE.L  #PUT_NUM,FREE(A0)
                MOVE.L  #PUT_HEX,BRC(A0)
                MOVE.L  #PUT_HEX,CALL(A0)
                MOVE.L  #PUT_NUM,ARGS(A0)
                MOVE.L  #PUT_NUM,AP(A0)
                MOVE.L  #PUT_NUM,CREATE_CLOS(A0)

		MOVE.L  #OPP2_TAB,A0
                MOVE.L  #PUT_NUM,PUSH_ES(A0)
                MOVE.L  #PUT_HEX,BRC(A0)
                MOVE.L  #PUT_HEX,CREATE_CLOS(A0)

		RTS

S_PUSH_S	DC.B	'PUSH_S ',0
S_PUSH_ES	DC.B	'PUSH_ES ',0,0
S_LINK		DC.B	'LINK ',0
S_MKFRAME	DC.B	'MKFRAME ',0,0
S_FREE		DC.B	'FREE ',0
S_BRC		DC.B	'BRC ',0,0
S_CALL		DC.B	'CALL ',0
S_ARGS		DC.B	'ARGS ',0
S_RET		DC.B	'RET ',0,0
S_AP		DC.B	'AP ',0
S_CREATE_CLOS	DC.B	'CREATE_CLOS ',0,0
S_PLUS		DC.B	'PLUS ',0
S_MINUS		DC.B	'MINUS ',0,0
S_MULT		DC.B	'MULT ',0
S_EQ		DC.B	'EQ ',0
S_GT		DC.B	'GT ',0
S_DONE		DC.B	'DONE ',0


********************************************************************************
*
* function: D0 GETC( )
*
* description:
*   read a single char from input
*
* registers affected: D0
*

GETC:		BTST	#0,SRA+DUART	check whether there is a char
		BEQ.S	GETC
		MOVE.B	RBA+DUART,D0	read character
		RTS


********************************************************************************
*
* function: void PUTC( (SP))
*
* description:
*   prints the character that is passed via the stack (lowest byte of the long)
*
* registers affected: none
*


PUTC:		LINK	A6,#0
		MOVEM.L	D0,-(SP)	save D0 on sp
		MOVE.L	8(A6),D0	fetch char

PUTC_LOOP:	BTST	#2,SRA+DUART	check whether buffer B is empty
		BEQ.S	PUTC_LOOP
		MOVE.B	D0,TBA+DUART	write data to output
		CMPI.B	#LINEFEED,D0	is this a linefeed?
		BNE	PUTC_DONE
		MOVE.B	#CARR_RETURN,D0	send a CR as well
		BRA	PUTC_LOOP

PUTC_DONE:	MOVEM.L	(SP)+,D0	restore D0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: void PUT_STR( (SP))
*
* description:
*   prints the string whose address is passed via the stack
*
* registers affected: none
*


PUT_STR:	LINK	A6,#0
		MOVEM.L	A0/D0,-(SP)
		MOVE.L	8(A6),A0	fetch address of string

PS_LOOP:	MOVE.B	(A0)+,D0	fetch first character of string
		CMPI.B	#0,D0		is this the terminating 0?
		BEQ	PS_DONE
		MOVE.L	D0,-(SP)
		JSR	PUTC
		BRA	PS_LOOP

PS_DONE:	MOVEM.L	(SP)+,A0/D0	restore A0/D0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: void NEW_LINE( )
*
* description:
*   prints a newline
*
* registers affected: none
*

NEW_LINE:	MOVE.L	#LINEFEED,-(SP)
		JSR	PUTC
		RTS


********************************************************************************
*
* function: void CLEAR_SCREEN( )
*
* description:
*   clears the output terminal
*
* registers affected: none
*

CLEAR_SCREEN:	MOVE.L	#CLEAR_STR,-(SP)
		JSR	PUT_STR
		RTS

CLEAR_STR	DC.B	27,'[;H',27,'[2J',0,0	clear screen code for vt100


********************************************************************************
*
* function: void PUT_NUM( (SP))
*
* description:
*   prints the integer that is passed via the stack
*
* registers affected: none
*

PUT_NUM:	LINK	A6,#0
		MOVEM.L	D0,-(SP)	save D0 on sp
		MOVE.L	8(A6),D0	fetch integer

		MOVE.L	#BUFFER_T,-(SP)	push pointer to buffer
		MOVE.L	D0,-(SP)	push integer
		JSR	LTOA		create ascii-rep in buffer and
					* return ptr to result on stack
		JSR	PUT_STR		print buffer starting at returned ptr

		MOVEM.L	(SP)+,D0	restore D0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: (SP1) LTOA( (SP1), (SP2))
*
* description:
*   converts the integer (SP2) into an ascii string which is put into the buffer
*   whose end is pointed at by (SP1). The starting address within the buffer is
*   returned via the stack (SP1).
*
* registers affected: none
*
                                                                                
LTOA:		LINK	A6,#0
		MOVEM.L	D0-D7/A0,-(SP)
		MOVE.L	8(A6),D0	fetch integer
		MOVE.L	12(A6),A0	fetch pointer to buffer

		MOVE.B	#$00,-(A0)	terminating 0
		CLR.L	D7		unset negative flag
		MOVE.L	D0,D1
		BLT	LTOA2		we do have a negative number here
		BGT	LTOALOOP	we do have a positive number here

		MOVE.B	#48,-(A0)	since its neither pos nor neg, put '0'
		BRA	LTOAEND

LTOA2:		NEG.L	D1		negate number to be converted
		MOVE.B	#$AA,D7		set negative flag

LTOALOOP:	DIVU.W	#10,D1		divide by 10
		MOVE.L	D1,D2
		ANDI.L	#$FFFF,D1	clear MSB( remainder)
		SWAP	D2		swap remainder into LSB
		ADD.B	#$30,D2		add $30
		MOVE.B	D2,-(A0)	write char into buffer
		TST.W	D1		is quotient 0?
		BNE	LTOALOOP

		CMPI.B	#$AA,D7		negative?
		BNE	LTOAEND
		MOVE.B	#$2D,-(A0)	prepand negative-sign


LTOAEND:	MOVE.L	A0,12(A6)	write result over buffer arg

		MOVEM.L	(SP)+,D0-D7/A0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill second argument frame entry
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: void PUT_HEX( (SP))
*
* description:
*   prints the hex number that is passed via the stack
*
* registers affected: none
*

PUT_HEX:	LINK	A6,#0
		MOVEM.L	D0,-(SP)	save D0 on sp
		MOVE.L	8(A6),D0	fetch hex number

		MOVE.L	#BUFFER_T,-(SP)	push pointer to buffer
		MOVE.L	D0,-(SP)	push integer
		JSR	HTOA		create ascii-rep in buffer and 
					* return ptr to result on stack
		JSR	PUT_STR		print buffer starting at returned ptr

		MOVEM.L	(SP)+,D0	restore D0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: (SP1) HTOA( (SP1), (SP2))
*
* description:
*   converts the hex number (SP2) into an ascii string which is put into the
*   buffer whose end is pointed at by (SP1). The starting address within the
*   buffer is returned via the stack (SP1).
*
* registers affected: none
*
                                                                                
HTOA:		LINK	A6,#0
		MOVEM.L	D0-D2/A0,-(SP)
		MOVE.L	8(A6),D0	fetch addr
		MOVE.L	12(A6),A0	fetch pointer to buffer

		MOVE.B	#$00,-(A0)	terminating 0
		MOVE.L	#8,D2		convert 8 digits

HTOA_LOOP:	MOVE.L	D0,D1
		ANDI.L	#$F,D1		separate last digit
		ADDI.B	#$30,D1
		CMPI.L	#$3A,D1		are we GE $a ?
		BLT	HTOA2
		ADD.B	#$7,D1
HTOA2:		MOVE.B	D1,-(A0)	write char into buffer
		LSR.L	#4,D0		shift addr 4 Bit right
		SUBI.L	#1,D2
		BNE	HTOA_LOOP	

		MOVE.B	#$24,-(A0)
		MOVE.L	A0,12(A6)	write result over buffer arg

		MOVEM.L	(SP)+,D0-D2/A0
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill second argument frame entry
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function: void PUT_OBJ( (SP))
*
* description:
*   prints the object that is passed via the stack. The lower 2 Bit of that
*   object decode its type:
*     00 - the value (as is) represents a ptr to program code or into the env
*     01 - the value is an integer
*     10 - the value (after eliminating the second but last bit) points to a 
*          closure
*     11 - the value is a boolean ( 3==TRUE / 7==FALSE)
*
* registers affected: none
*

PUT_OBJ:	LINK	A6,#0
		MOVEM.L	D0-D1/A0,-(SP)	save registers
		MOVE.L	8(A6),D0	fetch object

		MOVE.L	D0,D1
		ANDI.L	#3,D1		separate tag
		CMPI.L	#0,D1		is this a pointer to code?
		BNE	PU_NO_PC
		MOVE.L	D0,-(SP)
		JSR	PUT_HEX
		BRA	PU_DONE
PU_NO_PC:	CMPI.L	#1,D1		is this an integer?
		BNE	PU_NO_INT
		ASR.L	#2,D0		eliminate tag
		MOVE.L	D0,-(SP)
		JSR	PUT_NUM
		BRA	PU_DONE
PU_NO_INT:	CMPI.L	#2,D1		is this a pointer to a closure?
		BNE	PU_NO_CLS
		MOVE.L	#CLSH,-(SP)
		JSR	PUT_STR
		ANDI.L	#$FFFFFFFD,D0	eliminate tag
		MOVE.L	D0,A0
		MOVE.L	(A0)+,-(SP)
		JSR	PUT_HEX
		MOVE.L	#CLSM,-(SP)
		JSR	PUT_STR
		MOVE.L	A0,-(SP)	
		JSR	PUT_ENV
		MOVE.L	#CLSF,-(SP)
		JSR	PUT_STR
		BRA	PU_DONE
PU_NO_CLS:	CMPI.L	#3,D0		is this TRUE?
		BNE	PU_NO_TRUE
		MOVE.L	#TRUE,-(SP)
		JSR	PUT_STR
		BRA	PU_DONE
PU_NO_TRUE:	MOVE.L	#FALSE,-(SP)	it must be FALSE
		JSR	PUT_STR

PU_DONE:	MOVEM.L	(SP)+,D0-D1/A0	restore registers
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS

TRUE		DC.B	'#t',0,0
FALSE		DC.B	'#f',0,0
CLSH		DC.B	'{ fun:',0,0
CLSM		DC.B	' env:',0,0,0
CLSF		DC.B	'}',0,0,0


********************************************************************************
*
* function: void PUT_EF( (SP))
*
* description:
*   prints the environment frame pointed at by the topmost stack entry
*
* registers affected: none
*

PUT_EF:		LINK	A6,#0
		MOVEM.L D0-D1/A0,-(SP)	save D0 on sp
		MOVE.L  8(A6),A0	fetch object

		MOVE.L	#START_EF,-(SP)
		JSR	PUT_STR
		MOVE.L	(A0),D1
		BEQ	PEF_DONE
		MOVE.L	(A0)+,-(SP)
		JSR	PUT_HEX
		MOVEM.L	(A0)+,D0	D0 = frame size
PEF_LOOP:	MOVE.L	#SEP,-(SP)
		JSR	PUT_STR
		MOVE.L	(A0)+,-(SP)
		JSR	PUT_OBJ
		SUBI.L	#1,D0
		BNE	PEF_LOOP
PEF_DONE:	MOVE.L	#STOP_EF,-(SP)
		JSR	PUT_STR

		MOVEM.L	(SP)+,D0-D1/A0	restore DO and D1
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS

START_EF	DC.B	'[ ',0,0
STOP_EF		DC.B	' ]',0,0


********************************************************************************
*
* function: void PUT_ENV( (SP))
*
* description:
*   prints the environment pointed at by the topmost stack entry
*
* registers affected: none
*

PUT_ENV:	LINK	A6,#0
		MOVEM.L A0-A1,-(SP)	save A0 and A1 on sp
		MOVE.L  8(A6),A0	fetch object

PENV_LOOP:	MOVE.L	(A0),A1
		MOVE.L	A0,-(SP)
		JSR	PUT_EF
		MOVE.L	A1,A0
		CMP.L	#0,A0
		BNE	PENV_LOOP

		MOVEM.L	(SP)+,A0-A1	restore AO and A1
		UNLK	A6		restore A6
		MOVE.L	(SP),4(SP)	kill argument frame
		ADDQ.L	#4,SP
		RTS


********************************************************************************
*
* function void PR_STATE( (SP1), (SP2), (SP3), (SP4), (SP5), (SP6))
*
* description:
*   prints an SECDH-2 machine state.
*   Expects the following arguments on the stack:
*    (SP1) - pointer to the actual S-stack top
*    (SP2) - pointer to the S-stack bottom
*    (SP3) - the actual pE
*    (SP4) - the actual pC
*    (SP5) - pointer to the actual D-stack top
*    (SP6) - pointer to the D-stack bottom
*
* registers affected: none
*

PR_STATE:	LINK	A6,#0
		MOVEM.L	D0-D7/A0-A5,-(SP)	save registers

		JSR NEW_LINE
*
* print S-stack:
*
		MOVE.L	#S_HEADER,-(SP)
		JSR	PUT_STR
		MOVE.L	24(A6),A0		A0 = bottom S
S_LOOP:		CMP.L	28(A6),A0		(top S == A0)?
		BEQ	PRS_DONE
		MOVE.L	-(A0),-(SP)		put top elem on stack
		JSR	PUT_OBJ
		MOVE.L	#SEP,-(SP)
		JSR	PUT_STR
		BRA	S_LOOP
PRS_DONE:	JSR	NEW_LINE
*
* print environment:
*
		MOVE.L	#E_HEAD1,-(SP)
		JSR	PUT_STR
		MOVE.L	20(A6),-(SP)		push pE on stack
		JSR	PUT_HEX
		MOVE.L	#HEAD2,-(SP)
		JSR 	PUT_STR
		MOVE.L	20(A6),-(SP)		push pE on stack again
		JSR	PUT_ENV
		JSR	NEW_LINE
*
* print current instruction:
*
		MOVE.L	#C_HEAD1,-(SP)
		JSR	PUT_STR
		MOVE.L	16(A6),A0		A0 = pC
		MOVE.L	A0,-(SP)
		JSR	PUT_HEX
		MOVE.L	#HEAD2,-(SP)
		JSR	PUT_STR
* decode mnemonic:
		MOVE.L	#OPS_TAB,A1
		MOVE.L	(A0)+,D0		D0 = current op-code
		MOVE.L	(A1,D0),-(SP)
		JSR	PUT_STR
* decode arguments:
		MOVE.L	#OPN_TAB,A1
		MOVE.L	(A1,D0),D1		D1 = number of arguments
		MOVE.L	#OPP1_TAB,A1
C_LOOP:		CMPI	#0,D1
		BEQ	PRC_DONE
		MOVE.L	#SPC,-(SP)
		JSR	PUT_STR
		MOVE.L	(A0)+,-(SP)		push arg on stack
		MOVE.L	(A1,D0),A2
		JSR	(A2)
		MOVE.L	#OPP2_TAB,A1
		SUBI.L	#1,D1
		BRA	C_LOOP
PRC_DONE:	JSR	NEW_LINE
*
* print D-stack:
*
		MOVE.L	#D_HEADER,-(SP)
		JSR	PUT_STR
		MOVE.L	8(A6),A0		A0 = bottom D
D_LOOP:		CMP.L	12(A6),A0		(top D == A0) ?
		BEQ	PRD_DONE
		MOVE.L	-(A0),-(SP)
		JSR	PUT_HEX
		MOVE.L	#SEP,-(SP)
		JSR	PUT_STR
		BRA	D_LOOP
PRD_DONE:	JSR	NEW_LINE
		MOVE.L	#LINE,-(SP)
		JSR	PUT_STR
		JSR	NEW_LINE

		MOVEM.L	(SP)+,D0-D7/A0-A5	restore registers
		UNLK	A6			restore A6
		MOVE.L	(SP),24(SP)		kill argument frame
		ADDA.L	#24,SP
		RTS

S_HEADER	DC.B	'S| ',0
D_HEADER	DC.B	'D| ',0
E_HEAD1		DC.B	'pE(',0
C_HEAD1		DC.B	'pC(',0
HEAD2		DC.B	')->',0
SEP		DC.B	' : ',0
SPC		DC.B	' ',0
LINE		DC.B	'-------------------------------------------------------------------------------',0