6809_forth/forth.s

ACIA_CSR equ $EC14
ACIA_DR  equ $EC15

F_TRUE equ $FFFF
F_FALSE equ $0000

F_R0 equ $E7F0
F_S0 equ $E6F0


    DATA
    org $E000
    CODE
    org $F000

    DATA
mul_op_1
    fdb 0
mul_op_2
    fdb 0
mul_result
    fdb 0
    CODE

acia_write
    pshu A
1
    lda ACIA_CSR
    anda #2
    beq 1B
    pulu A
    sta ACIA_DR

    rts

acia_read
1
    lda ACIA_CSR
    anda #1
    beq 1B
    lda ACIA_DR

    rts

NEXT macro
    jmp __NEXT
    endm

__NEXT
    ; Load addr of the codeword at X into Y
    ldy ,X++

    ; Dereference codeword and jump
    jmp [,Y]

PUSHRSP macro
    pshs \1
    endm

POPRSP macro
    puls \1
    endm

DOCOL
    ; Push old PC
    PUSHRSP X

    ; Address of last codeword is still in Y from NEXT
    ; Move past codeword (Y+2)
    ldb ,Y++
    tfr Y,X

    ; Call NEXT to execute
    NEXT

entry
    ; == Init Stack ==
    ; Board 1 RAM
    ; ldu #$7400
    ; lds #$7500
    ; Onboard RAM
    ldu #F_S0
    lds #F_R0

    ; == Init ACIA ==
    ; Reset
    lda #$3
    sta ACIA_CSR
    ; CLK / 16 (9600)
    ; 8N1
    ; nRTS low, no TX int
    ; RX int disabled
    lda #$15
    sta ACIA_CSR

    lda #'A'
    jsr acia_write

    ; Initialize vars
    ldy #0
    sty var_STATE
    ldy #10
    sty var_BASE
    ldy #name_X
    sty var_LATEST
    ldy #initial_HERE
    sty var_HERE
    ldy #F_S0
    sty var_SZ

    ldx #cold_start
    NEXT

cold_start
    fdb QUIT

F_IMMED equ $80
F_HIDDEN equ $20
F_LENMASK equ $1F

link set 0

defword macro  ; name, namelen, flags, label
    align 2
name_\4
    fdb link
link set name_\4
    fcb \3+\2
    fcc "\1"
    align 2
\4
    fdb DOCOL
    endm

defcode macro  ; name, namelen, flags, label
    align 2
name_\4
    fdb link
link set name_\4
    fcb \3+\2
    fcc "\1"
    align 2
\4
    fdb code_\4
code_\4
    endm

    defcode "DROP",4,0,"DROP"
    pulu Y
    NEXT

    defcode "SWAP",4,0,"SWAP"
    pshu X
    ldx 2,U
    ldy 4,U
    stx 4,U
    sty 2,U
    pulu X
    NEXT

    defcode "DUP",3,0,"DUP"
    ldy ,U
    pshu Y
    NEXT

    defcode "OVER",4,0,"OVER"
    ldy 2,U
    pshu Y
    NEXT

    defcode "ROT",3,0,"ROT"
    pshu X
    ldx 2,U
    ldy 4,U
    stx 4,U
    ldx 6,U
    sty 6,U
    stx 2,U
    pulu X
    NEXT

    defcode "-ROT",4,0,"NROT"
    pshu X
    ldx 2,U
    ldy 6,U
    stx 6,U
    ldx 4,U
    sty 4,U
    stx 2,U
    pulu X
    NEXT

    defcode "2DROP",5,0,"TWODROP"
    pulu Y
    pulu Y
    NEXT

    defcode "2DUP",4,0,"TWODUP"
    ldy 2,U
    pshu Y
    ldy 2,U
    pshu Y
    NEXT

    defcode "2SWAP",5,0,"TWOSWAP"
    pshu X
    ldx 2,U
    ldy 6,U
    stx 6,U
    ldx 2,U
    ldy 8,U
    stx 8,U
    sty 4,U
    sty 4,U
    pulu X
    NEXT

    defcode "?DUP",4,0,"QDUP"
    ldd ,U
    beq 1F
    pshu D
