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.
85 lines
3.0 KiB
Forth
85 lines
3.0 KiB
Forth
: ['] ' 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 ;
|
|
|