;; Register allocations:
    ;; A - scratch
    ;; X - data stack, base address: stack
    ;; Y - scratch
    ;; S - return stack pointer, base address $0100
    ;;
    ;; Token pointer structure (grows downwards from ttab+ttab_size)
    ;; bit 0-12: address to word
    ;; bit 13: reserved
    ;; bit 14: immediate flag
    ;; bit 15: threaded flag (0 = native, 1 = token threaded)
    ;;
    ;; Word structure contains only the name, immediately before the code.
    ;; First byte of name has bit 7 set, to indicate start of string.

    ;; Joystick:
    ;; : JOY 7F 9122 C! 911F @ FF 9122 C! ;
    ;; : UP? 4 AND 0= ;
    ;; : DOWN? 8 AND 0= ;
    ;; : LEFT? 10 AND 0= ;
    ;; : RIGHT? 8000 AND 0= ;
    ;; : FIRE? 20 AND 0= ;

    ;; Bytes (in hex) used per configuration
    ;;
    ;;              threaded    native      names
    ;; minimal           3ec       269        18c
    ;; turnkey+words     447       26c        19c
    INC_BLOCK_EDITOR    = 0             ; include block editor?
    INC_TURNKEY         = 1             ; include TURNKEY?
    INC_WORDS           = 1             ; include INFO + WORDS?

    state_interpret     = $00
    state_compile       = $ff

    ;; Zero page variables in space used for BASIC numeric functions
    last                = $57           ; byte: last entry in token table
    here                = $58           ; word: HERE, top of heap
    w                   = $5a           ; word: address of current word
    rp                  = $5c           ; byte: return stack index
    ip                  = $5e           ; word: address of next token
    tmp                 = $60           ; 4 bytes: temporary space

    !address hwstack    = $0100         ; page of hardware stack
    !address stack      = $0100         ; page of data stack
    !address rstack     = $0100         ; page of return stack
    !address ttab       = $1000         ; token table
    ttab_half           = $100          ; half size of token table, must be
                                        ; power of 2 or change the !align
    ttab_size           = ttab_half*2

    initial_sp          = $c0           ; initial value of data stack pointer
    initial_rp          = $60           ; initial value of return stack pointer

    flag_threaded       = $80
    flag_immediate      = $40
    flag_native         = 0

    !to "vicforth.prg", cbm

    * = $1001
start:  
    !word basic_end, 2026
    !byte $9e, $20
    !byte '0' + entry % 10000 / 1000
    !byte '0' + entry %  1000 /  100
    !byte '0' + entry %   100 /   10
    !byte '0' + entry %    10
    !byte $00       ; end of line
basic_end:
    !byte $00, $00  ; end of basic


    !macro counted_string .value {
        !byte (.end - .start)
.start:
        !text .value
.end:
    }

    !macro incw .address {
    inc .address
    bne +
    inc .address+1
+
    }

    !macro adcw .address {
    adc .address
    sta .address
    bcc +
    inc .address+1
+
    }

    !macro decw .address {
    lda .address
    sec
    sbc #1
    sta .address
    bcs +
    dec .address+1
+
    }

    !macro branch .address {
    .offset = .address - (* + 2)
    !byte t_branch, .offset
    }

    !macro branch_if_not .address {
    .offset = .address - (* + 2)
    !byte t_qnbranch, .offset
    }

    !macro branch_if .address {
    .offset = .address - (* + 2)
    !byte t_qbranch, .offset
    }

    !set asm_token = ttab_half
    !set word_address = 0
    !macro word_header .firstletter, .restofname, .flags, ~.token_label {
.name_start:
        !byte .firstletter | $80
        !text .restofname
.name_end:
        !set asm_token = asm_token-1
        .token_label = asm_token
        !set word_address = *
        * = ttab+asm_token, overlay
        !byte <word_address
        * = ttab+ttab_half+asm_token, overlay
        !byte .flags | (>word_address)
        * = word_address, overlay
    }

    !macro litw .x {
    !byte t_lit
    !word .x
    }

    !macro lit .x {
    !if .x >= 0 and .x <= 255 {
    !byte t_litc, .x
    } else {
    !byte t_lit
    !word .x
    }
    }

    !macro print .text {
    !byte t_dott
    !byte .text_end-.text_start
.text_start:
    !text .text
.text_end:
    }

    !align (ttab_size-1), 0, 0

    ;; Part 1 -- non-relocatable native code

geta:                       ; get A from token stream
    ldy #0
    lda (ip), y
    +incw ip
    rts

dropzeq:
    lda stack, x
    inx
    inx
    ora+2 stack-1, x
    rts

pusha:
    dex
    dex
    sta stack, x
    lda #0
    sta stack+1, x
    rts

    +word_header '?', "NBR", flag_native, ~t_qnbranch
qnbranch:
    jsr dropzeq
    beq branch              ; branch taken? perform jump
    bne geta                ; otherwise read and ignore offset

    +word_header '?', "BR", flag_native, ~t_qbranch
qbranch:
    jsr dropzeq
    bne branch              ; branch taken? perform jump
    beq geta                ; otherwise read and ignore offset

    +word_header 'B', "R", flag_native, ~t_branch
branch:
    !zone {
    jsr geta
    pha
    clc
    adc ip
    sta ip
    pla
    bmi .back
    bcc .done
    inc ip+1
.done:
    rts
.back:
    bcs .done
    dec ip+1
    rts
    }

aluop:                      ; A = opcode of OP absolute, x
    !zone {
    sta .op1
    sta .op2
    lda stack+2, x
.op1:
    adc stack, x
    sta stack+2, x
    lda stack+3, x
.op2:
    adc stack+1, x
    sta stack+3, x
    inx
    inx
    rts
    }

    +word_header '+', "", flag_native, ~t_plus
plus:
    clc
    lda #$7d
    bne aluop

    +word_header '-', "", flag_native, ~t_minus
minus:
    sec
    lda #$fd
    bne aluop

    +word_header 'A', "ND", flag_native, ~t_and
land:    
    lda #$3d
    bne aluop

    +word_header 'O', "R", flag_native, ~t_or
lor:
    lda #$1d
    bne aluop

    +word_header 'X', "OR", flag_native, ~t_xor
lxor:
    lda #$5d
    bne aluop

    +word_header '<', "<", flag_native, ~t_shift_left
