;               pla             ; LSB
                sta tmptos
                ply             ; MSB

                ; --- CUT HERE FOR NATIVE CODING ---

                cpx #dsp0-1
                bmi +
                lda #11
                jmp error
*
                lda 1,x         ; MSB
                pha
                lda 0,x         ; LSB
                pha

                inx
                inx

                ; --- CUT HERE FOR NATIVE CODING ---

                phy             ; MSB
                lda tmptos
                pha             ; LSB

z_to_r:         rts

: ccc >r ;  ok
see ccc
 nt: 19F7  xt: 1A02
 size (decimal): 8
 
1A02  B5 01 48 B5 00 48 E8 E8   ok

: aaa drop ;  ok
see aaa
 nt: 19D2  xt: 19DD
 size (decimal): 11
 
19DD  E0 77 30 05 A9 0B 4C 42  AD E8 E8  ok

: bbb drop ;  ok
see bbb
 nt: 19E9  xt: 19F4
 size (decimal): 2
 
19F4  E8 E8  ok

; ## DNEGATE ( d -- d ) "Negate double cell number"
; ## "dnegate"  src: ANSI double  b: 33  c: TBA  status: coded
xt_dnegate:     
                cpx #dsp0-3
                bmi +
                lda #11
                jmp error
*
                ldy #0
                sec

                tya
                sbc 2,x         ; LSB of low cell
                sta 2,x

                tya
                sbc 3,x         ; MSB of low cell
                sta 3,x

                tya
                sbc 0,x         ; LSB of high cell
                sta 0,x

                tya
                sbc 1,x         ; MSB of high cell
                sta 1,x

z_dnegate:      rts

; ## FILL ( addr u char -- ) "Fill a memory region with a character"
; ## "fill"  src: ANSI core  b: TBA  c: TBA  status: coded
        ; """Fill u bytes of memory with char starting at addr. Note that
        ; this works on bytes, not on cells. On an 8-bit machine such as the
        ; 65c02, this is a serious pain in the rear. It is not defined what
        ; happens when we reach the end of the address space
        ; """
xt_fill:       
                cpx #dsp0-5
                bmi +
                lda #11         ; underflow
                jmp error
*

                ; We use tmp1 to hold the address
                lda 4,x         ; LSB
                sta tmp1
                lda 5,x         ; MSB
                sta tmp1+1

                phx             ; we also use X in our inner loop to
                                ;   improve performance, so save it

                ; Unfortunately, we also need to make sure that we don't
                ;   fill beyond the end of the RAM.  So we check:
                ;     if ram_end < base_addr then don't fill anything
                ;     if ram_end - base_addr < fill_count then
                ;       set fill_count to ram_end - base_addr
                sec
                lda #<ram_end   ; LSB
                sbc tmp1
                tay
                lda #>ram_end   ; MSB
                sbc tmp1+1
                bcc _done
                pha
                cpy 2,x
                sbc 3,x
                pla
                bcs +           ; fill_count is legal, so proceed
                sty 2,x         ; fill_count is not legal, so adjust it
                sta 3,x         ;   to the largest legal value
*
                ldy 0,x         ; the fill byte value we'll be using
                lda 3,x
                eor #$ff        ; complement the fill_count to improve
                sta tmp2        ;   performance of the inner loop
                lda 2,x
                eor #$ff
                tax
                tya
                ldy #0
                bra +

_loop:
                ; We're not in ROM and we still have stuff on the counter,
                ;   so let's actually do what we came here to do

                sta (tmp1),y
                iny
                bne +
                inc tmp1+1
*
                ; Update our fill_count and loop while not zero
                inx
                bne _loop
                inc tmp2
                bne _loop
_done:
                ; Drop three cells off the Data Stack. This uses one byte
                ;   less than six times INX
                pla
                clc
                adc #6
                tax
z_blank:
z_erase:
z_fill:         rts
.scend

; ## ALLOT ( n -- ) "Reserve or release memory"
; ## "allot"  src: ANSI core  b: 90  c: TBA  status: tested
        ; """Reserve a certain number of bytes (not cells) or release them.
        ; If n = 0, do nothing. If n is negative, release n bytes, but only
        ; to the beginning of the Dictionary. If n is positive (the most
        ; common case), reserve n bytes, but not past the end of the
        ; Dictionary. See http://forth-standard.org/standard/core/ALLOT
        ; """
        ; TODO see what to do with the Dictionary Pointer (dp) memory is
        ; released to the beginning of the Dictionary
