Subversion Repositories forth-cpu

( This program is written in a pseudo Forth like language, it is not

Forth and does not behave like it, it just looks like it. This should

be thought of as assembly code and not Forth.

A lot of the code has been taken verbatim from "The Zen of eForth by

C. H. Ting". Some routines have been adapted from the j1eforth implementation

available at https://github.com/samawati/j1eforth.

For a grammar of the language look into the file "h2.c", or "readme.md".

Execution begins at a label called "start".

A problem with this Forth is that is uses a singe block buffer, which can cause

problems when using the block word set from within blocks. The main reason for

this is due to the limited space on the device.

Forth To Do:

* Add do...loop, case statements, put them in block storage

* Reformat this so it can be stored in block storage, with

a maximum line length of 64 bytes

* Implement some words from the C library, like all of "ctype.h" and

put them in block storage.

* Implement many of the lessons learned whilst making the

'embed' Forth interpreter , which

cuts down on the interpreter size, and adds more functionality. )

( ======================== System Constants ================= )

constant cell 2 hidden

( The first 8 cells [16 bytes] of memory contain the entry point and interrupt

service routine call locations, we can set the instruction to be run [such as

a jump or a call] by setting the label to it with the ".set" directive. Later

in the program the entry point, the first location in memory, is set to the

start label )

entry:             .allocate cell ( Entry point - not an interrupt )

isrRxFifoNotEmpty: .allocate cell ( UART RX FIFO not empty )

isrRxFifoFull:     .allocate cell ( UART RX FIFO full )

isrTxFifoNotEmpty: .allocate cell ( UART TX FIFO not empty )

isrTxFifoFull:     .allocate cell ( UART TX FIFO full )

isrKbdNew:         .allocate cell ( New PS/2 Keyboard character )

isrTimer:          .allocate cell ( Timer interrupt )

isrDPadButton:     .allocate cell ( Any D-Pad Button Changed state )

.mode 3   ( Turn word header compilation and optimization on )

.built-in ( Add the built in words to the dictionary )

constant =exit         $601c hidden ( op code for exit )

constant =invert       $6600 hidden ( op code for invert )

constant =>r           $6147 hidden ( op code for >r )

constant =bl           32    hidden ( blank, or space )

constant =cr           13    hidden ( carriage return )

constant =lf           10    hidden ( line feed )

constant =bs           8     hidden ( back space )

constant =escape       27    hidden ( escape character )

constant c/l           64    hidden ( characters per line in a block )

constant l/b           16    hidden ( lines in a block )

constant dump-width    16    hidden ( number of columns for 'dump' )

constant tib-length    80    hidden ( size of terminal input buffer )

constant pad-length    80    hidden ( pad area begins HERE + pad-length )

constant word-length   31    hidden ( maximum length of a word )

( Outputs: $6000 - $7FFF )

constant oUart         $4000 hidden ( UART TX/RX Control register )

constant oVT100        $4002 hidden ( LEDs )

constant oTimerCtrl    $4004 hidden ( Timer control register )

constant oLeds         $4006 hidden ( VGA X/Y Cursor position )

constant oMemDout      $4008 hidden ( Memory output for writes )

constant oMemControl   $400A hidden ( Memory control and high address bits )

constant oMemAddrLow   $400C hidden ( Lower memory address bits )

constant o7SegLED      $400E hidden ( 4x7 Segment display )

constant oIrcMask      $4010 hidden ( Interrupt Mask )

( Inputs: $6000 - $7FFF )

constant iUart         $4000 hidden ( Matching registers for iUart )

constant iVT100        $4002 hidden ( Switch control [on/off] )

constant iTimerDin     $4004 hidden ( Current timer value )

constant iSwitches     $4006 hidden ( VGA text output, currently broken )

constant iMemDin       $4008 hidden ( Memory input for reads )

( ======================== System Constants ================= )

( ======================== System Variables ================= )

( Execution vectors for changing the behaviour of the program,

they are set at the end of this file )

location _key?      0  ( -- c -1 | 0 : new character available? )

location _emit      0  ( c -- : emit character )

location _expect    0  ( "accept" vector )

location _tap       0  ( "tap" vector, for terminal handling )

location _echo      0  ( c -- : emit character )

location _prompt    0  ( -- : display prompt )

location _boot      0  ( -- : execute program at startup )

location _bload     0  ( a u k -- f : load block )

location _bsave     0  ( a u k -- f : save block )

location _binvalid  0  ( k -- k : throws error if k invalid )

location _message   0  ( n -- : display an error message )

location last-def   0  ( last, possibly unlinked, word definition )

location flash-voc  0  ( flash and memory word set )

location cp         0  ( Dictionary Pointer: Set at end of file )

location csp        0  ( current data stack pointer - for error checking )

location _id        0  ( used for source id )

location rendezvous 0  ( saved cp and pwd )

.allocate cell

location seed       1  ( seed used for the PRNG )

location handler    0  ( current handler for throw/catch )

variable >in        0  ( Hold character pointer when parsing input )

variable state      0  ( compiler state variable )

variable hld        0  ( Pointer into hold area for numeric output )

variable base       10 ( Current output radix )

