312 lines
10 KiB
FortranFixed
312 lines
10 KiB
FortranFixed
|
FL
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ eeReadWord ( eeAddr -- n1 )
|
|||
|
|
: eeReadWord mcwT0 2 eeReadPage if eeErr cr then mcwT0 w@ ;
|
|||
|
|
|
|||
|
|
\ eeWriteWord ( n1 eeAddr -- )
|
|||
|
|
: eeWriteWord swap mcwT0 w! mcwT0 2 eeWritePage if eeErr cr then ;
|
|||
|
|
|
|||
|
|
\ eeReadByte ( eeAddr -- c1 )
|
|||
|
|
: eeReadByte eeReadWord FF and ;
|
|||
|
|
|
|||
|
|
\ eeCopy ( addr1 addr2 u -- ) copy u bytes from addr1 to addr2, addr1 and addr2 must be on a 0x80 byte page boundary
|
|||
|
|
\ clears the pad, so make sure no commands follow
|
|||
|
|
\ and u must be a multiple of 0x80 and should not overlap
|
|||
|
|
: eeCopy 7F invert and rot 7f invert and rot 7f invert and rot
|
|||
|
|
0 do over i + dup . mcPad 80 eeReadPage if eeErr leave then
|
|||
|
|
dup i + dup . mcPad 80 eeWritePage if eeErr leave then
|
|||
|
|
i 3FF and 0= if cr then 80 +loop 2drop cogid cogPadclr ;
|
|||
|
|
|
|||
|
|
: _d1 cr over .word space dup .word _ecs bounds ;
|
|||
|
|
: _d2 cr .word _ecs ;
|
|||
|
|
: _d3 mcT 10 bounds do i c@ .byte space loop 2 spaces mcT 10 .str ;
|
|||
|
|
|
|||
|
|
\ dump ( adr cnt -- ) uses mcT
|
|||
|
|
: dump _d1 do i _d2 i mcT 10 cmove _d3 10 +loop cr ;
|
|||
|
|
|
|||
|
|
\ rdump ( adr cnt -- ) uses mcwT1 - mcwT8
|
|||
|
|
: rdump _d1 do i _d2 i mcT 10 eeReadPage if mcT 10 0 fill then _d3 10 +loop cr ;
|
|||
|
|
|
|||
|
|
\ adump ( adr cnt -- )
|
|||
|
|
: adump cr over .word space dup .word _ecs bounds
|
|||
|
|
do
|
|||
|
|
cr i .word _ecs i 4 bounds
|
|||
|
|
do i @ .long space loop
|
|||
|
|
4 +loop cr ;
|
|||
|
|
|
|||
|
|
\ \ ( -- ) moves the parse pointer >in to the end of the line, tricky to redefine
|
|||
|
|
\ CTL-E gets traslated to \ by fast_load
|
|||
|
|
: \
|
|||
|
|
padsize mcw>in w! ; immediate exec
|
|||
|
|
|
|||
|
|
\ ' ( -- addr ) returns the execution token for the next name, if not found it returns 0
|
|||
|
|
: ' parsebl if pad>in nextword find 0= if _udf cr drop 0 then else 0 then ;
|
|||
|
|
|
|||
|
|
\ cq ( -- addr ) returns the address of the counted string following this word and increments the IP past it
|
|||
|
|
|
|||
|
|
: cq r> dup c@++ + alignw >r ;
|
|||
|
|
|
|||
|
|
\ c" ( -- c-addr ) compiles the string delimited by ", runtime return the addr of the counted string ** valid only in that line
|
|||
|
|
: c" compile?
|
|||
|
|
if
|
|||
|
|
cm_cq w, 1 mcw>in w+! 22 parse dup c, dup pad>in mswHere w@ rot cmove dup allot 1+ mcw>in w+! herewal
|
|||
|
|
else
|
|||
|
|
22 parse 1- pad>in 2dup c! swap 2+ mcw>in w+!
|
|||
|
|
then ; immediate exec
|
|||
|
|
|
|||
|
|
\ the base address for the input buffer
|
|||
|
|
wvariable fl_base
|
|||
|
|
|
|||
|
|
\ the number of buffered characters
|
|||
|
|
wvariable fl_count
|
|||
|
|
|
|||
|
|
\ the old mswDictend
|
|||
|
|
wvariable fl_top
|
|||
|
|
|
|||
|
|
\ the offset of the next byte in
|
|||
|
|
wvariable fl_in
|
|||
|
|
|
|||
|
|
\ one fast load at a time
|
|||
|
|
wvariable fl_lock
|
|||
|
|
|
|||
|
|
\ fl_buf ( -- t/f ) allocate all but 300 chars and load keys load true if successful
|
|||
|
|
: fl_buf mswDictend w@ mswHere w@ - 300 - 0 fl_count w! lockdict fl_lock w@
|
|||
|
|
if freedict cr 0 else -1 fl_lock w! freedict -1 then
|
|||
|
|
\ ( u t/f -- ) true if successful so far
|
|||
|
|
if
|
|||
|
|
\ save the old mswDictend and initialize variables
|
|||
|
|
mswDictend w@ dup fl_top w! swap - dup fl_base w! dup fl_in w! 1- mswDictend w!
|
|||
|
|
0
|
|||
|
|
begin dup mswKeyTO w@ 0
|
|||
|
|
do
|
|||
|
|
begin fkey?
|
|||
|
|
if dup 5C = \ if a backslash, throw away keys
|
|||
|
|
if drop begin keyto if D = else -1 then until else
|
|||
|
|
\ drop all characters between { }
|
|||
|
|
dup 7B = if drop begin keyto if 7D = else -1 then until else
|
|||
|
|
\ translate CTL-E 05 to backspace 5C
|
|||
|
|
dup 5 = if drop 5C then
|
|||
|
|
fl_in w@ c! 1+ fl_in w@ 1+ dup fl_top w@ =
|
|||
|
|
if _eoom clearkeys reset then fl_in w!
|
|||
|
|
then
|
|||
|
|
then 0
|
|||
|
|
\ stay in begin until
|
|||
|
|
else drop -1 then
|
|||
|
|
\ no key, exit begin until
|
|||
|
|
until
|
|||
|
|
loop
|
|||
|
|
swap over =
|
|||
|
|
\ until count is the same
|
|||
|
|
until
|
|||
|
|
dup . ." chars" cr fl_count w! -1
|
|||
|
|
else drop 0 then
|
|||
|
|
;
|
|||
|
|
|
|||
|
|
\ fl_skeys ( n -- ) emit the keys in the fast buffer
|
|||
|
|
: fl_skeys
|
|||
|
|
fl_lock w@ fl_count w@ 0<> and
|
|||
|
|
if
|
|||
|
|
fl_base w@ fl_count w@ bounds
|
|||
|
|
do
|
|||
|
|
i dup c@ emit mswDictend w!
|
|||
|
|
loop
|
|||
|
|
fl_top w@ mswDictend w! 0 fl_count w! lockdict 0 fl_lock w! freedict
|
|||
|
|
|
|||
|
|
then
|
|||
|
|
;
|
|||
|
|
|
|||
|
|
: loadee 2dup F andn bounds
|
|||
|
|
do i mcT 10 eeReadPage drop mcT 10 bounds do i c@ emit loop 10 +loop
|
|||
|
|
dup F andn rot + swap F and dup if bounds do i eeReadByte emit loop else 2drop then ;
|
|||
|
|
: _caend c" cr " over cappend cogid over cappendnc c" 0 mcwEmitptr w! >cog" swap cappend ;
|
|||
|
|
|
|||
|
|
: FL fl_buf if c" fl_skeys" mcT ccopy mcT _caend mcT cogXO then ;
|
|||
|
|
|
|||
|
|
\ file area 8000 - FFFF
|
|||
|
|
\ individual files start on 128 byte boundaries,
|
|||
|
|
\ the first thing is the length as a 16 bit word, then a cstr which is the file name, and then the contents
|
|||
|
|
\ of the file
|
|||
|
|
|
|||
|
|
8000 constant eeBot
|
|||
|
|
10000 constant eeTop
|
|||
|
|
|
|||
|
|
\ f_fill ( c1 -- ) fill the eeprom file area with c1
|
|||
|
|
: f_fill mcPad 80 rot fill eeTop eeBot
|
|||
|
|
do i mcPad 80 eeWritePage if eeErr cr leave then 80 +loop
|
|||
|
|
mcPad 80 bl fill ;
|
|||
|
|
|
|||
|
|
\ f_clear ( -- ) clear the eeprom file area, only writes the length word to FFFF
|
|||
|
|
: f_clear eeTop eeBot do FFFF i eeWriteWord 80 +loop ;
|
|||
|
|
|
|||
|
|
: _fi mcNumpad dup w@ swap 2+ c@ + 2+ 1+ 80 u/mod swap if 1+ then 80 u* ;
|
|||
|
|
|
|||
|
|
\ list ( -- ) list the files names in the eeprom
|
|||
|
|
: list eeTop eeBot
|
|||
|
|
do
|
|||
|
|
i mcNumpad numpadsize namemax 1+ 2+ min eeReadPage if eeErr leave then mcNumpad w@ FFFF =
|
|||
|
|
if i . cr 80 leave else i . mcNumpad dup w@ . 2+ .cstr cr _fi then
|
|||
|
|
+loop ;
|
|||
|
|
|
|||
|
|
\ f_find ( cstr -- n1 ) find the file, 0 if not found
|
|||
|
|
: f_find 0 eeTop eeBot
|
|||
|
|
do
|
|||
|
|
i mcNumpad numpadsize namemax 1+ 2+ min eeReadPage if eeErr leave then mcNumpad w@ FFFF =
|
|||
|
|
if nip 80 leave else over mcNumpad 2+ cstr= if drop i then _fi then
|
|||
|
|
+loop ;
|
|||
|
|
|
|||
|
|
\ f_free ( -- n1 ) address of the first free file page, 0 if there are none
|
|||
|
|
: f_free 0 eeTop eeBot
|
|||
|
|
do
|
|||
|
|
i mcNumpad 4 eeReadPage if eeErr leave then mcNumpad w@ FFFF =
|
|||
|
|
if drop i 80 leave else _fi then
|
|||
|
|
+loop ;
|
|||
|
|
|
|||
|
|
\ f_wfile ( -- ) write the file at fl_base for fl_count bytes, the format must be:
|
|||
|
|
\ word length the number of bytes in the content
|
|||
|
|
\ bytes cstr - filename
|
|||
|
|
\ bytes file contents
|
|||
|
|
: f_wfile f_free dup
|
|||
|
|
if
|
|||
|
|
dup fl_count w@ + eeTop <
|
|||
|
|
if fl_base w@ fl_count w@ bounds
|
|||
|
|
do dup
|
|||
|
|
i fl_count w@ dup 80 min swap over - fl_count w! eeWritePage
|
|||
|
|
if eeErr leave then
|
|||
|
|
80 + 80 +loop drop
|
|||
|
|
else drop _eoom then
|
|||
|
|
else drop eeErr cr then ;
|
|||
|
|
|
|||
|
|
\ FW ( n1 -- ) like a fast load but write to the file area, first entry after a blank lines must be 3 periods followed by the filename
|
|||
|
|
: FW fl_buf
|
|||
|
|
if fl_count w@ 0
|
|||
|
|
do
|
|||
|
|
fl_base w@ c@ 2E =
|
|||
|
|
if leave else fl_base w@ 1+ fl_base w! fl_count w@ 1- fl_count w! then
|
|||
|
|
loop
|
|||
|
|
fl_base w@ 3 + 20 bounds do i c@ bl <= lasti? or if i leave then loop fl_base w@ - dup
|
|||
|
|
3 - fl_base w@ 2+ c!
|
|||
|
|
fl_count w@ swap - dup fl_base w@ c! dup 8 rshift fl_base w@ 1+ c!
|
|||
|
|
if f_wfile then
|
|||
|
|
fl_top w@ mswDictend w! lockdict 0 fl_lock w! freedict
|
|||
|
|
then ;
|
|||
|
|
|
|||
|
|
\ f_al ( addr1 -- n1 addr2) for file at addr1, get the length - n1, and the address of teh contents - addr2
|
|||
|
|
: f_al dup eeReadWord over 2+ eeReadByte rot + 2+ 1+ ;
|
|||
|
|
|
|||
|
|
\ f_load ( cstr -- ) load the file name following from eeprom
|
|||
|
|
: f_load f_find dup
|
|||
|
|
if f_al 0 mcT c! mcT cappendnc mcT cappendnc c" loadee" mcT cappend mcT _caend mcT cogXO else drop then ;
|
|||
|
|
|
|||
|
|
\ load ( -- ) load the file name following from eeprom
|
|||
|
|
: load parsenw dup if f_load else drop then ;
|
|||
|
|
|
|||
|
|
: version c" PropForth v2.5 2009OCT24 17:15 0" ;
|
|||
|
|
|
|||
|
|
\ free ( -- ) display free main bytes and current cog longs
|
|||
|
|
: free mswDictend w@ mswHere w@ - . ." bytes free - " par mcwAhere w@ - . ." cog longs free" cr ;
|
|||
|
|
|
|||
|
|
\ saveforth( -- ) write the running image to eeprom
|
|||
|
|
: saveforth
|
|||
|
|
c" mswHere" find
|
|||
|
|
if
|
|||
|
|
version dup c@ + dup c@ 1+ swap c!
|
|||
|
|
pfa>nfa mswHere w@ swap
|
|||
|
|
\ 2e emit
|
|||
|
|
begin dup w@ over eeWriteWord 2+ dup 7F and 0= until
|
|||
|
|
do
|
|||
|
|
ibound i - 80 min dup i dup rot
|
|||
|
|
eeWritePage if leave then 2e emit
|
|||
|
|
+loop
|
|||
|
|
else drop then cr ;
|
|||
|
|
|
|||
|
|
\ _forget ( cstr -- ) wind the dictionary back to the word which follows - caution
|
|||
|
|
: _forget dup
|
|||
|
|
if
|
|||
|
|
find if
|
|||
|
|
pfa>nfa nfa>lfa dup mswHere w! w@ mswlastnfa w!
|
|||
|
|
else .cstr ??? cr then
|
|||
|
|
else drop then ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ forget ( -- ) wind the dictionary back to the word which follows - caution
|
|||
|
|
: forget parsenw _forget ;
|
|||
|
|
|
|||
|
|
\ this constant is used at boot time to set the forth starting routine, if it is changed
|
|||
|
|
\ it does not take effect until a reboot, a cog reset is not adequate
|
|||
|
|
cm_fstart wconstant cm_fstart
|
|||
|
|
|
|||
|
|
\ fstart ( -- ) the start word
|
|||
|
|
: fstart
|
|||
|
|
cogid dup cogInbyte 10 lshift cm_entry 2 lshift or swap or resetDreg !
|
|||
|
|
|
|||
|
|
mcwInbyte m@ l>w swap
|
|||
|
|
|
|||
|
|
100 mcwInbyte w!
|
|||
|
|
0 mcwEmitptr w!
|
|||
|
|
fMask @ mcwDebugcmd w!
|
|||
|
|
\ zero out cog data area
|
|||
|
|
par @ 8 + F8 0 fill
|
|||
|
|
\ initialize forth variables
|
|||
|
|
hex
|
|||
|
|
|
|||
|
|
ca_varEnd mcwAhere w!
|
|||
|
|
|
|||
|
|
\ initiliaze the common variables
|
|||
|
|
lockdict mswHere w@ 0=
|
|||
|
|
if 0 fl_lock w! lastnfa nfa>pfa 2+ alignl 4+ mswHere w! 7FFF dup mswMemend w! mswDictend w! then
|
|||
|
|
freedict rsTop 1- rsPtr !
|
|||
|
|
FFFF = if 8 lshift cogid + vxcog w! else drop then
|
|||
|
|
c" boot" mcT ccopy cogid mcT cappendn mcT find if execute else drop then
|
|||
|
|
-1
|
|||
|
|
begin
|
|||
|
|
compile? 0= if ." Cog" cogid . ." ok" cr then
|
|||
|
|
\ if the first time through set mcwDebugValue to -1 to let people know we are alive
|
|||
|
|
if -1 mcwDebugvalue m! then
|
|||
|
|
interpret
|
|||
|
|
0 0 until ;
|
|||
|
|
|
|||
|
|
: boot6 cogid >cog cog+ ;
|
|||
|
|
|
|||
|
|
\ cog? ( -- ) display active forth cogs
|
|||
|
|
: cog? ." Forth cogs: " ffcog w@ . 2D emit space lfcog w@ . cr ;
|
|||
|
|
|
|||
|
|
\ cog+ ( -- ) add a forth cog
|
|||
|
|
: cog+ ffcog w@ 1- dup 0>= if dup ffcog w! cogreset else drop then cog? ;
|
|||
|
|
|
|||
|
|
\ cog- ( -- ) stop first forth cog, cannot be executed form the first forth cog
|
|||
|
|
: cog- ffcog w@ dup cogid <> swap 1+ dup lfcog w@ <= rot and if dup 1- cogstop ffcog w! else drop then cog? ;
|
|||
|
|
|
|||
|
|
\ st? ( -- ) prints out the stack
|
|||
|
|
: st? ." ST: " stPtr @ 2+ dup stTop < if stTop swap - 0 do stTop 2- i - @ .long space loop else drop then cr ;
|
|||
|
|
|
|||
|
|
\ sc ( -- ) clears the stack
|
|||
|
|
: sc stTop stPtr @ - 3 - dup . ." items cleared" cr dup 0> if 0 do drop loop then ;
|
|||
|
|
|
|||
|
|
\ _pna ( addr -- ) print the address, contents and forth name
|
|||
|
|
: _pna dup .word 3a emit w@ dup .word space pfa>nfa .strname space ;
|
|||
|
|
|
|||
|
|
\ pfa? ( addr -- t/f) true if addr is a pfa
|
|||
|
|
: pfa? dup pfa>nfa dup c@ dup 80 and 0= swap namemax and 0<> rot nfa>pfa rot if w@ then rot = and ;
|
|||
|
|
|
|||
|
|
\ rs? ( -- ) prints out the return stack
|
|||
|
|
: rs? ." RS: " rsTop rsPtr @ 1+ - 0 do rsTop 1- i - @ dup 2- w@ pfa? if 2- _pna else .long space then loop cr ;
|
|||
|
|
|
|||
|
|
\ lasm ( addr -- ) expects an address pointing to a structure in the following form
|
|||
|
|
\ empty long, long upper address of the assembler routine, long lower address of the assembler routine
|
|||
|
|
\ a series of longs which are the assembler codes
|
|||
|
|
: lasm 4+ dup m@ swap 4+ swap over m@ dup mcwAhere w! do 4+ dup m@ a, loop drop ;
|
|||
|
|
|
|||
|
|
\ f_erase ( -- ) erase the word following from eeprom - DANGER - should be the last word only
|
|||
|
|
\ or following words may get overwritten when a new file is written to eeprom
|
|||
|
|
: f_erase parsenw dup if f_find dup if eeTop swap do FFFF i eeWriteWord 80 +loop else drop then else drop then ;
|
|||
|
|
\ no more symbols available
|
|||
|
|
|
|||
|
|
\ mswlastnfa is generated by the forth spinmaker word
|
|||
|
|
|
|||
|
|
|