You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
109 lines
3.1 KiB
Forth
109 lines
3.1 KiB
Forth
: cell+ cell + ;
|
|
: cells cell * ;
|
|
: char+ 1 + ;
|
|
: chars ;
|
|
|
|
: state [ _d 7 cells + ] literal ;
|
|
\ : [ 0 state ! ; immediate
|
|
\ : ] -1 state ! ;
|
|
|
|
: sp _d ;
|
|
: rp [ _d cell+ ] literal ;
|
|
: dp [ _d 3 cells + ] literal ;
|
|
|
|
: sp@ sp @ ;
|
|
: rp@ rp @ cell+ ;
|
|
: ip [ _d cell+ cell+ ] literal ;
|
|
: here dp @ ;
|
|
: unused [ _d 8 cells + ] literal @ here - ;
|
|
: base [ _d 9 cells + ] literal ;
|
|
: latest [ _d 4 cells + ] literal @ ;
|
|
|
|
\ : dup sp@ @ ;
|
|
\ : drop sp@ cell+ sp ! ;
|
|
: pick cells cell+ sp@ + @ ;
|
|
: >r rp@ cell - rp !
|
|
rp@ cell+ @ rp@ !
|
|
rp@ cell+ ! ;
|
|
: r> rp@ @
|
|
rp@ cell+ rp !
|
|
rp@ @ swap rp@ ! ;
|
|
\ : rot >r swap r> swap ;
|
|
: -rot rot rot ;
|
|
: over 1 pick ;
|
|
|
|
: 2drop drop drop ;
|
|
: 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 @ ;
|
|
|
|
: 0= 0 = ;
|
|
: 0< 0 < ;
|
|
: <= 2dup < >r = r> or ;
|
|
: > swap < ;
|
|
: <> = 0= ;
|
|
|
|
: 1+ 1 + ;
|
|
: 1- 1 - ;
|
|
|
|
: invert -1 xor ;
|
|
: negate -1 * ;
|
|
: 2* 2 * ;
|
|
: _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 ;
|
|
: bl 32 ;
|
|
: 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
|
|
|