variable span       0  ( Hold character count received by expect   )

variable loaded     0  ( Used by boot block to indicate it has been loaded  )

variable border    -1  ( Put border around block begin displayed with 'list' )

constant #vocs            8 hidden ( number of vocabularies in allowed )

variable forth-wordlist   0 ( set at the end near the end of the file )

location context          0 ( holds current context for vocabulary search order )

.allocate 14                ( ... space for context )

location #tib             0 ( Current count of terminal input buffer    )

location tib-buf          0 ( ... and address )

.set tib-buf $pc            ( set tib-buf to current dictionary location )

.allocate tib-length        ( allocate enough for the terminal input buffer )

.allocate cell              ( plus one extra cell for safety )

constant block-invalid   -1 hidden ( block invalid number )

constant b/buf 1024 ( size of a block )

variable blk             -1 ( current blk loaded )

location block-dirty      0 ( -1 if loaded block buffer is modified )

location block-buffer     0 ( block buffer starts here )

.allocate b/buf

location _blockop         0             ( used in 'mblock' )

location bcount           0             ( instruction counter used in 'see' )

location _test            0             ( used in skip/test )

location .s-string        " 

location see.unknown      "(no-name)"   ( used by 'see' for calls to anonymous words )

location see.lit          "LIT"         ( decompilation -> literal )

location see.alu          "ALU"         ( decompilation -> ALU operation )

location see.call         "CAL"         ( decompilation -> Call )

location see.branch       "BRN"         ( decompilation -> Branch )

location see.0branch      "BRZ"         ( decompilation -> 0 Branch )

location see.immediate    " immediate " ( used by "see", for immediate words )

location see.inline       " inline "    ( used by "see", for inline words )

location OK               "ok"          ( used by "prompt" )

location redefined        " redefined"  ( used by ":" when a word has been redefined )

location hi-string        "eFORTH V"    ( used by "hi" )

location loading-string   "loading..."  ( used in start up routine )

location failed           "failed"      ( used in start up routine )

( ======================== System Variables ================= )

( ======================== Forth Kernel ===================== )

: [-1] -1 ; hidden         ( -- -1 : space saving measure, push -1 onto stack )

: 0x8000 $8000 ; hidden    ( -- $8000 : space saving measure, push $8000 onto stack )

: ! store drop ;           ( n a -- : store a value 'n' at location 'a'  )

: 256* 8 lshift ; hidden   ( u -- u : shift left by 8, or multiple by 256 )

: 256/ 8 rshift ; hidden   ( u -- u : shift right by 8, or divide by 256 )

: 1+ 1 + ;                 ( n -- n : increment a value  )

: negate invert 1 + ;      ( n -- n : negate a number )

: - invert 1 + + ;         ( n1 n2 -- n : subtract n1 from n2 )

