*1
ip,	add fst	/ address interpreter instruction pointer
t,	0	/ temp, also ip between next and docol
tt,	0	/ another temp

*40
start,	clc
	trn next
	hlt

/ push to return stack
rpush,	sto rpush0
	add (add-trn-1
	sto .+2
	cla
	add .	/ arg
	sto rpush1
	cla
	add rsp
	add (1
	sto rsp
	cla
rpush1,	add .	/ val
rsp,	sto 10000	/ sp
	clc
rpush0,	trn .	/ ret

/ pop from return stack
rpop,	sto rpop0
	add (add-trn-1
	sto .+2
	cla
	add .	/ arg
	sto rpop1+1
	cla
	add rsp
	add (add
	sto rpop1
	add (-add-1
	sto rsp
	cla
rpop1,	add .	/ sp
	sto .	/ val
	clc
rpop0,	trn .	/ ret

/ push to parameter stack
push,	sto push0
	add (add-trn-1
	sto .+2
	cla
	add .	/ arg
	sto push1
	cla
	add psp
	add (1
	sto psp
	cla
push1,	add .	/ val
psp,	sto 20000	/ sp
	clc
push0,	trn .	/ ret

/ pop from parameter stack
pop,	sto pop0
	add (add-trn-1
	sto .+2
	cla
	add .	/ arg
	sto pop1+1
	cla
	add psp
	add (add
	sto pop1
	add (-add-1
	sto psp
	cla
pop1,	add .	/ sp
	sto .	/ val
	clc
pop0,	trn .	/ ret

/-- RP!
rpsto,	cla
	add (10000
	sto rsp
	clc
	trn next

/-- SP!
spsto,	cla
	add (20000
	sto psp
	clc
	trn next

/-- SP@
spat,	cla
	add psp
	sto t
	cla
	add (trn .+3
	trn push
	 add t	/ pre-incremented sp
	trn next


/ ip pointing to forth word to execute
/ make sure AC is -0 when jumping here
next,	add ip
	sto next0
	add (1
	sto ip
	sto t		/ for docol to push
	cla
next0,	add .		/ load trn codefield
	add (trn
	sto .+1
	trn .		/ must be negative
	hlt		/ can't happen

docol,	add (add-trn+1
	sto ip		/ advance ip to PF
	cla
	add (trn .+3
	trn rpush
	 add t		/ push old ip
	trn next

exit,	cla
	add (trn .+3
	trn rpop
	 sto ip
	trn next

dovar,	add (-trn+1
	sto t
	cla
	add (trn .+3
	trn push
	 add t
	trn next

docon,	add (add-trn+1
	sto docon0
	cla
	add (trn .+3
	trn push
docon0,	 add .	/ PF
	trn next

/-- literal
lit,	cla
	add ip
	sto lit0
	add (1
	sto ip
	cla
	add (trn .+3
	trn push
lit0,	 add .		/ literal
	trn next

zero,	cla
	add (trn .+3
	trn push
	 cla
	trn next

one,	cla
	add (trn .+3
	trn push
	 add (1
	trn next

two,	cla
	add (trn .+3
	trn push
	 add (2
	trn next

three,	cla
	add (trn .+3
	trn push
	 add (3
	trn next

/-- execute address on stack
exec,	cla
	add (trn .+3
	trn pop
	 sto t
	add t
	add (trn
	sto .+1
	trn .	/ jump to code

/-- branch
bran,	cla
	add ip
	sto .+1
	add .	/ branch offset
	sto ip
	clc
	trn next

/-- 0branch
zbran,	cla
	add (trn .+3
	trn pop
	 sto t
	add t
	trn .+2
/ TODO check code
	com		/ make negative
	com		/ make positive
	add (-0		/ normalize
	trn bran+1	/ -0
	cla
skip,	add ip
	add (1
	sto ip
	clc
	trn next

/-- DUP ( n1 n2 -- n1 n2 n2 )
dup,	cla
	add psp
	add (add
	sto dup0
	cla
dup1,	add (trn .+3
	trn push
dup0,	 add .		/ tos
	trn next

/-- DUP2 ( n1 n2 -- n1 n2 n1 n2 )
dup2,	trn docol
	over
	over
	exit

/-- OVER ( n1 n2 -- n1 n2 n1 )
over,	cla
	add psp
	add (add-1
	sto dup0
	clc
	trn dup1

pick,	trn docol
	onep; spat; swap; minus; at
	exit

/-- SWAP ( n1 n2 -- n2 n1 )
swap,	cla
	add psp
	sto swap0
	add (add
	sto swap1
	add (-1
	sto swap2
	add (-add
	sto swap3
	cla
swap1,	add .	/ tos
	sto t
	cla
swap2,	add .	/ 2nd
swap0,	sto .	/ tos
	cla
	add t
swap3,	sto .	/ 2nd
	clc
	trn next

/-- DROP ( n -- )
drop,	cla
	add psp
	add (-1
	sto psp
	clc
	trn next

/-- ! ( n addr -- ). Store n at addr
store,	cla
	add (trn .+3
	trn pop
	 sto store0
	add (trn .+3
	trn pop
	 sto t
	cla	/ not necessary if storing -0 for +0 is ok
	add t
store0,	sto .	/ addr
	clc
	trn next

/-- +!
pstor,	cla
	add (trn .+3
	trn pop
	 sto pstor0
	add pstor0
	add (add
	sto pstor0-1
	cla
	add (trn .+3
	trn pop
	 sto t
	cla	/ not necessary if storing -0 for +0 is ok
	add t
	add .	/ addr
pstor0,	sto .	/ addr
	clc
	trn next

/-- @
at,	cla
	add psp
	sto at0
	add (add
	sto .+2
	cla
	add .	/ addr
	add (add
	sto .+2
	cla
	add .	/ val
at0,	sto .	/ tos
	clc
	trn next

/-- >R
tor,	cla
	add (trn .+3
	trn pop
	 sto t
	add (trn .+3
	trn rpush
	 add t
	trn next

/-- R@
rat,	cla
	add rsp
	add (add
	sto rat0
	cla
	add (trn .+3
	trn push
rat0,	 add .	/ tos
	trn next

/-- R>
fromr,	cla
	add (trn .+3
	trn rpop
	 sto t
	add (trn .+3
	trn push
	 add t
	trn next

/-- (DO)
xdo,	cla
	add (trn .+3
	trn pop
	 sto t
	add (trn .+3
	trn pop
	 sto tt
	add (trn .+3
	trn rpush
	 add tt
	add (trn .+3
	trn rpush
	 add t
	trn next

/-- (LOOP)
xloop,	cla
	add rsp
	sto xlo0
	add (add
	sto xlo1
	add (-1
	sto xlo2
	cla
xlo1,	add .	/ 1st, index
	add (1
xlo0,	sto .	/ 1st, index
	com
xlo2,	add .	/ 2nd, limit
	add (-0		/ normalize
	trn xlo3	/ end of loop
	clc		/ branch back
	trn bran+1
xlo3,	cla
	add rsp
	add (-2
	sto rsp
	clc
	trn skip

/-- I ( -- index ). Get current loop index
i,	cla
	add rsp
	add (add
	sto i0
	cla
	add (trn .+3
	trn push
i0,	 add .	/ loop index
	trn next
	

/-- - ( n1 n2 -- diff )
/ alternative: copy code instead of modification
minus,	cla
	add (com
	sto plus0-1
	clc
	trn plus2
/-- + ( n1 n2 -- sum )
plus,	cla
	add (opr
	sto plus0-1
	cla
plus2,	add (trn .+3
	trn pop
	 sto t
	add psp
	sto plus0+1
	add (add
	sto plus0
	cla
	add t
	opr	/ negate for minus
plus0,	add .	/ tos
	sto .	/ tos
	clc
	trn next

/-- 1+ ( n - n+1 )
onep,	cla
	add psp
	sto onep0+1
	add (add
	sto onep0
	cla
	add (1
onep0,	add .	/ tos
	sto .	/ tos
	clc
	trn next

/-- mul2 ( n - n*2 )
mul2,	cla
	add psp
	sto mul20+2
	add (add
	sto mul20
	cla
mul20,	add .	/ tos
	cyl
	sto .	/ tos
	clc
	trn next

mul8,	trn docol
	mul2; mul2; mul2
	exit

false,	clc
	trn .+2
/ come here with AC=-0
true,	add (1
stob,	sto .		/ store boolean on stack
	clc
	trn next

/-- 0=
not,
zeq,	cla
	add psp
	sto stob
	add (add
	sto .+2
	cla
	add .	/ tos
	trn .+2
	com
	add (1
	trn false	/ not zero
	clc
	trn true	/ zero

/-- =
eq,	trn docol
	minus
	zeq
	exit

/-- 0>
zgt,	cla
	add psp
	sto stob
	add (add
	sto .+2
	cla
	add .	/ tos
	add (-0
	trn false	/ <= 0
	clc
	trn true	/ > 0

/-- 0<
zlt,	cla
	add psp
	sto stob
	add (add
	sto .+2
	cla
	add .	/ tos
	com
	add (-0
	trn false	/ >= 0
	clc
	trn true	/ < 0

/-- MOVE ( src dst n -- ). Copy n words from src to dst
move,	cla
	add (trn .+3
	trn pop
	 sto t
	add (trn .+3
	trn pop
	 sto move0
	add (trn .+3
	trn pop
	 sto move1
	add move1
	add (add
	sto move1
	cla
move1,	add .
move0,	sto .
	cla
	add t
	add (-1
	trn move2
	sto t
	cla
	add move1
	add (1
	sto move1
	cla
	add move0
	add (1
	sto move0
	clc
	trn move1-1
move2,	clc
	trn next

/-- KEY ( -- char ). get one character from input device
key,	cla
	lac
	add (400000
	trn key
	add (-1
	sto t
	cal
	add (trn .+3
	trn push
	 add t
	trn next

/-- EMIT ( char -- ). Print one character on output device
emit,	cla
	add (trn .+3
	trn pop
	 sto t
	add t
	prt
	clc
	trn next

/-- CR ( -- ). Print carriage return
cr,	trn docol
	lit; 101001
	emit
	exit
/-- SPACE ( -- ). Print space
space,	trn docol
	lit; 001000
	emit
	exit

/-- COUNT ( addr -- addr+1 n )
count,	trn docol
	dup
	onep
	swap
	at
	exit

/-- TYPE ( addr n -- ). Type string of n chars
type,	trn docol
	dup
	zbran; type0-.
	 over; plus; swap
	 xdo
type1,	  i; at; emit
	 xloop; type1-.
	 exit
type0,	drop; drop
	exit

/ turn add x into x
ptr,	trn docol
	lit; -200000
	plus
	exit

/-- (.")
pdotq,	trn docol
	rat
	ptr
	count
	dup; onep
	fromr; plus; tor
	type
	exit

/ input buffer
tib,	trn docon
	tibuf
/ current position in input buffer
in,	trn dovar
	0
/ end of dictionary pointer
dp,	trn dovar
	end
/ interpret/compile state
state,	trn dovar
	0	/ 0 interpret, 1 compile
/ blank
bl,	trn docon
	001000

/ address of next free word
here,	trn docol
	dp; at
	exit

/-- ALLOT ( n -- ). Add n words to end of dictionary
allot,	trn docol
	dp; pstor
	exit

/-- , ( n -- ). Put word into dictionary
comma,	trn docol
	here; store
	one; allot
	exit

/ exit loop
exlop,	trn docol
	fromr
	fromr; drop; fromr; drop
	tor
	exit

/-- EXPECT ( addr n -- ). Read up to n chars into addr
expec,	trn docol
	over; plus; swap
exp0,	dup2	/ start over here
	xdo
exp1,	 key
	 dup; lit; 100011; eq; zbran; exp2-.
	  / BS: restart loop
exp4,	  drop; cr
	  exlop
	  bran; exp0-.
exp2,	 dup; lit; 111111; eq; zbran; exp3-.	/ check DEL
	  bran; exp4-.	/ same as BS
exp3,	 dup; lit; 101001; eq; zbran; exp5-.	/ check CR
	  / CR: print space, terminate buffer, exit
	  drop; space
	  zero; fromr; store
	  fromr; drop
	  bran; exp6-.
exp5,	 / emit char and add to buffer
	 dup; emit
	 rat; store
	xloop; exp1-.
exp6,	drop; drop
	exit

/-- QUERY ( -- ). Read up to 128 chars into input buffer
query,	trn docol
	tib; lit; 200; expec
	zero; in; store
	exit

/-- WORD ( char -- addr ). Read word delimited by char from input stream.
/                          Copy to counted string at addr
/ maybe a bit complicated?
word,	trn docol
	tib; in; at; plus	/ start of buffer
	dup; tor	/ start on ret stack
	over; tor	/ delim on ret stack
	/ skip over delimiters
word1,	dup; at		/ get first char
	dup; rat; eq; zbran; word0-.
	 / saw a delimiter
	 drop; onep
	 bran; word1-.
word0,	/ first non delimiter
	over; swap	/ address of first char
word4,	dup; zeq; zbran; word2-.
	 / zero
	 drop
	 dup	/ next char
	 bran; word5-.
word2,	rat; eq; zbran; word3-.
	 / saw a delimiter
	 dup; onep	/ next char
	 bran; word5-.
word3,	/ normal char
	onep
	dup; at		/ get next char
	bran; word4-.
word5,	/ got input
	fromr; drop	/ drop delim
	fromr; minus; in; pstor	/ advance IN
	over; minus	/ get n
	dup; here; store
	here; onep; swap; move
	drop	/ delimiter
	here
	exit


/ split dictionary entry. last value is 1 if word is immediate
/ ( addr - name n 1|-1 )
split,	trn docol
	dup; onep
	swap; at
	dup; zlt; zbran; split0-.
	 lit; -400000; plus
	 lit; 1
	 exit
split0,	lit; -1
	exit

/ compare strings for equality
/ ( str1 n1 str2 n2 -- str1 n1 0|1 )
streq,	trn docol
	two; pick
	eq; not
	zbran; streq0-.
	 / length not equal
	 drop
	 zero
	 exit
streq0,	two; pick
	two; pick
	zero; xdo
streq1,	 over; i; plus; at
	 over; i; plus; at
	 eq; not; zbran; streq2-.
	  exlop
	  drop; drop
	  zero
	  exit
streq2,	xloop; streq1-.
	drop; drop
	one
	exit

/-- FIND ( str n dict -- 0 | cf -1 | cf 1 ). Find string in dictionary
find,	trn docol
find1,	dup; zeq; zbran; find2-.
	 drop; drop; drop
	 zero
	 exit
find2,	split; tor	/ immediate flag
	dup2; plus; tor	/ link field
	streq; zbran; find0-.
	 / found
	 drop; drop
	 fromr; onep	/ code field
	 fromr	/ immediate
	 exit
find0,	fromr; at	/ follow link
	fromr; drop	/ drop immediate flag
	bran; find1-.

/-- ROT ( n1 n2 n3 -- n2 n3 n1 )
rot,	trn docol
	tor; swap
	fromr; swap
	exit

/-- -ROT ( n1 n2 n3 -- n3 n1 n2 )
rotr,	trn docol
	swap; tor
	swap; fromr
	exit

/-- LOOKUP ( key table -- val 0|1 ). Lookup key in table (like counted string) and whether it was found
look,	trn docol
	count
	zero; xdo
look0,	 / ( key entry )
	 dup; at	/ key in table
	 two; pick	/ key
	 eq; zbran; look1-.
	  / found it
	  exlop
	  swap; drop	/ remove key
	  onep; at	/ val
	  one
	  exit
look1,	 two; plus
	xloop; look0-.
	drop; drop	/ table and key
	zero	/ not found
	exit

digits,	12
	111110; 00
	010101; 01
	001111; 02
	000111; 03
	001011; 04
	010011; 05
	011011; 06
	010111; 07
	000011; 10
	110110; 11

/-- >NUMBER ( ud1 addr1 n1 -- ud2 addr2 n2 )
number,	trn docol
numb1,	dup; zbran; numb0-.	/ check empty string
	over; at	/ get first char
	lit; digits
	look
	zbran; numb0-.
	 / valid digit
	 tor	/ numeric value to ret stack
	 rot	/ get number on top
	 mul8; fromr; plus	/ add digit
	 rot; onep	/ increment address
	 rot; one; minus	/ decrement count
	 bran; numb1-.	/ loop
numb0,	exit

/-- NUM ( addr -- n 1 | 0 ). Parse number from string
num,	trn docol
	zero; swap
	count
	over; at; lit; 011101; eq; zbran; num1+1-.
	 / minus sign
	 one; minus	/ decrement length
	 swap; onep; swap	/ increment ptr
	 num1
	 dup; zbran; numb0-1.	/ not a number
	 / negate
	 swap; zero; swap; minus; swap
	 exit
num1,	trn docol
	number
	zbran; num0-.	/ success
	 / no number
	 drop; drop
	 zero
	 exit
num0,	drop
	one
	exit

inter,	trn docol
inter3,	bl; word
	dup; count
	dup; zbran; inter2-.
	lit; dict; find
	dup; zbran; inter0-.
	 rot; drop	/ drop word
	 state; at; plus	/ add state and immediate
	 zbran; inter4-.	/ if sum is 0, compile
	  exec		/ interpret
	  bran; inter3-.
inter4,	 comma		/ compile
	 bran; inter3-.
inter0,	drop	/ not found in dict, try as number
	num
	zbran; inter1-.
	 / got a number
	 state; at; zbran; inter3-.	/ leave on stack
	 / compile it
	 lit; lit; comma; comma
	 bran; inter3-.
inter1,	halt	/ panic
inter2,	drop; drop; drop	/ no more input
	exit

/-- QUIT ( -- ). The top level
quit,	trn docol
quit0,	rpsto
	cr; query; inter
	state; at
	zeq; zbran; quit1-.
	 / ok
	 lit; 110000; emit
	 lit; 011110; emit
quit1,
	bran; quit0-.

halt,	hlt

/ forth start
fst,
	quit
	halt

/ dictionary entry:
/  0   length + immediate flag (sign bit)
/  1   name[n]
/  n+1 link to next entry
/  n+2 code[...]

asdf, 000000 3; 110010; 000110; 010100; 0; trn one	/ "bar"
dict, 400000 3; 011010; 110000; 110000; asdf; trn two	/ "foo"

literals=.

*030000
tibuf,
*.+200

end,


*literals