sforth/core.fth

: [']       ' postpone literal ; immediate

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

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

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

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

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

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

: _does>    latest dup cell+ @ [ 5 cells ] literal + +
            ['] _jmp over ! cell+ ! ;

: does>     here 4 cells + postpone literal ['] _does> , 0 , ; immediate

: variable  create cell allot ;
: constant  create , does> @ ;

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

: word      0 here c! begin \ bl
            key 2dup <>     \ bl key <>
            over 0<> and while \ bl key
            here c@ char+ \ bl key u
            dup here c! \ bl key u
            here + c! \ bl
            repeat 2drop here ;
: count     dup char+ swap c@ ;
: char      0 here char+ c! bl word char+ c@ ;
: [char]    char postpone literal ; immediate

: s"        state @ if ['] _jmp , here 0 , then
            [char] " word count
            state @ 0<> if
            dup cell+ allot
            rot here swap !
            swap postpone literal postpone literal then ; immediate
: type      ?dup if 0 do dup c@ emit 1+ loop then drop ;
: ."        postpone s" state @ if postpone type else type then ; immediate

: (         begin [char] ) key = until ; immediate

: execute   [ here 3 cells + ] literal ! [ ' _jmp , 0 , ] ;

: 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 ;