core-nucleus.a65

; core-nucleus.a65
;#echo .       core-nucleus.a65          Nucleus

;--------------------------------------------------------------
#if 0
name=UM*
stack=( u1 u2 -- ud )
tags=nucleus,math,forth-83
`ud` is the unsigned product of `u1` times `u2`.  All values and
arithmetic are unsigned.

check http://6502.org/source/ for multiply and divide and stuff

```
umstar
    lda stackl,x
    sta n+4
    lda stackh,x            ;multiplicand in tos
    sta n+5                 ;multiplier in N2
    jsr multiply            ;16 bit unsigned multiply
    lda n
    sta stackl,x
    lda n+1
    sta stackh,x
    lda n+2
    ldy n+3
    jmp put ;[26]

multiply
    lda #0                  ; unsigned multiply tos*N2 destroys tos
    sta n+2                 ;clear upper half of product
    sta n+3
    ldy #16
rshift
    lsr tos+1
    ror tos
    bcc rrot                ;Go rotate right if c = 0
    clc                     ; and add multiplicand to
    lda n+2                 ;Get upper half of product
    adc n+4                 ; it
    sta n+2
    lda n+3
    adc n+5
rrot
    ror                     ;shift partial product right
    sta n+3
    ror n+2
    ror n+1
    ror n
    dey                     ;Decrement bit count and
    bne rshift
    rts ;[38 == 64]

: um*   ( u2 u1 -- ud )
  0 tuck dup (um*) ;
```
#endif
#include "align.i65"
_umstar
    jsr enter
#include "page.i65"
    .word zero
#include "parm.i65"
    .word tozp
    .byt R0L+2*ACC
#include "pad.i65"
    .word tuck
#include "page.i65"
    .word pumstar
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=(UM*)
stack=( 0 multiplicand multiplier 0 0 -- product )
tags=nucleus,math,forth-83,nosymbol

```
set product to 0.
begin
    right shift multiplier
if
    add multiplicand to product
then
    double multiplicand
    multiplier 0=
until
```
#endif
pumstar
    jsr harvests6               ;( N0              N1              N2 )
                                ;( multiplicand.lo multiplicand.hi multiplier )
    stx z                       ; stash stack pointer
pumstar01
    lsr R0L+2*N2+1
    ror R0L+2*N2                ; shift off low bit of multiplier
    bcc pumstar03
    clc
    ldx #<(-4) ;$FC
pumstar02                       ; add 32-bit multiplicand to 32-bit product
    lda <(R0L+4),x
    adc <(R0L+2*N0+4),x
    sta <(R0L+4),x
    inx
    bmi pumstar02
pumstar03
    ;clc
    ldx #R0L+2*N0
    jsr wraprolls
    lda R0L+2*N2                ; done when multiplier reaches 0
    ora R0L+2*N2+1
    bne pumstar01               ; keep go?
    ldx z                       ; restore stack pointer
    lda R0L+2*ACC
    ldy R0L+2*ACC+1
    dex                         ; tuck prod.lo at `2os`
    jmp slmod40d

;--------------------------------------------------------------
#if 0
name=UD/MOD
stack=( ud1 u2 -- u3 ud4 )
tags=numword

http://www.bradrodriguez.com/papers/camel09.txt
\   High level: numeric output                   (c) 31mar95 bjr
: UD/MOD      \ ud1 u2 -- u3 ud4     32/16->32 divide
    >R 0 R@ UM/MOD  ROT ROT R> UM/MOD ROT ;

#endif
udslashmod
        lda #>(put-1)
        pha
        lda #<(put-1)
        pha
        stx z                   ; saves a dex;dex later
        ;ldy #4
        jsr harvests4           ; dividend to n0..n3
udslashmods
        clc
        ;ldy #0                 ; harvests does this for us
        ldx #33
        tya
        beq udslashmodb         ; bra to initialization code
udslashmoda
        rol n+4         ; [5]   ; I don't know what this 2-bytes is called
        rol n+5         ; [5]   ; trial minuend or something like that
        sec             ; [2]
        lda n+4         ; [3]
        sbc tos         ; [3]
        tay             ; [2]
        lda n+5         ; [3]
        sbc tos+1       ; [3]
        bcc udslashmodc         ; save or abandon the trial subtraction
udslashmodb
        sty n+4         ; [2+3+3] or [3]?
        sta n+5         ; treating this as [~6] clocks on average
udslashmodc
        rol n           ; [5]
        rol n+1         ; [5]
        rol n+2         ; [5]
        rol n+3         ; [5]
        dex             ; [2]
        bne udslashmoda ; [3]
                        ; [54] or [59] clocks for 33x main loop = [1839]
        ldx z
        lda n+5
        sta stackh+1,x
        lda n+4
        sta stackl+1,x
        lda n+1
        sta stackh,x
        lda n
        sta stackl,x
        ldy n+3
        lda n+2
        rts                     ; `put` if called as a Forth word

;--------------------------------------------------------------
#if 0
name=UM/MOD
stack=( ud u -- rem quot )
tags=forth-83,nucleus
Perform an unsigned division of the 16-bit "u" into the double
"ud", leaving the 16-bit unsigned remainder and quotient on
the stack

      http://6502.org/source/integers/ummodfix/ummodfix.htm

!!! pronounced: "u-m slash mod"
#endif
umslashmod
    lda stackl,x
    cmp tos
    lda stackh,x
    sbc tos+1
    bcs umslashmodx
umslashmoda
    lda #17
    sta n                       ; counter
umslashmodb
    rol stackl+1,x
    rol stackh+1,x
    dec n
    beq umslashmodz
    rol stackl,x
    rol stackh,x
    lda #$80
    rol
    sta n+1                     ; carry
    ;sec
    lda stackl,x
    sbc tos
    sta n+2
    lda stackh,x
    sbc tos+1
    tay
    lda n+1
    sbc #0
    bcc umslashmodb

    lda n+2
    sta stackl,x
    sty stackh,x
    bcs umslashmodb

umslashmodx
    lda #$ff
    sta stackl,x
    sta stackh,x
    sta stackh+1,x
    sta stackl+1,x
umslashmodz
    jsr slide                   ; ~
    jmp swap

;--------------------------------------------------------------
#if 0
name=AND
stack=( n1 n2 -- n1&n2 )
tags=forth-83,nucleus,boolean
#endif
andx
    lda tos+1
    and stackh,x
    tay
    lda tos
    and stackl,x
    inx
    bne not01       ; [3]       ; bra

;--------------------------------------------------------------
#if 0
name=OR
stack=( n1 n2 -- n1|n2 )
tags=forth-83,nucleus,boolean
#endif
orx
    lda tos+1
    ora stackh,x
    tay
    lda tos
    ora stackl,x
    inx
    bne not01       ; [3]       ; bra

;--------------------------------------------------------------
#if 0
name=XOR
stack=( n1 n2 -- n1^n2 )
tags=forth-83,nucleus,boolean
#endif
xor
    lda tos+1       ; [3]
    eor stackh,x    ; [4]
    tay             ; [2]
    lda tos         ; [3]
    eor stackl,x    ; [4]
    inx             ; [2]
    bne not01       ; [3]       ; bra

;--------------------------------------------------------------
#if 0
name=NOT
stack=( n -- !n )
tags=forth-83,nucleus,boolean
#endif
not
    lda tos+1
    eor #$ff
    tay
    lda tos
    eor #$ff
not01
    jmp put

;--------------------------------------------------------------
#if 0
name==R
stack=( x -- y ) r( y -- x )
tags=primitive,stack,ext
Exchange `tos` with top of return stack

#endif
rexchg
    pla
    tay
    pla
toray
    dex
    sty stackl,x                ; ay
    sta stackh,x
    bne tor                     ; >r

;--------------------------------------------------------------
#if 0
name=2>R
stack=( x1 x2 -- ) r( -- x1 x2 )
tags=double,stack,ext
Transfer cell pair x1 x2 to the return stack. Semantically equivalent to `swap >r >r` .

#endif
twotor
    lda stackh,x
    pha
    lda stackl,x
    pha
    inx
                                ; fall through
;--------------------------------------------------------------
#if 0
name=>R
stack=( n -- ) ( R; -- n )
tags=forth-83,nucleus,stack
Move the top element of the data stack to the return stack