shift_left:
    !zone {
    lda stack, x
    and #$0f
    beq .done
    tay                     ; Y = bits left to shift
    lda stack+2, x          ; A = low byte of value
.next_bit:
    asl
    rol stack+3, x          ; stack+3 = high byte of value
    dey
    bne .next_bit
    sta stack+2, x          ; write back cached low byte
.done:
    inx
    inx
    rts
    }

    +word_header '>', ">", flag_native, ~t_shift_right
shift_right:
    !zone {
    lda stack, x
    and #$0f
    beq .done
    tay                     ; Y = bits left to shift
    lda stack+2, x          ; A = low byte of value
.next_bit:
    lsr stack+3, x          ; stack+3 = high byte of value
    ror
    dey
    bne .next_bit
    sta stack+2, x          ; write back cached low byte
.done:
    inx
    inx
    rts
    }

    +word_header '0', "<>", flag_native, ~t_0neq
zeroneq:
    lda stack+1, x
    ora stack, x
    beq +
    lda #$ff
+   sta stack+1, x
    sta stack, x
    rts

    +word_header '0', "=", flag_threaded, ~t_0eq
    !byte t_0neq, t_not, t_exit

    +word_header 'N', "OT", flag_threaded, ~t_not
    !byte t_lit, $ff, $ff, t_xor, t_exit

    +word_header '=', "", flag_threaded, ~t_eq
    !byte t_minus, t_0eq, t_exit

    +word_header '<', ">", flag_threaded, ~t_neq
    !byte t_minus, t_0neq, t_exit

    +word_header 'D', "ROP", flag_native, ~t_drop
drop:
    inx
    inx
    rts

    +word_header '?', "DUP", flag_native, ~t_qdup
qdup:
    lda stack+1, x
    ora stack, x
    bne dup
    rts

    +word_header 'D', "UP", flag_native, ~t_dup
dup:
    !zone {
    jsr +
    ;; lda stack+1, x
    ;; dex
    ;; sta stack, x
+   lda stack+1, x
    dex
    sta stack, x
    rts
    }

    +word_header 'O', "VER", flag_native, ~t_over
over:
    !zone {
    jsr +
    ;; lda stack+3, x
    ;; dex
    ;; sta stack, x
+   lda stack+3, x
    dex
    sta stack, x
    rts
    }

    ;; TODO: consider : SWAP >R TMP ! R> TMP @ ;
    +word_header 'S', "WAP", flag_native, ~t_swap
swap:
    lda stack+3, x
    pha
    lda stack+2, x
    pha
    lda stack+1, x
    sta stack+3, x
    lda stack, x
    sta stack+2, x
    pla
    sta stack, x
    pla
    sta stack+1, x
    rts

    +word_header 'N', "IP", flag_threaded, ~t_nip
    !byte t_swap, t_drop, t_exit

tos_to_tmp:
    lda stack+1, x
    sta tmp+1
    lda stack, x
    sta tmp
    rts

fetch_common:
    jsr tos_to_tmp
    ldy #0
    lda (tmp), y
    sta stack, x
    rts

store_common:
    jsr tos_to_tmp
    inx
    inx
    ldy #0
    lda stack, x
    sta (tmp), y
    inx
    rts

    +word_header '@', "", flag_native, ~t_fetch
fetch:
    jsr fetch_common
    iny
    lda (tmp), y
    sta stack+1, x
    rts

    +word_header 'C', "@", flag_native, ~t_cfetch
cfetch:
    jsr fetch_common
    tya
    sta stack+1, x
    rts

    +word_header '!', "", flag_native, ~t_store
store:
    jsr store_common
    iny
    lda stack, x
    sta (tmp), y
    inx
    rts

    +word_header 'C', "!", flag_native, ~t_cstore
cstore:
    jsr store_common
    inx
    rts

    ;; +! ( X ADR -- )
    +word_header '+', "!", flag_threaded, ~t_plusstore
    !byte t_swap, t_over, t_fetch, t_plus, t_swap, t_store, t_exit

    +word_header 'E', "MIT", flag_native, ~t_emit
emit:
    lda stack, x
    inx
    inx
    jmp $ffd2

    +word_header 'E', "XIT", flag_native, ~t_exit
exit:
    ldy rp
    lda rstack, y
    sta ip
    iny
    lda rstack, y
    sta ip+1
    iny
    sty rp
    rts

    +word_header 'K', "EY", flag_native, ~t_key
key:
    !zone {
    stx tmp
-   jsr $ffe4
    cmp #0
    beq -
    ldx tmp
    jmp pusha
    }

    +word_header 'L', "ITC", flag_native, ~t_litc
litc:
    jsr geta
    jmp pusha

    +word_header 'L', "IT", flag_native, ~t_lit
lit:
    dex
    dex
    jsr geta
    sta stack, x
    jsr geta
    sta stack+1, x
    rts

    +word_header 'C', "ODE", flag_native, ~t_code
code:
    lda #>(exit-1)           ; set up return address
    pha
    lda #<(exit-1)
    pha

    jmp (ip)

enter:
    jsr puship
thread:
    pla
    clc
    adc #1
    sta ip
    pla
    adc #0
    sta ip+1
    jmp next

    ;; .NIB ( X BITS -- X )
    +word_header '.', "NIB", flag_threaded, ~t_dotnib
    !zone {
    !byte t_over, t_swap, t_shift_right, t_litc, $0f, t_and, t_lit
    !word hextable
    !byte t_plus, t_cfetch, t_emit, t_exit
    }

    +word_header '.', "H", flag_threaded, ~t_doth
    !zone {
    +litw $fff0
    !byte t_over, t_and
    +branch_if_not .one
    +litw $ff00
    !byte t_over, t_and
    +branch_if_not .two
    +litw $f000
    !byte t_over, t_and
    +branch_if_not .three
    !byte t_litc, 12, t_dotnib
.three:
    !byte t_litc, 8, t_dotnib
.two:
    !byte t_litc, 4, t_dotnib
.one:
    !byte t_litc, 0, t_dotnib
    !byte t_drop, t_exit
    }
    
;;     +word_header '.', "H", flag_threaded, ~t_doth
;; doth:
;;     !zone {
;;     !byte t_litc, 4
;; .next_digit:
;;     !byte t_over, t_litc, 12, t_shift_right, t_litc, $0f, t_and
;;     !byte t_lit
;;     !word hextable
;;     !byte t_plus, t_cfetch, t_emit
;;     !byte t_1, t_minus
;;     !byte t_swap, t_litc, 4, t_shift_left, t_swap
;;     !byte t_qdup
;;     +branch_if .next_digit
;;     !byte t_drop, t_exit
;;     }

