Subversion Repositories forth-cpu

system +order 0 <ok> !

.( FORTH META COMPILATION START ) cr

\ ============================================================================
\ # The Meta-Compiler
\ 
only forth definitions hex
system +order 0 <ok> !
variable meta          ( Metacompilation vocabulary )
meta +order definitions
variable assembler.1         ( Target assembler vocabulary )
variable target.1            ( Target dictionary )
variable tcp                 ( Target dictionary pointer )
variable tlast               ( Last defined word in target )
variable tdoVar              ( Location of doVar in target )
variable tdoConst            ( Location of doConst in target )
variable tdoNext             ( Location of doNext in target )
variable tdoPrintString      ( Location of .string in target )
variable tdoStringLit        ( Location of string-literal in target )
variable fence               ( Do not peephole optimize before this point )
5000 constant #target        ( Location where target image will be built )
2    constant =cell          ( Target cell size )
$3A00 constant pad-area      ( area for pad storage )
( 1   constant verbose ( verbosity level, higher is more verbose )
#target 2000 0 fill    ( Erase the target memory location )
: ]asm assembler.1 +order ; immediate    ( -- )
: a: current @ assembler.1 current ! : ; ( "name" -- wid link )
: a; [compile] ; current ! ; immediate   ( wid link -- )
: ( [char] ) parse 2drop ; immediate ( "comment" -- discard until parenthesis )
: \ source drop @ >in ! ; immediate  ( "comment" -- discard until end of line )
: there tcp @ ;                      ( -- a : target dictionary pointer value )
: tc! #target + c! ;                 ( u a -- : store character in target )
: tc@ #target + c@ ;                 ( a -- u : retrieve character in target )
: [last] tlast @ ;                   ( -- a : last defined word in target )
: t! over $FF and over tc! swap 8 rshift swap 1+ tc! ; ( u a -- )
: t@ dup tc@ swap 1+ tc@ 8 lshift or ; ( a -- u )
: 2/ 1 rshift ;                ( u -- u : non-standard definition divide by 2 )
\ : 2* 1 lshift ;                ( u -- u : multiple by two, non-standard )
: talign there 1 and tcp +! ;  ( -- : align target dictionary pointer value )
: tc, there tc! 1 tcp +! ;     ( c -- : write byte into target dictionary )
: t,  there t!  =cell tcp +! ; ( u -- : write cell into target dictionary )
\ : tallot tcp +! ;            ( n -- : allocate memory in target dictionary )
: update-fence there fence ! ; ( -- : update optimizer fence location )
: $literal                     ( <string>, -- )
  [char] " word count dup tc, 1- for count tc, next drop talign update-fence ;
: tcells =cell * ;             ( u -- a )
: tbody 1 tcells + ;           ( a -- a )
: tcfa cfa ;                   ( PWD -- CFA )
: tnfa nfa ;                   ( PWD -- NFA )
: meta! ! ;                    ( u a --  )
: checksum #target there crc ; ( -- u : calculate CRC of target image )
: finished ( -- : save target image and display statistics )
   hex
  ." COMPLETE" cr
  ." HOST:   " here  . cr
  ." TARGET: " there . cr
   only forth definitions hex
   ." SAVING..."  #target #target there + (save) throw ." DONE" cr
   ." STACK>" .s cr ;
: [a] ( "name" -- : find word and compile an assembler word )
  bl word assembler.1 search-wordlist 0= abort" [a]? "
  cfa compile, ; immediate
