forth85_06. @,c@,!,c!

;this is forth85_06. Hope to add @, c@, ! c! * (16 x 16 signed) and /MOD (ditto).
; @,c@, !, c! seem to be working OK. Not sure how many bytes c@ and c! should involve. 1 byte at this stage.
; next do * and /MOD. Find code on net.

.NOLIST
.include "tn85def.inc"
.LIST
.LISTMAC ;sometimes macro code gets in way of clarity in listing
.MACRO header
	.db high(@0), low(@0), @1, @2
.ENDMACRO
.MACRO mypop
	ld @0,-y
.ENDMACRO
.MACRO mypush
	st y+, @0
.ENDMACRO
.MACRO mypop2
	mypop @0
	mypop @1
.ENDMACRO
.MACRO mypush2
	mypush @0
	mypush @1
.ENDMACRO
.MACRO pushx
	push xl
	push xh
.ENDMACRO
.MACRO popx
	pop xh
	pop xl
.ENDMACRO


.def FOUND = r15	;if found=1 we have a match of Ram word on dictionary
.def BOTTOM = r14	;have hit the bottom of the dict and not found a match
.def STOP = r13		;stop interpreting line of words
.def STATE = r12
.def FOUNDCOUNTER = r11	;dealWithWord clicks this if found =1. Counts successful finds in dictionary.
.def SECONDLETTER =r10	;helpful for debugging
.def vl = r22
.def vh = r23		; u,v,w,x,y,z are all pointers
.DSEG
.ORG 0x60

;consts: .DB "jksdafhsdf",8, 255, 0b01010101, -128, 0xaa
.equ BUF1LENGTH = 64

buf1: .byte BUF1LENGTH
buf2: .byte 64			;could have third buffer?
varSpace: .byte 64		;might need more than 32 variables
;.org 0x1E0
myStackStart: .byte 64

.cseg
.ORG 0x800 ;dictionary starts at 4K (2K  words) mark
;----------------------------------------------------
one_1:
.db 0,0,3, "one" ;code for one
one:
;	rcall stackme
	rcall stackme_2
.db 01, 00
ret
;----------------------------------------------
two_1:
header one_1, 3, "two"
two:
	rcall stackme_2
	.db 02,00
ret
;------------------------------------------
dup_1:
header two_1,3,"dup"
dup:
	mypop r17
	mypop r16
	mypush r16
	mypush r17
	mypush r16
	mypush r17

ret
;-------------------------------------------
drop_1:
header dup_1,4,"drop"
drop:
	mypop r17
	mypop r16			;TODO what if stack pointer goes thru floor?
ret
;----------------------------------
swapp_1:		;twp p's becasue assembler recognizes avr opcode swap
header drop_1,5, "swapp"
swapp:
	mypop2 r17,r16
	mypop2 r19,r18
	mypush2 r16,r17
	mypush2 r18,r19
ret


;-------------------------------------------------
		;shift this later

S_1:
;the EOL token that gets put into end of buf1 to stop parsing
header swapp_1,1,"S"
S:
	clr STOP
	inc STOP	;set time-to-quit flag
ret
;------------------------------------------

fetch_1:	;doesn't like label = @-1
;classic fetch. (adr -- num). Only in RAM
header S_1,1,"@"
fetch:
	pushx	;going to use x to point so better save
	mypop xh
	mypop xl
	ld r16,x+
	ld r17,x
	mypush r16
	mypush r17	; and put them on my stack
	popx		;return with x intact and RAM val on my stack
ret
;dddddddddddddddddddddddddddddddddddddddddddddddd

cfetch_1:	;doesn't like label = c@-1
;classic fetch. (adr -- num). Only in RAM. Do I want y to advance just one byte on mystack
header fetch_1,2,"c@"
cfetch:
	pushx	;going to use x to point so better save
	mypop xh
	mypop xl
	ld r16,x+
	mypush r16
	popx		;return with x intact and RAM val on my stack
ret
;dddddddddddddddddddddddddddddddddddddddddddddddd

store_1:		;classic != "store"(adr num --) . Num is now at cell adr.
header cfetch_1,1,"!"
store:
	mypop2 r17,r16		;there goes the num
	pushx
	mypop2 xh,xl		;there goes the address
	st x+,r16
	st x,r17			;num goes to cell with location=adr
	popx
ret
;ddddddddddddddddddddddddddddddddddddddddddddddddddd
LATEST:
cstore_1:		;classic c!= "store"(adr 8-bitnum --) . 8 bit Num is now at cell adr.
header store_1,2,"c!"
cstore:
	mypop r16		;there goes the num. Just 8 bits at this stage.
	pushx
	mypop2 xh,xl		;there goes the address
	st x+,r16
;	st x,r17			;num goes to cell with location=adr
	popx
ret