hextable:
    !text "0123456789ABCDEF"

    +word_header 'T', "OKEN-NAME?", flag_native, ~t_token_nameq
    ;; ( TOK -- T/F )
token_nameq:    
    !zone {
    lda stack, x
    tay
    lda ttab, y
    sec
    sbc wbuf_len
    sta tmp
    lda ttab+ttab_half, y
    sbc #0
    and #$1f                ; tmp = token table pointer - word length
    sta tmp+1               ;     = potential start of token name

    ldy #0
    lda (tmp), y
    bpl .not_equal          ; if bit 7 = 0, can't be first letter of name

    and #$7f
    cmp wbuf_data, y        ; compare to first byte of word
    bne .not_equal          ; mismatch means strings are different

    iny
    cpy wbuf_len            ; one-letter word and that letter matched?
    beq .equal              ; then strings are equal
.next:
    lda (tmp), y
    bmi .not_equal          ; if bit 7 = 1, can't be non-first letter of name

    cmp wbuf_data, y        ; mismatch, so not equal
    bne .not_equal

    iny
    cpy wbuf_len            ; end of string and everything matched?
    bne .next               ; no, try again
.equal:
    lda #$ff                ; yes, return true
    bne .done
.not_equal:
    lda #0
.done:
    sta stack, x
    sta stack+1, x
    rts
    }

    ;; TODO: strong candidate for high-level implementation, in practice
    ;; nearly all cases will return success so should not slow the compiler
    ;; down too much.
    ;; : WORD>H  WBUF DUP C@ >R 1+ 0 BEGIN OVER C@ C>H IF R> DROP DROP DROP 0 EXIT THEN
    ;;           SWAP 4 << + SWAP 1+ SWAP
    ;;           R> 1- DUP>R 0UNTIL R> DROP SWAP DROP ;
    ;; ca 34 bytes, vs 60 below -- replacing hexdigit with C>H shuold be about even
    ;; WORD>H ( -- X TRUE | -- 0 )
    +word_header 'W', "ORD>H", flag_native, ~t_wordtoh
wordtoh:
    lda #0
    dex
    sta stack, x
    dex
    sta stack, x
    ldy #0
.next_char:
    lda #4
    sta tmp
.shift:
    asl stack, x
    rol stack+1, x
    dec tmp
    bne .shift
    lda wbuf_data, y
    jsr hexdigit
    cmp #$ff
    beq .fail
    ora stack, x
    sta stack, x
    iny
    cpy wbuf_len
    bne .next_char
    lda #0
    dex
    dex
.fail:
    eor #$ff
    sta stack, x
    sta stack+1, x
    rts

    ; input: A = PETSCII hex digit
    ; output: A = 0-15 or $ff on error
hexdigit:
    !zone {
    cmp #'0'
    bcc .fail
    cmp #'9'+1
    bcs .maybe_alpha
    sbc #'0'-1
    rts
.maybe_alpha:
    cmp #'A'
    bcc .fail
    cmp #'F'+1
    bcs .fail
    sbc #'A'-10-1
    rts
.fail:
    lda #$ff
    rts
    }

    +word_header 'C', "OUNT", flag_threaded, ~t_count
    !byte t_dup, t_1plus, t_swap, t_cfetch, t_exit

    +word_header 'T', "YPE", flag_threaded, ~t_type
    !zone {
.next:
    !byte t_qdup
    +branch_if_not .done
    !byte t_swap, t_dup, t_cfetch, t_emit, t_1plus, t_swap
    !byte t_1minus
    +branch .next
.done:
    !byte t_drop, t_exit
    }

    +word_header 'L', "OOKUP", flag_native, ~t_lookup
    !zone {
    lda #$ff
    jsr pusha
.try_token:
    jsr dup
    jsr token_nameq
    lda stack, x
    beq .not_this_one
    inx
    inx
    rts
.not_this_one:
    inx
    inx
    lda stack, x
    cmp last
    beq .not_found
    dec stack, x
    bne .try_token
.not_found:
    lda #0
    sta stack, x
    sta stack+1, x
    rts
    }

    ;; The threaded version below works but is very slow
    
;;     ; LOOKUP ( -- TOK|0 )
;;     +word_header 'L', "OOKUP", flag_threaded, ~t_lookup
;; lookup:
;;     !zone {
;;     ; start from the first token
;;     !byte t_litc, $ff
;; .try_token:
;;     ; check whether the current token matches the word buffer
;;     !byte t_dup, t_token_nameq ; ( TOK T/F )
;;     +branch_if_not .not_this_one
;;     ; yes, return the token
;;     !byte t_exit
;; .not_this_one:
;;     ; no, and do we have tokens left to check?
;;     !byte t_dup, t_litc, last, t_cfetch, t_neq ; ( TOK T/F )
;;     +branch_if_not .not_found
;;     ; yes, decrease the token number and try that
;;     !byte t_1minus
;;     +branch .try_token
;; .not_found:
;;     !byte t_drop, t_litc, 0, t_exit
;;     }

    +word_header '.', "T", flag_native, ~t_dott
