|
|
|
|
: state [ _d 7 cells + ] literal ;
|
|
|
|
|
|
|
|
|
|
: sp [ _d cell+ ] literal ;
|
|
|
|
|
: rp [ _d 2 cells + ] literal ;
|
|
|
|
|
: dp [ _d 4 cells + ] literal ;
|
|
|
|
|
|
|
|
|
|
: sp@ sp @ ;
|
|
|
|
|
: rp@ rp @ cell+ ;
|
|
|
|
|
: ip [ _d 3 cells + ] literal ;
|
|
|
|
|
: here dp @ ;
|
|
|
|
|
: unused [ _d 8 cells + ] literal @ here - ;
|
|
|
|
|
: base [ _d 9 cells + ] literal ;
|
|
|
|
|
: latest _d @ ;
|
|
|
|
|
|
|
|
|
|
: pick cells cell+ sp@ + @ ;
|
|
|
|
|
: >r rp@ cell - rp !
|
|
|
|
|
rp@ cell+ @ rp@ !
|
|
|
|
|
rp@ cell+ ! ;
|
|
|
|
|
: r> rp@ @
|
|
|
|
|
rp@ cell+ rp !
|
|
|
|
|
rp@ @ swap rp@ ! ;
|
|
|
|
|
: over 1 pick ;
|
|
|
|
|
|
|
|
|
|
: 2dup over over ;
|
|
|
|
|
: 2over 3 pick 3 pick ;
|
|
|
|
|
: 2swap rot >r rot r> ;
|
|
|
|
|
|
|
|
|
|
: +! dup >r swap r> @ + swap ! ;
|
|
|
|
|
: allot dp +! ;
|
|
|
|
|
: , here ! cell allot ;
|
|
|
|
|
: c, here c! 1 allot ;
|
|
|
|
|
: ['] ' [ ' literal , ] ; immediate
|
|
|
|
|
|
|
|
|
|
: if ['] _jmp0 , here 0 , ; immediate
|
|
|
|
|
: then here swap ! ; immediate
|
|
|
|
|
: else ['] _jmp , here 0 , swap here swap ! ; immediate
|
|
|
|
|
|
|
|
|
|
: 2r> ['] r> , ['] r> , ['] swap , ; immediate
|
|
|
|
|
: 2>r ['] swap , ['] >r , ['] >r , ; immediate
|
|
|
|
|
: r@ ['] r> , ['] dup , ['] >r , ; immediate
|
|
|
|
|
|
|
|
|
|
: 2! swap over ! cell+ ! ;
|
|
|
|
|
: 2@ dup cell+ @ swap @ ;
|
|
|
|
|
|
|
|
|
|
: <= 2dup < >r = r> or ;
|
|
|
|
|
|
|
|
|
|
: _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 ;
|
|
|
|
|
|
|
|
|
|
: aligned cell 1- + cell 1- invert and ;
|
|
|
|
|
: align here dup aligned swap - allot ;
|
|
|
|
|
|
|
|
|
|
: cr 10 emit ;
|
|
|
|
|
: space bl emit ;
|
|
|
|
|
\ : spaces begin dup 0 > while space 1- repeat drop ;
|
|
|
|
|
|
|
|
|
|
: decimal 10 base ! ;
|
|
|
|
|
: hex 16 base ! ;
|
|
|
|
|
|
|
|
|
|
: 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 , ['] 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> @ ;
|
