sprit-forth/core.fth

: cell+    [ 1 cells ] literal + ;
: char+    1 + ;
: chars    ;

: 1+       1 + ;
: 1-       1 - ;

: over     1 pick ;
: rot      >r swap r> swap ;
: -rot     rot rot ;

: +!       dup >r swap r> @ + swap ! ;

: imm      immediate ;

: base     [ 0 _d ] literal ;
: here     [ 1 cells _d ] literal @ ;
: allot    [ 1 cells _d ] literal +! ;
: _latest  [ 2 cells _d ] literal ;
: state    [ 3 cells _d ] literal ;
: _compxt  [ 4 cells _d ] literal ;
: _source  [ 5 cells _d ] literal ;
: _sourceu [ 6 cells _d ] literal ;
: >in      [ 7 cells _d ] literal ;
: _begin   [ 8 cells 80 chars + _d ] literal ;

: c,       here c! 1 allot ;

: if       ['] _jmp0 compile, here 0 , ; imm
: then     here swap ! ; imm
: else     ['] _jmp compile, here 0 , swap here swap ! ; imm

: postpone ' dup _i swap [ ' literal compile, ]
           if ['] execute else ['] , then compile, ; imm

: 2drop    drop drop ;
: 2dup     over over ;
: 2over    3 pick 3 pick ;
: 2swap    rot >r rot r> ;

: decimal  10 base ! ;

: 2r>      ['] r> compile, ['] r> compile, ['] swap compile, ; imm
: 2>r      ['] swap compile, ['] >r compile, ['] >r compile, ; imm
: r@       ['] r> compile, ['] dup compile, ['] >r compile, ; imm

: 2!       swap over ! cell+ ! ;
: 2@       dup cell+ @ swap @ ;

: 0=       0 = ;
: 0<       0 < ;
: <=       2dup < >r = r> or ;
: >        swap < ;
: <>       = 0= ;

: begin    0 here ; imm
: while    swap 1+ swap postpone if -rot ; imm
: repeat   ['] _jmp compile, , if postpone then then ; imm
: until    ['] _jmp0 compile, , drop ; imm

: do       0 postpone literal here 1 cells -
           ['] >r compile, postpone 2>r here ; imm
: unloop   postpone 2r> ['] 2drop compile,
           ['] r> compile, ['] drop compile, ; imm
: leave    postpone 2r> ['] 2drop compile, ['] exit compile, ; imm
: +loop    ['] r> compile,   ['] 2dup compile, ['] + compile,
           postpone r@       ['] swap compile, ['] >r compile,
           ['] - compile,    ['] 2dup compile, ['] + compile,
           ['] over compile, ['] xor compile,  ['] rot compile,
           ['] rot compile,  ['] xor compile,  ['] and compile,
           0 postpone literal ['] < compile, ['] _jmp0 compile, ,
           postpone unloop here 1 cells - swap ! ; imm
: loop     postpone 2r> ['] 1+ compile, ['] 2dup compile,
           postpone 2>r ['] = compile, ['] _jmp0 compile, ,
           postpone unloop here 1 cells - swap ! ; imm
: i        postpone r@ ; imm
: j        postpone 2r> ['] r> compile, postpone r@ ['] swap compile,
           ['] >r compile, ['] -rot compile, postpone 2>r ; imm

: invert   -1 ^ ;
: 2*       2 * ;
: _msb     [ 1 1 cells 8 * 1- lshift ] literal ;
: 2/       dup 1 rshift swap 0< if _msb or then ;

: cr       10 emit ;
: bl       32 ;
: space    bl emit ;
: spaces   begin dup 0 > while space 1- repeat drop ;

: ?dup     dup if dup then ;

: negate   -1 * ;
: abs      dup 0< if negate then ;
: min      2dup <= if drop else swap drop then ;
: max      2dup <= if swap drop else drop then ;

: source   _source @ _sourceu @ ;
: count    dup char+ swap c@ ;
: char     0 here char+ c! bl word char+ c@ ;
: [char]   char postpone literal ; imm

: (        begin [char] ) key <> while repeat ; imm

: _type    >r begin dup 0 > while
           swap dup c@ r@ execute char+ swap 1- repeat 2drop r> drop ;
: type     [ ' emit ] literal _type ;
: s"       state @ if ['] _jmp compile, here 0 , then
           [char] " word count
           state @ 0= if exit then
           dup cell+ allot
           rot here swap !
           swap postpone literal postpone literal ; imm
: ."       postpone s" state @ if ['] type compile, else type then ; imm

: create   : here [ 4 cells ] literal + postpone literal postpone ; 0 , ;
: >body    cell+ @ ;

: _does>   _latest @ @ [ 4 cells ] literal +
           ['] _jmp @ over !
           r@ [ 2 cells ] literal +
           swap cell+ ! ;

: does>    ['] _does> compile, ['] exit compile, ; imm

: variable create [ 1 cells ] literal allot ;
: constant create , does> @ ;

: move     dup 0 <= if drop 2drop exit then
           >r 2dup < r> swap if
           1- 0 swap do over i + c@ over i + c! -1 +loop
           else
           0 do over i + c@ over i + c! loop
           then 2drop ;
: fill     -rot begin dup 0 > while
           >r 2dup c! char+ r> 1- repeat
           2drop drop ;

: environment? 2drop 1 0= ;

: accept   over >r begin dup 0 > while
           key dup 32 < if 2drop 0
           else dup emit rot 2dup c! char+ swap drop swap 1- then
           repeat drop r> - [ 1 chars ] literal / ;

: recurse  _compxt @ compile, ; imm

: fib ( n1 -- n2 )   dup 1 > if    1- dup 1- recurse swap recurse + then ;

: fibs 10 0 do i fib . loop cr ;

5 constant five
five .
fibs ." hello world"