: 2/ 1 rshift ;            ( n -- n : divide by 2 NB. This isn't actually correct, just useful, "1 arshift" would be acceptable )

: 2* 1 lshift ;            ( n -- n : multiply by 2 )

: cell- cell - ;           ( a -- a : adjust address to previous cell )

: cell+ cell + ;           ( a -- a : move address forward to next cell )

: cells 2* ;               ( n -- n : convert number of cells to number to increment address by )

: ?dup dup if dup exit then ;   ( n -- 0 | n n : duplicate value if it is not zero )

: >  swap < ;              ( n1 n2 -- f : signed greater than, n1 > n2 )

: u> swap u< ;             ( u1 u2 -- f : unsigned greater than, u1 > u2 )

: u>= u< invert ;          ( u1 u2 -- f : )

: <> = invert ;            ( n n -- f : not equal )

: 0<> 0= invert ;          ( n n -- f : not equal  to zero )

: 0> 0 > ;                 ( n -- f : greater than zero? )

: 0< 0 < ;                 ( n -- f : less than zero? )

: 2dup over over ;         ( n1 n2 -- n1 n2 n1 n2 )

: 2drop drop drop ;        ( n n -- )

: tuck swap over ;         ( n1 n2 -- n2 n1 n2 )

: +! tuck @ + swap ! ;     ( n a -- : increment value at address by 'n' )

: 1+!  1 swap +! ;         ( a -- : increment value at address by 1 )

: 1-! [-1] swap +! ; hidden  ( a -- : decrement value at address by 1 )

: execute >r ;             ( cfa -- : execute a function )

: c@ dup ( -2 and ) @ swap 1 and if 8 rshift exit else $ff and exit then ; ( b -- c )

: c!                       ( c b -- )

        swap $ff and dup 8 lshift or swap

        swap over dup ( -2 and ) @ swap 1 and 0 = $ff xor

        >r over xor r> and xor swap ( -2 and ) store drop ;

: c, cp @ c! cp 1+! ;    ( c -- : store 'c' at next available location in the dictionary )

: 40ns begin dup while 1- repeat drop ; hidden ( n -- : wait for 'n'*40ns + 30us )

: ms for 25000 40ns next ; ( n -- : wait for 'n' milliseconds )

: doNext r> r> ?dup if 1- >r @ >r exit then cell+ >r ; hidden

: uart? ( a1 a2 -- c -1 | 0 : generic uart input using registers 'a1' and 'a2'  )

        swap >r dup >r

        @ $0100 and 0=

        if

                $0400 r> ! r> @ $ff and [-1]

        else

                rdrop rdrop 0

        then ; hidden

: rx?  oUart iUart uart? ; hidden ( -- c -1 | 0 : read in a character of input from UART )

: ps2? oVT100 iVT100 uart? ; hidden ( -- c -1 | 0 : PS/2 version of rx? )

: uart! ( c a1 a2 -- : write to a UART, specified with registers a1, a2 )

        >r >r

        begin r@ @ $1000 and 0= until rdrop ( Wait until TX FIFO is not full )

        $2000 or r> ! ; hidden

: tx!  oUart iUart uart! ; hidden

: vga! oVT100 iVT100 uart! ; hidden ( n a -- : output character to VT100 display )

: um+ ( w w -- w carry )

        over over + >r

        r@ 0 < invert >r

        over over and

        or 0 < r> and invert 1 +

        r> swap ;

: rp! ( n -- , R: ??? -- ??? : set the return stack pointer )

        r> swap begin dup rp@ = 0= while rdrop repeat drop >r ; hidden

: rpick ( n -- u, R: un ... u0 )

        rdrop

        dup

        begin dup while rdrop 1- repeat drop r@ swap

        begin dup while rup   1- repeat drop

        rup ;

( With the built in words defined in the assembler, and the words

defined so far, all of the primitive words needed by eForth should

be available. "doList" and "doLit" do not need to be implemented as

they can implemented in terms of instructions )

( ======================== Forth Kernel ===================== )

( ======================== Word Set ========================= )

: 2! ( d a -- ) tuck ! cell+ ! ;          ( n n a -- )

: 2@ ( a -- d ) dup cell+ @ swap @ ;      ( a -- n n )

: here cp @ ;                             ( -- a )

: source #tib 2@ ;                        ( -- a u )

: source-id _id @ ;                       ( -- 0 | -1 )

: pad here pad-length + ;                 ( -- a )

: @execute @ ?dup if >r then ;            ( cfa -- )

: 3drop drop 2drop ; hidden               ( n n n -- )

: bl =bl ;                                ( -- c )

: within over - >r - r> u< ;              ( u lo hi -- f )

: dnegate invert >r invert 1 um+ r> + ;   ( d -- d )

: abs dup 0< if negate exit then ;        ( n -- u )

: count  dup 1+ swap c@ ;                 ( cs -- b u )

: rot >r swap r> swap ;                   ( n1 n2 n3 -- n2 n3 n1 )

: -rot swap >r swap r> ;                  ( n1 n2 n3 -- n3 n1 n2 )

: min over over < if drop exit else nip exit then ; ( n n -- n )

: max over over > if drop exit else nip exit then ; ( n n -- n )

: >char $7f and dup 127 =bl within if drop [char] _ then ; ( c -- c )

: tib #tib cell+ @ ; hidden               ( -- a )

: echo _echo @execute ; hidden            ( c -- )

: key? _key? @execute ;                   ( -- c -1 | 0 )

: key begin key? until ;                  ( -- c )

: allot cp +! ;                           ( u -- )

: /string over min rot over + -rot - ;    ( b u1 u2 -- b u : advance a string u2 characters )

: last context @ @ ;                      ( -- pwd )

: emit _emit @execute ;                   ( c -- : write out a char )

: toggle over @ xor swap ! ; hidden       ( a u -- : xor value at addr with u )

: cr =cr emit =lf emit ;                  ( -- )

: space =bl emit ;                        ( -- )

: pick ?dup if swap >r 1- pick r> swap exit then dup ; ( @bug does not work for high stack depths - mashes the return stack )

: ndrop for aft drop then next ; hidden   ( n1 ... nu u -- )

: type begin dup while swap count emit swap 1- repeat 2drop ; ( b u -- : print a string )

: $type begin dup while swap count >char emit swap 1- repeat 2drop ; hidden ( b u -- : print a string )

: print count type ; hidden               ( b -- )

: nuf? ( -- f ) key =cr = ;  ( -- f : true if 'cr' pressed, blocking )

: decimal? 48 58 within ; hidden            ( c -- f : decimal char? )

: lowercase? [char] a [char] { within ; hidden  ( c -- f : is character lower case? )

: uppercase? [char] A [char] [ within ; hidden  ( c -- f : is character upper case? )

\ : >upper dup lowercase? if =bl xor then ; ( c -- c : convert to upper case )

: >lower dup uppercase? if =bl xor exit then ; hidden ( c -- c : convert to lower case )

: nchars swap 0 max for aft dup emit then next drop ; hidden ( +n c -- : emit c n times  )

: spaces =bl nchars ;                     ( +n -- )

: cmove for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ; ( b b u -- )

: fill swap for swap aft 2dup c! 1+ then next 2drop ; ( b u c -- )

: substitute dup @ >r ! r> ; hidden ( u a -- u : substitute value at address )

: switch 2dup @ >r @ swap ! r> swap ! ; hidden ( a a -- : swap contents )

: aligned dup 1 and if 1+ exit then ;          ( b -- a )

: align cp @ aligned cp ! ;               ( -- )

: catch  ( xt -- exception# | 0 : return addr on stack )

        sp@ >r        ( xt : save data stack depth )

        handler @ >r  ( xt : and previous handler )

        rp@ handler ! ( xt : set current handler )

        execute       (      execute returns if no throw )

        r> handler !  (      restore previous handler )

        r> drop       (      discard saved stack ptr )

: throw  ( ??? exception# -- ??? exception# )

        ?dup if ( exc# \ 0 throw is no-op )

                handler @ rp! ( exc# : restore prev return stack )

                r> handler !  ( exc# : restore prev handler )

                r> swap >r    ( saved-sp : exc# on return stack )

                sp@ swap - ndrop r>   ( exc# : restore stack )

                ( return to the caller of catch because return )

                ( stack is restored to the state that existed )

                ( when catch began execution )

        then ;

: -throw negate throw ; hidden ( space saving measure )

( By making all the Forth primitives call '?depth' it should be possible

to get quite good coverage for stack checking, if not there is only a few

choice words that need depth checking to get quite a large coverage )

: ?depth dup 0= if drop exit then sp@ 1- u> if 4 -throw exit then ; hidden ( u -- )

: 1depth 1 ?depth ; hidden

\ : 2depth 2 ?depth ; hidden

\ : 3depth 3 ?depth ; hidden

: um/mod ( ud u -- ur uq )

        ?dup 0= if 10 -throw exit then

        2dup u<

        if negate 15

                for >r dup um+ >r >r dup um+ r> + dup

                        r> r@ swap >r um+ r> or

                        if >r drop 1 + r> else drop then r>

                next

                drop swap exit

        then drop 2drop  [-1] dup ;

: m/mod ( d n -- r q ) \ floored division

        dup 0< dup >r

        if

                negate >r dnegate r>

        then

        >r dup 0< if r@ + then r> um/mod r>

        if swap negate swap exit then ;

: um* ( u u -- ud )

        for dup um+ >r >r dup um+ r> + r>

                if >r over um+ r> + then

        next rot drop ;

: /mod  over 0< swap m/mod ; ( n n -- r q )

: mod  /mod drop ;           ( n n -- r )

: /    /mod nip ;            ( n n -- q )

: *    um* drop ;            ( n n -- n )

: decimal 10 base ! ;                       ( -- )

: hex     16 base ! ;                       ( -- )

: radix base @ dup 2 - 34 u> if hex 40 -throw exit then ; hidden

: digit  9 over < 7 and + 48 + ; hidden      ( u -- c )

: extract  0 swap um/mod swap ; hidden       ( n base -- n c )

: ?hold hld @ cp @ u< if 17 -throw exit then ; hidden ( -- )

: hold  hld @ 1- dup hld ! ?hold c! ;        ( c -- )

: sign  0< if [char] - hold then ;           ( n -- )

: #>  drop hld @ pad over - ;                ( w -- b u )

: #  1depth radix extract digit hold ;       ( u -- u )

: #s begin # dup while repeat ;              ( u -- 0 )

: <#  pad hld ! ;                            ( -- )

: str dup >r abs <# #s r> sign #> ; hidden   ( n -- b u : convert a signed integer to a numeric string )

\ :  .r >r str r> over - spaces type ;       ( n n : print n, right justified by +n )

: u.r >r <# #s #> r> over - spaces type ;    ( u +n -- : print u right justified by +n)

: u.  <# #s #> space type ;                  ( u -- : print unsigned number )

:  .  radix 10 xor if u. exit then str space type ; ( n -- print space, signed number )

: ? @ . ;                                    ( a -- : display the contents in a memory cell )

: pack$ ( b u a -- a ) \ null fill

        aligned dup >r over

        dup 0 cell um/mod ( use -2 and instead of um/mod? ) drop

        - over +  0 swap !  2dup c!  1+ swap cmove  r> ;

: ^h ( bot eot cur c -- bot eot cur )

        >r over r@ < dup

        if

                =bs dup echo =bl echo echo

        then r> + ; hidden

: tap dup echo over c! 1+ ; hidden ( bot eot cur c -- bot eot cur )

: ktap ( bot eot cur c -- bot eot cur )

        dup =cr xor

        if =bs xor

                if =bl tap else ^h then

                exit

        then drop nip dup ; hidden

: accept ( b u -- b u )

        over + over

        begin

                2dup xor

        while

                key  dup =bl - 95 u<

                if tap else _tap @execute then

        repeat drop over - ;

: expect ( b u -- ) _expect @execute span ! drop ;

: query tib tib-length _expect @execute #tib !  drop 0 >in ! ; ( -- )

: =string ( a1 u2 a1 u2 -- f : string equality )

        >r swap r> ( a1 a2 u1 u2 )

        over xor if 3drop  0 exit then

        for ( a1 a2 )

                aft

                        count >r swap count r> xor

                        if 2drop rdrop 0 exit then

                then

        next 2drop [-1] ;

: address $3fff and ; hidden ( a -- a : mask off address bits )

: nfa address cell+ ; hidden ( pwd -- nfa : move to name field address)

: cfa nfa dup count nip + cell + $fffe and ; hidden ( pwd -- cfa : move to code field address )

: .id nfa print ; hidden ( pwd -- : print out a word )

: logical 0= 0= ; hidden ( n -- f )

: immediate? @ $4000 and logical ; hidden ( pwd -- f : is immediate? )

: inline?    @ 0x8000 and logical ; hidden ( pwd -- f : is inline? )

: search ( a a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )

        swap >r

        begin

                dup

        while

                dup nfa count r@ count =string

                if ( found! )

                        dup immediate? if 1 else [-1] then

                        rdrop exit

                then

                @ address

        repeat

        drop r> 0 ; hidden

: find ( a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )

        >r

        context

        begin

                dup @

        while

                dup @ @ r@ swap search ?dup if rot rdrop drop exit else drop then

                cell+

        repeat drop r> 0 ;

: numeric? ( char -- n|-1 : convert character in 0-9 a-z range to number )

        >lower

        dup lowercase? if 87 - exit then ( 97 = 'a', +10 as 'a' == 10 )

        dup decimal?   if 48 - exit then ( 48 = '0' )

        drop [-1] ; hidden

: digit? >lower numeric? base @ u< ; hidden ( c -- f : is char a digit given base )

: do-number ( n b u -- n b u : convert string )

        begin

                ( get next character )

                2dup >r >r drop c@ dup digit? ( n char bool, R: b u )

                if   ( n char )

                        swap base @ * swap numeric? + ( accumulate number )

                else ( n char )

                        drop

                        r> r> ( restore string )

                        exit

                then

                r> r> ( restore string )

                1 /string dup 0= ( advance string and test for end )

        until ; hidden

: >number ( n b u -- n b u : convert string )

        radix >r

        over c@ $2D = if 1 /string [-1] >r else 0 >r then ( -negative )

        over c@ $24 = if 1 /string hex then ( $hex )

        do-number

        r> if rot negate -rot then

        r> base ! ; hidden

: number? 0 -rot >number nip 0= ; ( b u -- n f : is number? )

: -trailing ( b u -- b u : remove trailing spaces )

        for

                aft =bl over r@ + c@ <

                        if r> 1+ exit then

                then

        next 0 ; hidden

: lookfor ( b u c -- b u : skip until _test succeeds )

        >r

        begin

                dup

        while

                over c@ r@ - r@ =bl = _test @execute if rdrop exit then

                1 /string

        repeat rdrop ; hidden

: skipper if 0> exit else 0<> exit then ; hidden    ( n f -- f )

: scanner skipper invert ; hidden         ( n f -- f )

: skip ' skipper _test ! lookfor ; hidden ( b u c -- u c )

: scan ' scanner _test ! lookfor ; hidden ( b u c -- u c )

: parser ( b u c -- b u delta )

        >r over r> swap >r >r

        r@ skip 2dup

        r> scan swap r> - >r - r> 1+ ; hidden

: parse >r tib >in @ + #tib @ >in @ - r> parser >in +! -trailing 0 max ; ( c -- b u ;  )

: ) ; immediate

: "(" 41 parse 2drop ; immediate

: .( 41 parse type ;

: "\" #tib @ >in ! ; immediate

: ?length dup word-length u> if 19 -throw exit then ; hidden

: word 1depth parse ?length here pack$ ;          ( c -- a ;  )

: token =bl word ; hidden

: char token count drop c@ ;               ( -- c;  )

: .s ( -- ) cr sp@ for aft r@ pick . then next .s-string print ;

: unused $4000 here - ; hidden

: .free unused u. ; hidden

: preset sp@ ndrop tib #tib cell+ ! 0 >in ! 0 _id ! ( console / io! ) ; hidden

: ] [-1] state ! ;

: [  0 state ! ; immediate

: .error ( n -- )

        abs dup 60 < loaded @ and

        if

                dup l/b / + 32 + _message @execute

        else

                negate . cr

        then ; hidden

: ?error ( n -- : perform actions on error )

        ?dup if

                [char] ? emit ( print error message )

                .error

                preset        ( reset machine )

                [             ( back into interpret mode )

                exit

        then ; hidden

: ?dictionary dup $3f00 u> if 8 -throw exit then ; hidden

: , here dup cell+ ?dictionary cp ! ! ; ( u -- )

: doLit 0x8000 or , ; hidden

: ?compile state @ 0= if 14 -throw exit then ; hidden ( fail if not compiling )

: literal ( n -- : write a literal into the dictionary )

        ?compile

        dup 0x8000 and ( n > $7fff ? )

        if

                invert doLit =invert , exit ( store inversion of n the invert it )

        else

                doLit exit ( turn into literal, write into dictionary )

        then ; immediate

: make-callable 2/ $4000 or ; hidden ( cfa -- instruction )

: compile, make-callable , ;         ( cfa -- : compile a code field address )

: $compile dup inline? if cfa @ , else cfa compile, then ; hidden ( pwd -- )

: interpret ( ??? a -- ??? : The command/compiler loop )

        find ?dup if

                state @

                if

                        0> if \ immediate

                                cfa execute exit

                        else

                                $compile exit

                        then

                else

                        drop cfa execute exit

                then

        else \ not a word

                dup count number? if

                        nip

                        state @ if literal exit then

                else

                        drop space print 13 -throw exit

                then

        then ;

: "immediate" last address $4000 toggle ;

: .ok state @ 0= if space OK print space then cr ;

: eval begin token dup count nip while interpret repeat drop _prompt @execute ; hidden

: quit quitLoop: preset [ begin query ' eval catch ?error again ;

: evaluate ( a u -- )

        _prompt @ >r  0 _prompt !

        _id     @ >r [-1] _id !

        >in     @ >r  0 >in !

        source >r >r

        #tib 2!

        ' eval catch

        r> r> #tib 2!

        r> >in !

        r> _id !

        r> _prompt !

        throw ;

: ccitt ( crc c -- crc : calculate polynomial $1021 AKA "x16 + x12 + x5 + 1" )

        over 256/ xor        ( crc x )

        dup  4  rshift xor   ( crc x )

        dup  5  lshift xor   ( crc x )

        dup  12 lshift xor   ( crc x )

        swap 8  lshift xor ; ( crc )

: crc ( b u -- u : calculate ccitt-ffff CRC )

        $ffff >r

        begin

                dup

        while

                over c@ r> swap ccitt >r 1 /string

        repeat 2drop r> ;

: random seed @ dup 15 lshift ccitt dup iTimerDin @ + seed ! ; ( -- u )

: 5u.r 5 u.r ; hidden

: dm+ 2/ for aft dup @ space 5u.r cell+ then next ; ( a u -- a )

: colon 58 emit ; hidden ( -- )

: dump ( a u -- )

        dump-width /

        for

                aft

                        cr dump-width 2dup

                        over 5u.r colon space

                        dm+ -rot

                        2 spaces $type

                then

        next drop ;

: CSI $1b emit [char] [ emit ; hidden

: 10u. base @ >r decimal <# #s #> type r> base ! ; hidden ( u -- )

: ansi swap CSI 10u. emit ; ( n c -- )

: at-xy CSI 10u. $3b emit 10u. [char] H emit ; ( x y -- )

: page 2 [char] J ansi 1 1 at-xy ; ( -- )

: sgr [char] m ansi ; ( -- )

( ==================== Extra Words =================================== )

\ : gcd gcdStart: dup if tuck mod branch gcdStart then drop ; ( u1 u2 -- u : greatest common divisor )

\ : lcm 2dup gcd / * ; ( u1 u2 -- u : lowest common multiple of u1 and u2 )

( ==================== Extra Words =================================== )

( ==================== Advanced I/O Control ========================== )

: segments! o7SegLED ! ;   ( u -- : display a number on the LED 7 segment display )

: led!      oLeds ! ;      ( u -- : write to LED lights )

: switches  iSwitches  @ ; ( -- u : get the state of the switches)

: timer!    oTimerCtrl ! ; ( u -- )

: timer     iTimerDin  @ ; ( -- u )

: input rx? if [-1] else ps2? then ; hidden ( -- c -1 | 0 : UART and PS/2 Input )

: output dup tx! vga! ; hidden ( c -- : write to UART and VGA display )

: printable? 32 127 within ; hidden ( c -- f )

: pace 11 emit ; hidden

: xio  ' accept _expect ! _tap ! _echo ! _prompt ! ; hidden

: file ' pace ' "drop" ' ktap xio ;

: star $2A emit ; hidden

: [conceal] dup 33 127 within if drop star else output then ; hidden

: conceal ' .ok ' [conceal] ' ktap xio ;

: hand ' .ok  '  emit  ' ktap xio ; hidden

: console ' rx? _key? ! ' tx! _emit ! hand ;

: interactive ' input _key? ! ' output _emit ! hand ;

: io! $8FFF oTimerCtrl ! interactive 0 ien oIrcMask ! ; ( -- : initialize I/O )

: ver $666 ;

: hi io! ( save ) hex cr hi-string print ver <# # # 46 hold # #> type cr here . .free cr [ ;

( ==================== Advanced I/O Control ========================== )

( ==================== Control Structures ============================ )

( The following section implements the control structures and high level

words used for interpreting Forth. As much error checking is done

as possible so the Forth environment is easy to use. )

( @note The word ';' currently throws an exception when it is ran in compile

mode, this is so a Forth block can have it's first word as ';' to stop

thru from executing it - thru should then ignore it, but it does not at the

moment. Another useful word would be one that lists the currently loaded

block then stops evaluation of the loaded block, this would be useful for

displaying block files as they are read in )

: !csp sp@ csp ! ; hidden

: ?csp sp@ csp @ xor if 22 -throw exit then ; hidden

: +csp csp 1+! ; hidden

: -csp csp 1-! ; hidden

: ?unique dup last search if drop redefined print cr exit else drop exit then ; hidden ( a -- a )

: ?nul count 0= if 16 -throw exit then 1- ; hidden ( b -- : check for zero length strings )

: find-cfa token find if cfa exit else 13 -throw exit then ; hidden

: "'" find-cfa state @ if literal exit then ; immediate

: [compile] ?compile find-cfa compile, ; immediate ( -- ;  )

: compile  r> dup @ , cell+ >r ; ( -- : Compile next compiled word NB. Works for words, instructions, and numbers below $8000 )

: "[char]" ?compile char literal ; immediate ( --,  : )

: ?quit state @ 0= if 56 -throw exit then ; hidden

: ";" ?quit ( ?compile ) +csp ?csp context @ ! =exit , ( save )  [ ; immediate

: ":" align ( save ) !csp here dup last-def ! last address ,  token ?nul ?unique count + aligned cp ! ] ;

: jumpz, 2/ $2000 or , ; hidden

: jump, 2/ ( $0000 or ) , ; hidden

: "begin" ?compile here -csp ; immediate

: "until" ?compile jumpz, +csp ; immediate

: "again" ?compile jump, +csp ; immediate

: "if" ?compile here 0 jumpz, -csp ; immediate

: doThen  here 2/ over @ or swap ! ; hidden

: "then" ?compile doThen +csp ; immediate

: "else" ?compile here 0 jump, swap doThen ; immediate

: "while" ?compile call "if" ; immediate

: "repeat" ?compile swap call "again" call "then" ; immediate

: recurse ?compile last-def @ address cfa compile, ; immediate

\ : tail ?compile last-def @ address cfa jump, ; immediate

: create call ":" compile doVar context @ ! [ ;

: doDoes r> 2/ here 2/ last-def @ address cfa dup cell+ doLit ! , ; hidden

: does> ?compile compile doDoes nop ; immediate

: "variable" create 0 , ;

: ":noname" here ] !csp ;

: "for" ?compile =>r , here -csp ; immediate

: "next" ?compile compile doNext , +csp ; immediate

: "aft" ?compile drop here 0 jump, call "begin" swap ; immediate

: doer create =exit last-def @ cfa ! =exit ,  ;

: make

        find-cfa find-cfa make-callable

        state @

        if

                literal literal compile ! exit

        else

                swap ! exit

        then ; immediate

: "constant" create ' doConst make-callable here cell- ! , ;

\ : [leave] rdrop rdrop rdrop ; hidden

\ : leave ?compile compile [leave] ; immediate

\ : [do] r> dup >r swap rot >r >r cell+ >r ; hidden

\ : do ?compile compile [do] 0 , here ; immediate

\ : [loop]

\     r> r> 1+ r> 2dup <> if >r >r @ >r exit then

\     >r 1- >r cell+ >r ; hidden

\ : [unloop] r> rdrop rdrop rdrop >r ; hidden

\ : loop compile [loop] dup , compile [unloop] cell- here 2/ swap ! ; immediate

\ : [i] r> r> tuck >r >r ; hidden

\ : i ?compile compile [i] ; immediate

\ : [?do]

\    2dup <> if r> dup >r swap rot >r >r cell+ >r exit then 2drop exit ; hidden

\ : ?do  ?compile compile [?do] 0 , here ; immediate

\ : back here cell- @ ; hidden ( a -- : get previous cell )

\ : call? back $e000 and $4000 = ; hidden ( -- f : is call )

\ : merge? back dup $e000 and $6000 = swap $1c and 0= and ; hidden ( -- f : safe to merge exit )

\ : redo here cell- ! ; hidden

\ : merge back $1c or redo ; hidden

\ : tail-call back $1fff and redo ; hidden ( -- : turn previously compiled call into tail call )

\ : compile-exit call? if tail-call else merge? if merge else =exit , then then ; hidden

\ : compile-exit call? if tail-call else merge? if merge then then =exit , ; hidden

\ : "exit" compile-exit ; immediate

\ : "exit" =exit , ; immediate

( Error recovery can be quite difficult when sending Forth large programs

over a serial port. One of the problems is if an error occurs in between a

colon definition the Forth interpreter would signal an error and go back into

command mode, subsequently words which are meant to be compiled are instead

executed which can cause the system to become unstable. There are potential

ways of getting around this:

1. The sender stops upon encountering an error

2. The receiver discards all input until the end of the file [if it can work

out when that is].

3. A third interpreter state in which words are discarded until a closing

';' is encountered.

To keep things simple non of these methods are used, but they highlight ways

in which the problem could be solved. )

( ==================== Control Structures ============================ )

( ==================== Strings ======================================= )

: do$ r> r@ r> count + aligned >r swap >r ; hidden ( -- a )

: $"| do$ nop ; hidden                             ( -- a : do string NB. nop needed to fool optimizer )

: ."| do$ print ; hidden                           ( -- : print string )

: $,' 34 word count + aligned cp ! ; hidden        ( -- )

: $"  ?compile compile $"| $,' ; immediate         ( -- ;  )

: ."  ?compile compile ."| $,' ; immediate         ( -- ;  )

\ : abort 0 rp! quit ;                               ( --, R: ??? --- ??? : Abort! )

\ : abort" ?compile ." compile abort ; immediate

( ==================== Strings ======================================= )

( ==================== Block Word Set ================================ )

: updated? block-dirty @ ; hidden      ( -- f )

: update [-1] block-dirty ! ;          ( -- )

: +block blk @ + ;                     ( n -- k )

: clean-buffers 0 block-dirty ! ; hidden

: empty-buffers clean-buffers block-invalid blk ! ;  ( -- )

: save-buffers                         ( -- )

        blk @ block-invalid = updated? 0= or if exit then

        block-buffer b/buf blk @ _bsave @execute throw

        clean-buffers ;

: flush save-buffers empty-buffers ;

: block ( k -- a )

        1depth

        _binvalid @execute                         ( check validity of block number )

        dup blk @ = if drop block-buffer exit then ( block already loaded )

        flush

        dup >r block-buffer b/buf r> _bload @execute throw

        blk !

        block-buffer ;

: line swap block swap c/l * + c/l ; hidden ( k u -- a u )

: loadline line evaluate ; hidden ( k u -- )

: load 0 l/b 1- for 2dup >r >r loadline r> r> 1+ next 2drop ;

: pipe 124 emit ; hidden

: .line line -trailing $type ; hidden

: .border border @ if 3 spaces c/l 45 nchars cr exit then ; hidden

: #line border @ if dup 2 u.r exit then ; hidden ( u -- u : print line number )

: ?pipe border @ if pipe exit then ; hidden

: ?page border @ if page exit then ; hidden

( @todo 'thru' should catch -56, or QUIT, and continue with next block )

\ : ?load ' load catch dup -56 <> if throw then drop ;

: thru over - for dup load 1+ next drop ; ( k1 k2 -- )

: blank =bl fill ;

: message l/b extract .line cr ; ( u -- )

: list

        ?page

        cr

        .border

                dup l/b <

        while

                2dup #line ?pipe line $type ?pipe cr 1+

        repeat .border 2drop ;

: index ( k1 k2 -- : show titles for block k1 to k2 )

        over - cr

        for

                dup 5u.r space pipe space dup  0 .line cr 1+

        next drop ;

( all words before this are now in the forth vocabulary, it is also set

later on )

.set forth-wordlist $pwd

( ==================== Block Word Set ================================ )

( ==================== See =========================================== )

( @warning This disassembler is experimental, and liable not

to work / break everything it touches )

: bcounter! bcount @ 0= if 2/ over swap -  bcount ! else drop then ; hidden ( u a -- u )

: -bcount   bcount @ if bcount 1-! then ; hidden ( -- )

: abits $1fff and ; hidden

: validate ( cfa pwd -- nfa | 0 )

        tuck cfa <> if drop 0 else nfa then ; hidden

( @todo Do this for every vocabulary loaded )

: name ( cfa -- nfa )

        abits 2*

        >r

        last address

        begin

                dup

        while

                address dup r@ swap dup @ address swap within ( simplify? )

                if @ address r> swap validate exit then

                address @

        repeat rdrop ; hidden

: .name name ?dup 0= if see.unknown then print ; hidden

: mask-off 2dup and = ; hidden ( u u -- u f )

i.end2t: 2*

i.end:   5u.r rdrop exit

: i.print print abits ; hidden

( @note A recursive version of 'see' that decompiled no-name words would complicate

things, the 'decompiler' word could be called manually on an address if desired )

: instruction ( decode instruction )

        over >r

        0x8000 mask-off if see.lit     print $7fff and      branch i.end then

        $6000  mask-off if see.alu     i.print              branch i.end then

        $4000  mask-off if see.call    i.print dup 2*       5u.r rdrop space .name exit then

        $2000  mask-off if see.0branch i.print r@ bcounter! branch i.end2t then

                           see.branch  i.print r@ bcounter! branch i.end2t ; hidden

: continue? ( u a -- f : determine whether to continue decompilation  )

        bcount @ if 2drop [-1] exit then

        over $e000 and 0= if u> exit else drop then

        dup ' doVar make-callable = if drop 0 exit then ( print next address ? )

        =exit and =exit <> ; hidden

: decompile ( a -- a : decompile a single instruction )

        dup 5u.r colon dup @ 5u.r space

        dup @ instruction

        dup @ ' doNext make-callable = if cell+ dup ? then

        cr

        cell+ ; hidden

: decompiler ( a -- : decompile starting at address )

        dup 2/ >r

        begin dup @ r@ continue? while decompile -bcount ( nuf? ) repeat decompile rdrop

        drop ; hidden

: see ( --,  : decompile a word )

        token find 0= if 13 -throw exit then

        cr colon space dup .id space

        dup inline?    if see.inline    print then

        dup immediate? if see.immediate print then

        cr

        cfa decompiler space 59 emit cr ;

\ : see

\       token find 0= if 13 -throw exit then

\       begin nuf? while

\               dup @ dup $4000 and $4000

\               = if space .name else . then cell+

\       repeat drop ;

.set forth-wordlist $pwd

( ==================== See =========================================== )

( ==================== Miscellaneous ================================= )

\ Testing for the interrupt mechanism, interrupts do not

\ work correctly at the moment

( @bug Interrupts work in simulation but not in hardware )

variable #irq 0

: doIrq

        switches led!

        #irq 1+!

        #irq @ segments!

        1 ien drop ; hidden

irqTask: doIrq nop exit

 \ doIrq nop exit

.set 2 irqTask

.set 4 irqTask

.set 6 irqTask