!!! pronounced: "to-r"
#endif
tor
    sec
    .byt $29                    ; AND #
    ;fall through
;--------------------------------------------------------------
#if 0
name=DUP>R
stack=( n -- n ) ( R; -- n )
tags=primitive,nucleus,stack
Copy the top of the data stack to the return stack

!!! pronounced: "dupe to-r"
#endif
duptor
    clc
    ;
    lda tos+1
    pha
    lda tos
    pha
    bcc rdrop01
    jmp drop

;--------------------------------------------------------------
#if 0
name=RDROP
stack=( -- ) ( R; a -- )
tags=nucleus,stack
Drop the top item on the return stack

!!! pronounced: "r-drop"
#endif
rdrop
    pla
    pla
rdrop01
    jmp next

;--------------------------------------------------------------
#if 0
name=2OFF
stack=( addr -- )
tags=nucleus,memory
Erase four bytes starting at `addr`

#endif
twooff
    ldy #4
    .byt $2C                    ; BIT abs opcode skips `ldy #1`
    ; fall through
;--------------------------------------------------------------
#if 0
name=3COFF
stack=( addr -- )
tags=nucleus,memory
Erase three bytes starting at `addr`

#endif
threecoff
    ldy #3
    ;
    .byt $2C                    ; BIT abs opcode skips `ldy #1`
    ; fall through
;--------------------------------------------------------------
#if 0
name=COFF
stack=( addr -- )
tags=nucleus,memory
Store 0 char at `addr`
#endif
coff
    ldy #1
    ;
    .byt $2C                    ; BIT abs opcode skips `clc $29`
    ; fall through
;--------------------------------------------------------------
#if 0
name=OFF
stack=( addr -- )
tags=nucleus,memory
Store 0 at `addr`

#endif
off
    ldy #2
    ;
    sec
off02
    lda #>(drop-1)
    pha
    lda #<(drop-1)
    pha

    jsr dectos                  ; alters A, not C
    lda #0
    sbc #0
erases02
    sta (tos),y
    dey
    bne erases02
    rts

;--------------------------------------------------------------
#if 0
name=ON
stack=( addr -- )
tags=nucleus,memory
Store -1 at `addr`
#endif
on
    ldy #2
    clc
    bcc off02                   ; bra

;--------------------------------------------------------------
#if 0
name=-
stack=( n1 n2 -- difference )
tags=forth-83,nucleus
Subtract `n2` from `n1`

#endif
minus
    jsr donegate
                                ; fall through
;--------------------------------------------------------------
#if 0
name=+
stack=( n1 n2 -- sum )
registers=A:X:C:TOS=sum
tags=forth-83,nucleus,math,fig,forth-79,primitive
Return the sum of n1 plus n2

!!! pronounced: "plus"
#endif
plus
    lda stackl,x
plus01                          ; entry point from >BIT
    clc
    adc tos
    sta tos
    lda stackh,x
    adc tos+1
    sta tos+1
    ;fall through
;--------------------------------------------------------------
#if 0
name=NIP
stack=( n1 n2 -- n2 )
tags=nucleus,stack
Remove the second item from the stack

#endif
nip
    inx
qdup01
    jmp next

;--------------------------------------------------------------
#if 0
name=ABS
stack=( n -- u )
tags=forth-83,nucleus,math,fig,forth-79
Leave the absolute value of n as u.
#endif
abs
    bit tos+1
    bpl qdup01
    ;fall through
;--------------------------------------------------------------
#if 0
name=NEGATE
stack=( n -- -n )
tags=forth-83,nucleus,math

#endif
negate
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
donegate
    sec
neg2
    lda #0
    sbc tos
    sta tos
    lda #0
    sbc tos+1
    sta tos+1
    rts

;--------------------------------------------------------------
#if 0
name=OVER
stack=( n1 n2 -- n1 n2 n1 )
tags=forth-83,nucleus,stack

#endif
over
    ldy stackh,x
    lda stackl,x
    jmp pushya

;--------------------------------------------------------------
#if 0
name=SWAP
stack=( n1 n2 -- n2 n1 )
tags=forth-83,nucleus,stack,fig,forth-79
Exchange the top two values on the stack.
#endif
swap
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
swaps
    ldy tos+1
    lda stackh,x
    sta tos+1
    sty stackh,x
    ldy tos
    lda stackl,x
    sta tos
    sty stackl,x
    rts

;--------------------------------------------------------------
#if 0
name=TUCK
stack=( n1 n2 -- n2 n1 n2 )
tags=nucleus,stack
Insert the top item on the stack beneath the second.
#endif
tuck
    dex
    jsr tuckdashrot
    jmp next

tuckdashrot
    lda stackh+1,x
    sta stackh,x
    lda stackl+1,x
    sta stackl,x
    lda tos+1
    sta stackh+1,x
    lda tos
    sta stackl+1,x
    rts

;--------------------------------------------------------------
#if 0
name=-ROT
stack=( a b c -- c a b )
tags=nucleus,stack

#endif
dashrot
    ldy stackh,x
    lda stackl,x                ; b
    pha
    jsr tuckdashrot
    pla
    jmp put                     ; b -> c

;--------------------------------------------------------------
#if 0
name=?DUP
stack=( 0 -- 0 | n -- n n )
tags=forth-83,nucleus
 DUP if top of stack is nonzero
#endif
qdup
    lda tos
    ora tos+1
    beq qdup01
    ; fall through
;--------------------------------------------------------------
#if 0
name=DUP
stack=( n -- n n )
tags=forth-83,nucleus,stack,forth-79,fig
Duplicate the value on the stack.

!!! pronounced: "dupe"
#endif
dup
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
    ; fall through
;--------------------------------------------------------------
#if 0
name=SLIP
stack=( n -- n n )
tags=nosymbol,subroutine
Push TOS to the stack (DUP)
#endif
slip
    dex
slip01
    lda tos+1
    sta stackh,x
    lda tos
    sta stackl,x
    rts
;[10]{22}

;--------------------------------------------------------------
#if 0
name=+!
stack=( n addr -- )
tags=forth-83,nucleus,fig,forth-79
Add "n" to the value at "addr"

!!! pronounced: "plus-store"
#endif
plusstore
    ldy #0
    clc
    lda stackl,x
    adc (tos),y
    sta (tos),y
    iny
    lda stackh,x
    adc (tos),y
    sta (tos),y
    jmp twodrop

;--------------------------------------------------------------
#if 0
name=TOGGLE
stack=( addr bitmask -- )
tags=nucleus,boolean,fig
Complement the contents of addr by the bit pattern b.
#endif
toggle
    lda stackl,x
    sta n
    lda stackh,x
    sta n+1
    ldy #0
    lda (n),y
    eor tos
    sta (n),y
    jmp twodrop

;--------------------------------------------------------------
#if 0
name=COUNT
stack=( addr1 -- addr2 n1 )
tags=forth-83
Leaves the address, addr2 and the character count +n of text
beginning at addr1.  addr2 is addr1+1 and n1 is the length of
the counted string at addr1.  The byte at addr1 contains the
byte count +n.  Range of +n is {0...255}.
#endif
count
    ; synonym for C@+, fall through
;--------------------------------------------------------------
#if 0
name=C@+
stack=( addr -- addr+1 c )
tags=nucleus,memory,primitive
Fetches the byte at addr, increments addr

!!!pronounced: "c-fetch-plus"
#endif
cfetchplus
    ldy #0
    lda (tos),y
    jsr inctos
    jmp pushya

;--------------------------------------------------------------
#if 0
name=@+
stack=( addr -- addr+2 w )
tags=nucleus,memory,primitive
Fetches word `w` at `addr`, increments addr by 2

!!!pronounced: "c-fetch-plus"
#endif
fetchplus
    ldy #1
fetchplus01
    lda (tos),y
    pha
    dey
    bpl fetchplus01
    jsr inctos
    jsr inctos
    jmp rfrom

;--------------------------------------------------------------
#if 0
name=CBIT!
stack=( mask addr -- )
tags=nucleus,boolean,memory
Turn on the `mask` bits in the byte at `addr`