dott:
    !zone {
    ldy #0
    lda (ip), y
    sta tmp                 ; tmp = length of string
.next_char:
    iny
    lda (ip), y
    jsr $ffd2
    dec tmp
    bne .next_char
    tya
    sec
    adc ip
    sta ip
    bcc +
    inc ip+1
+   rts
    }

    +word_header '1', "+", flag_threaded, ~t_1plus
    !byte t_1, t_plus, t_exit

    +word_header '1', "-", flag_threaded, ~t_1minus
    !byte t_1, t_minus, t_exit

    +word_header 'R', "EAD-LINE", flag_native, ~t_read_line
    !zone {
    lda #0
    sta lbuf_len
.next_char:
    jsr $ffcf
    cmp #$0d
    beq .done
    ldy lbuf_len
    sta lbuf_data, y
    inc lbuf_len
    jmp .next_char
.done:
    rts
    }
    
    +word_header 'D', "OVAR", flag_native, ~t_dovar
    lda ip+1
    dex
    sta stack, x
    lda ip
    dex
    sta stack, x
    jmp exit

    +word_header 'D', "OCONST", flag_native, ~t_doconst
    jsr lit
    jmp exit

   +word_header 'I', "NADR", flag_threaded, ~t_inadr
    !byte t_dovar
    !word lbuf_data

    +word_header 'I', "NEND", flag_threaded, ~t_inend
    !byte t_dovar
    !word lbuf_data

    +word_header '0', "", flag_threaded, ~t_0
    !byte t_doconst
    !word 0

    +word_header '1', "", flag_threaded, ~t_1
    !byte t_doconst
    !word 1

    +word_header 'T', "RUE", flag_threaded, ~t_true
    !byte t_doconst
    !word $ffff

    +word_header 'C', "@+", flag_threaded, ~t_cfetchplus
    !byte t_dup, t_1plus, t_swap, t_cfetch, t_exit

    +word_header 'C', "!+", flag_threaded, ~t_cstoreplus
    !byte t_swap, t_over, t_cfetch, t_plus, t_swap, t_cstore, t_exit

    ;; CHAR ( -- C T | 0 )
    +word_header 'C', "HAR", flag_threaded, ~t_char
    !zone {
    !byte t_inadr, t_fetch, t_inend, t_fetch, t_over, t_eq
    ;; ( inadr end of buffer? )
    +branch_if .empty
    !byte t_cfetchplus, t_swap, t_inadr, t_store, t_true, t_exit
.empty:
    !byte t_drop, t_0, t_exit
    }

    +word_header 'W', "ORD", flag_threaded, ~t_word
    !byte t_doconst
    !word wbuf_len

    +word_header 'D', "UP>R", flag_native, ~t_duptor
duptor:
    ldy rp
    lda stack+1, x
    dey
    sta rstack, y
    lda stack, x
    dey
    sta rstack, y
    sty rp
    rts

    +word_header 'R', "@", flag_native, ~t_rfetch
rfetch: 
    ldy rp
    lda rstack+1, y
    dex
    sta stack, x
    lda rstack, y
    dex
    sta stack, x
    rts

    +word_header '>', "R", flag_native, ~t_tor
    jsr duptor
    inx
    inx
    rts

    +word_header 'R', ">", flag_native, ~t_rto
    jsr rfetch
    iny
    iny
    sty rp
    rts

    ;; CAPP ( C COUNTED-STRING -- )
    ;; append character at the end of the string
    +word_header 'C', "APP", flag_threaded, ~t_capp
    !byte t_duptor, t_dup, t_cfetch, t_plus, t_1plus, t_cstore
    !byte t_1, t_rto, t_cstoreplus, t_exit

    +word_header 'B', "LANK?", flag_threaded, ~t_blankq
    !byte t_dup, t_litc, $0d, t_eq, t_swap, t_litc, ' ', t_eq, t_or, t_exit

    +word_header 'C', "R", flag_threaded, ~t_cr
    !byte t_litc, $0d, t_emit, t_exit

    +word_header 'S', "PACE", flag_threaded, ~t_space
    !byte t_litc, ' ', t_emit, t_exit

    ;; READ ( -- T/F )
    +word_header 'R', "EAD", flag_threaded, ~t_read
    !zone {
    !byte t_0
    +litw wbuf_len
    !byte t_cstore
.wait_for_first:
    !byte t_char
    +branch_if_not .eof
    !byte t_dup, t_blankq
    +branch_if_not .found_nonblank
    !byte t_drop
    +branch .wait_for_first
.found_nonblank:
    +litw wbuf_len
    !byte t_capp
    !byte t_char
    +branch_if_not .eof
    !byte t_dup, t_blankq
    +branch_if_not .found_nonblank
.done:
    !byte t_drop, t_true, t_exit
.eof:
    +litw wbuf_len
    !byte t_cfetch, t_0, t_neq, t_exit
    }

    +word_header 'C', "OMPILE?", flag_threaded, ~t_compileq
    !byte t_dovar
    !word 0

    ;; EXECUTE ( TOKEN -- )
    +word_header 'E', "XECUTE", flag_native, ~t_execute
    lda stack, x
    tay
    inx
    inx
    pla
    pla
    jmp execute_y

    ;; Currently not used
    ;; >EOF ( -- )
    ;; +word_header '>', "EOF", flag_threaded, ~t_toeof
    ;; !byte t_inend, t_fetch, t_inadr, t_store, t_exit

    ;; TOK@ ( TOK -- X )
    +word_header 'T', "OK@", flag_native, ~t_tokfetch
    lda stack, x
    tay
    lda ttab, y
    sta stack, x
    lda ttab+ttab_half, y
    sta stack+1, x
    rts

    ;; HERE ( -- ADR )
    +word_header 'H', "ERE", flag_threaded, ~t_here
    !byte t_litc, here, t_exit

    ;; C, ( C -- )
    +word_header 'C', ",", flag_threaded, ~t_ccomma
    !byte t_here, t_fetch, t_cstore
    !byte t_1, t_here, t_plusstore, t_exit

    ;; , ( X -- )
    +word_header ',', "", flag_threaded, ~t_comma
    !byte t_bytes, t_swap, t_ccomma, t_ccomma, t_exit
    ;;!byte t_here, t_fetch, t_store
    ;;!byte t_litc, 2, t_here, t_plusstore, t_exit

    ;; IF
    +word_header 'I', "F", flag_threaded|flag_immediate, ~t_if
    !byte t_litc, t_qnbranch, t_comma, t_here, t_fetch, t_exit

    ;; THEN
    +word_header 'T', "HEN", flag_threaded|flag_immediate, ~t_then
then:   
    !byte t_here, t_fetch, t_over, t_minus, t_swap, t_1minus, t_cstore, t_exit

    ;; ELSE
    +word_header 'E', "LSE", flag_threaded|flag_immediate, ~t_else
    !byte t_litc, t_branch, t_comma, t_here, t_fetch
    !byte t_swap
    +branch then

    ;; BEGIN
    +word_header 'B', "EGIN", flag_threaded|flag_immediate, ~t_begin
    !byte t_here, t_fetch, t_exit

    ;; AGAIN
    +word_header 'A', "GAIN", flag_threaded|flag_immediate, ~t_again
    !byte t_litc, t_branch, t_ccomma
    !byte t_here, t_fetch, t_1plus, t_minus, t_ccomma
    !byte t_exit

;;     ;; FOR
;;     +word_header 'F', "OR", flag_threaded|flag_immediate, ~t_for
;;     !byte t_litc, t_tor, t_ccomma, t_here, t_fetch, t_exit

