1133 lines
36 KiB
Forth
1133 lines
36 KiB
Forth
|
|
|
|
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" ;
|
|
|