; inner

; @ indirect
; + the instruction after this one (i.e. this is code)
; X+ the instruction after X
; ! word address of label

#define n 0
#define I n(fp)
#define R ++n(fp)
#define W ++n(fp)
#define CA ++n(fp)
#define b ++n(fp)

#define STACKw ++n(fp)
#define STACKb ++n(fp)
#define STACKf ++n(fp)
#define STACKl ++n(fp)
#define STACKp ++n(fp)
#define STACKc ++n(fp)
#define STACKm ++n(fp)
#define STACKmp ++n(fp)



colon:
	+
	consp I, R
	movp W, I
	JMP next
semi :
	+
	headp R, I
	tail R, R
next:
	movp @I, W
	movp I+, I
run :
	movp @W, C
	movp W+, W
	JMP C

; MAIN

outer :
	!execute
	nop
	nop	; when we get back here, 2 x 2gross should be on the d stack
	jmp start_restart

start_restart:
	movp outer, I
	consp main, R
	JMP next

main:
	!colon
	dup[b]
	semi


#define push[t] n : cons[t] n, STACK[t]
#define pop[t] n : head[t] n, STACK[t] tail STACK[t], STACK[t]



header("EXECUTE")
execute:
	+
	headp W, STACKp
	tail STACKp, STACKp
	jmp run

header("CONSTANT[t]")
constant[t]:
	:
;	!create
;	!comma)
;	!scode)

	; @WA -> CA
	movt t, @W
	
	; PSH CA -> SP
	const t, STACK[t]
	jmp next


header(4, "DROP[t]")	;	::
drop[t]:
	+
	tail STACK[t], STACK[t]
	JMP next

header("DUP[t]")	; A::A::
dupb:
	+
	headb STACKb, ++n(fp)
	consb n[fp], STACKb
	JMP next

dupw:
	+
	headw STACKw, ++n(fp)
	consw n[fp], STACKw
	JMP next

dupf:
	+
	headf STACKf, ++n(fp)
	consf f[fp], STACKf
	JMP next

dupl:
	+
	headl STACKl, ++n(fp)
	consl n(fp), STACKl
	JMP next
	

header("2DUP[t]")   ; A::A::A::
twodup[t]:
	+
	head[t] STACK[t], t
	cons[t] t, STACK[t]
	cons[t] t, STACK[t]
	JMP next

header("SWAP[t]")	; B::A::
swap[t] :
	+
	pop[t] t1
	pop[t] t2
	cons[t] t2, STACK[t]
	cons[t] t1, STACK[t]

	JMP next

header("OVER") ; B::A::B::
over[t] :
	+
	tail STACK[t], t1
	head[t] t1, t2  
	cons[t] t2, STACK[t]
	JMP next

header("RROT")  ;  C::B::A::
rrot[t]:
	+
	pop[t] t1
	pop[t] t2
	pop[t] t3
	cons[t] t1, STACK[t]
	cons[t] t2, STACK[t]
	cons[t] t3, STACK[t]
	JMP next


header("LROT")  ;  B::C::A::
lrot[t]:
	+
	pop[t] t1
	pop[t] t2
	pop[t] t3
	cons[t] t1, STACK[t]
	cons[t] t3, STACK[t]
	cons[t] t2, STACK[t]
	JMP next

header("2OVER") ; C::A::B::C::
twoover[t]:
	+ 
	tail t1, STACK[t]
	tail t2, t1
	head t3, t2
	cons[t] t3, STACK[t]
	JMP next

header("2SWAP")	; C::B::A::    funny this looks the same as RROT
twoswap[t]:
	+
	pop[t] t1
	pop[t] t2
	pop[t] t3
	cons[t] t1, STACK[t]
	cons[t] t2, STACK[t]
	cons[t] t3, STACK[t]
	JMP next