;;     ;; NEXT
;;     +word_header 'N', "EXT", flag_threaded|flag_immediate, ~t_next
;;     !byte t_litc, t_donext, t_ccomma
;;     !byte t_here, f_fetch, t_1plus, t_swap, t_minus, t_ccomma
;;     !byte t_exit

;;     +word_header 'D', "ONEXT", flag_native, ~t_donext
;;     !zone {
;;     ldy rp
;;     +decw rstack+2, y
;;     ora rstack+3, y
;;     beq .done
;;     jsr geta
;;     sta tmp
;;     sec
;;     lda rstack, y
;;     sbc tmp
;;     sta rstack, y
;;     lda rstack+1, y
;;     sbc #0
;;     sta rstack+1, y
;;     rts
;; .done:
;;     lda rstack, y
;;     sta rstack+2, y
;;     lda rstack+1, y
;;     sta rstack+3, y
;;     iny
;;     iny
;;     sta rp
;;     jsr geta
;;     rts
;;     }

    ;; CREATE
    +word_header 'C', "REATE", flag_threaded, ~t_create
    !zone {
    !byte t_read
    +branch_if_not .eof
    !byte t_word, t_count
    !byte t_over, t_cfetch, t_litc, $80, t_or, t_ccomma
.copy_next:
    !byte t_1minus, t_qdup
    +branch_if_not .done
    !byte t_swap, t_1plus, t_swap
    !byte t_over, t_cfetch, t_ccomma
    +branch .copy_next
.eof:
    !byte t_exit ;; TODO: error message?
.done:
    !byte t_drop, t_code
    dec last
    ldy last
    lda here
    sta ttab, y
    lda here+1
    ora #$80
    sta ttab+ttab_half, y
    rts
    }

    ;; :
    +word_header ':', "", flag_threaded, ~t_colon
    !byte t_create, t_true, t_compileq, t_store, t_exit

    ;; ;
    +word_header ';', "", flag_threaded | flag_immediate, ~t_semicolon
    !byte t_0, t_compileq, t_store, t_litc, t_exit, t_ccomma, t_exit

    ;; VAR
    +word_header 'V', "AR", flag_threaded | flag_immediate, ~t_var
    !byte t_create, t_litc, t_dovar, t_ccomma, t_0, t_comma, t_exit
    
    +word_header 'S', "P@", flag_native, ~t_spfetch
    txa
    dex
    dex
    sta stack, x
    lda #0
    sta stack+1, x
    rts

    +word_header 'H', "P@", flag_native, ~t_hpfetch
    stx tmp
    tsx
    txa
    ldx tmp
    dex
    dex
    sta stack, x
    lda #0
    sta stack+1, x
    rts

    +word_header 'R', "P@", flag_threaded, ~t_rpfetch
    +lit rp
    !byte t_cfetch, t_1plus, t_1plus, t_exit

    ;; INTERPRET ( FROM-ADR TO-ADR -- )
    +word_header 'I', "NTERPRET", flag_threaded, ~t_interpret
    !zone {
    !byte t_inadr, t_fetch, t_tor, t_inend, t_fetch, t_tor
    !byte t_inend, t_store, t_inadr, t_store
.read:
    !byte t_read
    +branch_if_not .done
    !byte t_lookup, t_qdup
    +branch_if_not .not_found
    !byte t_compileq, t_fetch
    +branch_if .compile_unless_immediate
.interpret:
    !byte t_execute
    +branch .read
.compile_unless_immediate:
    !byte t_dup, t_tokfetch
    +lit $4000
    !byte t_and
    +branch_if .interpret
.compile:
    !byte t_ccomma
    +branch .read
.not_found:
    !byte t_wordtoh
    +branch_if_not .unknown
    !byte t_compileq, t_fetch
    +branch_if_not .read    ; if interpreting, just leave number on stack
.compile_literal: ;; TODO: special case for t_litc
    !byte t_litc, t_lit, t_ccomma, t_comma
    +branch .read
.unknown:
    !byte t_word, t_count, t_type, t_litc, '?', t_emit
.done:
    !byte t_rto, t_inend, t_store, t_rto, t_inadr, t_store, t_exit
    }

    +word_header 'T', "OP", flag_threaded, ~t_top
    !byte t_doconst
    !word mem_top

    +word_header 'R', "EPL", flag_threaded, ~t_repl
    !zone {
    !byte t_litc, 8, t_lit, $0f, $90, t_cstore
    !byte t_dott, .welcome_end-.welcome
.welcome:
    !byte $93, $05
    !text "ROBERT'S FORTH\r2026-02-27\r\r"
.welcome_end:
!if INC_BLOCK_EDITOR {
    !byte t_lit, 0, $1d, t_lit, 0, 1, t_litc, $20, t_cfill
}
repl:
    !byte t_quiet, t_fetch
    +branch_if .re
    +print " OK  "
    !byte t_spfetch, t_doth, t_space, t_rpfetch, t_doth, t_space, t_hpfetch, t_doth
    !byte t_space, t_top, t_here, t_fetch, t_minus, t_doth, t_cr
.re:
    !byte t_0, t_quiet, t_store
    !byte t_read_line, t_cr
    +litw lbuf_len
    !byte t_count, t_over, t_plus, t_interpret
    +branch repl
    }

    +word_header 'H', "ALT", flag_threaded, ~t_halt
halt:
    +print "HALT"
    !byte t_key
    +branch repl

    ;; CUR! ( ROW COL -- )
    +word_header 'C', "UR!", flag_threaded, ~t_curstore
    !byte t_tor, t_tor, t_0, t_0, t_rto, t_rto, t_lit, $f0, $ff, t_kernal
    !byte t_drop, t_drop, t_drop, t_drop, t_exit

    ;; KERNAL ( C A X Y ADR -- A X Y C )
    +word_header 'K', "ERNAL", flag_native, ~t_kernal
    lda stack, x
    sta .call+1
    lda stack+1, x
    sta .call+2
    txa
    pha
    lda stack+6, x
    pha
    lda stack+2, x
    tay
    lda stack+8, x
    cmp #1
    lda stack+4, x
    tax
    pla
