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.
115 lines
3.6 KiB
Forth
115 lines
3.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 +! ;
|
|
: 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
|
|
|
|
." hello world"
|