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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
: 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"
|