1
    NEXT

    defcode "1+",2,0,"INCR"
    pulu D
    addd #1
    pshu D
    NEXT

    defcode "1-",2,0,"DECR"
    pulu D
    subd #1
    pshu D
    NEXT

    defcode "2+",2,0,"INCR2"
    pulu D
    addd #2
    pshu D
    NEXT

    defcode "2-",2,0,"DECR2"
    pulu D
    subd #2
    pshu D
    NEXT

    defcode "+",1,0,"ADD"
    pulu D
    addd ,U
    std ,U
    NEXT

    defcode "-",1,0,"SUB"
    ldd 2,U
    subd ,U
    std 2,U
    pulu D
    NEXT

    defcode "*",1,0,"MUL"
    pulu Y
    sty mul_op_1
    pulu Y
    sty mul_op_2
    jsr _MUL
    ldy mul_result
    pshu Y
    NEXT
ls8
    lslb
    rola
    lslb
    rola
    lslb
    rola
    lslb
    rola
    lslb
    rola
    lslb
    rola
    lslb
    rola
    lslb
    rola
    rts
_MUL
    lda mul_op_1+1  ; A = op1_L
    ldb mul_op_2+1  ; B = op2_L
    mul  ; D = A * B
    std mul_result  ; res = D

    lda mul_op_1+0  ; A = op1_H
    ldb mul_op_2+1  ; B = op2_L
    mul  ; D = A*B
    ; D << 8...
    jsr ls8
    addd mul_result  ; D += (D << 8)
    std mul_result

    lda mul_op_1+1  ; A = op1_L
    ldb mul_op_2+0  ; B = op2_H
    mul  ; D = A*B
    ; D << 8...
    jsr ls8
    addd mul_result  ; D += (D << 8)
    std mul_result
    rts

    defcode "/MOD",4,0,"DIVMOD"
    ; TODO
    NEXT

