*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
/ NB: AC must be 'trn cf' at the end
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

/ cycle left one bit
cyl1,	cla
	add psp
	sto cyl10
	add (add
	sto cyl11
	cla
cyl11,	add .		/ load from stack
	cyl
cyl10,	sto .		/ store on stack
	clc
	trn next

/ cycle right one bit
cyr1,	cla
	add psp
	sto cyr10
	add (add
	sto cyr11
	cla
cyr11,	add .		/ load from stack
	cyr
cyr10,	sto .		/ store on stack
	clc
	trn next


/-- execute address on stack
/ NB: AC must be 'trn cf' at the end
/     t will be pushed onto return stack by docol
exec,	cla
	add ip
	sto t
	cla
	add (trn .+3
	trn pop
	 sto tt
	add tt
	add (trn
	sto .+1
	trn .	/ jump to code
	hlt	/ can't happen

/-- 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

mul8,	trn docol
	cyl1; cyl1; cyl1
	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,	lac
	add (401776
	trn key		/ wait for key
key0,	cyr
	trn key0	/ cycle down
	add (-377600
	sto t
	cal
	add (trn .+3
	trn push
key1,	 add t
	trn next

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

/-- CR ( -- ). Print carriage return
cr,	trn docol
	lit; 51
	emit
	exit
/-- SPACE ( -- ). Print space
space,	trn docol
	lit; 10
	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
	10

/ 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; 43; eq; zbran; exp2-.
	  / BS: restart loop
exp4,	  drop; cr
	  exlop
	  bran; exp0-.
exp2,	 dup; lit; 77; eq; zbran; exp3-.	/ check DEL
	  bran; exp4-.	/ same as BS
exp3,	 dup; lit; 51; 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
	76; 00
	25; 01
	17; 02
	07; 03
	13; 04
	23; 05
	33; 06
	27; 07
	03; 10
	66; 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; 35; 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;
/halt; inter
inter
	state; at
	zeq; zbran; quit1-.
	 / ok
	 lit; 60; emit
	 lit; 36; emit
quit1,
	bran; quit0-.

halt,	hlt

/ forth start
fst,
	quit
	halt

bintab,
	000000
	000001
	000010
	000011
	000100
	000101
	000110
	000111
	001000
	001001
	001010
	001011
	001100
	001101
	001110
	001111
	010000
	010001
	010010
	010011
	010100
	010101
	010110
	010111
	011000
	011001
	011010
	011011
	011100
	011101
	011110
	011111
	100000
	100001
	100010
	100011
	100100
	100101
	100110
	100111
	101000
	101001
	101010
	101011
	101100
	101101
	101110
	101111
	110000
	110001
	110010
	110011
	110100
	110101
	110110
	110111
	111000
	111001
	111010
	111011
	111100
	111101
	111110
	111111


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

cyl., 000000 3; 34; 52; 44; 0; trn docol		/ "cyl"
	zero; xdo
cyl.1,	 cyl1
	xloop; cyl.1-.
	exit
cyl1., 000000 4; 25; 34; 52; 44; cyl.; trn cyl1		/ "1cyl"
cyr., 000000 3; 34; 52; 24; cyl1.; trn docol		/ "cyr"
	zero; xdo
cyr.1,	 cyr1
	xloop; cyr.1-.
	exit
cyr1., 000000 4; 25; 34; 52; 24; cyr.; trn cyr1		/ "1cyr"

emit., 000000 4; 2; 70; 14; 40; cyr1.; trn emit		/ "emit"

dig., 000000 6; 22; 14; 64; 14; 40; 12; emit.; trn docon	/ "digits"
	digits+1
plus., 000000 1; 15; dig.; trn plus		/ "+"
dict,
at., 000000 2; 6; 40; plus.; trn at		/ "at"


literals=.

*030000
tibuf,
*.+200

end,


*literals