.scope
xt_allot:       
                cpx #dsp0-1
                bmi +
                lda #11                 ; underflow
                jmp error
*
                ; cp adjust code is the same for negative, zero or positive
                clc
                lda cp
                adc 0,x
                sta cp

                lda cp+1
                adc 1,x
                sta cp+1

                ; did we just reserve bytes or free them?
                lda 1,x
                bmi _negative

                ; did we just grant more space than we have available?
                ldy #<cp_end           
                cpy cp
                lda #>cp_end
                sbc cp+1
                bcs _done               ; we're good

                ; we're not good, so we fail hard. This is going to be rare,
                ; and so it's not worth keeping the old values around to
                ; restore them. Instead, we reserve max memory
                sty cp
                lda #>cp_end
                sta cp+1

                lda #1                  ; error code for ALLOT
                jmp error
_negative:
                ; Free at most to the beginning of the Dictionary space. Note
                ; this completely destroys the user's Dictionary. Currently,
                ; this leaves the Dictionary Pointer dangling, so this is probably
                ; not the best solution
                ; TODO find the best solution
                ldy #<cp0
                cpy cp
                lda #>cp0
                sbc cp+1
                bcc _done               ; CP still > than CP0, we're good

                ; we're totally not good, set CP to CP0
                sty cp
                lda #>cp0
                sta cp+1                ; drop through to _done
_done:
                inx
                inx
z_allot:
                rts
.scend

; ## COMPILE_COMMA ( xt -- ) "Compile xt"
; ## "compile,"  src: ANSI core ext  b: TBA  c: TBA  status: fragment
        ; """Compile the given xt in the current word definition. It is an
        ; error if we are not in the compile state. Because we are using
        ; subroutine threading, we can't use , (COMMA) to compile new words
        ; the traditional way. By default, native compiled is allowed, unless
        ; there is a NN (Never Native) flag associated. If not, we use the
        ; value NC_LIMIT (from definitions.tasm) to decide if the code
        ; is too large to be natively coded: If the size is larger than
        ; NC_LIMIT, we silently use subroutine coding. If the AN (Always
        ; Native) flag is set, the word is always natively compiled
        ; """
.scope
xt_compile_comma:
                cpx #dsp0-1
                bmi +
                lda #11                 ; underflow
                jmp error
*
                ; See if this is an Always Native (AN) word by checking the
                ; AN flag. We need nt for this. First, save a copy of xt to
                ; the Return Stack
                lda 1,x                 ; MSB
                pha
                lda 0,x
                pha                     ; LSB

                jsr xt_int_to_name      ; ( xt -- nt )

                ; put nt away for safe keeping
                lda 0,x
                sta tmptos
                lda 1,x
                sta tmptos+1

                ; status byte is one further down
                inc 0,x
                bne +
                inc 1,x                 ; ( nt -- nt+1 )
*
                lda (0,x)
                sta tmp3                ; keep copy of status byte for NN
                and #AN                 ; mask all but Always Native (AN bit
                beq _compile_check

                ; We're natively compiling no matter what. Get length and
                ; compile in code. Get the original nt back
                lda tmptos
                sta 0,x
                lda tmptos+1
                sta 1,x

                jsr xt_wordsize         ; ( nt -- u )

                bra _compile_as_code

_compile_check:
                ; See if Native Compile is even alowed by checking the NN
                ; flag
                lda tmp3
                and #NN
                beq _check_size_limit

                jmp _compile_as_jump    ; too far for BRA

_check_size_limit:
                ; Native compile is a legal option, but we need to see what
                ; limit the user set for size
                lda tmptos
                sta 0,x
                lda tmptos+1
                sta 1,x

                jsr xt_wordsize         ; ( nt -- u )

                ; We implicitly assume that we don't want to compile anything
                ; greater than 255 bytes, so we only deal with LSB
                lda 0,x                 ; !!!this was a "clc", which had to be a bug!!!
                cmp nc_limit            ; user-defined limit
                bcc _compile_as_code

                jmp _compile_as_jump    ; too far for BRA

_compile_as_code:
                ; We arrive here with the length of the word's code TOS and
                ; xt on top of the Return Stack. MOVE will need ( xt cp u )
                ; on the data stack
                dex
                dex                     ; ( -- u ?? )
                dex
                dex                     ; ( -- u ?? ?? )

                lda 4,x
                sta 0,x                 ; LSB of u
                lda 5,x
                sta 1,x                 ; ( -- u ?? u )

                pla
                sta 4,x                 ; LSB of xt
                pla
                sta 5,x                 ; ( -- xt ?? u )

                lda cp                  ; LSB of cp
                sta 2,x
                lda cp+1
                sta 3,x                 ; ( -- xt cp u )

                ; --- SPECIAL CASE 1: PREVENT RETURN STACK THRASHINIG ---
               
                ; Native compiling allows us to strip the stack antics off
                ; a number of words that use the Return Stack such as >R, R>,
                ; 2>R and 2R> (but not 2R@ in this version). We compare the
                ; xt with the contents of the table
                ldy #0