do_cmp_pull macro
    ; Operands get pulled in the wrong order :(
    pulu Y
    cmpy ,U

    ; Remove second operand, does not clobber flags
    pulu Y
    endm

    defcode "=",1,0,"EQU"
    do_cmp_pull
    beq 1F
    ; Not Equal
    ldy #F_FALSE
    jmp 2F
1
    ; Equal
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "<>",2,0,"NEQU"
    do_cmp_pull
    bne 1F
    ; Equal
    ldy #F_FALSE
    jmp 2F
1
    ; Not Equal
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "<",1,0,"LT"
    do_cmp_pull
    bgt 1F
    ; Not less than
    ldy #F_FALSE
    jmp 2F
1
    ; Less than
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode ">",1,0,"GT"
    do_cmp_pull
    blt 1F
    ; Not greater than
    ldy #F_FALSE
    jmp 2F
1
    ; Greater than
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "<=",2,0,"LE"
    do_cmp_pull
    bge 1F
    ; Not less than
    ldy #F_FALSE
    jmp 2F
1
    ; Less than
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode ">=",2,0,"GE"
    do_cmp_pull
    ble 1F
    ; Not greater than
    ldy #F_FALSE
    jmp 2F
1
    ; Greater than
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

do_cmp0_pull MACRO
    ; Load into Y to get flags
    ldy ,U
    ; Pop off of stack
    pulu Y
    endm

    defcode "0=",2,0,"ZEQU"
    do_cmp0_pull
    beq 1F
    ; Not equals zero
    ldy #F_FALSE
    jmp 2F
1
    ; Equals zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "0<>",3,0,"ZNEQU"
    do_cmp0_pull
    bne 1F
    ; Equals zero
    ldy #F_FALSE
    jmp 2F
1
    ; Not equals zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "0<",2,0,"ZLT"
    do_cmp0_pull
    blt 1F
    ; Not less than zero
    ldy #F_FALSE
    jmp 2F
1
    ; Less than zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "0>",2,0,"ZGT"
    do_cmp0_pull
    bgt 1F
    ; Not greater than zero
    ldy #F_FALSE
    jmp 2F
1
    ; Greater than zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "0<=",3,0,"ZLE"
    do_cmp0_pull
    ble 1F
    ; Not less than zero
    ldy #F_FALSE
    jmp 2F
1
    ; Less than zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "0>=",3,0,"ZGE"
    do_cmp0_pull
    bge 1F
    ; Not greater than zero
    ldy #F_FALSE
    jmp 2F
1
    ; Greater than zero
    ldy #F_TRUE
2
    ; Push result
    pshu Y
    NEXT

    defcode "AND",3,0,"AND"
    pulu A
    anda 1,U
    sta 1,U
    pulu A
    anda 1,U
    sta 1,U
    NEXT

    defcode "OR",2,0,"OR"
    pulu A
    ora 1,U
    sta 1,U
    pulu A
    ora 1,U
    sta 1,U
    NEXT

    defcode "XOR",3,0,"XOR"
    pulu A
    eora 1,U
    sta 1,U
    pulu A
    eora 1,U
    sta 1,U
    NEXT

    defcode "INVERT",6,0,"INVERT"
    COM 1,U
    COM 0,U
    NEXT

    defcode "NEGATE",6,0,"NEGATE"
    neg 1,U
    bcc 1F
    inc 0,U
1  ; Handle carry
    neg 0,U
    NEXT

    defcode "EXIT",4,0,"EXIT"
    POPRSP X
    NEXT

    defcode "LIT",3,0,"LIT"
    ldy ,X++
    pshu Y
    NEXT

    defcode "!",1,0,"STORE"
    pulu Y  ; Address
    pulu D  ; Data
    std ,Y
    NEXT

    defcode "@",1,0,"FETCH"
    pulu Y
    ldy ,Y
    pshu Y
    NEXT

    defcode "+!",2,0,"ADDSTORE"
    pulu Y
    pulu D
    addd ,Y
    std ,Y
    NEXT

    defcode "-!",2,0,"SUBSTORE"
    pulu Y  ; Address
    ldd ,Y  ; Current value at address
    subd ,U  ; Amount to subtract from stack
    std ,Y
    pulu D  ; Pop off amount to subtract
    NEXT

    defcode "C!",2,0,"STOREBYTE"
    pulu Y
    pulu D
    stb ,Y
    NEXT

    defcode "C@",2,0,"FETCHBYTE"
    pulu Y
    ldb ,Y
    lda #0
    pshu D
    NEXT

    defcode "C@C!",4,0,"CCOPY"
    ldy 2,U  ; Src address
    lda ,Y
    pulu Y  ; Dst address
    sta ,Y++
    pshu Y  ; Dst address
    ldy 2,U
    lda ,Y++
    sty 2,U
    NEXT

    defcode "CMOVE",5,0,"CMOVE"
    pulu D  ; Length
    pulu Y  ; Dst address
    pshu X  ; Preserve PC
    ldx 2,U  ; Src address

1
    lda ,X+
    sta ,Y+
    decb
    bne 1B

    pulu X  ; Restore PC
    pulu Y  ; Drop src address
    NEXT

defvar macro  ; name, namelen, flags, label, initital
    defcode \1,\2,\3,\4
    ldy #var_\4
    pshu Y
    NEXT
    DATA
    align 2
var_\4
    fdb \5
    CODE
    endm

    defvar "STATE",5,0,"STATE",0
    defvar "HERE",4,0,"HERE",0
    defvar "LATEST",6,0,"LATEST",name_X
    defvar "S0",2,0,"SZ",0
    defvar "BASE",4,0,"BASE",10

defconst macro  ; name, namelen, flags, label, value
    defcode \1,\2,\3,\4
    ldy #\5
    pshu Y
    NEXT
    endm

    defconst "R0",2,0,"RZ",F_R0
    defconst "DOCOL",5,0,"__DOCOL",DOCOL
    defconst "F_IMMED",7,0,"__F_IMMED",F_IMMED
    defconst "F_HIDDEN",8,0,"__F_HIDDEN",F_HIDDEN
    defconst "F_LENMASK",9,0,"__F_LENMASK",F_LENMASK

    defcode ">R",2,0,"TOR"
    pulu Y
    PUSHRSP Y
    NEXT

    defcode "R>",2,0,"FROMR"
    POPRSP Y
    pshu Y
    NEXT

    defcode "RSP@",4,0,"RSPFETCH"
    pshu S
    NEXT

    defcode "RSP!",4,0,"RSPSTORE"
    pulu S
    NEXT

    defcode "RDROP",5,0,"RDROP"
    puls Y
    NEXT

    defcode "DSP@",4,0,"DSPFETCH"
    tfr U,Y
    pshu Y
    NEXT

    defcode "DSP!",4,0,"DSPSTORE"
    pulu Y
    tfr Y,U
    NEXT

    defcode "KEY",3,0,"KEY"
    jsr _KEY
    tfr A,B
    lda #0
    pshu D
    NEXT
_KEY
    jsr acia_read
    ; Echo
    jsr acia_write
    rts

    defcode "EMIT",4,0,"EMIT"
    pulu D
    tfr B,A
    jsr _EMIT
    NEXT
_EMIT
    jsr acia_write
    rts

    defcode "WORD",4,0,"WORD"
    jsr _WORD
    pshu Y  ; Address
    lda #0
    pshu D  ; Length
    NEXT

_WORD
1
    ; Skip spaces
    jsr _KEY
    ; TODO: Comments
    cmpa #' '
    beq 1B

    ldb #0
    ldy #word_bufer
2
    ; Read in word
    sta ,Y+
    incb
    jsr _KEY
    ; Break when key <= 0x20 (lazy search for newline or space)
    cmpa #' '
    bhi 2B

    ldy #word_bufer ; Address of word_bufer in Y
    ; Length is in B
    rts

    DATA
    align 2
word_bufer
    rzb 32
    CODE

    defcode "NUMBER",6,0,"NUMBER"
    pulu D  ; Length
    pulu Y  ; Address
    jsr _NUMBER
    pshu Y
    lda #0
    pshu D  ; Unparsed characers
    NEXT

putc macro
    pshu A
    lda #\1
    jsr acia_write
    pulu A
    endm

_NUMBER
    ; Zero out number buffer (steal multiply buffer)
    lda #0
    sta mul_op_1+0
    sta mul_op_1+1
    pshu B  ; Save counter
    ldd var_BASE
    std mul_op_2
    pulu B  ; Restore counter

    ; Zero length String
    tstb
    beq 6F

    ; Check for '-'
    pshu A
    lda ,Y+
    cmpa #'-'
    bne 2F
    pulu A
    lda #1
    pshu A

    ; Decrement count
    decb
    bne 1F
    ; Out of characters
    pulu B  ; Contains F_TRUE from above, indicating error
    rts

1
    pshu B  ; Save counter
    jsr _MUL
    ; Move result to operand for next loop
    ldd mul_result
    std mul_op_1
    pulu B  ; Restore counter

    ; Load next character into A
    lda ,Y+
2
    ; tolower
    cmpa #$60
    blo 3F
    anda #$DF
    ; Convert char to int
3
    suba #'0'
    blo 5F  ; Invalid digit
    cmpa #10
    blo 4F  ; Number
    suba #17  ; Alpha
    blo 5F  ; Invalid digit
    adda #10
4  ; Number
    cmpa var_BASE+1
    bge 5F  ; Invalid digit

    ; Add digit
    adda mul_op_1+1
    sta mul_op_1+1
    lda #0
    adca mul_op_1+0
    sta mul_op_1+0

    decb  ; Decrement count
    bne  1B

5  ; Invalid Digit
    ; Negate if first character was '-'
    pulu A
    tsta
    beq 7F
    ; Negate
    neg mul_op_1+1
    bcc 6F
    inc mul_op_1+0
6  ; Handle carry
    neg mul_op_1+0

7  ; Invert not needed
    ldy mul_op_1
    rts

    defcode "FIND",4,0,"FIND"
    pulu D  ; Length
    pulu Y  ; Address
    jsr _FIND
    pshu Y  ; Header of found word or 0
    NEXT

_FIND
    pshu X  ; Save IP
    ; Length in B
    ; Needle in X
    tfr Y,X

    ; Current word in Y
    ldy var_LATEST
1
    ; Check for end of list (LATEST == 0)
    beq 5F

    ; Compare length
    lda 2,Y
    anda #(F_HIDDEN | F_LENMASK)  ; And hidden to make the length not match
    ; This useless CPU cant compare registers, use the stack
    pshu B
    cmpa 0,U
    pulu B
    bne 4F

    ; Do a strcmp
    pshu B,X,Y  ; Save lenth and string pointers
    ; Skip link
    lda ,Y++
    ; Skip length
    lda ,Y+
2
    lda ,Y+
    cmpa ,X+
    bne 3F  ; Not equal
    decb
    bne 2B
    ; Equal
    pulu B,X,Y  ; Restore stack
    pulu X  ; Restore IP
    ; Y still has current word header
    rts

3
    ; Restore stack
    pulu B,X,Y
4
    ; Go up a link
    ldy ,Y
    bra 1B

5
    ; Not found
    ldy #0
    pulu X  ; Restore IP
    rts

    defcode ">CFA",4,0,"TCFA"
    pulu Y  ; Word header
    jsr _TCFA
    pshu Y  ; Word CFA
    NEXT

_TCFA
    ; Get length
    ldb 2,Y
    andb #F_LENMASK

    addb #3 ; Add 3 bytes to skip link and length/flags bytes + 1 byte for alignment

    ; Add B to Y
    pshu X
    tfr Y,X
    ABX
    tfr X,Y
    pulu X

    ; Align to 2 byte boundary
    tfr Y,D
    addb #1
    adca #0
    andb #~1
    tfr D,Y

    rts

    defword ">DFA",4,0,"TDFA"
    fdb TCFA
    fdb INCR2
    fdb EXIT

    defcode "CREATE",6,0,"CREATE"
    ; Get args
    pulu D  ; Length (in B)
    pulu Y  ; Address of name

    pshu X  ; Save PC

    pshu Y  ; Save name address
    ; Store LATEST at HERE
    ldy var_LATEST
    ldx var_HERE
    sty ,X++
    pulu Y  ; Restore name address

    ; X has HERE
    ; Y has name
    ; B has length

    ; Write length
    stb ,X+

    ; Write WORD
1
    lda ,Y+
    sta ,X+
    decb
    bne 1B

    ; Align to 2 byte boundary
    tfr X,D
    addb #1
    adca #0
    andb #~1

    ; Update LATEST and HERE
    ldy var_HERE
    sty var_LATEST
    std var_HERE

    ; Resetore PC
    pulu X

    NEXT

    defcode ",",1,0,"COMMA"
    pulu Y
    jsr _COMMA
    NEXT

_COMMA
    ; Save PC
    pshu X

    ldx var_HERE
    sty ,X++
    stx var_HERE

    ; Restore PC
    pulu X

    rts

    defcode "[",1,F_IMMED,"LBRAC"
    ldy #0
    sty var_STATE
    NEXT

    defcode "]",1,0,"RBRAC"
    ldy #1
    sty var_STATE
    NEXT

    defword ":",1,0,"COLON"
    fdb WORD
    fdb CREATE
    fdb __DOCOL, COMMA
    fdb LATEST, FETCH, HIDDEN
    fdb RBRAC
    fdb EXIT

    defword ";",1,F_IMMED,"SEMICOLON"
    fdb LIT, EXIT, COMMA
    fdb LATEST, FETCH, HIDDEN
    fdb LBRAC
    fdb EXIT

    defcode "IMMEDIATE",9,F_IMMED,"IMMEDIATE"
    ldy var_LATEST

    ; Toggle immediate flag
    lda 2,Y
    eora #F_IMMED
    sta 2,Y

    NEXT

    defcode "HIDDEN",6,0,"HIDDEN"
    pulu Y

    ; Toggle immediate flag
    lda 2,Y
    eora #F_HIDDEN
    sta 2,Y

    NEXT

    defword "HIDE",4,0,"HIDE"
    fdb WORD
    fdb FIND
    fdb HIDDEN
    fdb EXIT

    defcode "'",1,0,"TICK"
    ; Lazy hack to get the next XT in this word
    ; ONLY WORKS IN COMPILE
    ; Can be impl with WORD FIND >CFA
    ldy ,X++
    pshu Y
    NEXT

    defcode "BRANCH",6,0,"BRANCH"
    tfr X,D
    addd ,X
    tfr D,X
    NEXT

    defcode "0BRANCH",7,0,"ZBRANCH"
    do_cmp0_pull
    beq code_BRANCH
    lda ,X++
    NEXT

    defcode "LITSTRING",9,0,"LITSTRING"
    ; Read and skip length
    ldy ,X++

    ; Push address and length
    pshu X
    pshu Y

    ; Skip string chars
    tfr X,D
    addd ,U  ; Y is pushed above
    addb #1
    adca #0
    andb #~1
    tfr D,X

    NEXT

    defcode "TELL",4,0,"TELL"
    pulu D  ; Length (in B)
    pulu Y  ; Address
1
    lda ,Y+
    jsr acia_write
    decb
    bne 1B
    NEXT

    defword "QUIT",4,0,"QUIT"
    fdb RZ, RSPSTORE
    fdb INTERPRET
    fdb BRANCH,-4

    defcode "INTERPRET",9,0,"INTERPRET"
    jsr _WORD  ; Y = addr, B = length

    lda #0
    sta interpret_is_lit

    pshu B,Y  ; Save word
    jsr _FIND
    cmpy #0
    beq 1F

    ; In the dictionary, check if immediate
    ; Y has word header from FIND
    pulu D  ; Dump saved word, clobbers B
    pulu B
    lda 2,Y  ; Get flags
    pshu A
    jsr _TCFA
    pulu A
    ; Y now has the CW of the word
    anda #F_IMMED
    bne 4F  ; Immediate
    bra 2F  ; Not immediate

1
    ; Not a word, hopefully a literal
    pulu B,Y  ; Recover word
    inc interpret_is_lit
    jsr _NUMBER
    tstb
    bne 6F  ; Not a number
    pshu Y  ; Save number for later
    ldy #LIT  ; Codeword to write

2
    lda var_STATE+1  ; HACK: var_STATE is 16 bit but is only ever 0/1
    beq 4F  ; Executing

    ; Compiling
    jsr _COMMA
    lda interpret_is_lit
    beq 3F
    ; Literal
    ; Pull literal off stack and comma it
    pulu Y
    jsr _COMMA
3
    NEXT

4
    ; Executing
    lda interpret_is_lit
    bne 5F

    ; Not a literal, just jump to XT
    jmp [,Y]

5
    ; Executing a literal, number was already pushed to stack so just call NEXT
    NEXT

6
    ; Parse error
    ldb #errmsgend-errmsg
    ldy #errmsg
7
    lda ,Y+
    jsr acia_write
    decb
    bne 7B
    NEXT

errmsg
    fcc "ERR!\n"
errmsgend
    DATA
    align 2
interpret_is_lit
    fcb 0
    CODE

    defcode "CHAR",4,0,"CHAR"
    jsr _WORD
    ldb ,Y
    lda #0
    pshu D
    NEXT

    defcode "EXECUTE",7,0,"EXECUTE"
    pulu Y
    jmp [,Y]
    NEXT

    ; FORTH things
    defcode ".",1,0,"DOT"
    pulu D
    jsr w_HEX4
    NEXT
w_HEX1
    anda #$F
    cmpa #9
    ble 1F
    adda #'A' - '9' - 1
1
    adda #'0'
    jsr acia_write
    rts
w_HEX2
    pshu A
    lsra
    lsra
    lsra
    lsra
    jsr w_HEX1
    pulu A
    jsr w_HEX1
    rts
w_HEX4
    jsr w_HEX2

    tfr B,A
    jsr w_HEX2
    rts

    defword "BL",2,0,"BL"
    fdb LIT,32
    fdb EXIT

    defword "CR",2,0,"CR"
    fdb LIT,10
    fdb EMIT
    fdb EXIT

    defword "SPACE",5,0,"SPACE"
    fdb LIT,32
    fdb EMIT
    fdb EXIT

    defword "LITERAL",7,F_IMMED,"LITERAL"
    fdb TICK,LIT,COMMA
    fdb COMMA
    fdb EXIT

    defword "RECURSE",7,F_IMMED,"RECURSE"
    fdb LATEST,FETCH
    fdb TCFA
    fdb COMMA
    fdb EXIT

    defword "IF",2,F_IMMED,"IF"
    fdb TICK,ZBRANCH,COMMA
    fdb HERE,FETCH
    fdb LIT,0,COMMA
    fdb EXIT

    defword "THEN",4,F_IMMED,"THEN"
    fdb DUP
    fdb HERE,FETCH,SWAP,SUB
    fdb SWAP,STORE
    fdb EXIT

    defword "ELSE",4,F_IMMED,"ELSE"
    fdb TICK,BRANCH,COMMA
    fdb HERE,FETCH
    fdb LIT,0,COMMA
    fdb SWAP
    fdb DUP
    fdb HERE,FETCH,SWAP,SUB
    fdb SWAP,STORE
    fdb EXIT

    defword "BEGIN",5,F_IMMED,"BEGIN"
    fdb HERE,FETCH
    fdb EXIT

    defword "UNTIL",5,F_IMMED,"UNTIL"
    fdb TICK,ZBRANCH,COMMA
    fdb HERE,FETCH,SUB
    fdb COMMA

    defword "AGAIN",5,F_IMMED,"AGAIN"
    fdb TICK,BRANCH,COMMA
    fdb HERE,FETCH,SUB
    fdb COMMA
    fdb EXIT

    defword "WHILE",5,F_IMMED,"WHILE"
    fdb TICK,ZBRANCH,COMMA
    fdb HERE,FETCH
    fdb LIT,0,COMMA
    fdb EXIT

    defword "REPEAT",6,F_IMMED,"REPEAT"
    fdb TICK,BRANCH,COMMA
    fdb SWAP
    fdb HERE,FETCH,SUB,COMMA
    fdb DUP
    fdb HERE,FETCH,SWAP,SUB
    fdb SWAP,STORE
    fdb EXIT

    defword "NIP",3,0,"NIP"
    fdb SWAP,DROP
    fdb EXIT

    defword "TUCK",4,0,"TUCK"
    fdb SWAP,OVER
    fdb EXIT

    defword "PICK",4,0,"PICK"
    fdb INCR
    fdb LIT,2,MUL
    fdb DSPFETCH,ADD
    fdb FETCH
    fdb EXIT

    defword ".S",2,0,"DOTS"
    fdb DSPFETCH,SZ,FETCH
    fdb TWODUP,LT
    fdb ZBRANCH,16
    fdb DECR2
    fdb DUP,FETCH,DOT
    fdb SPACE
    fdb BRANCH,-20
    fdb TWODROP
    fdb EXIT

    defword "ID.",3,0,"IDDOT"
    fdb INCR2
    fdb DUP,FETCHBYTE
    fdb __F_LENMASK,AND
    fdb DUP,ZGT ; BEGIN
    fdb ZBRANCH,20
    fdb SWAP,INCR
    fdb DUP,FETCHBYTE
    fdb EMIT
    fdb SWAP,DECR
    fdb BRANCH,-24
    fdb TWODROP
    fdb EXIT

    defword "WORDS",5,0,"WORDS"
    fdb LATEST,FETCH
    fdb QDUP  ; BEGIN
    fdb ZBRANCH,14
    fdb DUP,IDDOT
    fdb SPACE
    fdb FETCH
    fdb BRANCH,-16
    fdb CR
    fdb EXIT

    defword "CFA>",4,0,"CFAT"
    fdb LATEST,FETCH
    fdb QDUP  ; BEGIN
    fdb ZBRANCH,22
    fdb TWODUP,SWAP
    fdb LT
    fdb ZBRANCH,6
    fdb NIP,EXIT
    fdb FETCH  ; THEN
    fdb BRANCH,-24
    fdb DROP,LIT,0
    fdb EXIT

    defcode "h#",2,0,"HEXNUM"
    ldy #16
    sty var_BASE
    NEXT

    defcode "d#",2,0,"DECNUM"
    ldy #10
    sty var_BASE
    NEXT

    defword "DUMPLINE",8,0,"DUMPLINE"
    fdb LIT,8
    fdb DUP,ZGT  ; BEGIN
    fdb ZBRANCH,42
    fdb SWAP,DUP,FETCH,DOT,INCR2,SWAP,DECR,SPACE
    fdb DUP,LIT,4,EQU
    fdb ZBRANCH,10
    fdb LIT,'|',EMIT,SPACE
    fdb BRANCH,-46
    fdb DROP,CR
    fdb EXIT

    defword "DUMPLINES",9,0,"DUMPLINES"
    fdb DUP,ZGT
    fdb ZBRANCH,14
    fdb SWAP,DUMPLINE,SWAP,DECR
    fdb BRANCH,-18
    fdb DROP
    fdb EXIT

    defword "C,",2,0,"CCOMMA"
    fdb HERE,FETCH,STOREBYTE
    fdb LIT,1,HERE,ADDSTORE
    fdb EXIT

    defword "[COMPILE]",9,F_IMMED,"BRACCOMP"
    fdb WORD,FIND,TCFA,COMMA
    fdb EXIT

    defword "CONSTANT",8,0,"CONSTANT"
    fdb WORD,CREATE
    fdb __DOCOL,COMMA
    fdb TICK,LIT,COMMA
    fdb COMMA
    fdb TICK,EXIT,COMMA
    fdb EXIT

    defword "ALLOT",5,0,"ALLOT"
    fdb HERE,FETCH,SWAP
    fdb HERE,ADDSTORE
    fdb EXIT

    defcode "CELLS",5,0,"CELLS"
    lsl 1,U
    rol 0,U
    NEXT

    defword "VARIABLE",8,0,"VARIABLE"
    fdb LIT,1,CELLS,ALLOT
    fdb WORD,CREATE
    fdb __DOCOL,COMMA
    fdb TICK,LIT,COMMA
    fdb COMMA
    fdb TICK,EXIT,COMMA
    fdb EXIT

    defconst "RAM1",4,0,"RAM1",$0000
    defconst "RAM2",4,0,"RAM2",$2000
    defconst "RAM3",4,0,"RAM3",$4000
    defconst "RAM4",4,0,"RAM4",$6000
    defconst "ROM1",4,0,"ROM1",$8000
    defconst "ROM2",4,0,"ROM2",$A000
    defconst "U28",3,0,"U28",$B000
    defconst "U29",3,0,"U29",$C000
    defconst "U30",3,0,"U30",$D000
    defconst "W13",3,0,"W13",$E000
    defconst "OUTS0",5,0,"OUTS0",$E8E0
    defconst "OUTS1",5,0,"OUTS1",$E8E8
    defconst "PROOFS0",7,0,"PROOFS0",$E8F0
    defconst "PROOFS1",7,0,"PROOFS1",$E8F8
    defconst "IRIG",4,0,"IRIG",$E900
    defconst "HOLD",4,0,"HOLD",$EA00
    defconst "FPI",3,0,"FPI",$EB00
    defconst "CASS",4,0,"CASS",$ED00
    defconst "PRNT",4,0,"PRNT",$ED04
    defconst "FDME",4,0,"FDME",$EE00
    defconst "INTC",4,0,"INTC",$EF00
    defconst "U27",3,0,"U27",$F000

    defcode "X",1,0,"X"

    DATA
initial_HERE
    fcb 0
    CODE

; == Vectors ==
    org $fff0
    fdb entry
    fdb entry
    fdb entry
    fdb entry
    fdb entry
    fdb entry
    fdb entry
    fdb entry