!!! pronounced: "c-bit-store"
#endif
cbitstore
    ldy #0
    lda (tos),y
    ora stackl,x
    sta (tos),y
    jmp twodrop

;--------------------------------------------------------------
#if 0
name=CBIT@
stack=( mask addr -- flag )
tags=nucleus

 test the mask bits in the byte at address

#endif
cbitfetch
    ldy #0
    lda (tos),y
    and stackl,x
    inx
    jmp put

;--------------------------------------------------------------
#if 0
name=TIB
stack=( -- addr )
tags=nucleus,const,forth-83
The address of the text input buffer.  This buffer is used
to hold characters when the input stream is coming from the
keyboard or other input stream (not a block).  The minimum
capacity of TIB is 80 characters.

!!!pronounced: "t-i-b"
#endif
tib
    jsr doconst
    .word BUF                   ; $0200

;--------------------------------------------------------------
#if 0
name=SIB
stack=( -- addr )
tags=nucleus,const,forth-83
The address of the screen input buffer.  This buffer is used to hold each logical line of screen codes from a packet that has been unpacked to `blkbuf` while interpreting it. As a working area, both `interpret` and `create` will replace space characters before and after a token with length bytes and vocabulary id's.  This buffer may not be pristine!

!!!pronounced: "screen-input-buffer"
#endif
sib
    jsr doconst
    .word $0130                 ; Put 80 bytes for a line input buffer
                                ; in the middle of the system stack
                                ; page?  What could possibly go wrong?

;--------------------------------------------------------------
#if 0
name=-5
stack=( -- -5 )
tags=nucleus,const

#endif
minusfive
    jsr doconst
    .word -5

;--------------------------------------------------------------
#if 0
name=-4
stack=( -- -4 )
tags=nucleus,const

#endif
minusfour
    jsr doconst
    .word -4

;--------------------------------------------------------------
#if 0
name=-3
stack=( -- -3 )
tags=nucleus,const

#endif
minusthree
    jsr doconst
    .word -3

;--------------------------------------------------------------
#if 0
name=-2
stack=( -- -2 )
tags=nucleus,const

#endif
minustwo
    jsr doconst
    .word -2

;--------------------------------------------------------------
#if 0
name=BLK@
stack=( -- blk )
tags=numword
Return the contents of user variable `blk`

~ implementation limits `blk` to the range 0..255 (tape only)
#endif
blkfetch
    lda userblk
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=9
stack=( -- 9 )
tags=nucleus
Constant: `9`
#endif
nine
    lda #9
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=8
stack=( -- 8 )
tags=nucleus
Constant: `8`
#endif
eight
    lda #8
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=7
stack=( -- 7 )
tags=nucleus
Constant: `7`
#endif
seven
    lda #7
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=6
stack=( -- 6 )
tags=nucleus
Constant: `6`
#endif
six
    lda #6
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=EIGHTY
stack=( -- 80 )
tags=nucleus,const
Constant: `80`
#endif
eighty
    lda #80
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=FORTY
stack=( -- 40 )
tags=nucleus,const
Constant: `40`
#endif
forty
    lda #40
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=TEN
stack=( -- 10 )
tags=nucleus,const
Constant: `10`
#endif
ten
    lda #10
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=BL
stack=( -- n )
tags=nucleus,const
Constant: `32`
#endif
bl
    lda #' '
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=L/SCR
stack=( -- n )
tags=nucleus,const
Lines per screen, 25
Constant: `25`
#endif
lperscr
    lda #LPERSCR
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=5
stack=( -- 5 )
tags=nucleus
Constant: `5`
#endif
five
    lda #5
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=4
stack=( -- 4 )
tags=nucleus
Constant: `4`
#endif
four
    lda #4
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=3
stack=( -- 3 )
tags=nucleus
Constant: `3`
#endif
three
    lda #3
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=2
stack=( -- 2 )
tags=nucleus
Constant: `2`
#endif
two
    lda #2
    .byt $2c                    ; BIT abs opcode
;--------------------------------------------------------------
#if 0
name=1
stack=( -- 1 )
tags=nucleus,const
Constant: `1`
#endif
one
    lda #1
    jmp push0a

;--------------------------------------------------------------
#if 0
name=?TERMINAL
stack=( -- flag )
tags=forth-83
Leaves a flag indicating whether the [[STOP]] key was pressed by the user
#endif
qterminal
    jsr GETSTOP
xpushz
    beq true
    ;fall through
;--------------------------------------------------------------
#if 0
name=ACC
stack=( -- 00|02 )
tags=assembler,vocabulary,extension
vocab=1

!!!Assembler constant
zero page scratch location

~todo fix this for C=64, C128, Plus/4

```
$00 cconstant acc
```
#endif
asmacc
    ;fall through
;--------------------------------------------------------------
#if 0
name=0
stack=( -- 0 )
tags=nucleus
Put a 0 on the stack
#endif
zero
    ;fall through
;--------------------------------------------------------------
#if 0
name=FALSE
stack=( -- 0 )
tags=nucleus
Put a 0 (false flag) on the stack
#endif
false
    clc
    .byt $29                    ; AND # opcode
    ;fall through
;--------------------------------------------------------------
#if 0
name=-1
stack=( -- -1 )
tags=nucleus

#endif
minusone
    ;fall through
;--------------------------------------------------------------
#if 0
name=TRUE
stack=( -- -1 )
tags=nucleus,forth-83
#endif
true
    sec
    ;
xpushc
    jsr slip
    jmp putc
puttrue
    sec
    .byt $29
putfalse
    clc
putc
    ldy #0
    bcc yyrts
    dey                         ; you load 16 ones, and whaddya get?
yyrts
    tya
    jmp put

;--------------------------------------------------------------
#if 0
name=<
stack=( n1 n2 -- flag )
tags=forth-83,nucleus
Perform a signed comparison and return `true` if `n1` is less
than `n2`
#endif
lt
    jsr sub16                   ; 2OS - TOS, return (N^V)
lt01
    bvs putnotn
    eor #$80
putnotn
    asl
putnotc
    bcc puttrue
    bcs putfalse                ; bra

;--------------------------------------------------------------
#if 0
name=BETWEEN?
stack=( low high n -- flag )
tags=nucleus,thinking-forth,forth200x
Returns `true` when `low <= n < high`

```
: WITHIN   ( n lo hi+1 -- ?)
    >r 1- over < swap r> < and ;
```
returns true iff a < x < b, unsigned

6.2.2440 WITHIN
CORE EXT
    ( n1|u1 n2|u2 n3|u3 -- flag )
Perform a comparison of a test value n1|u1 with a lower limit n2|u2 and an upper limit n3|u3, returning true if either (n2|u2 < n3|u3 and (n2|u2 <= n1|u1 and n1|u1 < n3|u3)) or (n2|u2 > n3|u3 and (n2|u2 <= n1|u1 or n1|u1 < n3|u3)) is true, returning false otherwise. An ambiguous condition exists if n1|u1, n2|u2, and n3|u3 are not all the same type.

See: A.6.2.2440 WITHIN, where after much monkeying about with ways that
are broken, they finally get to it:

```
: WITHIN ( test low high -- flag )  OVER - >R - R> U< ;

within
    brk
    .byt ld | TOS
    .byt st | N0
    .byt pull
    .byt
```

lo <= n < hi

"Thinking Forth" pp. 171,283
An often-used word is `within`, which determines wheteher a given value lies within two other values.  The syntax is:
n  lo hi within
where `n` is the value to be tested and `lo` and `hi` represent the range.
`within` returns true if `n` is greater-than or equal-to `lo` and //less-than//
`hi`.  This use of the non-incluseive upper limit parallels the syntax
of `do loop`s.

p.283
`within` can be defined in high level like this
: within ( n lo hi+1 -- ?)
>r 1- over < swap r> < and ;
#endif
betweenq
    jsr sub16                   ;hi-n
    inx
                                ; Boy I sure hope an IRQ doesn't strike
                                ; right now, and put things on the data
                                ; stack.  That would be a large problem.
                                ; This is why we can't have nice things
    bcc putc                    ;nope, too high
    dex
    ;fall through
;--------------------------------------------------------------
#if 0
name=U<
stack=( n1 n2 -- flag )
tags=forth-83,nucleus
#endif
ult
    jsr sub16                   ; also clears `z` flag
betwq01
    bne putnotc                 ; bra

;--------------------------------------------------------------
#if 0
name=0=
stack=( n -- flag )
tags=forth-83,nucleus
Leaves [[TRUE]] if the top of stack is zero, otherwise [[FALSE]].
Logical [[NOT]], turns nonzero values to `$FFFF`
#endif
zeq
    clc
    .byt $29                    ; AND # opcode, 1-byte branch trick

;--------------------------------------------------------------
#if 0
name=0<>
stack=( n -- flag )
tags=nucleus
Leave `FALSE` if `n` is 0, `TRUE` otherwise.  Normalizes nonzero
values to $FFFF .   Could this word be removed? ~~
#endif
zne
    sec
    lda tos
    ora tos+1
    bne putc
    bcs zlt                     ; `0<>` puts `false`
    dec tos+1                   ; `0=` puts `true`
    ;fall through
;--------------------------------------------------------------
#if 0
name=0<
stack=( n -- flag )
tags=forth-83,nucleus
#endif
zlt
    asl tos+1                   ; copy N to C
    jmp putc

;--------------------------------------------------------------
#if 0
name=SUB16
stack=( n1 n2 -- flag )
tags=nucleus,subroutine,nosymbol
Performs a 16-bit subtraction of `2OS - TOS`

"V is the exclusive or of the carrys out of bits 6 and 7" - Bogax

|AY|result A (high)  Y (low)|
|N|sign of result|
|C|borrow of result|
|Z|clear|
#endif
sub16
    sec                         ; 16-bit signed subtract/compare
    lda stackl,x                ; returns AY = (2OS-TOS)
    sbc tos                     ; (N^V) = result was negative
    tay                         ; !(N^V) = result was positive
    lda stackh,x
    sbc tos+1
    inx                         ; nip 2OS, clear `z` flag
    rts

;--------------------------------------------------------------
#if 0
name=0>
stack=( n -- flag )
tags=forth-83,nucleus,relational

#endif
zgt
    asl tos+1
    jmp putnotc

;--------------------------------------------------------------
#if 0
name=DU<
stack=( d1 d2 -- flag )
tags=forth-83,double,primitive,logical
Performs an unsigned compare of two doubles and leaves true if "d1" < "d2"

#endif
dult
    jsr dsub
    inx
    bne putnotc                 ; bra

;--------------------------------------------------------------
#if 0
name=D=
tags=double,primitive,logical
stack=( d1 d2 -- flag )
Leaves `true` if the two doubles are equal

```
: d=   ( d1 d2 -- flag )
   d- or 0= ;
```
#endif
#include "align.i65"
_deq
    jsr enter
#include "page.i65"
    .word dminus
#include "page.i65"
    .word orx
#include "page.i65"
    .word zeq
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=<>
stack=( n1 n2 -- flag )
tags=nucleus,relational
Leave a true flag if `n1` does not equal `n2`.

#endif
ne
    sec
    .byt $29                    ; AND # opcode, skip `clc`
    ;fall through
;--------------------------------------------------------------
#if 0
name==
stack=( n1 n2 -- flag )
tags=forth-83,nucleus,relational
Leave a true flag if "n1" does is equal to "n2".

#endif
eq
    clc
    ;
    jsr peq                     ; the answer is in the `z` flag
    php
    php
    inx                         ; nip 2nd operand
    pla
    lsr
    plp
    adc #0                      ; toggle bit 0 if `c` true
    lsr                         ; the answer is in the `c` flag
    bpl putc                    ; bra, replace 1st operand with flag

;--------------------------------------------------------------
#if 0
name=(=)
stack=( n1 n2 -- n1 n2 ; returns Z flag )
tags=nucleus,relational,nosymbol
subroutine evaluates TOS==2OS

* Compares the TOS with 2OS
* returns the Z flag
* doesn't alter the stack

|^A|^''*'' |^N|^''-'' |
|^X||^V||
|^Y||^Z|^''*'' |
|>||^C||
#endif
peq
    lda stackh,x    ; [4]
    eor tos+1       ; [3]
    sta z           ; [3]
    lda stackl,x    ; [4]
    eor tos         ; [3]
    ora z           ; [3]
    rts             ; [6]       ; Z flag is (TOS = 2OS)

;--------------------------------------------------------------
#if 0
name=D<
stack=( d1 d2 -- flag )
tags=forth-83,double,primitive
Compare two signed doubles.  True if `d1` < `d2`

#endif
dlt
    jsr dsub
    inx
    jmp lt01

;--------------------------------------------------------------
#if 0
name=>
stack=( n1 n2 -- flag )
tags=forth-83,double,primitive
Compare two values.  Return `true` if `n1` > `n2`

#endif
#include "align.i65"
gt
    jsr swaps
    jmp lt

;--------------------------------------------------------------
#if 0
name=D>=
stack=( d1 d2 -- flag )
tags=double

```
: d>
    d< not ;
```
#endif
#include "align.i65"
_dge
    jsr enter
#include "page.i65"
    .word dlt
#include "page.i65"
    .word not
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=D0=
stack=( d -- flag )
tags=double,primitive,logical
Leave true if the double `d` is zero

`D0<>` is not in PETTIL, nor the Forth-83 standard.  Use `or 0<>`.
#endif
#include "align.i65"
_dzeq
    jsr enter
#include "page.i65"
    .word orx
#include "page.i65"
    .word zeq
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=TOS2MINUS
stack=( n -- n-2 )
tags=nosymbol
!!!Subroutine
decrements the top of stack twice
#endif
tos2minus
    jsr dectos
    ; fall through
;--------------------------------------------------------------
#if 0
name=DECTOS
tags=nosymbol
decrement TOS
#endif
dectos
    lda tos
    bne dectos01
    dec tos+1
dectos01
    dec tos
    rts

;--------------------------------------------------------------
#if 0
name=1-
stack=( n -- n-1 )
tags=forth-83,nucleus
Subtract 1 from top of stack
#endif
oneminus
    lda #$ff
    bne oneminus01

;--------------------------------------------------------------
#if 0
name=3-
stack=( n -- n-3 )
tags=nucleus

#endif
threeminus
    lda #$fd
    .byt $2c ; BIT abs opcode, fall through to twominus
;--------------------------------------------------------------
#if 0
name=2-
stack=( n -- n-2 )
tags=nucleus,forth-83

#endif
twominus
    lda #$fe
oneminus01
    dec tos+1
    .byt $2c ; BIT abs opcode, fall through to twoplus
;--------------------------------------------------------------
#if 0
name=2+
stack=( n -- n+2 )
tags=nucleus,math,forth-83
Increment top of stack by 2

todo: code golf this together with slower tos2plus subroutine?
#endif
twoplus
    lda #2
nplus
    clc
    adc tos
    sta tos
    bcc twoplus01
    inc tos+1
twoplus01
    jmp next

;--------------------------------------------------------------
#if 0
name=3+
stack=( n -- n+3 )
tags=nucleus

#endif
threeplus
    lda #3
    bne nplus                   ; bra

;--------------------------------------------------------------
#if 0
name=2/
stack=( n -- n/2 )
tags=forth-83,nucleus


#endif
twoslash
    lsr tos+1
    ror tos
    jmp next

;--------------------------------------------------------------
#if 0
name=2*
stack=( n -- n*2 )
tags=nucleus

#endif
twostar
    asl tos
    rol tos+1
    jmp next

;--------------------------------------------------------------
#if 0
name=ROT
stack=( a b c -- b c a )
tags=forth-83,nucleus


#endif
rot
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
    ; fall through
rots
    ldy stackh+1,x
    lda stackh,x
    sta stackh+1,x
    lda tos+1
    sta stackh,x
    sty tos+1
    ldy stackl+1,x
    lda stackl,x
    sta stackl+1,x
    lda tos
    sta stackl,x
    sty tos
    rts

;--------------------------------------------------------------
#if 0
name=THIRD
stack=( n1 n2 n3 -- n1 n2 n3 n1 )
tags=nucleus


#endif
third
    lda stackl+1,x
    ldy stackh+1,x
    jmp pushya