;-------------------------------------------------
stackme_2:		;stacks on my stack next 16bit num. Address of 16bit number is on SP-stack
	; Used like this stackme_2 0034. Puts 0034 on myStack and increments past number on return stack.
	pop r17
	pop r16		; they now contain eg 0x0804 which contain the 16bit num
	movw zl,r16	;z now points to cell that cobtains the number
	clc
	rol zl
	rol zh		;double word address  for z. lpm coming up



	lpm r16,z+
	lpm r17,z+	;now have 16bit number in r16,17

	st y+,r16
	st y+, r17	;mystack now contains the number

	clc
	ror zh
	ror zl	;halve the z pointer to step past the number to return at the right place

	push zl
	push zh

ret



;====================================================================================================

.ORG 0
	rjmp start
typein: .db " one two dup drop swapp ", 0x0d

;stackme dropx onex stackme swap drop",0x0d
start:
	ldi r16, low(RAMEND)
	out SPL, r16
	ldi r16,high(RAMEND)
	out SPH, r16

	ldi YL,low(myStackStart)
	ldi YH,high(myStackStart)

;rjmp test_interpretLine
;rjmp test_cfetch
;rjmp test_store
rjmp test_cstore

	rjmp start

getline0:	;force a line into buf1 via flash string. Simulates GETLINE
	ldi zl, low(typein<<1)
	ldi zh, high(typein<<1)
	ldi xl, low(buf1)
	ldi xh, high(buf1)
type0:
	lpm r16,Z+
	st x+,r16
	cpi r16,0x0d		;have we got to the end of the line?
	brne type0
ret
;--------------------------------------------
;WORD gets x to point to start of word (copy in w=r24,25) with the length in len = r20
;assume word points to somewhere in buf1. Should advance thru spaces=0x20 to first real char
word: 			;maybe give it a header later
	ld r16,x+	;get char
	ld SECONDLETTER, x	;for debugging

	cpi r16,0x20	;is it a space?
	breq word		;if so get next char
;if here we're point to word start. so save this adr in w
	mov r24,xl
	mov r25,xh		;wordstart now saved in w


	clr r20			;length initially 0
nextchar:
	inc r20			;r20 = word length
	ld r16,x+		;get next char
	cpi r16,0x20
	brne nextchar
	dec r24			;adjust start of word
;if here we've found a word.Starting at w length in r20.x points to space just past word
ret
;----------------------------------------

compare: 		;given a word in buf1 and a word in the dic are they the same? The word in the dic is pointed to by Z.
				; and the word in buf1 is pointed to by w=r24,25. len = r20. Z on entry points to the link. Needs +2 to
	lpm r23,z+
	lpm r22,z+	;store next link in v=r22,23. z now points to len byte

startc:
	push r20	;save length
	lpm r16,Z+	;length of dictionary word, first entry now in r16
	cp r16,r20	;same lengths?
	brne outcom	;not = so bail out
;if here the words are the same length, what about the rest of the chars.First get x to point to word.
	mov xl,r24
	mov xh,r25	;x now point to start of buf1 word
upcom:
	lpm r16,z+
	ld r17,x+	;get one corresponding char from each word
	cp r16,r17	;same word?
	brne outcom	;bail out if chars are different
	dec r20		;count chars
	brne upcom	;still matching and not finished so keep going
;if here r20 is 0 so match must have been perfect so FOUND = 1
	clr FOUND
	inc FOUND
outcom:
	pop r20		;get old lngth of buf1 word back
ret
;-------------------------------------------
jmpNextWord:	;go to next word in the dictionary. Assume v=r22,23 contains next link word(not byte)
				; and w = r24,25 contains RAM word start with len in r20
				;exit with z pointing to next word ready for next COMPARE.
	clc
	rol r22
	rol r23		;above 3 instructions change word address into byte address by doubling
	movw r30,r22	;z now points to next word
ret
;-----------------------------------------

doLatest:	;set up so first jump in dictionary is to top=LATEST and other flags set up.
	ldi vl, low(LATEST)
	ldi vh, high(LATEST)
	clr FOUND
	clr BOTTOM		;not yet found the match, not yet at the bottom. Either will stop search.
	clr STOP		;keep parsing words til this goes to a 1
ret
;---------------------------------------------
interpretLine:		;given line of words in buf one, search for words one by one. Don't do code
					; or compile at this stage, just find and report that and go into next one.
	rcall getline0	;change later to real getline via terminal
	rcall pasteEOL
	ldi xl, low(buf1)
	ldi xh,high(buf1)	;last 3 statemnts are done onece. Now the main loop.
	clr FOUNDCOUNTER	;counts finds in line parsing.

nextWord:
	tst STOP
	brne stopLine
	rcall word
	rcall findWord			;not done yet
	rcall dealWithWord		;go and run code STATE=0, or compile (STATE =1).{ c0de, comp1le}
	rjmp nextWord
stopLine:
	ret
;-----------------------------------------------------------------
findWord:
	rcall doLatest
