HIVE
/
TriOS-alt
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
TriOS-alt/zubehör/PropForth/PropForthPart1.f

1133 lines
36 KiB
FortranFixed
Raw Normal View History

2010-11-26 23:58:06 +01:00
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" ;