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.

154 lines
4.6 KiB
Forth

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