.call:
    jsr $ff00
    stx tmp
    sta tmp+1
    pla
    tax
    inx
    inx
    lda #0
    sta stack+1, x
    sta stack+3, x
    sta stack+5, x
    sta stack+7, x
    adc #0
    sta stack, x
    lda tmp
    sta stack+4, x
    lda tmp+1
    sta stack+6, x
    tya
    sta stack+2, x
    rts

    +word_header 'D', "EVICE", flag_threaded, ~t_device
    !byte t_dovar
device: 
    !word 8

    ;; BYTES ( X -- XLOW XHIGH )
    +word_header 'B', "YTES", flag_threaded, ~t_bytes
    !byte t_dup, t_litc, $ff, t_and, t_swap, t_litc, 8, t_shift_right, t_exit
    
    ;; SAVE ( START END -- ERRCODE ERROR? )
    ;; Assumes DEVICE is set.
    ;; Will use secondary device 1, logical file 15.
    +word_header 'S', "AVE", flag_threaded, ~t_save
    !zone {
    !byte t_read            ; read name to wbuf
    +branch_if_not .error
    !byte t_0, t_litc, 15, t_device, t_cfetch, t_1
    !byte t_lit
    !word $ffba             ; SETLFS 15, DEVICE, 1
    !byte t_kernal
    !byte t_drop, t_drop, t_drop, t_drop
    !byte t_0, t_word, t_count, t_swap, t_bytes
    !byte t_lit
    !word $ffbd             ; SETNAM
    !byte t_kernal
    !byte t_drop, t_drop, t_drop, t_drop
    ;; Save START to tmp+2, split END into bytes
    !byte t_swap, t_litc, tmp+2, t_store
    !byte t_0, t_swap
    !byte t_litc, tmp+2, t_swap, t_bytes
    !byte t_lit
    !word $ffd8
    !byte t_kernal, t_nip, t_nip
    +branch_if_not .done
    +print "SAVE ERR#"
    !byte t_doth, t_exit
.done:
    !byte t_drop, t_exit
.error:
    +print "SAVE WHAT?"
    !byte t_halt
    }

    +word_header 'L', "AST", flag_threaded, ~t_last
    !byte t_litc, last, t_exit

!if INC_TURNKEY {
    ;; TURNKEY ( TOKEN -- ERRCODE ERROR? )
    ;; Example:
    ;;   ' START-OF-PROGRAM TURNKEY FILENAME
    ;; Alternatively, to leave start unchanged:
    ;;   0 TURNKEY FILENAME
    +word_header 'T', "URNKEY", flag_native, ~t_turnkey
    !zone {
    lda here
    sta init_here_low
    lda here+1
    sta init_here_high
    lda last
    sta init_last
    lda stack, x
    beq .default_word
    sta init_tok
.default_word:
    pla
    pla
    jsr enter
    !byte t_drop
    !byte t_lit
    !word start
    !byte t_here, t_fetch, t_save
    !byte t_exit
    }
}
    
    +word_header '>', "NAME", flag_threaded, ~t_to_name
    !zone {
.try_next:
    !byte t_1minus, t_dup, t_cfetch, t_litc, $80, t_and
    +branch_if_not .try_next
    !byte t_exit
    }

    ;; ' ( -- TOK )
    +word_header '\'', "", flag_threaded, ~t_tick
    !zone {
    !byte t_read
    +branch_if_not .error ;; TODO: different error handling
    !byte t_lookup, t_qdup
    +branch_if_not .error
    !byte t_exit
.error:
    !byte t_word, t_count, t_type, t_litc, '?', t_emit, t_exit
    }

    ;; TOK>A ( TOK -- A )
    +word_header 'T', "OK>A", flag_threaded, ~t_tok_to_a
    !byte t_tokfetch
    +litw $1fff
    !byte t_and, t_exit

    ;; FORGET ( -- )
    +word_header 'F', "ORGET", flag_threaded, ~t_forget
    !byte t_tick, t_dup, t_1plus, t_last, t_cstore
    !byte t_tok_to_a, t_to_name, t_here, t_store, t_exit

    +word_header '.', "\"", flag_threaded|flag_immediate, ~t_dotquote
    !byte t_litc, t_dott, t_ccomma, t_readquote, t_exit

    +word_header 'R', "EAD\"", flag_threaded, ~t_readquote
    !zone {
    !byte t_here, t_fetch, t_0, t_ccomma
.next_char:
    !byte t_char
    +branch_if_not .eof
    !byte t_dup, t_litc, '\"', t_eq
    +branch_if .done
    !byte t_ccomma
    +branch .next_char
.done:
    !byte t_drop, t_here, t_fetch, t_over, t_1plus, t_minus
    !byte t_swap, t_cstore, t_exit
.eof:
    !byte t_halt ;; TODO: more general error handling
    }

!if INC_WORDS {
    ;; INFO ( TOK -- )
    +word_header 'I', "NFO", flag_threaded, ~t_info
    !zone {
    !byte t_dup, t_tokfetch, t_lit, $00, $40, t_and
    +branch_if_not .not_immediate
    !byte t_litc, $9e, t_emit
.not_immediate:
    !byte t_tok_to_a, t_dup, t_to_name
.next_char:
    !byte t_dup, t_cfetch, t_litc, $7f, t_and, t_emit
    !byte t_1plus, t_over, t_over, t_eq
    +branch_if_not .next_char
    !byte t_litc, $05, t_emit
    !byte t_drop, t_drop, t_exit
    }

    +word_header 'W', "ORDS", flag_threaded, ~t_words
    !zone {
    !byte t_last, t_cfetch
.next_word:
    +lit ttab_half
    !byte t_over, t_eq
    +branch_if .done
    !byte t_dup, t_info, t_space, t_1plus
    !byte t_dup, t_last, t_cfetch, t_minus, t_litc, $1f, t_and
    +branch_if .next_word
    !byte t_key, t_drop
    +branch .next_word
.done:
    !byte t_drop, t_exit
    }
}
    
    ;; VARIABLE QUIET
    +word_header 'Q', "UIET", flag_threaded, ~t_quiet
    !byte t_dovar
    !word 0