: asm[ assembler.1 -order ; immediate ( -- )
a: #literal $8000 a; ( literal instruction - top bit set )
a: #alu     $6000 a; ( ALU instruction, further encoding below... )
a: #call    $4000 a; ( function call instruction )
a: #?branch $2000 a; ( branch if zero instruction )
a: #branch  $0000 a; ( unconditional branch )

a: #t      $0000 a; ( T = t )
a: #n      $0100 a; ( T = n )
a: #t+n    $0200 a; ( T = t+n )
a: #t&n    $0300 a; ( T = t&n )
a: #t|n    $0400 a; ( T = t|n )
a: #t^n    $0500 a; ( T = t^n )
a: #~t     $0600 a; ( T = ~t )
a: #t==n   $0700 a; ( T = n == t? )
a: #n<t    $0800 a; ( T = n < t, signed version )
a: #n>>t   $0900 a; ( T = n right shift by t places )
a: #t-1    $0A00 a; ( T == t - 1 )
a: #r      $0B00 a; ( T = Top of Return Stack )
a: #[t]    $0C00 a; ( T = memory[t] )
a: #n<<t   $0D00 a; ( T = n << t )
a: #sp@    $0E00 a; ( T = depth )
a: #nu<t   $0F00 a; ( T = n < t, unsigned )
a: #cpu!   $1000 a; ( T = set interrupts )
a: #cpu?   $1100 a; ( T = interrupts set? )
a: #rp@    $1200 a; ( T = r-depth )
a: #t==0   $1300 a; ( T = t == 0? )
a: #cpu-id $1400 a; ( T = CPU ID )
\ a: #alu-lit $1500 a; ( T = instruction, hidden )

a: d+1     $0001 or a; ( increment variable stack by one )
a: d-1     $0003 or a; ( decrement variable stack by one )
a: d-2     $0002 or a; ( decrement variable stack by two, not used )
a: r+1     $0004 or a; ( increment variable stack by one )
a: r-1     $000C or a; ( decrement variable stack by one )
a: r-2     $0008 or a; ( decrement variable stack by two, not used )
a: r->pc   $0010 or a; ( Set Program Counter to Top of Return Stack )
a: n->[t]  $0020 or a; ( Set Next on Variable Stack to Top on Variable Stack )
a: t->r    $0040 or a; ( Set Top of Return Stack to Top on Variable Stack )
a: t->n    $0080 or a; ( Set Next on Variable Stack to Top on Variable Stack )
: ?set dup $E000 and abort" argument too large" ; ( u -- )
a: branch  2/ ?set [a] #branch  or t, a; ( a -- : an Unconditional branch )
a: ?branch 2/ ?set [a] #?branch or t, a; ( a -- : Conditional branch )
a: call    2/ ?set [a] #call    or t, a; ( a -- : Function call )
a: ALU        ?set [a] #alu     or    a; ( u -- : Make ALU instruction )
a: alu                    [a] ALU  t, a; ( u -- : ALU operation )
a: literal ( n -- : compile a number into target )
  dup [a] #literal and if   ( numbers above $7FFF take up two instructions )
    invert recurse  ( the number is inverted, and 'literal' is called again )
    [a] #~t [a] alu ( then an invert instruction is compiled into the target )
  else
    [a] #literal or t, ( numbers below $8000 are single instructions )
  then a;
a: return ( -- : Compile a return into the target )
   [a] #t [a] r->pc [a] r-1 [a] alu a;
: previous there =cell - ;                      ( -- a )
: lookback previous t@ ;                        ( -- u )
: call? lookback $E000 and [a] #call = ;        ( -- t )
: call>goto previous dup t@ $1FFF and swap t! ; ( -- )
: fence? fence @  previous u> ;                 ( -- t )
: safe? lookback $E000 and [a] #alu = lookback $001C and 0= and ; ( -- t )
: alu>return previous dup t@ [a] r->pc [a] r-1 swap t! ; ( -- )
: exit-optimize                                 ( -- )
  fence? if [a] return exit then
  call?  if call>goto  exit then
  safe?  if alu>return exit then
  [a] return ;
: exit, exit-optimize update-fence ;            ( -- )
: compile-only tlast @ tnfa t@ $20 or tlast @ tnfa t! ; ( -- )
: immediate    tlast @ tnfa t@ $40 or tlast @ tnfa t! ; ( -- )
: mcreate current @ >r target.1 current ! create r> current ! ;
: thead ( b u -- : compile word header into target dictionary )
  talign
  there [last] t, tlast !
  there #target + pack$ c@ 1+ aligned tcp +! talign ;
: lookahead ( -- b u : parse a word, but leave it in the input stream )
  >in @ >r bl parse r> >in ! ;
: literal [a] literal ;       ( u --  )
: [ ' literal   <literal> ! ; ( -- )
: ] ' (literal) <literal> ! ; ( -- )
: h: ( -- : create a word with no name in the target dictionary )
 [compile] [
 $F00D mcreate there , update-fence does> @ [a] call ;
: t: ( "name", -- : creates a word in the target dictionary )
  lookahead thead h: ;
: ?unstructured $F00D xor if source type cr 1 abort" unstructured! " then ;
: fallthrough; [compile] ] ?unstructured ; ( u -- )
: t; fallthrough; exit, ; \ "[a] return" <- unoptimized version
: ;; t; ?unstructured ;
: fetch-xt @ dup 0= abort" (null) " ; ( a -- xt )
: tconstant ( "name", n --, Run Time: -- )
  >r
  lookahead
  thead
  there tdoConst fetch-xt [a] call r> t, >r
  mcreate r> ,
  does> @ tbody t@ [a] literal ;
: tvariable ( "name", n -- , Run Time: -- a )
  >r
  lookahead
  thead
  there tdoVar fetch-xt [a] call r> t, >r
  mcreate r> ,
  does> @ tbody [a] literal ;
: tlocation ( "name", n -- : Reserve space in target for a memory location )
  there swap t, mcreate , does> @ [a] literal ;
: [t] ( "name", -- a : get the address of a target word )
  bl word target.1 search-wordlist 0= abort" [t]?"
  cfa >body @ ;
: [f] ( "name", -- execute word in host Forth vocabulary )
  bl word forth-wordlist search-wordlist 0= abort" [f]?"
  cfa execute ;
: [v] [t] =cell + ; ( "name", -- a )
: xchange ( "name1", "name2", -- : exchange target vocabularies )
  [last] [t] t! [t] t@ tlast meta! ;
: begin  there update-fence ;                ( -- a )
: until  [a] ?branch ;                       ( a -- )
: if     there update-fence 0 [a] ?branch  ; ( -- a )
: skip   there update-fence 0 [a] branch ;   ( -- a )
: then   begin 2/ over t@ or swap t! ;       ( a -- )
: else   skip swap then ;                    ( a -- a )
: while  if swap ;                           ( a -- a a )
: repeat [a] branch then update-fence ;      ( a -- )
: again  [a] branch update-fence ;           ( a -- )
: aft    drop skip begin swap ;              ( a -- a )
: constant mcreate , does> @ literal ;       ( "name", a -- )
: [char] char literal ;                      ( "name" )
: postpone [t] [a] call ;                    ( "name", -- )
: next tdoNext fetch-xt [a] call t, update-fence ; ( a -- )
: exit exit, ;                               ( -- )
: ' [t] literal ;                            ( "name", -- )
: recurse tlast @ tcfa [a] call ;            ( -- )
: ." tdoPrintString fetch-xt [a] call $literal ; ( "string", -- )
: $" tdoStringLit   fetch-xt [a] call $literal ; ( "string", -- )
: nop      ]asm #t                             alu asm[ ;
: dup      ]asm #t      t->n               d+1 alu asm[ ;
: over     ]asm #n      t->n               d+1 alu asm[ ;
: invert   ]asm #~t                            alu asm[ ;
: +        ]asm #t+n                       d-1 alu asm[ ;
: swap     ]asm #n      t->n                   alu asm[ ;
: nip      ]asm #t                         d-1 alu asm[ ;
: drop     ]asm #n                         d-1 alu asm[ ;
: >r       ]asm #n             t->r    r+1 d-1 alu asm[ ;
: r>       ]asm #r      t->n           r-1 d+1 alu asm[ ;
: r@       ]asm #r      t->n               d+1 alu asm[ ;
: @        ]asm #[t]                           alu asm[ ;
: rshift   ]asm #n>>t                      d-1 alu asm[ ;
: lshift   ]asm #n<<t                      d-1 alu asm[ ;
: =        ]asm #t==n                      d-1 alu asm[ ;
: u<       ]asm #nu<t                      d-1 alu asm[ ;
: <        ]asm #n<t                       d-1 alu asm[ ;
: and      ]asm #t&n                       d-1 alu asm[ ;
: xor      ]asm #t^n                       d-1 alu asm[ ;
: or       ]asm #t|n                       d-1 alu asm[ ;
: sp@      ]asm #sp@    t->n               d+1 alu asm[ ;
: 1-       ]asm #t-1                           alu asm[ ;
: rp@      ]asm #rp@    t->n               d+1 alu asm[ ;
: 0=       ]asm #t==0                          alu asm[ ;
: rdrop    ]asm #t                     r-1     alu asm[ ;
\ : 2rdrop ]asm #t                     r-2     alu asm[ ;
\ : rdrop>r ]asm #n            t->r        d-1 alu asm[ ;
: dup>r    ]asm #t             t->r    r+1     alu asm[ ;
: over-and ]asm #t&n                           alu asm[ ;
: over+    ]asm #t+n                           alu asm[ ;
\ : over-xor ]asm #t^n                         alu asm[ ;
: >r-dup   ]asm #n             t->r    r+1     alu asm[ ;
: 2dup=    ]asm #t==n  t->n                d+1 alu asm[ ;
: 2dup<    ]asm #n<t   t->n                d+1 alu asm[ ;
: 2dupu<   ]asm #nu<t  t->n                d+1 alu asm[ ;
: 2dup-xor ]asm #t^n   t->n                d+1 alu asm[ ;
: store    ]asm #n     n->[t]              d-1 alu asm[ ;
: tuck!    ]asm #t     n->[t]              d-1 alu asm[ ;
: cpu-id   ]asm #cpu-id                    d+1 alu asm[ ;
: cpu!     ]asm #cpu!                      d-1 alu asm[ ;
: cpu?     ]asm #cpu?  t->n                d+1 alu asm[ ;
: dup@     ]asm #[t]   t->n                d+1 alu asm[ ;
: r>rdrop  ]asm #r     t->n            r-2 d+1 alu asm[ ;
: rxchg    ]asm #r             t->r            alu asm[ ;
: nip-nip  ]asm #t                         d-2 alu asm[ ;
: for >r begin ;
: meta: : ;
( : :noname h: ; )
: : t: ;
meta: ; t; ;
hide meta:
hide t:
hide t;
]asm #~t              ALU asm[ constant =invert ( invert instruction )
]asm #t  r->pc    r-1 ALU asm[ constant =exit   ( return/exit instruction )
]asm #n  t->r d-1 r+1 ALU asm[ constant =>r     ( to r. stk. instruction )
$20   constant =bl         ( blank, or space )
$D    constant =cr         ( carriage return )
$A    constant =lf         ( line feed )
$8    constant =bs         ( back space )
$7F   constant =del        ( delete key )
\ $1B   constant =escape     ( escape character )
$50   constant tib-length  ( size of terminal input buffer )
$40   constant word-length ( maximum length of a word )
$40   constant c/l         ( characters per line in a block )
$10   constant l/b         ( lines in a block )
$2BAD constant magic       ( magic number for compiler security )
( Volatile variables )
$3B02 constant last-def    ( last, possibly unlinked, word definition )
$3B06 constant id          ( used for source id )
$3B0A constant handler     ( current handler for throw/catch )
$3B0C constant block-dirty ( -1 if loaded block buffer is modified )
$3B14 constant <expect>    ( "accept" vector )
$3B16 constant <tap>       ( "tap" vector, for terminal handling )
$3B18 constant <echo>      ( c -- : emit character )
$3B1A constant context     ( holds current context for search order )
  ( area for context is #vocs large )
$3B2A constant #tib        ( Current count of terminal input buffer )
$3B2C constant tib-buf     ( ... and address )
$3B2E constant tib-start   ( backup tib-buf value )
$3C00 constant block-buffer ( block buffer is stored here )

$10   constant header-length ( location of length in header )
$12   constant header-crc    ( location of CRC in header )
$14   constant header-options ( location of options bits in header )
target.1         +order ( Add target word dictionary to search order )
meta -order meta +order ( Reorder so *meta* has a higher priority )
system           -order ( Remove system vocabulary to previously accidents )
forth-wordlist   -order ( Remove normal Forth words to prevent accidents )

\ ============================================================================
\ # Start of Image

0        t, \  $0: IRQ-0; Reset Vector / maskable IRQ for Down D-PAD button
0        t, \  $2: IRQ-1; UART RX FIFO NOT EMPTY
0        t, \  $4: IRQ-2; UART RX FIFO FULL
0        t, \  $6: IRQ-3; UART TX FIFO NOT EMPTY

0        t, \  $8: IRQ-4; UART TX FIFO FULL
0        t, \  $A: IRQ-5; PS/2 KEYBOARD (NEW CHARACTER)
0        t, \  $C: IRQ-6; TIMER
0        t, \  $E: IRQ-7; D-PAD BUTTON CHANGED

0        t, \ $10: For Length of Forth image, different from VM size
0        t, \ $12: For CRC of Forth image, not entire VM memory
$0001    t, \ $14: Header options
h: doVar   r> ;    ( -- a : push return address and exit to caller )
h: doConst r> @ ;  ( -- u : push value at return address and exit to caller )
[t] doVar   tdoVar   meta!
[t] doConst tdoConst meta!
0 tlocation root-voc     ( root vocabulary )
0 tlocation editor-voc   ( editor vocabulary )
pad-area tconstant pad   ( pad variable - offset into temporary storage )
$8       constant  #vocs ( number of vocabularies in allowed )
$2       tconstant cell  ( size of a cell in bytes )
$400     tconstant b/buf ( size of a block )
0        tlocation #irq  ( Used in example IRQ, count of IRQs )
0        tlocation cp    ( Dictionary Pointer: Set at end of file )
0        tlocation _forth-wordlist ( set at the end near the end of the file )
0        tlocation _system ( system specific vocabulary )
$0       tvariable >in   ( Hold character pointer when parsing input )
1        tlocation seed1 ( PRNG seed; never set to zero )
1        tlocation seed2 ( PRNG seed; never set to zero )
$0       tvariable state ( compiler state variable )
$0       tvariable hld   ( Pointer into hold area for numeric output )
$A       tvariable base  ( Current output radix )
$0       tvariable span  ( Hold character count received by expect   )
0        tvariable blk   ( current blk loaded, set in *cold* )
$FFFF    tvariable dpl   ( number of places after fraction )
0        tvariable current   ( WID to add definitions to )
xchange _forth-wordlist _system
0        tvariable <save>    ( holds execution vector for saving blocks )
0        tvariable <block>   ( holds execution vector for block )
0        tvariable <literal> ( holds execution vector for literal )
0        tvariable <ok>      ( prompt execution vector )
0        tvariable <key>     ( -- c : new character, blocking input )
0        tvariable <emit>    ( c -- : emit character )
( : nop    nop      ; ( -- : do nothing )
: cpu-id  cpu-id    ; ( -- u : returns CPU ID )
: cpu?    cpu?      ; ( -- u : returns CPU status )
: cpu!    cpu!      ; ( u -- : sets CPU status )
xchange _system _forth-wordlist
: dup      dup      ; ( n -- n n : duplicate value on top of stack )
: over     over     ; ( n1 n2 -- n1 n2 n1 : duplicate second value on stack )
: invert   invert   ; ( u -- u : bitwise invert of value on top of stack )
: +        +        ; ( u u -- u : addition without carry )
: swap     swap     ; ( n1 n2 -- n2 n1 : swap two values on stack )
: nip      nip      ; ( n1 n2 -- n2 : remove second item on stack )
: drop     drop     ; ( n -- : remove item on stack )
: @        @        ; ( a -- u : load value at address )
: !        store drop ; ( u a -- : store *u* at address *a* )
: rshift   rshift   ; ( u1 u2 -- u : shift u2 by u1 places to the right )
: lshift   lshift   ; ( u1 u2 -- u : shift u2 by u1 places to the left )
: =        =        ; ( u1 u2 -- t : does u2 equal u1? )
: u<       u<       ; ( u1 u2 -- t : is u2 less than u1 )
: <        <        ; ( u1 u2 -- t : is u2 less than u1, signed version )
: and      and      ; ( u u -- u : bitwise and )
: xor      xor      ; ( u u -- u : bitwise exclusive or )
: or       or       ; ( u u -- u : bitwise or )
: 1-       1-       ; ( u -- u : decrement top of stack )
: 0=       0=       ; ( u -- t : if top of stack equal to zero )
: sp@      sp@      ; ( -- u : stack position [equivalent to depth] )
there constant inline-start
( : rp@ rp@   fallthrough; compile-only ( -- u )
: exit  exit  fallthrough; compile-only ( -- )
: >r    >r    fallthrough; compile-only ( u --, R: -- u )
: r>    r>    fallthrough; compile-only ( -- u, R: u -- )
: r@    r@    fallthrough; compile-only ( -- u )
: rdrop rdrop fallthrough; compile-only ( --, R: u -- )
there constant inline-end

\ ============================================================================
\ # Core Words

( 0        tvariable hidden  ( vocabulary for hidden words )
h: [-1] -1 ;                 ( -- -1 : space saving measure, push -1 )
h: 0x8000 $8000 ;            ( -- $8000 : space saving measure, push $8000 )
h: 2drop-0 drop fallthrough; ( n n -- 0 )
h: drop-0 drop fallthrough;  ( n -- 0 )
h: 0x0000 $0000 ;            ( -- $0000 : space/optimization, push $0000 )
h: state@ state @ ;          ( -- u )
h: first-bit 1 and ;         ( u -- u )
h: in@ >in @ ;               ( -- u )
h: base@ base @ ;            ( -- u )
h: hld@ hld @ ;              ( -- u )
h: blk-@ blk @ ;

h: ?exit if rdrop exit then ; ( u --, R: xt -- xt| : conditional return )
: 2drop drop drop ;         ( n n -- )
: 1+ 1 + ;                  ( n -- n : increment a value  )
: negate 1- invert ;        ( n -- n : negate a number )
: - negate + ;              ( n1 n2 -- n : subtract n1 from n2 )
h: over- over - ;           ( u u -- u u )
: aligned dup first-bit + ; ( b -- a )
h: cell- cell - ;           ( a -- a : adjust address to previous cell )
: cell+  cell + ;           ( a -- a : move address forward to next cell )
: cells 1 lshift ;          ( n -- n : convert cells count to address count )
: chars 1 rshift ;          ( n -- n : convert bytes to number of cells )
: ?dup dup if dup exit then ; ( n -- 0 | n n : duplicate non zero value )
: >  swap  < ;              ( n1 n2 -- t : signed greater than, n1 > n2 )
: u> swap u< ;              ( u1 u2 -- t : unsigned greater than, u1 > u2 )
:  <>  = invert ;           ( n n -- t : not equal )
: 0<> 0= invert ;           ( n n -- t : not equal  to zero )
: 0> 0 > ;                  ( n -- t : greater than zero? )
: 0< 0 < ;                  ( n -- t : less than zero? )
: 2dup over over ;          ( n1 n2 -- n1 n2 n1 n2 )
: tuck swap over ;          ( n1 n2 -- n2 n1 n2 )
: +! tuck @ +  fallthrough; ( n a -- : increment value at *a* by *n* )
h: swap! swap ! ;           ( a u -- )
h: zero 0 swap! ;           ( a -- : zero value at address )
: 1+!   1  h: s+! swap +! ;; ( a -- : increment value at address by 1 )
: 1-! [-1] s+! ;            ( a -- : decrement value at address by 1 )
: 2! ( d a -- ) tuck! cell+ ! ;      ( n n a -- )
: 2@ ( a -- d ) dup cell+ @ swap @ ;  ( a -- n n )
h: get-current current @ ;            ( -- wid )
: bl =bl ;                            ( -- c )
: within over- >r - r> u< ;           ( u lo hi -- t )
h: s>d dup 0< ;                       ( n -- d )
: abs s>d if negate exit then ;       ( n -- u )
: source #tib 2@ ;                    ( -- a u )
h: tib source drop ;                  ( -- a )
: source-id id @ ;                    ( -- 0 | -1 )
: rot >r swap r> swap ;               ( n1 n2 n3 -- n2 n3 n1 )
: -rot rot rot ;                      ( n1 n2 n3 -- n3 n1 n2 )
h: rot-drop rot drop ;                ( n1 n2 n3 -- n2 n3 )
h: d0= or 0= ;                        ( d -- t )
( : 2swap >r -rot r> -rot ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
( : d< rot   )
(     2dup   )
(     > if = nip-nip if 0 exit then [-1] exit then 2drop u< ; ( d -- f )
( : d>  2swap d< ;                    ( d -- t )
( : du> 2swap du< ;                   ( d -- t )
( : d=  rot = -rot = and ;            ( d d -- t )
( : d- dnegate d+ ;                   ( d d -- d )
( : dabs  s>d if dnegate exit then ;  ( d -- ud )
( : even first-bit 0= ;               ( u -- t )
( : odd even 0= ;                     ( u -- t )
( : pow2? dup dup 1- and 0= and ;     ( u -- u|0 : is u a power of 2? )
( : opposite? xor 0< ;                ( n n -- f : true if opposite signs )
: execute >r ;                   ( cfa -- : execute a function )
h: @execute @ ?dup if execute exit then ;  ( cfa -- )
: c@ dup@ swap first-bit 3 lshift rshift h: lsb $FF and ;; ( b--c: char load )
: c! ( c b -- : store character at address )
  tuck first-bit 3 lshift dup>r swap lsb swap
  lshift over @
  $FF r> 8 xor lshift and or swap! ;
: here cp @ ;                         ( -- a )
: align here fallthrough;             ( -- )
h: cp! aligned cp ! ;                 ( n -- )
: allot cp +! ;                       ( n -- )
h: 2>r rxchg swap >r >r ;        ( u1 u2 --, R: -- u1 u2 )
h: 2r> r> r> swap rxchg nop ;    ( -- u1 u2, R: u1 u2 -- )
h: doNext 2r> ?dup if 1- >r @ >r exit then cell+ >r ;
[t] doNext tdoNext meta!
: min 2dup< fallthrough;              ( n n -- n )
h: mux if drop exit then nip ;        ( n1 n2 b -- n : multiplex operation )
: max 2dup > mux ;                    ( n n -- n )
( : 2over 2>r 2dup 2r> 2swap ; )
( : 2nip 2>r 2drop 2r> nop ; )
( : 4dup 2over 2over ; )
( : dmin 4dup d< if 2drop exit else 2nip ; )
( : dmax 4dup d> if 2drop exit else 2nip ; )
\ : um+ ( w w -- w carry )
\       over over+ >r
\       r@ 0 < invert >r
\       over over-and
\       0 < r> or >r
\       or 0 < r> and 1- invert
\       r> swap ;
\ h: upivot ( u1 u2 -- min max ) 2dupu< if exit then swap ;
: um+ 2dupu< 0= if swap then over+ swap over swap u< 1 and ; ( u u -- u carry )

h: dnegate invert >r invert 1 um+ r> + ; ( d -- d )
h: d+ >r swap >r um+ r> + r> + ;         ( d d -- d )
: um* ( u u -- ud )
        0 swap ( u1 0 u2 ) $F
        for dup um+ >r >r-dup um+ r> + r>
                if >r over um+ r> + then
        next rot drop ;
: *    um* drop ;            ( n n -- n )
h: rp! ( n -- , R: ??? -- ??? : set the return stack pointer )
        r> swap begin dup rp@ = 0= while rdrop repeat drop >r ;
: key? <key> @execute ;                   ( -- c -1 | 0 )
: key begin key? until ;                  ( -- c )
: /string over min rot over+ -rot - ;  ( b u1 u2 -- b u : advance string u2 )
h: +string 1 /string ;                 ( b u -- b u : )
: count dup 1+ swap c@ ;               ( b -- b u )
h: string@ over c@ ;                   ( b u -- b u c )
xchange _forth-wordlist _system
h: lshift-xor lshift xor ;
h: rshift-xor rshift xor ;
: crc ( b u -- u : calculate ccitt-ffff CRC )
  [-1] ( -1 = 0xffff ) >r
  begin
    ?dup
  while
   string@ r> swap 
     ( CCITT polynomial $1021, or "x16 + x12 + x5 + 1" )
     over $8 rshift-xor ( crc x )
     dup  $4 rshift-xor ( crc x )
     dup  $5 lshift-xor ( crc x )
     dup  $C lshift-xor ( crc x )
     swap $8 lshift-xor ( crc )
   >r +string
  repeat r> nip ;
xchange _system _forth-wordlist
h: last get-current @ ;         ( -- pwd )
h: echo <echo> @execute ;              ( c -- )
: emit <emit> @execute ;               ( c -- : write out a char )
: cr =cr emit =lf emit ;               ( -- : emit a newline )
: space     1 fallthrough;             ( -- : emit a space )
h: spaces =bl fallthrough;             ( +n -- )
h: nchars                              ( +n c -- : emit c n times )
   swap 0 max for aft dup emit then next drop ;
h: colon-space [char] : emit space ;   ( -- )
\ This version of pick mashes the return stack for large pick depths, an
\ alternative would be to move non-destructively up and down the stack with
\ special instructions.
( vn...v0 u -- vn...v0 vu )
: pick ?dup if swap >r 1- pick r> swap exit then dup ; 
h: ndrop for aft drop then next ;
h: >char dup $7F =bl within if drop [char] _ then ; ( c -- c )
: type 0 fallthrough;                  ( b u -- )
h: typist                              ( b u f -- : print a string )
  >r begin dup while
    swap count r@
    if
      >char
    then
    emit
    swap 1-
  repeat
  rdrop 2drop ;
h: $type [-1] typist ;                   ( b u --  )
: 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 -- )

: 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 )
  rdrop         (      discard saved stack ptr )
  0x0000 ;      ( 0  : normal completion )

: throw  ( ??? exception# -- ??? exception# )
  ?dup if ( exc# \ 0 throw is no-op )
    handler @ rp! ( exc# : restore prev return stack )
    r> handler !  ( exc# : restore prev handler )
    rxchg         ( 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 ;
h: -throw negate throw ;  ( u -- : negate and throw )
[t] -throw 2/ 4 tcells t!
: um/mod ( ud u -- ur uq )
  ?dup 0= if $A -throw exit then
  2dupu<
  if negate $F
    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 2drop drop [-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 ;
\ : */ >r um* r> m/mod nip ; ( n n n -- )
: /mod  over 0< swap m/mod ; ( n n -- r q )
: mod  /mod drop ;           ( n n -- r )
: /    /mod nip ;            ( n n -- q )
h: 1depth 1 fallthrough; ( ??? -- : check depth is at least one )
h: ?depth dup 0= if drop exit then sp@ 1- u> if 4 -throw exit then ; ( u -- )
: decimal  $A fallthrough;  ( -- : set base to decimal )
h: base!  base ! ;          ( u -- : set base )
: hex     $10 base! ;                      ( -- )
\ h: radix base@ dup 2 - $23 u< ?exit decimal $28 -throw ; ( -- u )
: hold hld@ 1- dup hld ! c! hld@ pad $80 - u> ?exit $11 -throw ; ( c -- )
h: extract dup>r um/mod rxchg um/mod r> rot ;  ( ud ud -- ud u )
h: digit 9 over < 7 and + [char] 0 + ;         ( u -- c )
: #> 2drop hld@ pad over- ;                ( w -- b u )
: #  2 ?depth 0 base@ extract digit hold ;  ( d -- d )
: #s begin # 2dup d0= until ;               ( d -- 0 )
: <# pad hld ! ;                            ( -- )
: sign 0< 0= ?exit [char] - hold ; ( n -- )
h: (.) ( n -- b u : convert a signed integer to a numeric string )
  dup>r abs 0 <# #s r> sign #> ;
h: (u.) 0 <# #s #> ;             ( u -- b u : turn *u* into number string )
: u.r >r (u.) r> fallthrough;    ( u +n -- : print u right justified by +n)
h: adjust over- spaces type ;    ( b n n -- )
h: d5u.r dup fallthrough;        ( u -- u )
h: 5u.r space 5 u.r space ;      ( u -- )
( :  .r >r (.)( r> adjust ;      ( n n -- : print n, right justified by +n )
: u.  (u.) h: blt space type ;;  ( u -- : print unsigned number )
:  .  (.) blt ;                  ( n -- print number )
( : >base swap base @ >r base ! execute r> base ! ; )
( : d. $a  '  . >base ; )
( : h. $10 ' u. >base ; )
h: adown cell negate and ; ( a -- a : align down )
xchange _forth-wordlist _system
: pack$ ( b u a -- a ) \ null fill
  aligned dup>r over
  dup adown
  - over+ zero 2dup c! 1+ swap ( 2dup 0 fill ) cmove r> ;
xchange _system _forth-wordlist
: compare ( a1 u1 a2 u2 -- n : string equality )
  rot
  over- ?dup if >r 2drop r> nip exit then
  for ( a1 a2 )
    aft
      count rot count rot - ?dup
      if rdrop nip-nip exit then
    then
  next 2drop-0 ;
h: ^h ( bot eot cur -- bot eot cur )
  >r over r@ < dup
  if
    =bs dup echo =bl echo echo
  then r> + ;
h: tap dup echo over c! 1+ ; ( bot eot cur c -- bot eot cur )
h: delete? dup =bs = swap =del = or 0= ; ( c -- t : delete key pressed? )
h: ktap                                  ( bot eot cur c -- bot eot cur )
 dup =cr xor
 if delete? \ =bs xor
   if =bl tap exit then ^h exit
 then drop nip dup ;
\ h: ktap? dup =bl - $5F u< swap =del xor and ; ( c -- t : possible ktap? )
: accept ( b u -- b u )
  over+ over
  begin
    2dup-xor
  while
    key dup =bl - $5F u< if tap else <tap> @execute then
  repeat drop over- ;
: expect <expect> @execute span ! drop ;   ( b u -- )
: query tib tib-length <expect> @execute #tib ! drop-0 fallthrough;
h: in! >in ! ;                             ( u -- )
h: word.count count fallthrough; ( nfa -- u : get a words length )
h: word.length $1F and ;
xchange _forth-wordlist _system
: nfa cell+ ; ( pwd -- nfa : move to name field address)
: cfa nfa dup c@ word.length + cell+ adown ; ( pwd -- cfa )
xchange _system _forth-wordlist
h: .id nfa word.count type space ; ( pwd -- : print out a word )
h: immediate? nfa $40 fallthrough; ( pwd -- t : is word immediate? )
h: set? swap @ and 0<> ;           ( a u -- t : is any of 'u' set? )
h: compile-only? nfa $20 set? ;    ( pwd -- t : is word compile only? )
h: inline? inline-start inline-end within ; ( pwd -- t : is word inline? )
h: (search-wordlist) ( a wid -- PWD PWD 1|PWD PWD -1|0 a 0: find word in WID )
  swap >r-dup
  begin
    dup
  while
    dup nfa count $9F ( $1F:word-length + $80:hidden ) and r@ count compare 0=
    if ( found! )
      rdrop
      dup immediate? 1 or negate exit
    then
    nip dup@
  repeat
  rdrop 2drop-0 ;
h: (find) ( a -- pwd pwd 1 | pwd pwd -1 | 0 a 0 : find a word dictionary )
  >r
  context
  begin
    dup@
  while
    dup@ @ r@ swap (search-wordlist) ?dup
    if
      >r rot-drop r>rdrop exit
    then
    cell+
  repeat drop-0 r> 0x0000 ;
: search-wordlist (search-wordlist) rot-drop ; ( a wid -- PWD 1|PWD -1|a 0 )
: find ( a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )
  (find) rot-drop ;
h: digit? ( c base -- u f )
  >r [char] 0 - 9 over <
  if
    7 -
    dup $A < or
  then dup r> u< ;
: >number ( ud b u -- ud b u : convert string to number )
  begin
    ( get next character )
    2dup 2>r drop c@ base@ digit?
    0= if                                 ( d char )
      drop                                ( d char -- d )
      2r>                                 ( restore string )
      nop exit                            ( ..exit )
    then                                  ( d char )
    swap base@ um* drop rot base@ um* d+  ( accumulate digit )
    2r>                                   ( restore string )
    +string dup 0=                         ( advance string and test for end )
  until ;
h: number? ( a u -- d -1 | a u 0 )
  [-1] dpl !
  base@ >r
  string@ [char] - = dup>r if     +string then
  string@ [char] $ =       if hex +string then
  2>r 0 dup 2r>
  begin
    >number dup
  while string@ [char] .  ( fsp @ ) xor
    if rot-drop rot r> 2drop-0 r> base! exit then
    1- dpl ! 1+ dpl @
  repeat 2drop r> if dnegate then r> base! [-1] ;
h: -trailing ( b u -- b u : remove trailing spaces )
  for
    aft =bl over r@ + c@ <
      if r> 1+ exit then
    then
  next 0x0000 ;
h: lookfor ( b u c xt -- b u : skip until *xt* test succeeds )
  swap >r -rot
  begin
    dup
  while
    string@ r@ - r@ =bl = 4 pick execute
    if rdrop rot-drop exit then
    +string
  repeat rdrop rot-drop ;
h: no-match if 0> exit then 0<> ; ( n f -- t )
h: match no-match invert ;        ( n f -- t )
h: parser ( b u c -- b u delta )
  >r over r> swap 2>r
  r@ ' no-match lookfor 2dup
  r> ' match    lookfor swap r> - >r - r> 1+ ;
: parse ( c -- b u ; <string> )
   >r tib in@ + #tib @ in@ - r@ parser >in +!
   r> =bl = if -trailing then 0 max ;
: ) ; immediate ( -- : do nothing )
:  ( [char] ) parse 2drop ; immediate \ ) ( parse until matching paren )
: .( [char] ) parse type ; ( print out text until matching parenthesis )
: \ #tib @ in! ; immediate ( comment until new line )
h: ?length dup word-length u< ?exit $13 -throw ;
: word 1depth parse ?length here pack$ ; ( c -- a ; <string> )
h: token =bl word ;                      ( -- a )
: char token count drop c@ ;             ( -- c; <string> )
h: ?dictionary dup $3B00 u< ?exit 8 -throw ;
: , here dup cell+ ?dictionary cp! ! ; ( u -- : store *u* in dictionary )
: 2, , , ;                             ( u u -- )
: c, here ?dictionary c! cp 1+! ;      ( c -- : store *c* in the dictionary )
h: doLit 0x8000 or , ;                 ( n+ -- : compile literal )
: literal ( n -- : write a literal into the dictionary )
  dup 0x8000 and ( n > $7FFF ? )
  if
    invert doLit =invert , exit ( store inversion of n the invert it )
  then
  doLit ; compile-only immediate ( turn into literal, write into dictionary )
h: make-callable chars $4000 or ;    ( cfa -- instruction )
: compile, make-callable , ;         ( cfa -- : compile a code field address )
h: $compile dup inline? if cfa @ , exit then cfa compile, ; ( pwd -- )
h: not-found source type $D -throw ; ( -- : throw 'word not found' )
h: ?compile dup compile-only? 0= ?exit source type $E -throw ;
xchange _forth-wordlist _system
: (literal) state@ 0= ?exit postpone literal ; ( u -- u | )
xchange _system _forth-wordlist
: interpret ( ??? a -- ??? : The command/compiler loop )
  \ dup count type space ( <- for tracing the parser )
  find ?dup if
    state@
    if
      0> if cfa execute exit then \ <- immediate word are executed
      $compile exit               \ <- compiling word are...compiled.
    then
    drop ?compile     \ <- check it's not a compile only word word
    cfa execute exit  \ <- if its not, execute it, then exit *interpreter*
  then
  \ not a word
  dup>r count number? if rdrop \ it's a number!
    dpl @ 0< if \ <- dpl will -1 if its a single cell number
       drop     \ drop high cell from 'number?' for single cell output
    else        \ <- dpl is not -1, it's a double cell number
       state@ if swap then
       <literal> @execute \ <literal> is executed twice if it's a double
    then
    <literal> @execute exit
  then
  r> not-found ; \ not a word/number, it's an error! NB. We could vector this
: compile  r> dup@ , cell+ >r ; compile-only ( --:Compile next compiled word )
: immediate $40 last nfa fallthrough; ( -- : previous word immediate )
h: toggle tuck @ xor swap! ;        ( u a -- : xor value at addr with u )
h: count+ count + ;         ( b -- b : advance address over counted string )
h: do$ 2r> dup count+ aligned >r swap >r ; ( -- a )
h: string-literal do$ nop ; ( -- a : do string NB. nop to fool optimizer )
h: .string do$ fallthrough; ( -- : print string  )
h: print count type ;                    ( b -- )
[t] .string        tdoPrintString meta!
[t] string-literal tdoStringLit   meta!
( <string>, --, Run: -- b )
: $" compile string-literal fallthrough; immediate compile-only
h: parse-string [char] " word count+ cp! ; ( ccc" -- )
: ." compile .string parse-string ; immediate compile-only ( <string>, -- )
: abort [-1] throw ;                                    ( -- )
h: ?abort swap if print cr abort exit then drop ;              ( u a -- )
h: (abort) do$ ?abort ;                                        ( -- )
: abort" compile (abort) parse-string ; immediate compile-only ( u -- )

\ See:
\ <https://b2d-f9r.blogspot.com/2010/08/16-bit-xorshift-rng-now-with-more.html>
\
\ For a super tiny N-bit PRNG use; "x+=(x*x) | 5;", you can only use the
\ highest bit however.
\ See: <http://www.woodmann.com/forum/showthread.php?3100-super-tiny-PRNG>
: random 
  seed1 @ dup 5 lshift-xor
  seed2 @ seed1 !
  dup 3 rshift-xor
  seed2 @ dup 1 rshift-xor xor dup seed2 !  ;

h: 40ns begin dup while 1- repeat drop ; ( n -- : wait for 'n'*40ns + 30us )
: ms for 25000 40ns next ; ( n -- : wait for 'n' milliseconds )

\ ============================================================================
\ # I/O wordset


xchange _forth-wordlist _system
: segments! $400E ! ; ( u -- : write to 4 7-segment hex displays )
: led!      $4006 ! ; ( u -- : write to 8 LEDs )
: switches  $4006 @ ; ( -- u : retrieve switch on/off for 8 switches )
: timer!    $4004 ! ; ( u -- : set timer and timer control )
: timer     $4004 @ ; ( -- u : get timer and timer control )
\ NB. Perhaps this could be vectored?
h: (irq) 
  ( cpu? 0 cpu! )
  switches led! 
   #irq dup@ segments! 1+!
  ( cpu! ) ;
[t] (irq) 2/ $C t!
: irq $0040 $4010 ! [-1] timer! 1 cpu! ;

\ FIFO: Write Read Enable after Read
\ h: uart? ( uart-register -- c -1 | 0 : generic UART input functions )
\ dup@ $0100 and if drop 0x0000 exit then dup@ $FF and swap $0400 swap! [-1] ; 
\ FIFO: Write Read Enable before Read
h: uart? ( uart-register -- c -1 | 0 : generic UART input functions )
 dup@ $0100 and if drop-0 exit then dup $0400 swap! @ lsb [-1] ; 

: rx?  $4000 uart? if [-1] exit then $4002 uart? ; ( -- c -1|0: rx uart/ps2 )
h: uart! ( c uart-register -- )
        begin dup@ $1000 and 0= until swap $2000 or swap! ;
: tx! dup $4002 uart! ( VGA/VT-100 ) $4000 uart! ( UART )  ;
h: (ok) state@ if cr exit then ."  ok" cr ;  ( -- : default state aware prompt )
h: preset tib-start #tib cell+ ! 0 in! id zero ;  ( -- : reset input )
: io! \ preset 
  ( 115200 / 9600 )
  $35    ( $28B ) $4012 ! ( set TX baud rate - 54 )
  $34    ( $28A ) $4014 ! ( set RX baud rate - 53, hack! )
  $8080 $4016 ! ( set UART control register; 8 bits, 1 stop, no parity )
  0 timer! 0 led! cpu-id segments!
  0 cpu! 0 $4010 ! ( set IRQ mask )
  fallthrough;  ( -- : initialize I/O )
h: console ' rx? <key> ! ' tx! <emit> ! fallthrough;
h: hand
   ' (ok) 
   ' emit ' ktap
   fallthrough;
h: xio  ' accept <expect> ! <tap> ! <echo> ! <ok> ! ;
h: pace [char] . emit ;
: file ' pace ' drop ' ktap xio ;

\ ============================================================================
\ # Evaluation, Control Structures and Vocabulary Words

\ h: pace 11 emit ;
\ : file ' pace ' drop ' ktap xio ;
xchange _system _forth-wordlist
: ] [-1] state !    ;                                ( -- : compile mode )
: [      state zero ; immediate                      ( -- : command mode )
h: empty sp@ ndrop ; ( 0..n -- : empty variable stack )
h: ?error ( n -- : perform actions on error )
  ?dup 0= ?exit
  .             ( print error number )
  [char] ? emit ( print '?' )
  cr            ( and terminate the line )
  empty         ( empty the variable stack )
  fallthrough;
h: prequit      ( perform actions needed to start 'quit' off )
  preset        ( reset I/O streams )
  postpone [ ;  ( back into interpret mode )
h: eval ( -- : evaluation loop, get token, evaluate, loop, prompt )
  begin
    token dup c@
  while
    interpret 0 ?depth
  repeat drop <ok> @execute ;
: quit prequit begin query ' eval catch ?error again ;
h: get-input source in@ source-id <ok> @ ; ( -- n1...n5 )
h: set-input <ok> ! id ! in! #tib 2! ;     ( n1...n5 -- )
: evaluate ( a u -- )
  get-input 2>r 2>r >r
  0 [-1] 0 set-input
  ' eval catch
  r> 2r> 2r> set-input
  throw ;
h: ?check ( magic-number -- : check for magic number on the stack )
   magic = ?exit $16 -throw ;
h: ?unique ( a -- a : print a message if a word definition is not unique )
  dup get-current (search-wordlist) 0= ?exit
    ( source type )
  space
  2drop last-def @ .id ." redefined" cr ;
h: ?nul ( b -- : check for zero length strings )
   dup c@ ?exit $A -throw ;
h: find-token token find fallthrough; ( -- pwd,  <string> )
h: ?not-found ?exit not-found ;       ( t -- )
h: find-cfa find-token cfa ;          ( -- xt, <string> )
: ' find-cfa state@ if postpone literal exit then ; immediate
: [compile] find-cfa compile, ; immediate compile-only  ( --, <string> )
: [char] char postpone literal ; immediate compile-only ( --, <string> )
: ; ?check =exit , postpone [ ( -- wid )
( h: get-current! ) ?dup if get-current ! exit then ;  immediate compile-only
: : align here dup last-def ! ( "name", -- colon-sys )
  last , token ?nul ?unique count+ cp! magic postpone ] ;
: begin here    ; immediate compile-only ( -- a )
: again chars , ; immediate compile-only ( a -- )
: until $4000 or postpone again ; immediate compile-only ( a --, NB. again !? )
h: here-0 here 0x0000 ;
h: >mark here-0 postpone again ;
: if here-0 postpone until ; immediate compile-only
( : unless ' 0= compile, postpone if ; immediate compile-only )
: then fallthrough; immediate compile-only
h: >resolve here chars over @ or swap! ;
: else >mark swap >resolve ; immediate compile-only
: while postpone if ; immediate compile-only
: repeat swap postpone again postpone then ; immediate compile-only
h: last-cfa last-def @ cfa ;  ( -- u )
: recurse last-cfa compile, ; immediate compile-only
: create postpone : drop compile doVar get-current ! postpone [ ;
: >body cell+ ; ( a -- a )
h: doDoes r> chars here chars last-cfa dup cell+ doLit h: !, ! , ;;
: does> compile doDoes nop ; immediate compile-only
: variable create 0 , ;
: constant create ' doConst make-callable here cell- !, ;
: :noname here-0 magic postpone ] ; ( NB. need postpone! )
: for =>r , here ; immediate compile-only
: next compile doNext , ; immediate compile-only
: aft drop >mark postpone begin swap ; immediate compile-only
: marker ( "name", -- : create an eraser )
  here >r current @ dup@ r> 
  create , 2,
  doDoes ( <- meta-compiler version of does> ) 
  dup cell+ 2@ swap! @ here - allot ;

\ h: (do) r@ swap rot >r >r cell+ >r ; ( hi lo -- index )
\ : do compile (do) 0 , here ; compile-only immediate ( hi lo -- )
\ h: (leave) rdrop rdrop rdrop ; compile-only
\ : leave compile (leave) nop ; compile-only immediate
\ h: (loop)
\    r> r> 1+ r> 2dup-xor if
\     >r >r @ >r exit
\    then >r 1- >r cell+ >r ; compile-only
\ h: (unloop) r>rdrop rdrop rdrop >r ; compile-only
\ : unloop compile (unloop) nop ; compile-only immediate
\ h: (?do)
\   2dup-xor if r@ swap rot >r >r cell+ >r exit then 2drop ; compile-only
\ : ?do compile (?do) 0 , here ; compile-only immediate ( hi lo -- )
\ : loop  compile (loop) dup , compile (unloop) cell- here chars ( -- )
\     swap! ; compile-only immediate
\ h: (+loop)
\    r> swap r> r> 2dup - >r
\    2 pick r@ + r@ xor 0< 0=
\    3 pick r> xor 0< 0= or if
\     >r + >r @ >r exit
\    then >r >r drop cell+ >r ; compile-only
\ : +loop ( n -- ) compile (+loop) dup , compile
\   (unloop) cell- here chars swap! ; compile-only immediate
\ h: (i)  2r> tuck 2>r nop ; compile-only ( -- index )
\ : i  compile (i) nop ; compile-only immediate ( -- index )

xchange _forth-wordlist _system
: hide find-token nfa $80 swap toggle ; ( --, <string> : hide word by name )
xchange _system _forth-wordlist
: get-order ( -- widn ... wid1 n : get the current search order )
  context
  0
  ( : find-cell ) >r begin dup@ r@ xor while cell+ repeat rdrop ( ; u a -- a )
  dup cell- swap
  context - chars dup>r 1- s>d if $32 -throw exit then
  for aft dup@ swap cell- then next @ r> ;
xchange _forth-wordlist root-voc
: forth-wordlist _forth-wordlist ; ( -- wid : push forth vocabulary )
: system _system ;                 ( -- wid : push system vocabulary )
: set-order ( widn ... wid1 n -- : set the current search order )
  dup [-1] = if drop root-voc 1 set-order exit then ( NB. Recursion! )
  dup #vocs > if $31 -throw exit then
  context swap for aft tuck! cell+ then next zero ;
: forth root-voc forth-wordlist 2 set-order ; ( -- )
: words
  get-order begin ?dup while 
  swap dup cr u. colon-space @ 
    begin
      ?dup
    while dup 
      nfa c@ $80 and 0= ( <- not-hidden? )
      if dup .id then @ 
    repeat cr 
  1- repeat ;
xchange root-voc _forth-wordlist
( : previous get-order nip 1- set-order ; ( -- )
( : also get-order over swap 1+ set-order ;     ( wid -- )
: only [-1] set-order ;                         ( -- )
( : order get-order for aft . then next cr ;    ( -- )
( : anonymous get-order 1+ here 1 cells allot swap set-order ; ( -- )
: definitions context @ current ! ( <- set current ) ; ( -- )
h: (order)                                      ( w wid*n n -- wid*n w n )
  dup if
    1- swap >r (order) over r@ xor
    if
      1+ r> -rot exit
    then rdrop
  then ;
: -order get-order (order) nip set-order ;             ( wid -- )
: +order dup>r -order get-order r> swap 1+ set-order ; ( wid -- )
: editor editor-voc +order ; ( -- : load editor vocabulary )

\ ============================================================================
\ # Block Wordset

\ h: updated? block-dirty @ ;          ( -- f )
: update [-1] block-dirty ! ;          ( -- )
\ h: +block blk-@ + ;                  ( n -- k )
\ h: clean-buffers 0 block-dirty ! ;
\ h: empty-buffers clean-buffers 0 blk ! ;  ( -- )
: flush 
  blk-@ 0= block-dirty @ d0= ?exit
  block-buffer b/buf blk-@ <save> @execute throw
  0 block-buffer ! ( <- clean-buffer )
  0 h: blk! blk ! ;;        ( <- empty-buffers )
h: ?block if $23 -throw exit then ;
: block ( k -- a )
  1depth
  dup 0= ?block ( check validity of block number )
  dup blk-@ = if drop block-buffer exit then ( block already loaded )
  flush
  dup>r block-buffer b/buf r> <block> @execute throw 
  blk!
  block-buffer ;

\ xchange _forth-wordlist _system
\ : (block) ( a u k -- f )
\       1- dup $C u> ?block
\       $A lshift ( <- b/buf * )
\       -rot cmove 0x0000 ;
\ : (save) 2drop drop-0 ; ( a u k -- f )
\ xchange _system _forth-wordlist

\ ============================================================================
\ # Memory Interface

\ The manual for the Nexys 3 board specifies that there is a PCM
\ memory device called the NP8P128A13T1760E, this is a device behaves like
\ normal flash with the addition that individual cells can be written to
\ without first erasing the block, this is accomplished with an extension
\ to the Common Flash Interface that most flash devices support. However,
\ there are boards with the PC28F128P33BF60 on in lieu of this, which is a
\ normal flash device without the "bit alterable write" extension. Normal
\ flash memory works by erasing a block of data, which sets all the bits. 
\ Writing to the memory works by masking in a value as bits can be cleared in
\ a memory cell but not set, they can only be set by erasing a block.
\ 
\ The Nexys 3 has three memory devices, two of which are accessed over
\ a parallel interface. They share the same data and address bus, and
\ can be selected with a chip select. The signals to be controlled
\ are:
\ 
\       +-----+-------------------------+
\       | Bit | Description             |
\       |-----|-------------------------|
\       | 0-9 | Upper Memory Bits       |
\       | 10  | Flash chip select       |
\       | 11  | SRAM chip select        |
\       | 12  | Memory Wait [not used]  |
\       | 13  | Flash Reset             |
\       | 14  | Output Enable           |
\       | 15  | Write Enable            |
\       +-----+-------------------------+
\ 
\ The usage of the output enable and write enable are mutually exclusive,
\ as are both of the chip selects.  )
\ 
xchange _forth-wordlist _system

0 tlocation memory-upper  ( upper bits of external memory address )
0 tlocation memory-select ( SRAM/Flash select SRAM = $400, Flash = 0 )
0 tlocation _blockop

h: mdelay 5 40ns ; 

h: mcontrol! ( u -- : write to memory control register )
  $F3FF and
  memory-select @ $400 + or               ( select correct memory device )
  $1FF invert and            ( mask off control bits )
  memory-upper @ $1FF and or ( or in higher address bits )
  $400A ! ; ( and finally write in control )

: m! ( n a -- : write to non-volatile memory )
  $400C !
  $4008 !
  mdelay
  0x8000 mcontrol!
  mdelay
  $0000 mcontrol! ;

: m@ ( a -- n : read from non-volatile memory )
  $400C !
  $4000 mcontrol! ( read enable mode )
  mdelay
  $4008 @        ( get input )
  $0000 mcontrol! ;

: sram   $400 memory-select ! ;
h: nvram $000 memory-select ! ; 
h: block-mode memory-upper @ memory-upper zero ; ( -- hi )
h: flash-reset ( -- : reset non-volatile memory )
  $2000 mcontrol! mdelay $0000 mcontrol! ; 
h: flash! dup>r m! r> m! ; ( u u a )
: flash-status nvram $70 0 m! 0 m@ ; ( -- status )
: flash-read   $FF 0 m! ;      ( -- )
: flash-setup  memory-select @ 
   if flush then nvram flash-reset block-mode drop 20 ms ;
h: flash-wait begin flash-status $80 and until ; 
: flash-clear $50 0 m! ; ( -- clear status )
: flash-write $40 swap flash! flash-wait ; ( u a -- )
\ : flash-unlock block-mode >r $d0 swap $60 swap flash! r> memory-upper ! ; 
\ : flash-lock block-mode >r $01 swap $60 swap flash! r> memory-upper ! ;
\ : flash-lock-down block-mode >r $2f swap $60 swap flash! r> memory-upper ! ;
: flash-erase block-mode >r flash-clear $D0 swap $20 swap 
    flash! flash-wait r> memory-upper ! ; ( ba -- )
: flash-query $98 0 m! ; ( -- : query mode )

( -- read id mode : does the same as flash-query on the PC28F128P33BF60 )
\ : flash-read-id   $90 0 m! ; 

h: flash->sram ( a a : transfer flash memory cell to SRAM )
  nvram flash-clear flash-read
  m@ sram swap m! ;

: transfer ( a a u -- : transfer memory block from Flash to SRAM )
  ?dup 0= if 2drop exit then
  1-
  for
    2dup
    flash->sram
    cell+ swap cell+ swap
  next 2drop ;
\ .set flash-voc $pwd

h: c>m swap @ swap m! ; ( a a --  )
h: m>c m@ swap! ;      ( a a -- )

h: mblock ( a u k -- f )
  1- b/buf um* memory-upper ! >r
  begin
    dup
  while
    over r@ _blockop @execute r> cell+ >r
    cell /string
  repeat
  rdrop 2drop-0 ;

: (save)  ' c>m _blockop ! mblock ; 
: (block) ' m>c _blockop ! mblock ; 

\ ============================================================================
\ # ANSI Escape Sequences

h: CSI $1B emit [char] [ emit ;                     ( -- )
h: 10u. base@ >r decimal 0 <# #s #> type r> base! ; ( u -- )
: ansi swap CSI 10u. emit ;                         ( n c -- )
xchange _system _forth-wordlist
: at-xy CSI 10u. $3B emit 10u. [char] H emit ; ( x y -- ) \ <at-xy> @execute
: page 2 [char] J ansi 1 1 at-xy ;             ( -- )     \ <page>  @execute
xchange _forth-wordlist _system
: sgr   [char] m ansi ; ( -- : emit an SGR )
: up    [char] A ansi ; ( u -- : move the cursor up )
: down  [char] B ansi ; ( u -- : move the cursor down )
: right [char] C ansi ; ( u -- : move the cursor right )
: left  [char] D ansi ; ( u -- : move the cursor left )

\ 0 constant black 1 constant red 2 constant green 4 constant blue
\ red green        + constant yellow
\     green blue   + constant cyan
\ red       blue   + constant magenta
\ red green blue + + constant white
\ : background $A + ;
\ : color $1E + sgr ;

h: tableu ( -- )
   $7 for
     $A right $7 r@ - $28 + dup sgr u. colon-space
     $7   for $7 r@ - $1E + dup sgr u. next cr
   next ;
 
: table page $2 down tableu 1 sgr $2 down tableu 0 sgr ; ( -- )
\ : nuf? key? if drop [-1] exit then 0x0000 ; ( -- f )
xchange _system _forth-wordlist

\ ============================================================================
\ # Higher Level Block Words

h: c/l* ( c/l * ) 6 lshift ;             ( u -- u )
h: line c/l* swap block + c/l ;          ( k u -- a u )
\ h: loadline line evaluate ;            ( k u -- )
: load 0 $F for 2dup 2>r line evaluate 2r> 1+ next 2drop ; ( k -- )
h: pipe [char] | emit ;                  ( -- )
\ h: .line line -trailing $type ;        ( k u -- )
h: .border 3 spaces c/l [char] - nchars cr ; ( -- )
: thru over- for dup load 1+ next drop ; ( k1 k2 -- )
( : message l/b extract .line cr ;       ( u -- )
h: retrieve block drop ;                 ( k -- )
: list                                   ( k -- )
  dup retrieve
  cr
  .border
  0 begin
    dup l/b <
  while
    2dup dup 2 u.r pipe line $type pipe cr 1+
  repeat .border 2drop ;

\ : list  block l/b for dup l/b 1- r@ - c/l * + c/l type cr next ;

: index ( k1 k2 -- : show titles for block k1 to k2 )
  over- cr
  for
    dup 5u.r pipe space dup 0 line $type cr 1+
  next drop ;
( : --> blk-@ 1+ load ; immediate )
\ ============================================================================
\ # Boot Sequence

\ We could select different behaviors depending on what switches were set at
\ at start up, some for debugging, others for functionality.

h: bist ( -- u : built in self test )
  header-options @ first-bit 0= if 0x0000 exit then ( is checking disabled? )
  header-length @ here xor if 2 exit then ( length check )
  header-crc @ header-crc zero            ( retrieve and zero CRC )
  0 here crc xor if 3 exit then           ( check CRC )
  1 header-options toggle 0x0000 ;        ( disable check, success )
: bye fallthrough;
h: cold ( -- : performs a cold boot  )
  bist ?dup if negate dup bye exit then
  io! forth
  empty 0 rp!
  hex cr ." eFORTH v" cpu-id 0 u.r cr here .  $4000 here - u. cr 
  ." loading..."
  0 0 0x8000 transfer (ok)
  1 block c@ 32 127 within ( <- ASCII? ) if 
    (ok) ( 1 load ) else ." failed" cr 
  then quit ;

\ ============================================================================
\ # Decompiler / Tools

h: validate over cfa xor if drop-0 exit then nfa ; ( pwd cfa -- nfa | 0 )
h: search-for-cfa ( wid cfa -- nfa | 0 : search for CFA in a word list )
  cells $1FFF and >r
  begin
    dup
  while
    dup@ over r@ -rot  within
    if dup@ r@ validate ?dup if rdrop nip exit then then
    @
  repeat rdrop ;
h: name ( cwf -- a | 0 )
   >r
   get-order
   begin
     dup
   while
     swap r@ search-for-cfa ?dup if >r 1- ndrop r>rdrop exit then
   1- repeat rdrop ;
( h: neg? dup 2 and if $FFFE or then ;  )
( h: .alu  ( u -- )
(   dup 8 rshift $1F and 5u.r )
(   dup $80 and if ." t->n  " then   )
(   dup $40 and if ." t->r  " then  )
(   dup $10 and if ." r->pc " then  )
(   dup $0C and [char] r emit 2 rshift neg? . space )
(       $03 and [char] d emit          neg? . ;  )
h: ?instruction ( i m e -- i t )
   >r over-and r> = ;
( a -- : find word by address, and print )
h: .name dup $1FFF and cells 5u.r ( a -- )
         name ?dup if word.count type then ;
h: decompile ( u -- : decompile a single instruction )
   0x8000 0x8000 ?instruction if [char] L emit $7FFF and 5u.r exit then
    $6000  $6000 ?instruction if [char] A emit  drop ( .alu ) exit then
    $6000  $4000 ?instruction if [char] C emit .name exit then
    $6000  $2000 ?instruction if [char] Z emit .name exit then
   [char] B emit .name ;
h: decompiler ( previous current -- : decompile starting at address )
  >r
  begin dup r@ u< while
    d5u.r colon-space
    dup@
    d5u.r decompile cr cell+
  repeat rdrop drop ;
: see ( --, <string> : decompile a word )
  token (find) ?not-found
  swap 2dup= if drop here then >r
  cr colon-space dup .id dup cr
  cfa r> decompiler space [char] ; emit
  dup compile-only? if ."  compile-only" then
  dup inline?       if ."  inline"       then
      immediate?    if ."  immediate"    then cr ;
: .s ( -- ) cr sp@ for aft r@ pick . then next ."  <sp" cr ; ( -- )
: dump ( a u -- )
  $10 + \ align up by dump width
  4 rshift ( <-- equivalent to "dump-width /" )
  for
    aft
      cr $10 2dup
      over 5u.r colon-space
      chars for aft dup@ 5u.r cell+ then next ( <- dm+; [ a u -- ] )
      -rot
      2 spaces $type
    then
  next drop ;
\ ============================================================================
\ # Block Editor

[last]              [t] _forth-wordlist t!
[t] _forth-wordlist [v] current         t!
0 tlast meta!
h: [block] blk-@ block ;       ( k -- a : loaded block address )
h: [check] dup b/buf 6 rshift u< ?exit $18 -throw ;
h: [line] [check] c/l* [block] + ; ( u -- a )
: b retrieve ;                 ( k -- : Load a block )
: l blk-@ list ;               ( -- : list current block )
: n   1  h: +blv blk-@ + b l ;;   ( -- : load and list Next block )
: p [-1]    +blv ;             ( -- : load and list Previous block )
: d [block] b/buf h: blank =bl fill ;;   ( -- : Zero/blank loaded block )
: k [line] c/l blank ;         ( u -- : delete/Kill line )
: s update flush ;             ( -- : Save changes to disk )
: q editor-voc -order ;        ( -- : Quit editor )
: x q blk-@ load editor ;      ( -- : eXecute/evaluate block )
: ia c/l* + [block] + tib in@ + ( u u -- Insert At )
   swap source nip in@ - cmove postpone \ ;
: i 0 swap ia ;                ( u -- : Insert line )
( : u update ;                 ( -- : set block set as dirty )
( : w words ; )
( : yank pad c/l ; )
( : c [line] yank >r swap r> cmove ; )
( : y [line] yank cmove ; )
( : ct swap y c ; )
( : xa [line] c/l evaluate ; )
( : sw 2dup y [line] swap [line] swap c/l cmove c ; )
[last] [t] editor-voc t! 0 tlast meta!

\ ============================================================================
\ # Final Touches
there [t] cp t!
[t] (literal)      [v] <literal> t! ( set literal execution vector )
[t] (block)        [v] <block>   t! ( set block execution vector )
[t] (save)         [v] <save>    t! ( set block execution vector )
[t] cold 2/            0         t! ( set starting word in boot-loader )
there    [t] header-length t! \ Set Length First!
checksum [t] header-crc t!    \ Calculate image CRC
finished
bye