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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
: 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"
source type
|