_strip_loop:
                lda _strip_table,y      ; LSB of first word
                cmp 4,x                 ; LSB of xt
                bne _next_entry

                ; LSB is the same, test MSB
                lda _strip_table+1,y
                cmp 5,x
                beq _found_entry

                ; MSB is not equal.
_next_entry:
                ; Not a word that needs stripping, so check next entry in table
                ; Let's see if we're done with the table (marked by zero entry)
                lda _strip_table,y      ; pointing to LSB
                ora _strip_table+1,y    ; get MSB
                beq _underflow_strip    ; table done, let's get out of here

                iny             
                iny
                bra _strip_loop
_found_entry:
                ; This word is one of the ones that needs to have its size
                ; adjusted during native compile. We find the values in the
                ; next table with the same index, which is Y.
                tya
                lsr
                tay

                ; Get the adjustment out of the size table. We were clever
                ;   enough to make sure the cut on both ends of the code is
                ;   the same size
                lda _strip_size,y
                sta tmptos              ; save a copy

                ; Adjust xt: Start later
                clc
                adc 4,x
                sta 4,x
                bcc +
                inc 5,x
*
                ; Adjust u: Quit earlier. Since we cut off the top and the
                ;   bottom of the code, we have to double the value
                asl tmptos

                sec
                lda 0,x
                sbc tmptos
                sta 0,x
                bcs +
                dec 1,x
*
                ; drop through to underflow check stripping

_underflow_strip:
                ; --- SPECIAL CASE 2: REMOVE UNDERFLOW CHECKING ---
               
                ; The user can choose to remove the underflow testing in those
                ; words that have the UF flag. This shortens the word by
                ; 9 bytes and increases speed by 5 cycles (because the branch
                ; is taken) if there is no underflow.
               
                ; See if the user wants underflow stripping turned on
                lda uf_strip
                ora uf_strip+1
                beq _specials_done

                ; See if this word even contains underflow checking
                lda tmp3
                and #UF
                beq _specials_done

                ; If we arrived here, underflow has to go. It's always 9 bytes
                ; long (except for PICK, which has a special case that can't
                ; be stripped)
 
                ; Adjust xt: Start later
                clc
                lda 4,x
                adc #9
                sta 4,x
                bcc +
                inc 5,x
*
                ; Adjust u: End earlier
                sec
                lda 0,x
                sbc #9
                sta 0,x
                bcs +
                dec 1,x
*
                ; --- END OF SPECIAL CASES ---
_specials_done:
                ; Store size of area to be copied for calculation of
                ; new CP. We have to do this after all of the special cases
                ; because they might change the size
                lda 1,x                 ; MSB
                pha
                lda 0,x                 ; LSB
                pha
               
                ; Enough of this, let's move those bytes already! We have
                ; ( xt cp u ) on the stack at this point
                jsr xt_move

                ; Update CP
                clc
                pla                     ; LSB
                adc cp
                sta cp

                pla                     ; MSB
                adc cp+1
                sta cp+1

                bra _done

_strip_table:
               ; List of words we strip the Return Stack antics from
               ; during native compile, zero terminated. The index here
               ; must be the same as for the sizes
                .word xt_r_from, xt_r_fetch, xt_to_r    ; R>, R@, >R
                .word xt_two_to_r, xt_two_r_from, 0000  ; 2>R, 2R>, EOL

_strip_size:   
                ; List of bytes to be stripped from the words that get their
                ; Return Stack antics removed during native compile. Index must
                ; be the same as for the xts. Zero terminated.
                .byte 4, 4, 4, 6, 6, 0          ; R>, R@, >R, 2>R, 2R>, EOL
               
_compile_as_jump:
                ; Compile xt as a subroutine jump
                lda #$20
                sta (cp)
               
                ldy #1
                pla             ; LSB
                sta (cp),y
                iny
                pla             ; MSB
                sta (cp),y

                ; allot space we just used
                tya
                sec
                adc cp
                sta cp
                bcc +
                inc cp+1
*
                inx             ; drop xt
                inx
