1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
: ['] ' 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
: ." 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 ;
|
