Create a gist now

Instantly share code, notes, and snippets.

anonymous /tforth.asm
Created Jan 16, 2016

What would you like to do?
TinyForth for AVR by T. NAKAGAWA
; Tiny FORTH
; T. NAKAGAWA
; 2004/08/02-05
; Additional comments by Ken Boak Jan 2016
; Register
; r0: temporary
; r1-15: input buffer (terminated by 0x00, separated by 0x20)
; r16: temporary
; r17: temporary
; r18: temporary
; r19: temporary
; r20: DICPTR_L
; r21: DICPTR_H
; r22: DICENT_L
; r23: DICENT_H
; r24: zero
; r25: system I/O
; r26: XL (paramater stack L)
; r27: XH (paramater stack H)
; r28: YL (return stack L)
; r29: YH (return stack H)
; r30: ZL (temporary)
; r31: ZH (temporary)
;
; Memory Map
; 0060-008f(48) : [return stack]-> <-[parameter stack]
; 0090-00df(80) : [dictionary]-> <-[hardware stack]
; Code Analysis - major routines - instruction count ( double these for bytes on AVR)
; Initialisation 34
; UART Init, getchr, putchr 13
; Main 51
; Message 12
; Get Token 50
; Literal 43
; Lookup 23
; Find 23
; Compile 182
; Variable 40
; Forget 14
; Execute 68
; Primitives 287
; MUL 18
; DIV 29
; Putnum 13
; Total Instructions 860
; Instr Byte Count 1720
; Defined bytes 160
; Code size estimate 1880
.def dicptr_L = r20
.def dicptr_H = r21
.def dicent_L = r22
.def dicent_H = r23
.def zero = r24
.equ PFX_UDJ = 0x80
.equ PFX_CDJ = 0xa0
.equ PFX_CALL = 0xc0
.equ PFX_PRIMITIVE = 0xe0
.equ I_RET = 0xfe
.equ I_LOOP = (PFX_PRIMITIVE | 25)
.equ I_RDROP2 = (PFX_PRIMITIVE | 26)
.equ I_I = (PFX_PRIMITIVE | 27)
.equ I_P2R2 = (PFX_PRIMITIVE | 28)
.equ STK_BGN = 0x0060
.equ STK_END = 0x0060 + 48
.equ DIC_BGN = 0x0060 + 48
.include "2313def.inc" ; Put your AVR .inc here
.cseg
.org 0
; Interruption Vector
rjmp main
reti
reti
reti
reti
reti
reti
reti
reti
reti
reti
main:
clr zero
; Initialize the hardware stack
ldi r16, RAMEND
out SPL, r16
; System init.
rcall initl
; Initialize the stack and dictionary
ldi YL, LOW(STK_BGN)
ldi YH, HIGH(STK_BGN)
ldi XL, LOW(STK_END)
ldi XH, HIGH(STK_END)
ldi dicptr_L, LOW(DIC_BGN)
ldi dicptr_H, HIGH(DIC_BGN)
ldi dicent_L, LOW(0xffff)
ldi dicent_H, HIGH(0xffff)
; Initialize the input buffer
ldi r16, ' ' ; Put a space into r16, copy to r1 and r2
mov r1, r16
mov r2, r16
ldi ZL, 0x03
ldi ZH, 0x00
main0: st Z+, zero ; zero the first 16 words of memory
cpi ZL, 16
brne main0
ldi ZL, LOW(2 * msg_start) ; ZH,ZL points to message
ldi ZH, HIGH(2 * msg_start)
rcall putmsg ; Put out the start message "Tiny FORTH"
main1: rcall gettkn ; get the first token
; keyword
ldi ZL, LOW(2 * key_runmode)
ldi ZH, HIGH(2 * key_runmode)
rcall find ; find it in the dictionary
brne main2
main11: ;; : ; If it's a colon : call compile
cpi r16, 0
brne main12
rcall compile
rjmp maina
main12: ;; VAR ; is it VAR ? Call variable
cpi r16, 1
brne main13
rcall variable
rjmp maina
main13: ;; FGT ; is it FGT ? Call forget
cpi r16, 2
brne main14
rcall forget
main14: rjmp maina
main2: ; User Defined Command ; is it a user defined word. Look it up then call execute
rcall lookup
brne main3
adiw ZL, 5
rcall execute
rjmp maina
main3: ; primitive ; is it a primitive word. Look it up then call primitive-execute
ldi ZL, LOW(2 * key_primitive)
ldi ZH, HIGH(2 * key_primitive)
rcall find
brne main4
rcall primitive
rjmp maina
main4: ; literal ; it's likely to be a literal. Call literal then put it on the stack
rcall literal
brne main5
st -X, ZL
st -X, ZH
rjmp maina
main5: ;; error ; If you have got here - it's an error
ldi ZL, LOW(2 * msg_error)
ldi ZH, HIGH(2 * msg_error)
rcall putmsg ; Put out the error message
rjmp main1 ; go back and get the next token
maina: ldi r16, LOW(STK_END + 1) ; tset for stack overflow
ldi r17, HIGH(STK_END + 1)
cp XL, r16
cpc XH, r17
brcs mainb
ldi ZL, LOW(2 * msg_ovf)
ldi ZH, HIGH(2 * msg_ovf)
rcall putmsg ; put out the Overflow message
ldi XL, LOW(STK_END)
ldi XH, HIGH(STK_END)
rjmp main1 ; go back and get the next token
mainb: ldi ZL, LOW(2 * msg_ok) ; If you get this far - put out the OK message
ldi ZH, HIGH(2 * msg_ok)
rcall putmsg
rjmp main1 ; go back and get the next token
;
; Put a Message
; IN: ZH:ZL=pointer to the string
;
putmsg:
lpm
tst r0
breq putm1 ; Test for zero at end of message string - jump to crlf
mov r25, r0
rcall putchr
adiw ZL, 1
rjmp putmsg
putm1: ldi r25, 0x0d ; end message with crlf 0x0d 0x0a
rcall putchr
ldi r25, 0x0a
rcall putchr
ret
;
; Get a Token
; OUT: r1-r15=input string(terminated by ' ')
;
gettkn:
ldi r17, ' '
ldi ZH, 0x00
; remove leading non-delimiters
rcall gettA
cp r1, r17
brne gettkn
; remove leading delimiters
gett1: rcall gettA
gett2: cp r1, r17
breq gett1
; return if tokens exist
cp r1, zero
breq gett3
ret
gett3: ; read
ldi ZL, 0x01
gett4: rcall getchr ; get the character from the UART
;; RET
cpi r25, 0x0d ; '\r' ; check for "return"
brne gett41
ldi r25, 0x0a ; '\n' ; check for "newline"
rcall putchr
st Z, r17
rjmp gett2
gett41: ;; BS
cpi r25, 0x08 ; '\b' ; check for "backspace"
brne gett42
cpi ZL, 1
breq gett4
st -Z, zero
ldi r25, ' ' ; put out a "space"
rcall putchr
ldi r25, 0x08 ; '\b' ; put out a "backspace"
rcall putchr
rjmp gett4
;; CTRL
gett42: cpi r25, 0x20
brcc gett43
rjmp gett4
gett43: ;; INS
cpi ZL, 15
breq gett44
st Z+, r25
rjmp gett4
gett44: ;; Else
ldi r25, 0x08 ; '\b' ; put out a "backspace"
rcall putchr
ldi r25, ' ' ; put out a "space"
rcall putchr
ldi r25, 0x08 ; '\b' ; put out a "backspace"
rcall putchr
rjmp gett4
gettA: ; shift left the buffer
ldi ZL, 0x01
gettA1: cpi ZL, 15
breq gettA2 ; finish when you get to 15
ldd r16, Z+1
st Z+, r16
rjmp gettA1
gettA2: st Z, zero
ret
;
; Process a Literal
; IN: r1-r15=keyword
; OUT: ZH:ZL=number, ZF=1/0(is literal/not literal)
;
literal:
push YL
push YH
ldi YL, 0x01
ldi YH, 0x00
ldi ZL, 0
ldi ZH, 0
ld r16, Y
lit1: ; Hex value ; check if it's hex, if it's preceded by $
cpi r16, '$'
brne lit2 ; not hex - jump to decimal
lit11: adiw YL, 1
ld r16, Y
cpi r16, ' '
breq lit4
ldi r16, LOW(16) ; *= 16
ldi r17, HIGH(16)
rcall mul16 ; multiply by 16
ld r16, Y
subi r16, 'A'
brcc lit12
subi r16, -('A') + '0' + (10) ; convert from ASCII
lit12: subi r16, -(10)
add ZL, r16 ; put it on the stack
adc ZH, zero
rjmp lit11
lit2: ; Decimal value
cpi r16, '0'
brcs lit3
cpi r16, '9'+1
brcc lit3
lit21: ld r16, Y
cpi r16, ' ' ; is it a space?
breq lit4
ldi r16, LOW(10) ; *= 10
ldi r17, HIGH(10)
rcall mul16
ld r16, Y+
subi r16, '0'
add ZL, r16 ; put it on the stack
adc ZH, zero
rjmp lit21
lit3: clz
lit4: pop YH ; restore YH, YL
pop YL
ret
;
; Lookup the keyword from the Dictionary
; OUT: ZH:ZL=pointer to the entry, ZF=1/0(found/not found)
;
lookup:
mov ZL, dicent_L ; point to the dictionary entry
mov ZH, dicent_H
lup1: ldi r16, LOW(0xffff) ; check for end of dictionary space
ldi r17, HIGH(0xffff)
cp ZL, r16
cpc ZH, r17
breq lup2
; read the keyword (r18, r19, r0)
ldd r18, Z+2 ; get the first 3 characters
ldd r19, Z+3
ldd r0, Z+4
cpi r19, ' ' ; is it a space
breq lup11
cp r0, r3
lup11: cpc r19, r2 ; compare against the 3 characters of the current dictionary
cpc r18, r1
breq lup3 ; found ; found a match, so return
; not found
ldd r16, Z+0 ; move to the next dictionary entry and repeat lookup
ldd r17, Z+1
mov ZL, r16
mov ZH, r17
rjmp lup1
lup2: clz
lup3: ret
;
; Find the Keyword in a List
; IN: r1-r15=keyword, ZH:ZL=pointer to the list
; OUT: r16=id, ZF=1/0(found/not found)
;
find:
ldi r16, 0
lpm
adiw ZL, 1
mov r17, r0
find1: cp r17, r16
breq find2
; read the keyword (r18, r19, r0)
lpm
adiw ZL, 1
mov r18, r0
lpm
adiw ZL, 1
mov r19, r0
lpm
adiw ZL, 1
cpi r19, ' '
breq find11
cp r0, r3
find11: cpc r19, r2
cpc r18, r1
breq find3
inc r16
rjmp find1
find2: clz
find3: ret
;
; Compile Mode
;
compile:
push XL ; Push X
push XH
mov XL, dicptr_L ; get the dictionary pointer
mov XH, dicptr_H
rcall gettkn ; get token
; Write the header
mov ZL, dicent_L ; get the dictionary address into Z
mov ZH, dicent_H
mov dicent_L, XL ; write entry into XH, XL
mov dicent_H, XH
st X+, ZL
st X+, ZH
st X+, r1 ; Write the first 3 characters
st X+, r2
st X+, r3
mov r16, r2
cpi r16, ' ' ; is it a space?
brne comp1
st -X, r16
adiw XL, 1
comp1: ; compile ; Put out the ">" to indicate the token has compiled
ldi ZL, LOW(2 * msg_compile)
ldi ZH, HIGH(2 * msg_compile)
rcall putmsg
rcall gettkn ; get the next token
; keyword
ldi ZL, LOW(2 * key_compilemode) ; search the list of compile-mode tokens
ldi ZH, HIGH(2 * key_compilemode)
rcall find
breq comp11
rjmp comp2
comp11: ;; ; ; Check for terminating semi-colon ;
cpi r16, 0
brne comp12
ldi r16, I_RET
st X+, r16
mov dicptr_L, XL
mov dicptr_H, XH
pop XH
pop XL
ret
comp12: ;; IF ; now search through the compile words and execute
cpi r16, 1
brne comp13
st Y+, XL
st Y+, XH
ldi r16, PFX_CDJ ; conditional jump
st X+, r16
adiw XL, 1
rjmp comp1
comp13: ;; ELS
cpi r16, 2
brne comp14
ld ZH, -Y
ld ZL, -Y
st Y+, XL
st Y+, XH
ldi r16, PFX_UDJ ; unconditional jump
st X+, r16
adiw XL, 1
mov r18, XL
mov r19, XH
sub r18, ZL
sbc r19, ZH
subi r19, -0x10 ; +4096
ld r16, Z
or r19, r16
st Z+, r19
st Z+, r18
rjmp comp1
comp14: ;; THN
cpi r16, 3
brne comp15
ld ZH, -Y
ld ZL, -Y
mov r18, XL
mov r19, XH
sub r18, ZL
sbc r19, ZH
subi r19, -0x10 ; +4096
ld r16, Z
or r19, r16
st Z+, r19
st Z+, r18
rjmp comp1
comp15: ;; BGN
cpi r16, 4
brne comp16
st Y+, XL
st Y+, XH
rjmp comp1
comp16: ;; END
cpi r16, 5
brne comp17
ld ZH, -Y
ld ZL, -Y
sub ZL, XL
sbc ZH, XH
subi ZH, -0x10 ; +4096
ori ZH, PFX_CDJ
st X+, ZH
st X+, ZL
rjmp comp1
comp17: ;; WHL
cpi r16, 6
brne comp18
st Y+, XL
st Y+, XH
adiw XL, 2
rjmp comp1
comp18: ;; RPT
cpi r16, 7
brne comp19
ld ZH, -Y
ld ZL, -Y
adiw XL, 2
mov r18, XL
mov r19, XH
sbiw XL, 2
sub r18, ZL
sbc r19, ZH
subi r19, -0x10 ; +4096
ori r19, PFX_CDJ
st Z+, r19
st Z+, r18
ld ZH, -Y
ld ZL, -Y
sub ZL, XL
sbc ZH, XH
subi ZH, -0x10 ; +4096
ori ZH, PFX_UDJ
st X+, ZH
st X+, ZL
rjmp comp1
comp19: ;; DO
cpi r16, 8
brne comp1a
ldi r16, I_P2R2
st X+, r16
st Y+, XL
st Y+, XH
rjmp comp1
comp1a: ;; LOP
cpi r16, 9
brne comp1b
ldi r16, I_LOOP
st X+, r16
ld ZH, -Y
ld ZL, -Y
sub ZL, XL
sbc ZH, XH
subi ZH, -0x10 ; +4096
ori ZH, PFX_CDJ
st X+, ZH
st X+, ZL
ldi r16, I_RDROP2
st X+, r16
rjmp comp1
comp1b: ;; I
cpi r16, 10
brne comp1c
ldi r16, I_I
st X+, r16
comp1c: rjmp comp1
comp2: ; User Defined Command
rcall lookup
brne comp3
adiw ZL, 5
sub ZL, XL
sbc ZH, XH
subi ZH, -0x10 ; +4096
ori ZH, PFX_CALL
st X+, ZH
st X+, ZL
rjmp comp1
comp3: ; keyword
ldi ZL, LOW(2 * key_primitive)
ldi ZH, HIGH(2 * key_primitive)
rcall find
brne comp4
ori r16, PFX_PRIMITIVE
st X+, r16
rjmp comp1
comp4: ; literal
rcall literal
brne comp5
cpi ZL, 128
cpc ZH, zero
brcc comp41
st X+, ZL
rjmp comp1
comp41: ldi r16, 0xff
st X+, r16
st X+, ZL
st X+, ZH
rjmp comp1
comp5: ; else
ldi ZL, LOW(2 * msg_error2)
ldi ZH, HIGH(2 * msg_error2)
rcall putmsg
rjmp comp1
;
; VARIABLE instruction
;
variable:
push XL
push XH
mov XL, dicptr_L
mov XH, dicptr_H
; get the identifier
rcall gettkn
; Write the header
mov ZL, dicent_L
mov ZH, dicent_H
mov dicent_L, XL
mov dicent_H, XH
st X+, ZL
st X+, ZH
st X+, r1
st X+, r2
st X+, r3
mov r16, r2
cpi r16, ' '
brne var1
st -X, r16
adiw XL, 1
var1: mov ZL, XL
mov ZH, XH
adiw ZL, 2
cpi ZL, 128
cpc ZH, zero
brcc var2
st X+, ZL
rjmp var3
var2: adiw ZL, 2
ldi r16, 0xff
st X+, r16
st X+, ZL
st X+, ZH
var3: ldi r16, I_RET
st X+, r16
st X+, zero ; data area
st X+, zero ; data area
mov dicptr_L, XL
mov dicptr_H, XH
pop XH
pop XL
ret
;
; Forget Words in the Dictionary
forget:
; get a word
rcall gettkn
rcall lookup
breq fgt1
ldi ZL, LOW(2 * msg_error3)
ldi ZH, HIGH(2 * msg_error3)
rcall putmsg
ret
fgt1: ldd r16, Z+0
ldd r17, Z+1
mov dicent_L, r16
mov dicent_H, r17
mov dicptr_L, ZL
mov dicptr_H, ZH
ret
;
; Virtual Code Execution
; ZH:ZL=start address
;
execute:
ldi r16, 0xff
st Y+, r16
st Y+, r16
exec1: ldi r16, 0xff
cp ZL, r16
cpc ZH, r16
brne exec2
ret
exec2: ld r16, Z+
exec3: ; literal(0-127)
cpi r16, 128
brcc exec4
st -X, r16
st -X, zero
rjmp exec1
exec4: ; literal(128-65535)
cpi r16, 0xff
brne exec5
ld r16, Z+
ld r17, Z+
st -X, r16
st -X, r17
rjmp exec1
exec5: ; RET: return
cpi r16, I_RET
brne exec6
ld ZH, -Y
ld ZL, -Y
rjmp exec1
exec6: ; UDJ: unconditional direct jump
mov r17, r16
andi r16, 0xe0
andi r17, 0x1f
cpi r16, PFX_UDJ
brne exec7
ld r16, Z
sbiw ZL, 1
add ZL, r16
add ZH, r17
subi ZH, 0x10 ; -4096
rjmp exec1
exec7: ; CDJ: conditional direct jump
cpi r16, PFX_CDJ
brne exec8
ld r19, X+
ld r18, X+
cp r18, zero
cpc r19, zero
brne exec71
ld r16, Z
sbiw ZL, 1
add ZL, r16
add ZH, r17
subi ZH, 0x10 ; -4096
rjmp exec1
exec71: adiw ZL, 1
rjmp exec1
exec8: ; CALL: subroutine call
cpi r16, PFX_CALL
brne exec9
ld r16, Z+
st Y+, ZL
st Y+, ZH
sbiw ZL, 2
add ZL, r16
add ZH, r17
subi ZH, 0x10 ; -4096
rjmp exec1
exec9: ; primitive functions
mov r16, r17
push ZL
push ZH
rcall primitive
pop ZH
pop ZL
rjmp exec1
;
; Execute a Primitive Instruction
; IN: r16=instruction
;
primitive:
prim1: ; DROP
cpi r16, 0
brne prim2
adiw XL, 2
ret
prim2: ; DUP
cpi r16, 1
brne prim3
ld r17, X+
ld r16, X+
st -X, r16
st -X, r17
st -X, r16
st -X, r17
ret
prim3: ; SWAP
cpi r16, 2
brne prim4
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
st -X, r18
st -X, r19
st -X, r16
st -X, r17
ret
prim4: ; >R
cpi r16, 3
brne prim5
ld r17, X+
ld r16, X+
st Y+, r16
st Y+, r17
ret
prim5: ; R>
cpi r16, 4
brne prim6
ld r17, -Y
ld r16, -Y
st -X, r16
st -X, r17
ret
prim6: ; +
cpi r16, 5
brne prim7
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
add r16, r18
adc r17, r19
st -X, r16
st -X, r17
ret
prim7: ; -
cpi r16, 6
brne prim8
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
sub r16, r18
sbc r17, r19
st -X, r16
st -X, r17
ret
prim8: ; *
cpi r16, 7
brne prim9
ld r17, X+
ld r16, X+
ld ZH, X+
ld ZL, X+
rcall mul16
st -X, ZL
st -X, ZH
ret
prim9: ; /
cpi r16, 8
brne prima
ld r17, X+
ld r16, X+
ld ZH, X+
ld ZL, X+
rcall div
st -X, ZL
st -X, ZH
ret
prima: ; MOD
cpi r16, 9
brne primb
ld r17, X+
ld r16, X+
ld ZH, X+
ld ZL, X+
rcall div
st -X, r16
st -X, r17
ret
primb: ; AND
cpi r16, 10
brne primc
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
and r16, r18
and r17, r19
st -X, r16
st -X, r17
ret
primc: ; OR
cpi r16, 11
brne primd
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
or r16, r18
or r17, r19
st -X, r16
st -X, r17
ret
primd: ; XOR
cpi r16, 12
brne prime
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
eor r16, r18
eor r17, r19
st -X, r16
st -X, r17
ret
prime: ; =
cpi r16, 13
brne primf
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r16, r18
cpc r17, r19
breq primTR
primFL: ldi r16, 0x00
rjmp prime1
primTR: ldi r16, 0x01
prime1: ldi r17, 0x00
st -X, r16
st -X, r17
ret
primf: ; <
cpi r16, 14
brne primg
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r16, r18
cpc r17, r19
brcs primTR
rjmp primFL
primg: ; >
cpi r16, 15
brne primh
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r18, r16
cpc r19, r17
brcs primTR
rjmp primFL
primh: ; <=
cpi r16, 16
brne primi
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r18, r16
cpc r19, r17
brcc primTR
rjmp primFL
primi: ; >=
cpi r16, 17
brne primj
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r16, r18
cpc r17, r19
brcc primTR
rjmp primFL
primj: ; <>
cpi r16, 18
brne primk
ld r19, X+
ld r18, X+
ld r17, X+
ld r16, X+
cp r16, r18
cpc r17, r19
brne primTR
rjmp primFL
primk: ; NOT
cpi r16, 19
brne priml
ld r17, X+
ld r16, X+
cp r16, zero
cpc r17, zero
breq primTR
rjmp primFL
priml: ; @
cpi r16, 20
brne primm
ld ZH, X+
ld ZL, X+
ldd r16, Z+0
ldd r17, Z+1
st -X, r16
st -X, r17
ret
primm: ; @@
cpi r16, 21
brne primn
ld ZH, X+
ld ZL, X+
ldd r16, Z+0
st -X, r16
st -X, zero
ret
primn: ; !
cpi r16, 22
brne primo
ld ZH, X+
ld ZL, X+
ld r17, X+
ld r16, X+
std Z+0, r16
std Z+1, r17
ret
primo: ; !!
cpi r16, 23
brne primp
ld ZH, X+
ld ZL, X+
ld r17, X+
ld r16, X+
std Z+0, r16
ret
primp: ; .
cpi r16, 24
brne primq
ld ZH, X+
ld ZL, X+
rcall putnum
ldi r25, ' '
rcall putchr
ret
primq: ; LOOP
cpi r16, 25
brne primr
ld r17, -Y
ld r16, -Y
ld ZH, -Y
ld ZL, -Y
adiw ZL, 1
st Y+, ZL
st Y+, ZH
st Y+, r16
st Y+, r17
cp ZL, r16
cpc ZH, r17
brcc primq1
ldi r16, 0x00
rjmp primq2
primq1: ldi r16, 0x01
primq2: ldi r17, 0x00
st -X, r16
st -X, r17
ret
primr: ; RDROP2
cpi r16, 26
brne prims
sbiw YL, 4
ret
prims: ; I
cpi r16, 27
brne primt
ld r19, -Y
ld r18, -Y
ld r17, -Y
ld r16, -Y
st Y+, r16
st Y+, r17
st Y+, r18
st Y+, r19
st -X, r16
st -X, r17
ret
primt: ; P2R2
cpi r16, 28
brne primu
ld r17, X+
ld r16, X+
st Y+, r16
st Y+, r17
ld r17, X+
ld r16, X+
st Y+, r16
st Y+, r17
primu: ret
;
; Put a Number
; IN: ZH:ZL=number
;
putnum:
ldi r16, LOW(10)
ldi r17, HIGH(10)
rcall div
cp ZL, zero
cpc ZH, zero
breq putn1
push r16
rcall putnum
pop r16
putn1: mov r25, r16
subi r25, -('0')
rcall putchr
ret
;------------------------------------------------------------------------------
; 16bit Multiplicatoin
; IN: ZH:ZL=multiplicand, r17:r16=multiplier
; OUT: ZH:ZL=product
mul16:
push YL
push YH
clr YL
clr YH
ldi r18, 16
mul1: sbrs ZL, 0
rjmp mul2
add YL, r16
adc YH, r17
mul2: lsr YH
ror YL
ror ZH
ror ZL
dec r18
brne mul1
pop YH
pop YL
ret
; 16bit Division
; IN: ZH:ZL=dividend, r17:r16=divisor
; OUT: ZH:ZL=quotient, r17:r16=remainder
div:
push YL
push YH
clr YL
clr YH
ldi r18, 16
lsl ZL
rol ZH
rol YL
div1: sub YL, r16
sbc YH, r17
brcc div2
add YL, r16
adc YH, r17
clc
rjmp div3
div2: sec
div3: rol ZL
rol ZH
rol YL
rol YH
dec r18
brne div1
lsr YH
ror YL
mov r16, YL
mov r17, YH
pop YH
pop YL
ret
;------------------------------------------------------------------------------
; Initialize
initl:
ldi r25, (EXP2(RXEN) | EXP2(TXEN))
out UCR, r25
ldi r25, 23 ; 19200baud @ 7.3728MHz clock
out UBRR, r25
ret
; Get a character
getchr:
sbis USR, RXC
rjmp getchr
in r25, UDR
rjmp putchr
; Put a character
putchr:
sbis USR, UDRE
rjmp putchr
out UDR, r25
ret
key_runmode:
.db 3, ": ", "VAR", "FGT"
key_compilemode:
.db 11, 0x3b, " ", "IF ", "ELS", "THN", "BGN", "END", "WHL", "RPT", "DO ", "LOP", "I "
key_primitive:
.db 25, "DRP", "DUP", "SWP", ">R ", "R> ", "+ ", "- ", "* ", "/ ", "MOD", "AND", "OR ", "XOR", "= ", "< ", "> ", "<= ", ">= ", "<> ", "NOT", "@ ", "@@ ", "! ", "!! ", ". "
msg_start:
.db "Tiny FORTH", 0x00, 0
msg_error:
.db "?", 0x00
msg_ovf:
.db "OVF", 0x00
msg_ok:
.db "OK", 0x00, 0
msg_compile:
.db ">", 0x00
msg_error2:
.db "!", 0x00
msg_error3:
.db "??", 0x00, 0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment