FL




\ these variables are the current dictionary limits
\ cannot really easily redefine these variable on a running forth system, it really screws things up
\ to redefine requires multiple steps and caution, not worth the bother usually

\ mswMemend  w@ wvariable mswMemend  mswMemend  w!
\ mswHere    w@ wvariable mswHere    mswHere    w!
\ mswDictend w@ wvariable mswDictend mswDictend w! 

\ constants which reference the cogdata space are effectively variables with
\ a level of indirection. refedinition of these, if the base variable is the same
\ is reasonable and can be done on a running system

\ caution with other variables

\ these constants are all intialized to the running values, so any following words compile correctly
\ if you add constants that are used by the base compiler, follow the practice
\ any word constant which begins with cm_xxx is compiled with the value @xxxPFA + $10 - which is the exection address
\ any word constant which begins with ca_xxx is copiled with the value (@xxx - @a_base)/4 - execution address

\ cogid if the cog had an over/underflow
-1 wvariable vxcog vxcog w!

\ first forth cog
ffcog w@ wvariable ffcog ffcog w!

\ the last forth cog
lfcog w@ wvariable lfcog lfcog w!

cm_serentry wconstant cm_serentry
cm_entry wconstant cm_entry

\ this is a pointer to the main cogdata area
cm_cogdata	wconstant	cm_cogdata
\ this is ' cq - the routine which handles the word c"
cm_cq	wconstant	cm_cq
\ this is ' dq - the routine which handles the word ."
cm_dq		wconstant	cm_dq

\ these constants are all assembler addresses
ca_a_exit	wconstant ca_a_exit
ca_a_dovarw	wconstant ca_a_dovarw
ca_a_doconw	wconstant ca_a_doconw
ca_a_branch	wconstant ca_a_branch
ca_a_litw	wconstant ca_a_litw
ca_a_2>r	wconstant ca_a_2>r
ca_a_(loop)	wconstant ca_a_(loop)
ca_a_(+loop)	wconstant ca_a_(+loop)
ca_a_0branch	wconstant ca_a_0branch
ca_a_dovar	wconstant ca_a_dovar
ca_a_docon	wconstant ca_a_docon
ca_a_literal	wconstant ca_a_literal
ca_a_debugonoff wconstant ca_a_debugonoff
ca_a_reset	wconstant ca_a_reset
ca_a_ifunc	wconstant ca_a_ifunc
ca_a_ifunc1	wconstant ca_a_ifunc1
ca_a_ifunc2	wconstant ca_a_ifunc2
ca_a_umstarlp	wconstant ca_a_umstarlp
ca_a_umslashmodlp wconstant ca_a_umslashmodlp	
ca_a_cstreqlp wconstant ca_a_cstreqlp	
ca_a_finlp wconstant ca_a_finlp	

\ addresses for the stack routines
ca_a_stPush		wconstant ca_a_stPush
ca_a_stPush_ret		wconstant ca_a_stPush_ret
ca_a_rsPush		wconstant ca_a_rsPush
ca_a_rsPush_ret		wconstant ca_a_rsPush_ret
ca_a_stPop		wconstant ca_a_stPop
ca_a_stPoptreg		wconstant ca_a_stPoptreg
ca_a_stPop_ret		wconstant ca_a_stPop_ret
ca_a_stPoptreg_ret	wconstant ca_a_stPoptreg_ret
ca_a_rsPop		wconstant ca_a_rsPop
ca_a_rsPop_ret		wconstant ca_a_rsPop_ret

\ address for the a_next routine
ca_a_next	wconstant ca_a_next

\ this group of words needs to align with the assembler code
ca_varStart	wconstant ca_varStart
ca_varEnd	wconstant ca_varEnd
: _cv ca_varStart + ;
\ : aCondMask 0 _cv ;
: fMask 0 _cv ;
: fAddrMask 1 _cv ;
: fLongMask 2 _cv ;
: resetDreg 3 _cv ;
: IP 4 _cv ;
: stPtr 5 _cv ;
: rsPtr 6 _cv ;
: stTOS 7 _cv ;

: treg1 8 _cv ;
\ : treg2 9 _cv ;
\ : treg3 a _cv ;
\ : treg4 b _cv ;
\ : treg5 c _cv ;
\ : treg6 d _cv ;
: stBot e _cv ;
: stTop 2e _cv ;
: rsBot stTop ;
: rsTop 4e _cv ;

\ this is space constant
bl		wconstant bl
\ -1 or true, used frequently
-1		constant -1
\ 0 or false, used frequently
0		wconstant 0
\ this is the par register, always initalized to point to this cogs section of cogdata
1F0	wconstant par
\ the other cog special registers
1F1	wconstant cnt
1F2	wconstant ina
\ 1F3	wconstant inb
1F4	wconstant outa
\ 1F5	wconstant outb
1F6	wconstant dira
\ 1F7	wconstant dirb
1F8	wconstant ctra
1F9	wconstant ctrb
1FA	wconstant frqa
1FB	wconstant frqb
1FC	wconstant phsa
1FD	wconstant phsb
1FE	wconstant vcfg
1FF	wconstant vscl

\ this variable define the number of loops for a key timeout
\ used by keyTO, fast_load, f_write, and after an undefined word
mswKeyTO  w@ wvariable mswKeyTO  mswKeyTO  w!

\ use in the ifuncs to get rid of litw word
: cnip mswHere w@ 2- dup w@ over 2- w! mswHere w! ; immediate

\ ifunc ( n1 n2 -- n ) \ the assembler operation is specified by the literal which follows (replaces the i field)

' ifunc asmlabel ifunc

\ ifunc1 ( n -- n ) \ the assembler operation is specified by the literal which follows (replaces the i field)

' ifunc1 asmlabel ifunc1

\ ifunc2 ( n1 n2 -- ) \ the assembler operation is specified by the literal which follows (replaces the i field)

' ifunc2 asmlabel ifunc2

\ fin ( nfa cstr -- n1) the nfa match in the dictionary, or 0 if not found
' fin asmlabel fin

\ mpx ( n -- t/f ) n is the bit mask to read in
' mpx asmlabel mpx

\ mpxl ( n -- ) set the bits in n low
' mpxl asmlabel mpxl

\ mpxh ( n -- ) set the bits in n hi
' mpxh asmlabel mpxh

\ name= ( nfa cstr -- t/f)
' name= asmlabel name= 

\ cstr= ( cstr cstr -- t/f)
' cstr= asmlabel cstr= 

\ abs ( n1 -- abs_n1 ) \ absolute value of n1
: abs ifunc1 151 cnip ;

\ and ( n1 n2 -- n1 ) \ bitwise and n1 n2
: and ifunc 0C1 cnip ;

\ andn ( n1 n2 -- n1 ) \ bitwise and n1 invert n2
: andn ifunc 0C9 cnip ;

\ !d ( n1 n2 -- n1 ) set the d field of n1 with n2
: !d ifunc 0A9 cnip ;

\ !i ( n1 n2 -- n1 ) set the i field of n1 with n2
: !i ifunc 0B1 cnip ;

\ !s ( n1 n2 -- n1 ) set the s field of n1 with n2
: !s ifunc 0A1 cnip ;

\ m@ ( addr -- n1 ) \ fetch 32 bit value at main memory addr
: m@ ifunc1 011 cnip ;

\ c@ ( addr -- c1 ) \ fetch 8 bit value at main memory addr
: c@ ifunc1 001 cnip ;

\ w@ ( addr -- h1 ) \ fetch 16 bit value at main memory addr
: w@ ifunc1 009 cnip ;

\ @ ( addr -- n1 ) \ fetch 32 bit value at cog addr
' @ asmlabel @

\ m! ( n1 addr -- ) \ store 32 bit value (n1) at main memory addr
: m! ifunc2 010 cnip ;

\ c! ( c1 addr -- ) \ store 8 bit value (c1) main memory at addr
: c! ifunc2 000 cnip ;

\ w! ( h1 addr -- ) \ store 16 bit value (h1) main memory at addr
: w! ifunc2 008 cnip ;

\ ! ( n1 addr -- ) \ store 32 bit value (n1) at cog addr
' ! asmlabel !

\ branch \ 16 bit branch offset follows -  -2 is to itself, +2 is next word
' branch asmlabel branch

\ hubop ( n1 n2 -- n3 t/f ) n2 specifies which hubop (0 - 7), n1 is the source data, n3 is returned, 
\ t/f is the 'c' flag is set from the hubop

' hubop asmlabel hubop

\ doconw ( -- h1 ) \ push 16 bit constant which follows on the stack - implicit a_exit
' doconw asmlabel doconw

\ docon ( -- n1 ) \ push a 32 bit constant which follows the stack - implicit a_exit
' docon asmlabel docon

\ dovarw ( -- addr ) \ push address of 16 bit variable which follows on the stack - implicit a_exit
' dovarw asmlabel dovarw

\ dovar ( -- addr ) \ push address of 32 bit variable which follows the stack - implicit a_exit
' dovar asmlabel dovar

\ drop ( n1 -- ) \ drop the value on the top of the stack
' drop asmlabel drop

\ dup ( n1 -- n1 n1 )
' dup asmlabel dup

\ = ( n1 n2 -- t/f ) \ compare top 2 32 bit stack values, true if they are equal
' = asmlabel =

\ exit \ exit the current forth word, and back to the caller
' exit asmlabel exit

\ > ( n1 n2 -- t/f ) \ flag is true if and only if n1 is less than n2
' > asmlabel >

\ litw ( -- h1 ) \  push a 16 bit literal on the stack
' litw asmlabel litw

\ literal ( -- n1 ) \  push a 32 bit literal on the stack
' literal asmlabel literal

\ lshift (n1 n2 -- n3) \ n3 = n1 shifted left n2 bits
: lshift ifunc 059 cnip ;

\ < ( n1 n2 -- t/f ) \ flag is true if and only if n1 is greater than n2
' < asmlabel <

\ max ( n1 n2 -- n1 ) \ signed max of top 2 stack values
: max ifunc 081 cnip ;

\ min ( n1 n2 -- n1 ) \ signed min of top 2 stack values
: min ifunc 089 cnip ;

\ - ( n1 n2 -- n1-n2 )
: - ifunc 109 cnip ;

\ or ( n1 n2 -- n1_or_n2 ) \ bitwise or
: or ifunc 0D1 cnip ;

\ over ( n1 n2 -- n1 n2 n1 ) \ duplicate 2 value down on the stack to the top of the stack
' over asmlabel over

\ + ( n1 n2 -- n1+n2 ) \ sum of n1 & n2
: + ifunc 101 cnip ;

\ rot ( n1 n2 n3 -- n2 n3 n1 ) \ rotate top 3 value on the stack
' rot asmlabel rot

\ r@ ( -- n1 ) \ copy top of RS to stack
: r@ rsPtr @ 2+ @ ;

\ rshift ( n1 n2 -- n3) \ n3 = n1 shifted right logically n2 bits
: rshift ifunc 51 cnip ;

\ rashift ( n1 n2 -- n3) \ n3 = n1 shifted right arithmetically n2 bits
: rashift ifunc 071 cnip ;

\ r> ( -- n1 ) \ pop top of RS to stack
' r> asmlabel r>

\ >r ( n1 -- ) \ pop stack top to RS
' >r asmlabel >r

\ 2>r ( n1 n2 -- ) \ pop top 2 stack top to RS
' 2>r asmlabel 2>r

\ 0branch ( t/f -- ) \ branch it top of stack value is zero 16 bit branch offset follows,
\ -2 is to itself, +2 is next word
' 0branch asmlabel 0branch

\ (loop) ( -- ) \ add 1 to loop counter, branch if count is below limit offset follows,
\ -2 is to itself, +2 is next word
' (loop) asmlabel (loop)

\ (+loop) ( n1 -- ) \ add n1 to loop counter, branch if count is below limit, offset follows,
\ -2 is to itself, +2 is next word
' (+loop) asmlabel (+loop)

\ swap ( n1 n2 -- n2 n1 ) \ swap top 2 stack values
' swap asmlabel swap

\ um* ( u1 u2 -- u1*u2L u1*u2H ) \ unsigned 32bit * 32bit -- 64bit result
' um* asmlabel um*

\ um/mod ( u1lo u1hi u2 -- remainder quotient ) \ unsigned divide & mod  u1 divided by u2
' um/mod asmlabel um/mod

\ u/mod ( u1 u2 -- remainder quotient ) \ unsigned divide & mod  u1 divided by u2
: u/mod 0 swap um/mod ;

\ xor ( n1 n2 -- n1_xor_n2 ) \ bitwise xor
: xor ifunc 0D9 cnip ;

\ waitcnt ( n1 n2 -- n1 ) \ wait until n1, add n2 to n1
: waitcnt ifunc 1F1 cnip ;

\ waitpeq ( n1 n2 -- ) \ wait until state n1 is equal to ina anded with n2
: waitpeq ifunc2 1E0 cnip ;

\ waitpne ( n1 n2 -- ) \ wait until state n1 is not equal to ina anded with n2
: waitpne ifunc2 1E8 cnip ;

\ vfcog ( n -- n ) makes sure n is a valid forth cog
: vfcog dup ffcog w@ lfcog w@ between 0= if drop ffcog w@ then ;

\ reboot ( -- ) reboot the propellor chip
: reboot FF 0 hubop ;

\ cogstop ( n -- )
: cogstop 3 hubop 2drop ;

\ cogreset ( n1 -- ) reset the forth cog
: cogreset 7 and dup cogstop dup dup cogd dup 100 0 fill 10 lshift cm_entry
2 lshift or or 2 hubop 2drop 
\ wait for the cog to come alive
cogDebugvalue 8000 0 do dup m@ if leave then loop drop ;

\ reset ( -- ) reset this cog
: reset mydictlock w@ 0> if 1 mydictlock w! freedict then cogid cogreset ;

\ disio ( n -- ) disconnect the output of cog n
: disio cogEmitptr 0 swap w! ;

\ connio ( n1 n2 -- ) connect the output from cog n1 to the input of cog n2
: connio 7 and cogInbyte swap 7 and cogEmitptr w! ;

\ >cog ( n1 -- ) connect the console to the forth cog
: >cog cogCON w@ disio inCON over cogEmitptr w! dup cogInbyte outCON w! cogCON w! ;

\ these variables need to be defined after >cog to operate properly when forth is being rebuilt

\ the cog connected to the console
cogCON w@ wvariable cogCON cogCON w!

\ data to the console, a cogs mcwEmitptr points to inCON when it is connected
inCON w@ wvariable inCON inCON w!

\ data from the console, points to a cogs mcwInbyte when it is connected
outCON w@ wvariable outCON outCON w!

\ the CTLa CTLb and CTLc input from the console
ctlCON w@ wvariable ctlCON ctlCON w!

\ clkfreq ( -- u1 ) the system clock frequency
: clkfreq 0 m@ ;

\ parat ( offset -- addr )  the offset is added to the contents of the par register, giving an address references 
\ the cogdata
: parat par @ + ;

\ cogd ( n -- addr) the address of the data area for cog n
: cogd 7 and 8 lshift cm_cogdata + ;

\ mcwInbyte  ( -- addr ) the address of the character input as a word, $100 means no char is ready, otherwise the 
\ next char is in the lo byte, write $100 after the char is read
: mcwInbyte 0 parat ;

: cogInbyte cogd ;

\ mcwEmitptr ( -- addr ) address of the word for memory based emit
: mcwEmitptr 2 parat ;
: cogEmitptr cogd 2+ ;

\ mcwState ( -- addr ) access as a word, the address of a variable which is 
\ 0 - interpret mode
\ 1 - forth compile mode
: mcwState 4 parat ;

\ compile? ( -- t/f ) true if we are in a compile
: compile? mcwState w@ 0<> ;

\ mcwDebugcmd  ( -- addr ) the address of the debugcmd as a word, used to commincate from forth cog to request a reset, 
\ or for traces
: mcwDebugcmd 6 parat ;
: cogDebugcmd cogd 6 + ;

\ mcwDebugvalue  ( -- addr ) the address of the debugvalue as a long, used in conjuction with debugcmd
: mcwDebugvalue 8 parat ;
: cogDebugvalue cogd 8 + ;

\ mcwBase ( -- addr ) access as a word, the address of the base variable
: mcwBase C parat ;

\ mcwAhere ( -- addr ) access as a word, the first unused register address in this cog
: mcwAhere E parat ;

\ execword ( -- addr ) a long, an area where the current word for execute is stored
: execword 10 parat ;

\ execute ( addr -- ) execute the word - pfa address is on the stack
: execute dup fMask @ and if IP ! else execword w! ca_a_exit execword 2+ w! execword IP ! then ;

\ mcw>out ( -- addr ) access as a word, the offset to the current output byte
: mcw>out 14 parat ;

\ mcw>in ( -- addr ) access as a word, addr is the var the offset in characters from the start of the input buffer to
\ the parse area.
: mcw>in 16 parat ;

\ mydictlock ( -- addr ) access as a word, the number of times dictlock has been executed in the cog minus the freedict
: mydictlock 18 parat ;

\ mcwFsliceptr ( -- ) if this is not zero it is called in the key routine
: mcwFsliceptr 1A parat ;

\ the negative of the last time the _fSlice routine was called
: mcLastcnt 1C parat ;

\ the maximum count between calls of _fSlice
: mcFslicecnt 20 parat ;

: _fSlicer cnt @ dup mcLastcnt m@ + mcFslicecnt m@ max mcFslicecnt m! negate mcLastcnt m! ;

\ _fSlice ( -- ) if the fSLicePtr is set  
: _fSlice mcwFsliceptr w@ dup if execute else drop then ;

\ mcPad  ( -- addr ) access as bytes, or words and long, the address of the pad area - used by accept for keyboard input,
\ can be used carefully by other code
: mcPad 24 parat ;
: cogPad cogd 24 + ;

\ _pclr ( addr -- ) fill padsize / 4 longs with blanks, addr must be long aligned
: _pclr dup padsize + swap do 20202020 i m! 4 +loop ;

\ cogPadclr ( n -- ) clear out the pad on cog n
: cogPadclr cogPad _pclr ;

\ pad>in ( -- addr ) addr is the address to the start of the parse area.
: pad>in mcw>in w@ mcPad + ;

\ namemax ( -- n1 ) the maximum name length allowed must be 1F
: namemax 1F ;

\ padsize  ( -- n1 ) the size of the pad area
: padsize 80 ;

\ these are temporay variables, and by convention are only used within a word
\ caution, make sure you know what words you are calling
: mcwT0 A4 parat ;
: mcwT1 A6 parat ;
: mcT A8 parat ; \   40 byte array overflows into mcNumpad

\ mcNumpad ( -- addr ) the of the area used by the numeric output routines, can be used carefully by other code
: mcNumpad C0 parat ;

\ pad>out ( -- addr ) addr is the address to the the current output byte
: pad>out mcw>out w@ mcNumpad + ;

\ numpadsize ( -- n1 ) the size of the numpad
: numpadsize 30 ;

\ keyto ( -- c1 true | false ) a key or a timeout
: keyto 0 mswKeyTO w@ 0 do key? if drop key -1 leave then loop ;

\ emit? ( -- t/f) true if the output is ready for a char
: emit? _fSlice mcwEmitptr w@ dup if w@ 100 and 0<> else drop -1 then ;

\ emit ( c1 -- ) emit the char on the stack
: emit begin emit? until FF and mcwEmitptr w@ dup if w! else 2drop then ;

\ key? ( -- t/f) true if there is a key ready for input
: key? _fSlice mcwInbyte w@ 100 and 0= ;

\ key ( -- c1 ) get a key
: key begin key? until mcwInbyte w@ 100 mcwInbyte w! ;

\ fkey? ( -- c1 t/f ) fast nonblocking key routine
: fkey? mcwInbyte w@ dup 100 and if 0 else 100 mcwInbyte w! -1 then ;

\ nip ( x1 x2 -- x1 )
: nip swap drop ;

\ tuck ( x1 x2 -- x2 x1 x2 )
: tuck swap over ;

\ 2dup ( n1 n2 -- n1 n2 n1 n2 ) copy top 2 items on the stack
: 2dup over over ;

\ 2drop ( n1 n2 -- ) drop top 2 items on the stack
: 2drop drop drop ;

\ 3drop ( n1 n2 n3 -- ) drop top 3 items on the stack
: 3drop drop drop drop ;

\ u/ ( u1 u2 -- u1/u2) u1 divided by u2
: u/ u/mod nip ;

\ u* ( u1 u2 -- u1*u2) u1 multiplied by u2
: u* um* drop ;

\ invert ( n1 -- n2 ) bitwise invert n1
: invert -1 xor ;

\ negate ( n1 -- 0-n1 ) the negative of n1
: negate ifunc1 149 cnip ;

\ 0= ( n1 -- t/f ) true if n1 is zero
: 0= 0 = ;

\ <> ( x1 x2 -- flag ) flag is true if and only if x1 is not bit-for-bit the same as x2. 
: <> = invert ;

\ 0 <> ( n1 -- t/f ) true if n1 is not zero
: 0<> 0= invert ; 

\ 0< ( n1 -- t/f ) true if n1 < 0
: 0< 0 < ;

\ 0> ( n1 -- t/f ) true if n1 > 0
: 0> 0 > ;

\ 1+ ( n1 -- n1+1 )
: 1+ 1 + ;

\ 1- ( n1 -- n1-1 )
: 1- 1 - ;

\ 2+ ( n1 -- n1+2 )
: 2+ 2 + ;

\ 4+ ( n1 -- n1+4 )
: 4+ 4 + ;

\ 2- ( n1 -- n1-2 )
: 2- 2 - ;

\ 2* ( n1 -- n1<<1 ) n2 is shifted logically left 1 bit
: 2* 1 lshift ; 

\ 2/ ( n1 -- n1>>1 ) n2 is shifted arithmetically right 1 bit
: 2/ 1 rashift ; 

\ rot2 ( x1 x2 x3 -- x3 x1 x2 )
: rot2 rot rot ;

\ >= ( n1 n2 -- t/f) true if n1 >= n2
: >= 2dup > rot2 = or ;

\ <= ( n1 n2 -- t/f) true if n1 <= n2
: <= 2dup < rot2 = or ;

\ 0>= ( n1 -- t/f ) true if n1 >= 0
: 0>= dup 0 > swap 0= or ;

\ w+! ( n1 addr -- ) add n1 to the word contents of address
: w+! dup w@ rot + swap w! ;

\ orc! ( c1 addr -- ) or c1 with the contents of address
: orc! dup c@ rot or swap c! ;

\ andc! ( c1 addr -- ) and c1 with the contents of address
: andc! dup c@ rot and swap c! ;

\ between ( n1 n2 n3 -- t/f ) true if n2 <= n1 <= n3
: between rot2 over <= rot2 >= and ;

\ cr ( -- ) emits a carriage return
: cr D emit ;

\ space ( -- ) emits a space
: space bl emit ;

\ spaces ( n -- ) emit n spaces
: spaces dup if 0 do space loop else drop then ;

\ .hex ( n -- ) emit a single hex digit
: .hex F and 30 + dup 39 > if 7 + then emit ;

\ .byte ( n -- ) emit 2 hex digits
: .byte dup 4 rshift .hex .hex ;

\ .word ( n -- ) emit 4 hex digits
: .word dup 8 rshift .byte .byte ;

\ .long ( n -- ) emit 8 hex digits
: .long dup 10 rshift .word .word ;

\ bounds ( x n -- x+n x )
: bounds over + swap ;

\ alignl ( n1 -- n1) aligns n1 to a long (32 bit)  boundary
: alignl 3 + FFFFFFFC and ;

\ alignw ( n1 -- n1) aligns n1 to a halfword (16 bit)  boundary
: alignw 1+ FFFFFFFE and ;

\ c@++ ( c-addr -- c-addr+1 c1 ) fetch the character and increment the address
: c@++ dup c@ swap 1+ swap ;

\ ctolower ( c1 -- c1 ) if c is A-Z converts it to lower case
: ctolower dup 41 5A between if 20 or then ;

\ ctoupper ( c1 -- c1 ) if c is a-z converts it to upper case
: ctoupper dup 61 7A between if DF and then ;

\ todigit ( c1 -- n1 ) converts character to a number 
: todigit ctoupper 30 - dup 9 > if 7 - dup A < if -1 then then ;

\ isdigit ( c1 -- t/f ) true if is it a valid digit according to base
: isdigit todigit dup 0>= swap mcwBase w@ < and ;

\ isunumber ( c-addr len -- t/f ) true if the string is numeric
: isunumber bounds -1 rot2 do i c@ isdigit and loop ;

\ unumber ( c-addr len -- u1 ) convert string to an unsigned number
: unumber bounds 0 rot2 do mcwBase w@ u* i c@ todigit + loop ;

\ number ( c-addr len -- n1 ) convert string to a signed number
: number over c@ 2D = if 1- 0 max swap 1+ swap unumber negate else unumber then ;

\ isnumber ( c-addr len -- t/f ) true if the string is numeric
: isnumber over c@ 2D = if 1- 0 max swap 1+ swap then isunumber ;

\ .str ( c-addr u1 -- ) emit u1 characters at c-addr
: .str dup if bounds do i c@ 20 max 7F min emit loop else 2drop then ;

\ npfx ( c-addr1 c-addr2 -- t/f ) -1 if c-addr2 is prefix of c-addr1, 0 otherwise
: npfx namelen rot namelen rot 2dup > if min bounds do c@++ i c@ <> if drop 0 leave then loop 0<> else 2drop 2drop 0 then ;

\ namelen ( c-addr -- c-addr+1 len ) returns c-addr+1 and the length of the name at c-addr
: namelen c@++ namemax and ;

\ cmove ( c-addr1 c-addr2 u -- ) If u is greater than zero, copy u consecutive characters from the data space starting
\  at c-addr1 to that starting at c-addr2, proceeding character-by-character from lower addresses to higher addresses.
: cmove dup 0= if 3drop else bounds do c@++ i c! loop then drop ;

\ namecopy ( c-addr1 c-addr2 -- ) Copy the name from c-addr1 to c-addr2
: namecopy over namelen 1+ nip cmove ;

\ ccopy ( c-addr1 c-addr2 -- ) Copy the cstr from c-addr1 to c-addr2
: ccopy over c@ 1+ cmove ;

\ cappend ( c-addr1 c-addr2 -- ) addpend the cstr from c-addr1 to c-addr2
: cappend dup dup c@ + 1+ rot2 over c@ over c@ + swap c! dup c@ swap 1+ rot2 cmove ;

\ cappendc ( c cstr -- ) append c the cstr
: cappendc dup c@ 1+ over c! dup c@ + c! ;

\ cappendn ( n cstr -- ) print the number n and append to cstr
: cappendn swap <# #s #> swap cappend ;

\ cappendnc ( n cstr -- ) print the number n and append to cstr and then append a blank
: cappendnc swap <# #s #> over cappend bl swap cappendc ;

\ cogX ( cstr n -- ) execute cstr on cog n
: cogX vfcog dup cogInbyte begin dup w@ 100 and until rot2 dup cogPadclr cogPad 1+ swap c@++ rot swap cmove d swap w! ;

\ cogXO ( cstr -- ) disconnect console input, execute cstr on the next available cog, directing output back to this cog
: cogXO 0 outCON w! cogid dup 1+ vfcog dup rot connio cogX ;

\ ??? ( -- ) prints out ???
: ??? ." ???" ;

\ .strname ( c-addr -- ) c-addr point to a forth name field, print the name
: .strname dup if namelen .str else drop ??? then ;

\ .cstr ( addr -- ) emit a counted string at addr
: .cstr c@++ .str ;

\ dq ( -- ) emit a counted string at the IP, and increment the ip past it and word align it
: dq r> c@++ 2dup + alignw >r .str ;

\ i ( -- n1 ) the most current loop counter
: i rsPtr @ 3 + @ ;

\ j ( -- n1 ) the second most current loop counter
: j rsPtr @ 5 + @ ;

\ ibound ( -- n1 ) the upper bound of i
: ibound rsPtr @ 2+ @ ;

\ jbound ( -- n1 ) the upper bound of j
: jbound rsPtr @ 4+ @ ;

\ lasti? ( -- t/f ) true if this is the last value of i in this loop
: lasti? rsPtr @ 2+ @ 1- rsPtr @ 3 + @ = ;

\ lastj? ( -- t/f ) true if this is the last value of j in this loop
: lastj? rsPtr @ 4+ @ 1- rsPtr @ 5 + @ = ;

\ seti ( n1 -- ) set the most current loop counter
: seti rsPtr @ 3 + ! ;

\ setj ( n1 -- ) set the second most current loop counter
: setj rsPtr @ 5 + ! ;

\ eol? ( c1 -- c1 t/f )  true if c1 == LF or CR
: eol? dup A = over D = or ;

\ bs? ( c1 -- c1 t/f )  true if c1 == BS or DEL
: bs? dup 8 = over 7F = or ;

\ fill ( c-addr u char -- )
: fill rot2 bounds do dup i c! loop drop ;

\ nfa>lfa ( addr -- addr ) go from the nfa (name field address) to the lfa (link field address)
: nfa>lfa 2- ;

\ nfa>pfa ( addr -- addr ) go from the nfa (name field address) to the pfa (parameter field address)

: nfa>pfa 7FFF and namelen + alignw ;

\ nfa>next ( addr -- addr ) go from the current nfa to the prev nfa in the dictionary

: nfa>next nfa>lfa w@ ;

\ lastnfa ( -- addr ) gets the last NFA

: lastnfa mswlastnfa w@ ;

\ fnamechar? ( c1 -- t/f ) true if c1 is a valif name char > $20 < $7F

: fnamechar? dup 20 > swap 7F < and ;

\ fpfa>nfa ( addr -- addr ) pfa>nfa for a forth word

: fpfa>nfa 7FFF and 1- begin 1- dup c@ fnamechar? 0= until ;

\ apfa>nfa ( addr -- addr ) pfa>nfa for an asm word

: apfa>nfa lastnfa begin 2dup nfa>pfa w@ = over c@ 80 and 0= and if -1 else  nfa>next dup 0= then until nip ;

\ pfa>nfa ( addr -- addr ) gets the name field address (nfa) for a parameter field address (pfa)

: pfa>nfa dup fMask @ and if fpfa>nfa else apfa>nfa then ;

\ accept ( c-addr +n1 -- +n2 ) collect n1 -2 characters or until eol, ctl characters, tab included are converted to space,
\ pad with 1 space at start & end. For parsing ease, and for the length byte when we make cstrs

: accept 3 max 2dup bl fill 1- swap 1+ swap bounds 0

begin key eol? 
	if cr drop -1 
	else bs?
		if drop dup
			if 8 emit bl emit 8 emit 1- swap 1- bl over c! swap then 0
		else bl max dup emit swap >r over c! 1+ 2dup 1+ = r> 1+ swap then 
	then
until nip nip ;

\ parse ( c1 -- +n2 ) parse the word delimited by c1, or the end of buffer is reached, n2 is the length >in is the offset
\ in the pad of the start of the parsed word

: parse padsize mcw>in w@ = if 0 else 0 begin 2dup pad>in + c@ = if -1 else 1+ 0 then until then nip ;

\ skipbl ( -- ) increment >in past blanks or until it equals padsize
: skipbl begin pad>in c@ bl = if mcw>in w@ 1+ dup mcw>in w! padsize = else -1 then until ;

\ nextword ( -- ) increment >in past current counted string
: nextword padsize mcw>in w@ > if pad>in c@ mcw>in w@ + 1+ mcw>in w! then ; 

\ parseword ( c1 -- +n2 ) skip blanks, and parse the following word delimited by c1, update to be a counted string in
\ the pad

: parseword skipbl parse dup if mcw>in w@ 1- 2dup mcPad + c! mcw>in w! then ; 

\ parsebl ( -- t/f) parse the next word in the pad delimited by blank, true if there is a word

: parsebl bl parseword 0<> ;

\ padnw ( -- t/f ) move past current word and parse the next word, true if there is a next word

: padnw nextword parsebl ;

\ parsenw ( -- cstr ) parse and move to the next word, str ptr is zero if there is no next word
: parsenw parsebl if pad>in nextword else 0 then ;

\ padclr ( -- )
: padclr begin padnw 0= until ;

\ find ( c-addr -- c-addr 0 | xt 2 | xt 1  |  xt -1 ) c-addr is a counted string, 0 - not found, 2 eXecute word, 
\ 1 immediate word, -1 word NOT ANSI

: find lastnfa over fin dup 
if nip dup nfa>pfa over c@ 80 and 0= if w@ then
	swap c@ dup 40 and 
	if 20 and if 2 else 1 then
	else drop -1 then
then ;

\ <# ( -- ) initialize the output area
: <# numpadsize mcw>out w! ;

\ #> ( -- caddr ) address of a counted string representing the output, NOT ANSI
: #> drop numpadsize mcw>out w@ - -1 mcw>out w+! pad>out c! pad>out ;

\ tochar ( n1 -- c1 ) convert c1 to a char
: tochar 1F and 30 + dup 39 > if 7 + then ;

\ # ( n1 -- n2 ) divide n1 by mcwBase and convert the remainder to a char and append to the output
: # mcwBase w@ u/mod swap tochar -1 mcw>out w+! pad>out c! ;

\ #s ( n1 -- 0 ) execute # until the remainder is 0
: #s begin # dup 0= until ;

\ . ( n1 -- )
: . dup 0< if 2D emit negate then <# #s #> .cstr 20 emit ;

\ cogid ( -- n1 ) return id of the current cog ( 0 - 7 )
: cogid -1 1 hubop drop ;

\ locknew ( -- n2 ) allocate a lock, result is in n2, -1 if unsuccessful	
: locknew -1 4 hubop -1 = if drop -1 then ;  

\ lockret ( n1 -- ) deallocate a lock, previously allocated via locknew
: lockret 5 hubop 2drop ;  

\ lockset ( n1 -- n2 ) set lock n1, result is in n2, -1 if the lock was set as per 'c' flag, lock ( n1 ) must have
\ been allocated via locknew
: lockset 6 hubop nip ;  

\ lockclr ( n1 -- n2 ) set lock n1, result is in n2, -1 if the lock was set as per 'c' flag, lock ( n1 ) must have
\ been allocated via locknew

: lockclr 7 hubop nip ;
 
\ lockdict? ( -- t/f ) attempt to lock the forth dictionary, 0 if unsuccessful -1 if successful

: lockdict? mydictlock w@ if 1 mydictlock w+! -1 else 0 lockset 0= if 1 mydictlock w! -1 else 0 then then ;

\ freedict ( -- ) free the forth dictionary, if I have it locked

: freedict mydictlock w@ dup if 1- dup mydictlock w! 0= if 0 lockclr drop then else drop then ;

\ lockdict ( -- ) lock the forth dictionary

: lockdict begin lockdict? until ; 

: _eoom ." Out of memory" cr ;
\ checkdict ( n -- ) make sure there are at least n bytes available in the dictionary
: checkdict mswHere w@ + mswDictend w@ >= 
if cr mswHere w@ . mswDictend . _eoom clearkeys reset then ;

: _c1 lockdict 
	mswlastnfa w@ mswHere w@ dup 2+ mswlastnfa w! swap over w! 2+ ;

: _c2 over namecopy namelen + alignw mswHere w! freedict ;

\ ccreate ( cstr -- ) create a dictionary entry
: ccreate  _c1 swap  _c2 ;
 
\ create ( -- ) skip blanks parse the next word and create a dictionary entry
: create bl parseword if _c1 pad>in _c2 nextword then ;

\ clabel ( cstr -- ) create an assembler constant at the current cog mcwAhere
: clabel lockdict ccreate ca_a_doconw w, mcwAhere w@ w, forthentry freedict ; 

\ herelal ( -- ) align contents of here to a long boundary, 4 byte boundary
: herelal lockdict 4 checkdict mswHere w@ alignl mswHere w! freedict ;

\ herewal ( -- ) align contents of here to a word boundary, 2 byte boundary
: herewal lockdict 2 checkdict mswHere w@ alignw mswHere w! freedict ;

\ allot ( n1 -- ) add n1 to here, allocates space on the data dictionary or release it
: allot lockdict dup checkdict mswHere w+! freedict ;

\ aallot ( n1 -- ) add n1 to aHere, allocates space in the cog or release it, n1 is # of longs
: aallot mcwAhere w+! mcwAhere w@ par >= if _eoom reset then ;

\ , ( x -- ) allocate 1 long, 4 bytes in the dictionary and copy x to that location

: , lockdict  herelal mswHere w@ m! 4 allot freedict ;

\ a, ( x -- ) allocate 1 long in the cog and copy x to that location
: a, mcwAhere w@ ! 1 aallot ;

\ w, ( x -- ) allocate 1 halfword 2 bytes in the dictionary and copy x to that location
: w, lockdict herewal mswHere w@ w! 2 allot freedict ;

\ c, ( x -- ) allocate 1 byte in the dictionary and copy x to that location
: c, lockdict mswHere w@ c! 1 allot freedict ;

\ orlnfa ( c1 -- ) ors c1 with the nfa length of the last name field entered
: orlnfa lockdict lastnfa orc! freedict ;

\ forthentry ( -- ) marks last entry as a forth word
: forthentry lockdict 80 orlnfa freedict ;

\ immediate ( -- ) marks last entry as an immediate word
: immediate lockdict 40 orlnfa freedict ;

\ exec ( -- ) marks last entry as an eXecute word, executes always
: exec lockdict 60 orlnfa freedict ;

\ leave ( -- ) exits at the next loop or +loop, i is placed to the max loop value
: leave r> r> r> drop dup 2>r >r ;

\ clearkeys ( -- ) clear the input keys
: clearkeys 0 mcwState w!
begin -1 mswKeyTO w@ 0 do key? if key drop drop 0 leave then loop until ;

\ w>l ( n1 n2 -- n1n2 ) consider only lower 16 bits
: w>l FFFF and swap 10 lshift or ;

\ l>w ( n1n2 -- n1 n2) break into 16 bits
: l>w dup 10 rshift swap FFFF and ;


: : lockdict create 3741 1 mcwState w! ;

: _mmcs ." MISMATCHED CONTROL STRUCTURE(S)" cr clearkeys ;

: _; w, 0 mcwState w! forthentry 3741 <> if _mmcs then freedict ;
\ to prevent ; from using itself while it is defining itself
: ;; ca_a_exit _; ; immediate
 
: ; ca_a_exit _; ;; immediate

: dothen l>w dup 1235 = swap 1239 = or if dup mswHere w@ swap - swap w! else _mmcs then ;

: then dothen ; immediate

: thens begin dup FFFF and dup 1235 = swap 1239 = or if dothen 0 else -1 then until ; immediate

: if ca_a_0branch w, mswHere w@ 1235 w>l 0 w, ; immediate

: else ca_a_branch w, 0 w, dothen mswHere w@ 2- 1239 w>l ; immediate

: until l>w 1317 = if ca_a_0branch w, mswHere w@ - w, else _mmcs then ; immediate

: begin mswHere w@ 1317 w>l ; immediate

: doloop swap l>w 2329 = if swap w, mswHere w@ - w, else _mmcs then ;

: loop  ca_a_(loop) doloop ; immediate

: +loop  ca_a_(+loop) doloop ; immediate

: do ca_a_2>r w, mswHere w@ 2329 w>l ; immediate

: _ecs 3A emit space ;
: _udf ." UNDEFINED WORD " ;

: ." cm_dq w, 1 mcw>in w+! 22 parse dup c, dup pad>in mswHere w@ rot cmove dup allot 1+ mcw>in w+! herewal ;  immediate

\ fisnumber ( -- ) dummy routine s for indirection when float package is loaded
: fisnumber isnumber ;
: fnumber number ;

\ interpretpad ( -- ) interpret the contents of the pad
: interpretpad  0 mcw>in w!
begin bl parseword
	if pad>in nextword find dup
		if dup -1 = 
			if drop compile? if w, else execute then 0
			else 2 = 
				if execute 0 else
					compile? if execute 0 else pfa>nfa ." IMMEDIATE WORD " .strname clearkeys cr -1 then
				then
			then
		else drop dup c@++  fisnumber
			if
				c@++ fnumber compile? if dup 0 FFFF between if ca_a_litw w, w, else ca_a_literal w, , then then 0
			else  
				0 mcwState w! freedict _udf .strname cr clearkeys -1 
			then
		then
	else -1 then until ;

\ [0m ( -- ) a dummy word, fast load echos this so...
: [0m ;

\ interpret ( -- ) the main interpreter loop
: interpret
\ ansi red
1b emit 5b emit 33 emit 31 emit 6d emit
mcPad padsize accept drop 
\ ansi normal 
1b emit 5b emit 30 emit  6d emit
interpretpad ;


\ variable ( -- ) skip blanks parse the next word and create a variable, allocate a long, 4 bytes
: variable lockdict create ca_a_dovar w, 0 , forthentry freedict ;

\ _wc1 ( x -- nfa ) skip blanks parse the next word and create a constant, allocate a word, 2 bytes
: _wc1 lockdict create ca_a_doconw w, w, forthentry lastnfa freedict ;

\ wconstant ( x -- ) skip blanks parse the next word and create a constant, allocate a word, 2 bytes
: wconstant _wc1 drop ;

\ avariable ( -- ) skip blanks parse the next word and create a cog variable, allocate a long
: avariable mcwAhere w@ _wc1 1 aallot ;

\ wvariable ( -- ) skip blanks parse the next word and create a variable, allocate a word, 2 bytes 
: wvariable lockdict create ca_a_dovarw w, 0 w, forthentry freedict ;

\ constant ( x -- ) skip blanks parse the next word and create a constant, allocate a long, 4 bytes
: constant lockdict create ca_a_docon w, , forthentry freedict ;

\ asmlabel ( x -- ) skip blanks parse the next word and create an assembler entry
: asmlabel lockdict create w, freedict ;

\ hex ( -- ) set the base for hexadecimal
: hex 10 mcwBase w! ;

\ decimal ( -- ) set the mcwBase for decimal
: decimal A mcwBase w! ;


\ words ( cstr -- ) prints the words in the forth dictionary starting with cstr, 0 prints all

: _words 0 >r lastnfa ." NFA (Forth/Asm Immediate eXecute) Name"   
begin
	2dup swap dup if npfx else 2drop -1 then
	if
		r> dup 0= if cr then 1+ 3 and >r 
		dup .word space dup c@ dup 80 and 
		if 46 else 41 then emit dup 40 and 
		if 49 else 20 then  emit 20 and 
		if 58 else 20 then emit 
		space dup .strname dup c@ namemax and 15 swap - 0 max spaces 
	then nfa>next dup 0= 
until r> 3drop cr ;

\ words ( -- ) prints the words in the forth dictionary, if the pad has another string following, with that prefix
: words parsenw _words ;



\ del_ms ( n1 -- ) for 80Mhz 68DB max
: del_ms 7FFFFFFF clkfreq 3e8 u/ u/ min 1 max clkfreq 3E8 u/ u* cnt @ + begin dup cnt @ - 0< until drop ;
: del_sec 10 u/mod dup if 0 do 3e80 del_ms loop else drop then dup if 0 do 3e8 del_ms loop else drop then ;

\ >m ( n1 -- n2 ) produce a 1 bit mask n2 for position n
: >m 1 swap lshift ;

\ eeprom read and write routine for the prop proto board AT24CL256 eeprom on pin 28 sclk, 29 sda
\ pxi ( n1 -- ) set pin # n1 to an input
: pxi >m invert dira @ and dira ! ;

\ pxo ( n1 -- ) set pin # n1 to an input 
: pxo >m dira @ or dira ! ;

\ pxl ( n1 -- ) set pin # n1 to lo
: pxl >m mpxl ;

\ pxh ( n1 -- ) set pin # n1 to hi
: pxh >m mpxh ;

\ px ( t/f n1 -- ) set pin # n1 to h - true or l false
: px swap if pxh else pxl then ;

\ px? ( n1 -- t/f) true if pin n1 is hi
: px? >m mpx ;

1C wconstant _scl \ SCL
1D wconstant _sda \ SDA

1 _scl lshift constant _sclm
1 _sda lshift constant _sdam

: _sdai _sda pxi ;
: _sdao _sda pxo ;
: _scli _scl pxi ;
: _sclo _scl pxo ;

: _sdal _sdam mpxl ;
: _sdah _sdam mpxh ;
: _scll _sclm mpxl ;
: _sclh _sclm mpxh ;
: _sda? _sdam mpx ;

\ _eeInit ( -- ) initialize the eeprom in case it is in a weird state
: _eeInit _sclh _sclo _sdai 9 0 do _scll _sclh _sda? if leave then loop ;

\ _eeStart ( -- ) start the data transfer
: _eeStart _sclh _sclo _sdah _sdao _sdal _scll ;

\ _eeStop ( -- ) stop the data transfer
: _eeStop _sclh _sdah _scli _sdai ;

\ _eeWrite ( c1 -- t/f ) write a byte to the eeprom, returns ack bit
: _eeWrite 80 8 0 
do 2dup and if _sdah else _sdal then _sclh _scll 1 rshift loop
2drop _sdai _sclh _sda? _scll _sdal _sdao ;

\ _eeRead ( t/f -- c1 ) read a byte from the eeprom, ackbit in, byte out
: _eeRead _sdai 0 8 0 
do 1 lshift _sclh _sda? _scll if 1 or then loop
swap _sda px _sdao _sclh _scll _sdal ;

\ the eeReadPage and eeWritePage words assume the eeprom are 64kx8 and will address up to 
\ 8 sequential eeproms
\ eeReadPage ( eeAddr addr u -- t/f ) return true if there was an error, use lock 1
: eeReadPage begin 1 lockset 0= until
1 max rot dup ff and swap dup 8 rshift ff and swap 10 rshift 7 and 1 lshift dup >r
_eeStart A0 or _eeWrite swap _eeWrite or swap _eeWrite or 
_eeStart r> A1 or _eeWrite or 
rot2 bounds 
do lasti? _eeRead i c! loop _eeStop 1 lockclr drop ;

\ eeWritePage ( eeAddr addr u -- t/f ) return true if there was an error, use lock 1
: eeWritePage  begin 1 lockset 0= until
1 max rot dup ff and swap dup 8 rshift ff and swap 10 rshift 7 and 1 lshift
_eeStart A0 or _eeWrite swap _eeWrite or swap _eeWrite or 
rot2 bounds 
do i c@ _eeWrite or loop _eeStop 10 del_ms 1 lockclr drop ;
: eeErr ." eeProm error" ;