_done:               
z_compile_comma:
                rts
.scend

; ## CONSTANT ( n "name" -- ) "Define a constant"
; ## "constant"  src: ANSI core  b: 82  c: TBA  status: tested
        ; """Forth equivalent is  CREATE , DOES> @  but we do
        ; more in assembler and let CREATE do the heavy lifting.
        ; See http://www.bradrodriguez.com/papers/moving3.htm for
        ; a primer on how this works in various Forths.
        ; """
xt_constant:   
                cpx #dsp0-1
                bmi +
                lda #11
                jmp error
*
                jsr xt_create

                ; CREATE by default installs a subroutine jump to DOVAR,
                ; but we want DOCONST for constants. Go back two bytes and
                ; replace the subroutine jump target
                sec             ; !!!this was missing, and had to be a bug!!!
                lda cp
                sbc #2
                sta tmp1
                lda cp+1
                sbc #0
                sta tmp1+1

                lda #<doconst   ; LSB of DOCONST
                sta (tmp1)
                ldy #1
                lda #>doconst   ; MSB of DOCONST
                sta (tmp1),y

                ; Now we save the constant number itself in the next cell
                jsr xt_comma            ; drop through to adjust_z

adjust_z:
                ; Now the length of the complete word (z_word) has increased by
                ; two. We need to update that number or else words such as SEE
                ; will ignore the PFA. We use this same routine for VARIABLE,
                ; VALUE and DEFER
                jsr xt_latestnt         ; gives us ( -- nt )

                ; z_word is six bytes further down
                lda 0,x
                sta tmp1
                lda 1,x
                sta tmp1+1

                ldy #6
                lda (tmp1),y
                clc
                adc #2
                sta (tmp1),y    ; !!!this was sta tmp2, and had to be a bug!!!
                iny
                lda (tmp1),y
                adc #0          ; only need carry
                sta (tmp1),y
             
                inx
                inx

z_constant:     rts

; ## PICK ( n n u -- n n n ) "Move element u of the stack to TOS"
; ## "pick"  src: ANSI core ext  b: TBA  c: TBA  status: coded
        ; """Take the u-th element out of the stack and put it on TOS,
        ; overwriting the original TOS. 0 PICK is equivalent to DUP, 1 PICK to
        ; OVER. Note that using PICK is considered poor coding form. Also note
        ; that FIG Forth has a different behavior for PICK than ANS Forth.
        ; """
.scope
xt_pick:
                ; Checking for underflow is difficult because it depends on
                ; which element we want to grab

                asl 0,x         ; we assume u < 128 (stack is small)
                txa
                adc 0,x
                tay
                lda 0002,y
                sta 0,x
                lda 0003,y
                sta 1,x
               
z_pick:         rts
.scend

cmpl_subroutine:
                lda #$20        ; compile "JSR" opcode first
                bra cmpl_common
cmpl_jump:
                lda #$4c        ; compile "JMP", fall through to common
cmpl_common:
                ; A contains the opcode that must be compiled
                ; first. This is basically C, ("c-comma")
                sta (cp)
                inc cp
                bne cmpl_word
                inc cp+1
cmpl_word:
                ; The cmpl_word routine is the body of all these routines
                ; and compiles the value on the Return Stack
                pla             ; LSB of return address
                sta tmp1
                pla             ; MSB of return address
                sta tmp1+1

                pla             ; LSB of word to compile
                sta (cp)
                ldy #1
                pla             ; MSB of word to compile
                sta (cp),y

                tya
                sec
                adc cp
                sta cp
                bcc +
                inc cp+1
*
                lda tmp1+1
                pha             ; MSB of return address
                lda tmp1
                pha             ; LSB of return address

                rts

Tali Forth 2 for the 65c02                                                     
Version ALPHA 11. Mar 2018                                                     
Copyright 2014-2018 Scot W. Stevenson                                           
Tali Forth 2 comes with absolutely NO WARRANTY                                 
Type 'bye' to exit                                                             
variable foo  ok                                                               
65 foo !  ok                                                                   
: bar foo dup @ .s ;  ok                                                       
bar  ok                                                                         
.s <1> 16319  ok                                                               
drop  ok                                                                       
0 nc-limit !  ok                                                               
variable foo2  ok                                                               
63 foo2 !  ok                                                                   
: bar2 foo2 dup @ .s ;  ok                                                     
bar2 <2> 16448 63  ok                                                           
drop drop  ok                                                                   
: baz foo dup @ .s ;  ok                                                       
baz <2> 16047 65  ok