!if INC_BLOCK_EDITOR {
    ;; CFILL ( ADR N C -- )
    +word_header 'C', "FILL", flag_threaded, ~t_cfill
    !zone {
    !byte t_tor
.next:
    !byte t_qdup
    +branch_if_not .done
    !byte t_over, t_rfetch, t_swap, t_cstore
    !byte t_swap, t_1plus, t_swap, t_1minus
    +branch .next
.done:
    !byte t_drop, t_rto, t_drop, t_exit
    }

    ;; EMITS ( C N -- )
    +word_header 'E', "MITS", flag_threaded, ~t_emits
    !zone {
.next:
    !byte t_qdup
    +branch_if_not .done
    !byte t_over, t_emit, t_1minus
    +branch .next
.done:
    !byte t_drop, t_exit
    }

    +word_header 'B', "BUF", flag_threaded, ~t_bbuf
    !byte t_doconst
    !word $1d00

    +word_header 'B', "LOCK", flag_threaded, ~t_block
    !byte t_dovar
    !word 0

    ;; CLB ( -- )
    ;; clear block contents
    +word_header 'C', "LB", flag_threaded, ~t_clb
    !byte t_true, t_blkmod, t_store
    !byte t_bbuf, t_lit, 0, 1, t_litc, $20, t_cfill, t_exit

    ;; >LINE ( LINENO -- ADR )
    +word_header '>', "LINE", flag_threaded, ~t_toline
    !byte t_litc, 4, t_shift_left, t_bbuf, t_plus, t_exit

    ;; LL ( LINENO -- )
    ;; list block source line
    +word_header 'L', "L", flag_threaded, ~t_ll
    !byte t_dup, t_doth, t_space, t_litc, 'O', t_emit, t_space
    !byte t_toline, t_litc, $10, t_type, t_cr, t_exit

    +word_header 'L', "", flag_threaded, ~t_l
    !zone {
    !byte t_0
.list_line:
    !byte t_dup, t_ll, t_1plus, t_dup, t_litc, $10, t_eq
    +branch_if_not .list_line
    !byte t_drop, t_exit
    }

    ;; <MOVE ( SRC TRG N -- )
    +word_header '<', "MOVE", flag_threaded, ~t_leftmove
    !zone {
    !byte t_tor
.next:
    !byte t_rfetch
    +branch_if_not .done
    !byte t_over, t_cfetch, t_over, t_cstore
    !byte t_swap, t_1plus, t_swap, t_1plus
    !byte t_rto, t_1minus, t_tor
    +branch .next
.done:
    !byte t_rto, t_drop, t_drop, t_drop, t_exit
    }

    ;; >MOVE ( SRC TRG N -- )
    +word_header '>', "MOVE", flag_threaded, ~t_rightmove
    !zone {
    !byte t_tor
    !byte t_rfetch, t_plus, t_swap, t_rfetch, t_plus, t_swap
.next:
    !byte t_rfetch
    +branch_if_not .done
    !byte t_swap, t_1minus, t_swap, t_1minus
    !byte t_over, t_cfetch, t_over, t_cstore
    !byte t_rto, t_1minus, t_tor
    +branch .next
.done:
    !byte t_rto, t_drop, t_drop, t_drop, t_exit
    }

    ;; VARIABLE BLK#
    ;; current block number
    +word_header 'B', "LK#", flag_threaded, ~t_blknr
    !byte t_dovar
    !word $ffff
    
    ;; VARIABLE BLKMOD
    ;; is the current block modified?
    +word_header 'B', "LKMOD", flag_threaded, ~t_blkmod
    !byte t_dovar
    !word 0

    ;; BLK>TB ( N -- TRACK DISK-BLOCK )
    ;; convert logital block number to track/disk block
    +word_header 'B', "LK>TB", flag_threaded, ~t_blktotb
    !byte t_dup, t_litc, 4, t_shift_right, t_1plus, t_swap, t_litc, $0f, t_and, t_exit

    ;; FLUSH ( -- )
    +word_header 'F', "LUSH", flag_threaded, ~t_flush
    !byte t_blknr, t_fetch, t_dup, t_1plus
    +branch_if_not .no_block
    !byte t_blkmod, t_fetch
    +branch_if_not .no_mod
    !byte t_bbuf, t_swap, t_blktotb, t_wblk, t_drop
    !byte t_0, t_blkmod, t_store, t_exit
.no_mod:
.no_block:
    !byte t_drop, t_exit

    ;; BLK ( N -- )
    ;; load the given block, save buffered one if needed
    +word_header 'B', "LK", flag_threaded, ~t_blk
    !byte t_blknr, t_fetch, t_over, t_eq
    +branch_if .already_loaded
    !byte t_flush
    !byte t_dup, t_blknr, t_store
    !byte t_bbuf, t_swap, t_blktotb, t_rblk
    ;; !byte t_exit
.already_loaded:
    !byte t_drop, t_exit

    ;; RB ( N -- )
    +word_header 'R', "B", flag_threaded, ~t_rb
    !byte t_blk, t_r, t_exit
    
    ;; BLOCKS ( -- )
    ;; initialize block system
    +word_header 'B', "LOCKS", flag_threaded, ~t_blocks
    !byte t_bbuf, t_0, t_blktotb, t_rblk
    !byte t_0, t_blkmod, t_store
    !byte t_0, t_blknr, t_store, t_exit
    
    ;; RL ( LINENO -- )
    +word_header 'R', "L", flag_threaded, ~t_rl
    !byte t_dup, t_toline, t_swap, t_1plus, t_toline, t_interpret, t_exit

    ;; R ( -- )
    ;; interpret the current block line by line
    +word_header 'R', "", flag_threaded, ~t_r
    !byte t_0, t_tor
.run_line:
    !byte t_rfetch, t_rl
    !byte t_rto, t_1plus, t_dup, t_tor, t_litc, $10, t_eq
    +branch_if_not .run_line
    !byte t_rto, t_drop, t_exit

    ;; O ( LINENO -- )
    +word_header 'O', "", flag_threaded, ~t_o
    !zone {
    !byte t_true, t_blkmod, t_store
    !byte t_toline
.next:
    !byte t_char
    +branch_if_not .eof
    !byte t_dup, t_litc, $0d, t_eq
    +branch_if .done
    !byte t_over, t_cstore, t_1plus
    !byte t_dup, t_litc, $0f, t_and
    +branch_if .next
.overflow:
    !byte t_drop, t_char
    +branch_if_not .terminate
    !byte t_litc, $0d, t_eq
    +branch_if .terminate
.overflow_done:
    !byte t_litc, 21, t_0, t_curstore
    +print "TOO LONG"
    !byte t_exit
.done:
.eof:
    ;; fill rest of line with spaces
    !byte t_dup, t_litc, $10, t_plus, t_lit, $f0, $ff, t_and, t_over, t_minus, t_litc, $20, t_cfill
    ;; omit the "OK" and other messages
.terminate:
    !byte t_true, t_quiet, t_store
    !byte t_exit
    }

    ;; DUMP ( ADR N -- )
    +word_header 'D', "UMP", flag_threaded, ~t_dump
    !zone {
.next:
    !byte t_qdup
    +branch_if_not .done
    !byte t_over, t_cfetch, t_doth, t_space
    !byte t_swap, t_1plus, t_swap, t_1minus
    +branch .next
.done:
    !byte t_drop, t_exit
    }

    ;; Used for testing byte_to_dec
    ;; +word_header '>', "DEC", flag_native, ~t_todec
    ;; lda stack, x
    ;; jsr byte_to_dec
    ;; dex
    ;; dex
    ;; sta stack, x
    ;; tya
    ;; sta stack+2, x
    ;; rts

byte_to_dec:
    ;; A = value 0-99
    ;; returns:
    ;; Y = ASCII of most significant decimal digit
    ;; A = ASCII of least significant decimal digit
    ldy #'0'-1
-   iny
    sec
    sbc #10
    bcs -
    adc #'0'+10
    rts

    ;; WBLK ( ADR TRACK SECTOR -- ERR|0 )
    +word_header 'W', "BLK", flag_native, ~t_wblk
    lda #'2'
    bne rwblk

    ;; RBLK ( ADR TRACK SECTOR -- ERR|0 )
    +word_header 'R', "BLK", flag_native, ~t_rblk
    !zone {
    lda #'1'
rwblk:
    sta .cmd

    ;; address of 256 byte buffer (for reading or writing)
    lda stack+4, x
    sta tmp
    lda stack+5, x
    sta tmp+1

    lda stack, x
    jsr byte_to_dec
    sty .sector
    sta .sector+1
    lda stack+2, x
    jsr byte_to_dec
    sty .track
    sta .track+1

    txa
    pha
    lda #1
    ldx #<.cname
    ldy #>.cname
    jsr $ffbd               ; SETNAM "#"

    lda #2
    ldx device
    ldy #2
    jsr $ffba               ; SETLFS 2,8,2

    jsr $ffc0               ; OPEN
    bcs .error

    lda .cmd
    cmp #'1'
    bne .write

.read:
    lda #.cmdname_end-.cmdname
    ldx #<.cmdname
    ldy #>.cmdname
    jsr $ffbd               ; SETNAM "U1 2 0 nn nn"
    lda #15
    ldx device
    ldy #15
    jsr $ffba               ; SETLFS 15,8,15

    jsr $ffc0               ; OPEN
    bcs .error

    ldx #2
    jsr $ffc6               ; CHKIN

    ldy #0
.read_loop:
    jsr $ffcf               ; CHRIN
    sta (tmp), y
    iny
    bne .read_loop
    beq .success

.write:
    lda #.bpcmd_end-.bpcmd
    ldx #<.bpcmd
    ldy #>.bpcmd
    jsr $ffbd               ; SETNAM "B-P 2 0"
    ;; TODO: remove redundancy here
    lda #15
    ldx device
    ldy #15
    jsr $ffba               ; SETLFS 15,8,15

    jsr $ffc0               ; OPEN
    bcs .error

    ldx #2
    jsr $ffc9               ; CHKOUT 2

    ldy #0
.write_loop:
    lda (tmp), y
    jsr $ffd2               ; CHROUT
    iny
    bne .write_loop

    ldx #15
    jsr $ffc9               ; CHKOUT 15

    ldy #0
.cmd_loop:
    lda .cmdname, y
    jsr $ffd2
    iny
    cpy #(.cmdname_end+1)-.cmdname
    bne .cmd_loop           ; include the CR at the end

.success:
    lda #0
.error:
    sta tmp
.close:
    jsr $ffcc               ; CLRCHN
    lda #15
    jsr $ffc3               ; CLOSE 15
    lda #2
    jsr $ffc3               ; CLOSE 2
    jsr $ffcc               ; CLRCHN
    pla
    tax

    lda tmp
    inx
    inx
    inx
    inx
    sta stack, x
    lda #0
    sta stack+1, x
    rts

.cname:
    !text "#"
.cmdname:
    !text "U"
.cmd:
    !text "1 2 0 "
.track:
    !text "00 "
.sector:
    !text "00"
.cmdname_end:
    !byte $0d
.bpcmd:
    !text "B-P 2 0"
.bpcmd_end:
    }
}