upjmpf:
	rcall jmpNextWord
	rcall compare
	tst FOUND
	brne stopsearchf		;if last compare got a match (FOUND=1) then stop searching
	tst vl
	brne upjmpf			;if v=0000 then we've hit the bottom of the dictionary
	tst vh
	brne upjmpf			;not found and not at bottom so keep going
;if here FOUND =0, ie no match yet and we've hit the bottom of the dictionary
	clr BOTTOM
	inc BOTTOM			;exit with FOUND=0 and BOTTOM =1
stopsearchf: nop
ret
;----------------------------
test_interpretLine:
	rcall interpretLine
til: rjmp til ;**
;------------------------------
dealWithWord:			;come here when it's time to compile or run code
;Good debugging spot. Enter here with Z pointing to CFA of word found. Y points to myStack. X points to just
; past the word we are seeking (w-s). r10 is 2nd letter of w-s. w = start adr of w-s. v is a link
; to the next word in dic. Either just below the found word or 0000 if we get to the bottome with no match
;
	nop
	tst FOUND
	breq notfound
	inc FOUNDCOUNTER

	;want to hop over filler bytes,0's added to keep codes on even byte boundaries
	; so if r30 is odd at this stage inc it. odd is lsbit = 1.
	sbrs r30,0 	;skip 	next instruction if final bit lsb = 1
	rjmp downdw
;if here lsb = 1 so we're on a padding byte and have to add 1 to get to a 2 byte boundary
	inc r30
	brcc downdw
	inc r31		;add one to z before converting to bytes

downdw:
		clc
	ror zh
	ror zl		;put z back into word values


	rcall executeCode



	.MESSAGE "Word found"
	rjmp outdww
notfound:
	.MESSAGE "Word not found"
	clr STOP
	inc STOP		;stop parsing line
outdww:
ret
;------------------------------------------------------------------------
pasteEOL:		;when a line of text is TYPEd into buf1 it should end with CR=$0d. This gets replaced with ]}, a
	; special end of line word. When the word is invoked it casues a QUIT back to  the waiting for input stage.
	; Start at buf1 start and inspect each char for a $0D. When found replace with a "$20 S $20 "
	ldi xl, low(buf1)
	ldi xh, high(buf1)	;pnt to start of buffer
	clr r17
nxtChar:
	inc r17				;r17 is counter. Bail out when r17 > BUF1LENGTH
	cpi r17, BUF1LENGTH -4
	breq outProb
	ld r16, x+
	cpi r16, $0d
	brne nxtChar
;if here we've found a $0d in buf1 before the end, so replace with an EOL token. x points to just after it.
	ldi r16,$20
	st -x, r16		;back up. Then go forward.
;	ldi r16, ']'
	st x+, r16
	ldi r16,'S'
	st x+, r16
;	ldi r16, '}'
;	st x+, r16
	ldi r16, $20
	st x, r16
	rjmp outpel


outProb:
	nop
	.MESSAGE "Couldn't find $0d"
outpel:
ret

;-------------------------------------
executeCode:		;with Z pointing to cfa. Not sure whether to jmp or call

	ijmp
	ret
;---------------------------------------
test_fetch:		;do run thru of @
	rcall getline0	;change later to real getline via terminal
	rcall pasteEOL
	ldi xl, low(buf1)
	ldi xh,high(buf1)	;last 3 statemnts are done onece. Now the main loop.

	ldi r16,$62
	mypush r16
	ldi r16,$0
	mypush r16		;should now have adr $0062 on mystack
	rcall fetch
tf1:
	rjmp tf1
;---------------------------------
test_cfetch:		;do run thru of @
	rcall getline0	;change later to real getline via terminal
	rcall pasteEOL
	ldi xl, low(buf1)
	ldi xh,high(buf1)	;last 3 statemnts are done onece. Now the main loop.

	ldi r16,$62
	mypush r16
	ldi r16,$0
	mypush r16		;should now have adr $62 on mystack
	rcall cfetch
tcf1:
	rjmp tcf1
;----------------------------
test_store:
	rcall getline0	;change later to real getline via terminal
	rcall pasteEOL
	ldi xl, low(buf1)
	ldi xh,high(buf1)	;last 3 statemnts are done onece. Now the main loop.
	ldi r16,$62
	ldi r17,$0
	mypush2 r16,r17 	;should now have adr $62 on mystack
	ldi r16, $AB
	ldi r17, $CD
	mypush2 r16,r17		;now have $ABCD on mystack
	rcall store
ts1:
	rjmp ts1
;------------------------
test_cstore:
	rcall getline0	;change later to real getline via terminal
	rcall pasteEOL
	ldi xl, low(buf1)
	ldi xh,high(buf1)	;last 3 statemnts are done onece. Now the main loop.
	ldi r16,$62
	ldi r17,$0
	mypush2 r16,r17 	;should now have adr $62 on mystack
	ldi r16, $AB
;	ldi r17, $CD
	mypush r16	;now have $ABCD on mystack
	rcall cstore
ts11:
	rjmp ts11