;--------------------------------------------------------------
#if 0
name=3DUP
stack=( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
tags=nucleus
Duplicate the top three elements on the stack

```
: 3dup
    2dup 4 pick -rot ;
```
code version runs in about half the time for more than
twice the memory

```
threedup
    dex
    dex
    dex
    lda tos+1
    sta stackh+2,x
    lda tos
    sta stackl+2,x
    lda stackh+4,x
    sta stackh+1,x
    lda stackl+4,x
    sta stackl+1,x
    lda stackh+3,x
    sta stackh,x
    lda stackl+3,x
    sta stackl,x
    jmp next
```
#endif
#include "align.i65"
_threedup
    jsr enter
#include "page.i65"
    .word third
#include "page.i65"
    .word third
#include "page.i65"
    .word third
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=UNDER
stack=( n1 n2 -- n1 n1 n2 )
tags=nucleus

 Make a duplicate of the second stack element beneath `TOS`

#endif
under
    dex
    lda stackh+1,x
    sta stackh,x
    lda stackl+1,x
    sta stackl,x
    jmp next

;--------------------------------------------------------------
#if 0
name=+UNDER
stack=( n1 n2 n3 -- n1+n3 n2 )
tags=nucleus

 Add the top of stack to item underneath the second on stack

#endif
plusunder
    lda #>(drop-1)
    pha
    lda #<(drop-1)
    pha
    clc
plusunders
    lda tos
    adc stackl+1,x
    sta stackl+1,x
    lda tos+1
    adc stackh+1,x
    sta stackh+1,x
    rts

;--------------------------------------------------------------
#if 0
name=2+UNDER
stack=( n1 n2 -- n1+1 n2 )
tags=nucleus,extra

Add 2 to second on stack.  Equivalent to `2 +under`

#endif
twoplusunder
    jsr oneplunders
    ;fall through
;--------------------------------------------------------------
#if 0
name=1+UNDER
stack=( n1 n2 -- n1+1 n2 )
tags=nucleus,extra

Increment second on stack.  Equivalent to `1 +under`

#endif
oneplusunder
    clc
    ;
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
    bcs oneminders
    ; fall through
;--------------------------------------------------------------
#if 0
name=ONEPLUNDERS
stack=( a b c d -- a b+1 c d )
tags=nucleus,extra,subroutine,nosymbol
Increment stack at `x`.
#endif
oneplunders
    inc stackl,x
    bne oneplunders01
    inc stackh,x
oneplunders01
    rts

;--------------------------------------------------------------
#if 0
name=3-UNDER
stack=( n1 n2 -- n1-3 n2 )
tags=nucleus,extra

Decrement second on stack, twice.  Equivalent to `-2 +under`

#endif
threeminusunder
    ;fall through
    jsr oneminders
;--------------------------------------------------------------
#if 0
name=2-UNDER
stack=( n1 n2 -- n1-1 n2 )
tags=nucleus,extra

Decrement second on stack, twice.  Equivalent to `-2 +under`

#endif
twominusunder
    jsr oneminders
    ;fall through
;--------------------------------------------------------------
#if 0
name=1-UNDER
stack=( n1 n2 -- n1-1 n2 )
tags=nucleus,extra

Decrement second on stack.  Equivalent to `-1 +under`

#endif
oneminusunder
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
    ; fall through
oneminders
    lda stackl,x
    bne oneminders01
    dec stackh,x
oneminders01
    dec stackl,x
    rts

;--------------------------------------------------------------
#if 0
name=FILL
stack=( addr +howmany value -- )
tags=forth-83,nucleus


 howmany has an upper limit of 32K bytes

#endif
fill
    jsr harvests4               ; addr -> N0; howmany -> N1
    lda #>(drop-1)
    pha
    lda #<(drop-1)
    pha
fills
    clc
    ;ldy #0
    lda tos
fill01
    dec n+3
    bpl fill02
    sec             ; fill a partial page then exit
    ldy n+2
    beq fill03      ; nothing to do?
fill02
    dey
    sta (n),y
    bne fill02
    inc n+1
    bcc fill01
fill03
    rts
    ;jmp drop

;--------------------------------------------------------------
#if 0
name=>FILL
stack=( addr howmany -- )
tags=nucleus,nosymbol
shared `does>` for `erase` and `blank`

#endif
#include "align.i65"
dofill
    jsr dodoes
#include "page.i65"
    .word cfetch
#include "page.i65"
    .word fill
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=ERASE
stack=( addr howmany -- )
tags=nucleus

#endif
#include "align.i65"
erase
    jsr dofill
    .byt 0

;--------------------------------------------------------------
#if 0
name=BLANK
stack=( addr howmany -- )
tags=nucleus

#endif
#include "align.i65"
blank
    jsr dofill
    .byt ' '

;--------------------------------------------------------------
#if 0
name=>-BUF
stack=( char == ; buff max -- buff actual )
tags=nucleus,nosymbol

[38] >-buf
[4] -trailing
[4] -nulls
[46]

```
    ( buf size )
    c@ >r
    begin
        ( buf size )
        1- 2dup + c@ r@
        ( buf size-1 c1 c2 )
        <> over 1+ 0= or

        ( buf size-1 flag )
    until 1+ rdrop ;

    c@ >r
    1-
    begin
        2dup + c@ r@
        <> over 0= or
        1-under
    until 1+ rdrop ;


: >-buf   ( char == ; buf maxsize addr -- buf size )
\   <builds  c,  does>
    c@ >r under +
    begin
        1- dup
        c@ r@ =
    while
        2dup <
    until
    rdrop 1+ under - ;          ( buf size )

: >-buf   ( char == ; buf maxsize addr -- buf size )
\   <builds  c,  does>
    c@ >r
    begin
        1- 2dup +
        c@ r@ =
    while
        dup 0<
    until
    rdrop 1+ ;                  ( buf size )
```
#endif
#include "align.i65"
dodashbuf
    jsr dodoes
#include "page.i65"
    .word cfetch
#include "page.i65"
    .word tor
#include "page.i65"
dbuf01
    .word oneminus
#include "page.i65"
    .word twodup
#include "page.i65"
    .word plus
#include "page.i65"
    .word cfetch
#include "page.i65"
    .word rfetch
#include "page.i65"
    .word eq
#include "parm.i65"
    .word qbranch
    .byt <(dbuf02-*+1)
#include "pad.i65"
    .word dup
#include "page.i65"
    .word zlt
#include "parm.i65"
    .word qbranch
    .byt <(dbuf01-*+1)
#include "pad.i65"
dbuf02
    .word rdrop
#include "page.i65"
    .word oneplus
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=-NULLS
stack=( addr +n1 -- addr +n2 )
tags=nucleus

 The character count +n1 of a text string beginning at addr
 is adjusted to exclude trailing nulls.  If +n1 is zero,
 then +n2 is also zero.  If the entire string consists of
 nulls, then +n2 is zero.

#endif
dashnulls
    jsr dodashbuf
    .byt 0

;--------------------------------------------------------------
#if 0
name=-TRAILING
stack=( addr +n1 -- addr +n2 )
tags=nucleus

 The character count +n1 of a text string beginning at addr
 is adjusted to exclude trailing spaces.  If +n1 is zero,
 then +n2 is also zero.  If the entire string consists of
 spaces, then +n2 is zero.

#endif
dashtrailing
    jsr dodashbuf
    .byt ' '

;--------------------------------------------------------------
#if 0
name=CMOVE
stack=( from to howmany -- )
tags=forth-83,nucleus,memory


"~ see http://6502.org/source/general/memory_move.html
#endif
cmove
    sec
    .byt $29
    ; fall through
;--------------------------------------------------------------
#if 0
name=CMOVE>
stack=( from to howmany -- )
tags=forth-83,nucleus,memory
 Move the u bytes beginning at address addr1 to
 addr2.  The move begins by moving the byte at
 (addr1 plus u minus 1) to (addr2 plus u minus 1)
 and proceeds to successively lower addresses
 for u bytes.  If u is zero nothing is moved.
 Useful for sliding a string towards higher addresses.

#endif
cmovegt
    clc
    jsr harvests4
    stx z                       ; stash the data stack pointer
    lda #>(drop-1)
    pha
    lda #<(drop-1)
    pha
    bcs cmoves+2
cmovegts
    ldx tos+1
    clc
    txa
    adc n+1
    sta n+1
    clc
    txa
    adc n+3
    sta n+3
    inx
    ldy tos
    beq cmovegt03
    dey
    beq cmovegt02
cmovegt01
    lda (n),y
    sta (n+2),y
    dey
    bne cmovegt01
cmovegt02
    lda (n),y
    sta (n+2),y
cmovegt03
    dey
    dec n+1
    dec n+3
    dex
    bne cmovegt01
    beq cmove03     ; bra

;cmove, callable as a subroutine
; n0 = from
; n1 = to
; tos = howmany
; clear Carry on entry to copy < 256 bytes
cmoves
    bcc cmove02
    ;sec            ; assume more pagers.
    ldx #0
cmove01
    dec tos+1
    bpl cmove02     ; do a whole page
    ldx tos         ; last page
    beq cmove03     ; none at all?
; move X bytes from (N0) to (N1), restore X and return
    clc             ; exit after this iteration
; alternative cmove entry point, come here for shortest fastest bursts
; be sure to `clc   stx z   ldy #0` first
cmove02
    lda (n),y
    sta (n+2),y
    iny
    dex
    bne cmove02
    inc n+1
    inc n+3
    bcs cmove01
cmove03
    ldx z       ; revive the data stack pointer
    rts
    ;jmp drop    ; [37]

;--------------------------------------------------------------
#if 0
name=MOVE
stack=( from to howmany -- )
tags=nucleus,memory
 Move the `howmany` bytes beginning at `from` to
 `to`.  Designed to prevent clobber if both memory regions
 overlap.

```
: move   ( from to howmany -- )
     >r 2dup u< r> swap
     ?: cmove> cmove ;


     dup 2over u< nip  ?: cmove> cmove ;
```
#endif
#include "align.i65"
_move
    jsr enter
#include "page.i65"
    .word dup
#include "page.i65"
    .word twoover
#include "page.i65"
    .word ult
#include "page.i65"
    .word nip
#include "parm.i65"
    .word pquerycolon
    .word cmovegt
    .word cmove
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=+MOVE
stack=( start end delta -- )
tags=nucleus

 Move a block of memory between start and end (inclusive) to
 a new address calculated by adding the signed delta to start

```
 for example, x = (5 of each letter)     AAAAABBBBBCCCCCDDDDD
 after  x 8 + x 11 + -7 +move, x becomes ABBCCBBBBBCCCCCDDDDD
 vidram dup 3+ 3+ 12 +move

: +move   ( start end delta -- )
    ?dup
    if
        >r over - 1+
                                ( start size ; delta )
         over r> + swap move    ( start size start+delta )
    else
        2drop
    then ;
```
#endif
#include "align.i65"
_plusmove
    jsr enter
#include "page.i65"
    .word qdup
#include "parm.i65"
    .word qbranch
    .byt <(plusmove01-*+1)
#include "pad.i65"
    .word tor
#include "page.i65"
    .word over
#include "page.i65"
    .word minus
#include "page.i65"
    .word oneplus               ; ( from howmany ) ( R; delta )
#include "page.i65"
    .word over
#include "page.i65"
    .word rfrom
#include "page.i65"
    .word plus
#include "page.i65"
    .word swap                  ; ( from to howmany )
#include "page.i65"
    .word _move
#include "parm.i65"
    .word branch
    .byt <(plusmove02-*+1)
#include "pad.i65"
plusmove01
    .word twodrop
#include "past.i65"
plusmove02
    .word exit

;--------------------------------------------------------------
#if 0
name=PAD
stack=( -- addr )
tags=nucleus,forth-83

 The lower address of a scratch area used to hold data for
 intermediate processing.  The address or contents of PAD may
 change and the data lost if the address of the next
 available dictionary location is changed.  The minimum
 capacity of PAD is 84 characters.

#endif
#include "align.i65"
_pad
    jsr enter
#include "page.i65"
    .word here
#include "page.i65"
    .word eighty
#include "page.i65"
    .word plus
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=S>D
stack=( s -- d )
tags=nucleus
sign-extends a single into a double


```
: s>d   ( s -- d )
    dup 0< ;

stod
    lda tos+1
    eor #$80
    asl
    lda #0
    sbc #0
    tay
    jmp pushya
;[13 bytes, 16 cycles] chitselb OG
```
#endif
stod
    lda #$7f
    cmp tos+1    ; clear carry if negative
    sbc #$7f     ; $00 for +, $ff for -
    tay
    jmp pushya
;~~~code golf~~~
;[-3 bytes, -4 cycles] barrym95838 2020-03-30

;--------------------------------------------------------------
#if 0
name=C>S
stack=( c -- s )
tags=nucleus
sign-extends a character into a single
#endif
ctos
    ldy #0
    lda tos
    bpl ctos01
    dey
ctos01
    jmp put

;--------------------------------------------------------------
#if 0
name=SGN
stack=( n -- -1|0|1 )
tags=nucleus

 return the sign of n

#endif
sgn
    ldy #$FF
    lda tos+1
    bmi sgn01       ; negative
    iny
    ora tos
    beq sgn01       ; zero
    lda #1          ; positive
    .byt $24        ; BIT zp to skip over tya
sgn01
    tya
    jmp put

;--------------------------------------------------------------
#if 0
name=RANDUS
stack=( -- r )
tags=nucleus,subroutine,nosymbol

 return a random byte in the range 0..255
 from the [[First Book of KIM-1|http://users.telenet.be/kim1-6502/6502/fbok.html]]. Also see [[RND]] and [[RANDOM]]

#endif
randu
    txa                         ; replaced `stx z` so this can be used in IRQ
    pha
    sec
    lda randbuff+1
    adc randbuff+4
    adc randbuff+5
    sta randbuff
    ldx #4
rpl
    lda randbuff,x
    sta randbuff+1,x
    dex
    bpl rpl
    pla
    tax
    lda randbuff+1
    rts

;--------------------------------------------------------------
#if 0
name=RND
stack=( -- r )
tags=nucleus

 return a random number in the range 0..65535
 from the [[First Book of KIM-1|http://users.telenet.be/kim1-6502/6502/fbok.html]]

#endif
rnd
    jsr randu
    tay
    .byt $2C                    ; bit abs, skip two bytes
;--------------------------------------------------------------
#if 0
name=RANDU
stack=( -- r )
tags=nucleus

 return a random number in the range 0..65535
 from the [[First Book of KIM-1|http://users.telenet.be/kim1-6502/6502/fbok.html]]

#endif
randuc
    ldy #0
randu2
    jsr randu
    jmp pushya

;--------------------------------------------------------------
#if 0
name=RANDOM
stack=( -- a )
tags=nucleus

 Returns the address of the 6-byte random number buffer

#endif
random
    jsr docreate
randbuff
    .byt $08,$12,$b3,$16,$29,$62        ; random number seed

;--------------------------------------------------------------
#if 0
name=2+!
stack=( n -- )
tags=nucleus
Add 2 to the word addressed by `n`

#endif
twoplusstore
    sec
    .byt $29                    ; AND imm, skips `clc`
;--------------------------------------------------------------
#if 0
name=1+!
stack=( n -- )
tags=nucleus

 increments the word addressed by n

#endif
oneplusstore
    clc
    ldy #$FF
    lda #1
oneplusstore01
    iny
    adc (tos),y
    sta (tos),y
    tya
    beq oneplusstore01
    jmp drop

;--------------------------------------------------------------
#if 0
name=1-!
stack=( n -- )
tags=nucleus

Decrement the word of memory at address `n`

#endif
oneminusstore
    ldy #$FF
    clc
onemin01
    iny
    lda (tos),y
    sbc #0
    sta (tos),y
    tya
    beq onemin01
    jmp drop

.dsb 5,0

;--------------------------------------------------------------
#if 0
name=>MINMAX
stack=( n1 n2 -- n )
tags=nucleus,nosymbol
leverage similarities of [[MIN]] and [[MAX]]

```
: minmax   ( cfa == ; n1 n2 addr1 -- n )
    <builds , does>             \ defining word not built into asm source
    3dup rot @ execute choose ;
```

>C:0000  03 00 00 00  a2 06 19 ff  04 40 0b 59  06 60 07 70   c@@@.fy.d@kYf`gp
>C:0010  08 80 09 90  04 59 34 d5  00 01 0d d0  00 83 86 00   h.i.dY4U@amP@..@
>C:0040  aa aa aa aa  aa aa aa 08  88 6c 07 04  0b 8a 98 01   .......h.lgdk..a
>C:0070  bb bb bb bb  bb bb bb 00  06 06 00 00  59 07 75 10   .......@ff@@Ygup
>C:0080  00 00 00 00  74 06 e6 8b  e6 8b 6c c0  18 00 05 2e   @@@@tf....l.x@e.
>C:01e0  65 57 e4 00  2d 05 20 5c  04 80 6b 4b  0a db 75 4b   eW.@-e \d.kKj.uK
>C:01f0  68 32 68 05  66 61 66 b0  1a 81 b7 00  01 01 41 fd   h2hefaf.z..@aaA.
.C:0d17  20 D1 10    JSR .dodoes    - A:00 X:2B Y:00 SP:ea N.-.....   37294261

>C:18c0  31 0d 46 0a                                          1mFj

.C:0a46   .false:
.C:0a46  18          CLC
.C:0a47  29 38       AND #$38

.C:0d31   .max:
.C:0d31  20 17 0D    JSR .dominmax

>C:0d31  20 17 0d 5b  0a                                       wm[j

.C:0a5b   .lt:
.C:0a5b  20 85 0A    JSR .sub16
(C:$0da7) m d10
>C:0d10  9d 0f 00 00  00 00 00 20  d1 10 c3 0f  de 08 b8 12   .o@@@@@ QpCo.h.r
>C:0d20  e0 13 1d 10  0a 10 25 09  9d 0f 69 11  20 17 0d cc    s]pjp%i.oiq wmL
>C:0d30  0a 20 17 0d  5b 0a 20 03  11 b8 12 29  09 4c 09 29   j wm[j cq.r)iLi)
>C:0d40  09 d4 07 ec  12 b5 08 80  0a 8e 11 04  8b 12 69 11   iTg.r.h.j.qd.riq
>C:0d50  20 03 11 de  08 36 0d e0  13 7d 0d 69  11 20 03 11    cq.h6m s}miq cq
>C:0d60  36 0d 9d 0f  69 11 20 6c  0d 4c 86 00  48 48 10 01   6m.oiq lmL.@HHpa
>C:0d70  88 ca ca 68  68 a0 00 20  6c 0d 4c 25  09 20 03 11   .JJhh @ lmL%i cq
>C:0d80  9d 0f 69 11  20 6c 0d 4c  9d 0f 4c 86  00 8a 49 ff   .oiq lmL.oL.@.I.
>C:0d90  38 69 30 4c  2a 12 ca b5  51 4a 95 50  b5 21 48 29   8i0L*rJ.QJ.P.!H)

>C:18c0  31 0d 46 0a  c3 11 07 b7  18 4e 11 fd  69 11 20 ed   1mFjCqg.xNq.iq .
>C:18d0  06 18 a5 02  6d a0 06 8d  a0 06 a5 03  6d a1 06 8d   fx.bm f. f.cm.f.
>C:18e0  a1 06 c4 02  d0 07 c6 03  10 03 4c 9d  0f b1 04 20   .fDbPgFcpcL.o.d
>C:18f0  d2 ff c8 d0  ed e6 05 d0  e9 20 03 11  c3 09 73 11   R.HP..eP. cqCisq
>C:1900  ce 18 69 11  20 03 11 cc  07 02 0d cc  07 c3 0f 8c   Nxiq cqLgbmLgCo.
>C:1910  0f 69 11 20  03 11 86 0c  cc 07 8e 0f  69 11 20 03   oiq cq.lLg.oiq c
>C:1920  11 9c 0f cc  07 c3 0f 86  0c 45 09 15  09 69 11 20   q.oLgCo.lEiuiiq
>C:1930  03 11 80 0a  8e 11 07 79  11 2d 04 19  69 11 a5 02   cq.j.qgyq-dyiq.b
>C:1940  f8 c9 0a 69  30 d8 85 02  4c 86 00 20  03 11 8a 07   .Iji0X.bL.@ cq.g
(C:$1950)

#endif
#include "align.i65"
dominmax
    jsr dodoes
#include "page.i65"
    .word fetch
#include "page.i65"
    .word tor
#include "page.i65"
    .word twodup
#include "page.i65"
    .word rfrom
#include "page.i65"
    .word execute
#include "parm.i65"
    .word pquerycolon
    .word nip
    .word drop
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=MIN
stack=( n1 n2 -- n )
tags=forth-83,nucleus
Returns the lower of the two signed arguments

```
' >  minmax min
```
#endif
#include "align.i65"
min
    jsr dominmax
    .word gt

;--------------------------------------------------------------
#if 0
name=MAX
stack=( n1 n2 -- n )
tags=forth-83,nucleus
Returns the higher of the two signed arguments

```
' <  minmax max
```
#endif
#include "align.i65"
max
    jsr dominmax
    .word lt

;--------------------------------------------------------------
#if 0
name=M*
stack=( n1 n2 -- d )
tags=nucleus
Multiply two signed words, leaving the double product on the stack

```
: m*   ( n1 n2 -- d )
    2dup abs swap abs um*
    2swap eor 0< if dnegate then ;

mstar
    jsr mult
    jmp next
mult
    lda stackl,x
    sta n+4
    lda stackh,x
    sta n+5
    eor tos+1
    php                     ; we only care about the sign bit
    bit tos+1
    bpl mult01
    jsr donegate
mult01
    bit n+5
    bpl mult02
    sec
    lda #0
    sbc n+4
    sta n+4
    lda #0
    sbc n+5
    sta n+5
mult02
    ;jsr multiply
    lda n+1
    sta stackh,x
    lda n
    sta stackl,x
    lda n+3
    sta tos+1
    lda n+2
    sta tos
    plp
    bpl mult03
    jmp dodnegate
mult03
    rts

```



#endif
#include "align.i65"
_mstar
    jsr enter
#include "page.i65"
    .word twodup
#include "page.i65"
    .word abs
#include "page.i65"
    .word swap
#include "page.i65"
    .word abs
#include "page.i65"
    .word _umstar
#include "page.i65"
    .word twoswap
#include "page.i65"
    .word xor
#include "page.i65"
    .word zlt
#include "parm.i65"
    .word qbranch
    .byt <(mstar01-*+1)
#include "pad.i65"
    .word dnegate
#include "past.i65"
mstar01
    .word exit

;--------------------------------------------------------------
#if 0
name=M*/
stack=( n1 n2 n3 -- d )
tags=nucleus

 multiplies n1*n2 giving an intermediate 16-bit value, and divides
 that by n3 yielding a 16-bit quotient.  Remainder is ignored,
 all values are signed.

~ 16-bit intermediate value? is this in the standard?

```
: m*/   ( n1 n2 n3 -- d )
    >r m* r> m/ ;
```
#endif
#include "align.i65"
_mstarslash
    jsr enter
#include "page.i65"
    .word tor
#include "page.i65"
    .word _mstar
#include "page.i65"
    .word rfrom
#include "page.i65"
    .word _mslash
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=*
stack=( n1 n2 -- n1*n2 )
tags=forth-83,nucleus

 multiply two signed words
#endif
#include "align.i65"
_star
    jsr enter
#include "page.i65"
    .word _mstar
#include "page.i65"
    .word drop
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=/MOD
stack=( n1 n2 -- n3 n4 )
tags=forth-83,nucleus

 n3 is the remainder and n4 the floor of the
 quotient of n1 divided by the divisor n2.  n3
 has the same sign as n2 or is zero.  An error
 condition results if the divisor is zero or if
 the quotient falls outside the range {-32,768
 ... 32,676}.
~todo: should probably use ud/mod and then set signs
~todo: division/modulo/multiplication words are kind of a mess

```
          division, floored
               Integer division in which the remainder carries the sign of
               the divisor or is zero, and the quotient is rounded to its
               arithmetic floor.  Note that, except for error conditions,
               n1 n2 SWAP OVER /MOD ROT * + is identical to n1.
               See: "floor, arithmetic"
               Examples:
                    dividend  divisor  remainder  quotient
                      10        7        3          1
                     -10        7        4         -2
                      10       -7       -4         -2
                     -10       -7       -3          1
```
#endif
slashmod
    jsr doslashmod
    jmp next
doslashmod
    ;       lda stack+1,x
    pha
    ;       lda stack,x
    pha
    ;       lda stack+3,x
    bpl doslashmod01
    dey
doslashmod01
    ;       sty stack,x
    ;       sty stack+1,x
    dex
    dex
    pla
    ;       sta stack,x
    pla
    ;       sta stack+1,x
    ldy #0
;    jmp domslash

;--------------------------------------------------------------
#if 0
name=/
stack=( n1 n2 -- n3 )
tags=forth-83,nucleus

 n3 is the floor of the quotient of n1 divided
 by the divisor n2.  An error condition results
 if the divisor is zero or if the quotient falls
 outside the range {-32,768 ... 32,767}.
#endif
slash
    jsr doslashmod
    jmp nip

;--------------------------------------------------------------
#if 0
name=M/
stack=( n1 n2 -- n3 )
tags=forth-83,nucleus

 n3 is the floor of the quotient of n1 divided
 by the divisor n2.  An error condition results
 if the divisor is zero or if the quotient falls
 outside the range {-32,768 ... 32,767}.
#endif
#include "align.i65"
_mslash
    jsr enter
#include "page.i65"
    .word drop                  ; effectively divides by 1; broken! ~~fix
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=MOD
stack=( n1 n2 -- n3 )
tags=forth-83,nucleus

 n3 is the remainder after dividing n1 by the
 divisor n2.  n3 has the same sign as n2 or is
 zero.  An error condition results if the
 divisor is zero or if the quotient falls out-
 side the range {32,768...32,768}.

#endif
mod
    jsr doslashmod
    jmp drop

;--------------------------------------------------------------
#if 0
name=*/MOD
stack=( n1 n2 n3 -- n4 n5 )
tags=forth-83,nucleus

 n1 is first multiplied by n2 producing an inter-
 mediate 32 bit result.  n4 is the remainder and
 n5 is the floor of the quotient of the inter-
 mediate 32-bit result divided by the divisor
 n3.  A 32-bit intermediate product is used for
 */ .  n4 has the same sign as n3 or is zero.
 An error condition results if the divisor is
 zero or if the quotient falls outside of the
 range {-32,768...32,767}.

#endif
starslashmod

;--------------------------------------------------------------
#if 0
name=*/
stack=( n1 n2 n3 -- n4 )
tags=forth-83,nucleus

 n1 is first multiplied by n2 producing an inter-
 mediate 32-bit result.  n4 is the floor of the
 quotient of the intermediate 32-bit result
 divided by the divisor n3.  The product of n1
 times n2 is maintained as an intermediate 32-
 bit result for greater precision than the other-
 wise equivalent sequence n1 n2 * n3 / .  An
 error condition results if the divisor is zero
 or if the quotient falls outside the range
 {-32,768...32,767}.

#endif
starslash
    jmp next

;--------------------------------------------------------------
#if 0
name=HERE<
stack=( -- addr )
tags=nucleus,extra
Push lower byte of `dp` to the stack

#endif
herelsb
    sec
    .byt $29
;--------------------------------------------------------------
#if 0
name=HERE
stack=( -- addr )
tags=nucleus,forth-83

#endif
here
    clc
    ;
    lda userdp
    bcs depth01 ; push0a
    ldy userdp+1
    jmp pushya

;--------------------------------------------------------------
#if 0
name=DEPTH
stack=( -- n )
tags=forth-83,nucleus
Returns the depth of the data stack
#endif
depth
    txa
    eor #$ff
    sec
    adc #<bos
depth01
    jmp push0a

;--------------------------------------------------------------
#if 0
name=>BIT
stack=( bit# base -- mask addr )
tags=nucleus,ext
Indexes `bit#` bits into a bit array starting at `base`, returns a `mask` and
`addr` for [[CBIT!]] or [[CBIT@]]

addressing a bit field

mask = 2^(n%8)

offset = n/8

e.g.

```
0 8192 >bit . . 8192 128  ok
7 8192 >bit . . 8192 1  ok
19 8192 >bit . . 8194 16  ok
```


```
: >bit   ( bit# base -- mask offset )
        over 7 and power2 + c@ -rot
        swap 2/ 2/ 2/ + ;

```
#endif
tobit
    dex
    lda stackh+1,x
    lsr
    sta stackh,x
    lda stackl+1,x
    pha
    and #7
    tay
    lda power2,y
    sta stackl+1,x
    pla
    ror
    lsr stackh,x
    ror
    lsr stackh,x
    ror
    sta stackl,x
    jmp plus01

;--------------------------------------------------------------
#if 0
name=$!
stack=( addr1 size addr2 -- )
tags=string,nucleus,ext
Copies `size` bytes from `addr1` to `addr2+1` as a counted string, storing
`size` at `addr2`

e.g. `2000 COUNT 2008 $!`

|addr|before|after|h
|2000|3|3|
|2001|'F'|'F'|
|2002|'O'|'O'|
|2003|'O'|'O'|
|2004|-|-|
|2005|-|-|
|2006|-|-|
|2007|-|-|
|2008|-|3|
|2009|-|'F'|
|200A|-|'O'|
|200B|-|'O'|
|200C|-|-|

```
: $!   ( addr1 size addr2 -- )
    over c!+ swap move ;
```
#endif
#include "align.i65"
_dolstore
    jsr enter
#include "page.i65"
    .word over
#include "page.i65"
    .word cstoreplus
#include "page.i65"
    .word swap
#include "page.i65"
    .word _move
#include "past.i65"
    .word exit

;--------------------------------------------------------------
#if 0
name=!+
stack=( addr n -- addr+2 )
tags=nucleus

Stores n at addr, returns the following address

note: Does an inverted store operation!

!!! pronounced: "store-plus"

`PAD 4096 0 DO I !+ LOOP DROP`

* 109 jiffies, 11 bytes (Forth)
* 245 jiffies, 7 bytes (Sweet16)
* 65 jiffies, 25 bytes (6502)

```
storeplus
    brk
    .byt ld | TOS
    .byt st | N0
    .byt pull
    .byt ld | N0
    .byt std | TOS
    .byt nxt
;[7]

storeplus
    lda tos+1
    pha
    lda tos
    pha
    jsr slide
    ldy #0
    pla
    sta (tos),y
    iny
    pla
    sta (tos),y
    jmp twoplus
;[21]
```
#endif
#include "align.i65"
_storeplus
    jsr enter
#include "page.i65"
    .word over
#include "page.i65"
    .word store
#include "page.i65"
    .word twoplus
#include "past.i65"
    .word exit
;[11]

;--------------------------------------------------------------
#if 0
name=C!+
stack=( addr c -- addr+1 )
tags=nucleus,memory,primitive
The least-significant 8 bits of c are stored into the byte
at addr, and addr is incremented by one

!!!pronounced: "c-store-plus"
#endif
cstoreplus
    ldy tos
    jsr slide
    tya
    ldy #0
    sta (tos),y
    beq oneplus                 ; bra

;--------------------------------------------------------------
#if 0
name=DOCREATE
stack=( -- addr )
tags=nosymbol,inner
The business end of words created by CREATE, returns the address
of the calling word plus 1
#endif
#include "align.i65"
docreate
    jsr slip
    pla
    sta tos
    pla
    sta tos+1
    ; fall through
;--------------------------------------------------------------
#if 0
name=1+
stack=( n -- n+1 )
tags=forth-83,nucleus
Add 1 to top of stack

#endif
oneplus
    lda #>(next-1)
    pha
    lda #<(next-1)
    pha
    ;fall through
;--------------------------------------------------------------
#if 0
name=INCTOS
stack=( n -- n+1 )
tags=nosymbol
increment TOS; sets the Z flag according to `tos`

`z` flag 0 - tos = 0
         1 - tos <> 0
#endif
inctos
    inc tos             ;{5}
    bne inctos01        ;{3}
    inc tos+1
inctos01
    rts                 ;{6|14}