next:
    !zone {
    lda $91
    cmp #$fe
    beq .stop

    ldy #0
    lda (ip), y
    +incw ip
    ;; Option if very short on space:
    ;;jsr geta

    tay
execute_y:
    lda ttab, y
    sta w
    lda ttab+ttab_half, y
    bmi .enter              ; branch if high-level word, otherwise native

    and #$1f
    sta w+1

    lda #>(next-1)           ; set up return address
    pha
    lda #<(next-1)
    pha

    jmp (w)
.enter:
    and #$1f                ; threaded word
    sta w+1

    jsr puship

    lda w
    sta ip
    lda w+1
    sta ip+1

    jmp next
.stop:
    ldx #initial_sp         ; set up data stack
    lda #initial_rp         ; set up return stack
    sta rp
    lda #>repl
    sta ip+1
    lda #<repl
    sta ip
    jmp next
    }

puship:
    ldy rp
    lda ip+1
    dey
    sta rstack, y
    lda ip
    dey
    sty rp
    sta rstack, y
    rts

    
entry:
    !zone {

    init_last = *+1
    lda #asm_token
    sta last

    init_here_low = *+1
    lda #<heap_start
    sta here
    init_here_high = *+1
    lda #>heap_start
    sta here+1
soft_reset: 
    ldx #initial_sp         ; set up data stack
    lda #initial_rp         ; set up return stack
    sta rp

    jsr thread
init_tok:
    !byte t_repl
    !byte t_halt
    }


heap_start:

    mem_end = $1e00
!if INC_BLOCK_EDITOR {
    blockbuf = mem_end-$100
    wbuf_len = blockbuf - 32 - 1
} else {
    wbuf_len = mem_end - 32 - 1
}
    wbuf_data = wbuf_len + 1
    lbuf_len = $0200 ; wbuf_len - 88 - 1
    lbuf_data = $0201 ; lbuf_len + 1
    mem_top = wbuf_len ; lbuf_len