-
Notifications
You must be signed in to change notification settings - Fork 29
/
01-helloworld.f
209 lines (178 loc) · 7.16 KB
/
01-helloworld.f
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
\ "hello, world" example for sectorforth, a 512-byte, bootable x86 Forth.
\ Copyright (c) 2020 Cesar Blum
\ Distributed under the MIT license. See LICENSE for details.
: dup ( x -- x x ) sp@ @ ;
\ make some numbers
: -1 ( x -- x -1 ) dup dup nand dup dup nand nand ;
: 0 -1 dup nand ;
: 1 -1 dup + dup nand ;
: 2 1 1 + ;
: 4 2 2 + ;
: 6 2 4 + ;
\ logic and arithmetic operators
: invert ( x -- !x ) dup nand ;
: and ( x y -- x&y ) nand invert ;
: negate ( x -- -x ) invert 1 + ;
: - ( x y -- x-y ) negate + ;
\ equality checks
: = ( x y -- flag ) - 0= ;
: <> ( x y -- flag ) = invert ;
\ stack manipulation words
: drop ( x y -- x ) dup - + ;
: over ( x y -- x y x ) sp@ 2 + @ ;
: swap ( x y -- y x ) over over sp@ 6 + ! sp@ 2 + ! ;
: nip ( x y -- y ) swap drop ;
: 2dup ( x y -- x y x y ) over over ;
: 2drop ( x y -- ) drop drop ;
\ more logic
: or ( x y -- x|y ) invert swap invert and invert ;
\ compile things
: , ( x -- ) here @ ! here @ 2 + here ! ;
\ left shift 1 bit
: 2* ( x -- 2x ) dup + ;
\ constant to check/set immediate flag
: 80h ( -- 80h ) 1 2* 2* 2* 2* 2* 2* 2* ;
\ make words immediate
: immediate latest @ 2 + dup @ 80h or swap ! ;
\ control interpreter state
: [ 0 state ! ; immediate
: ] 1 state ! ;
\ unconditional branch
: branch ( r:addr -- r:addr+offset ) rp@ @ dup @ + rp@ ! ;
\ conditional branch when top of stack is 0
: ?branch ( r:addr -- r:addr | r:addr+offset)
0= rp@ @ @ 2 - and rp@ @ + 2 + rp@ ! ;
\ lit pushes the value on the next cell to the stack at runtime
\ e.g. lit [ 42 , ] pushes 42 to the stack
: lit ( -- x ) rp@ @ dup 2 + rp@ ! @ ;
\ ['] is identical to lit, the choice of either depends on context
\ don't write as : ['] lit ; as that will break lit's assumptions about
\ the return stack
: ['] ( -- addr ) rp@ @ dup 2 + rp@ ! @ ;
\ push/pop return stack
: >rexit ( addr r:addr0 -- r:addr )
rp@ ! ; \ override return address with original return
\ address from >r
: >r ( x -- r:x)
rp@ @ \ get current return address
swap rp@ ! \ replace top of return stack with value
>rexit ; \ push new address to return stack
: r> ( r:x -- x )
rp@ 2 + @ \ get value stored in return stack with >r
rp@ @ rp@ 2 + ! \ replace value with address to return from r>
lit [ here @ 6 + , ] \ get address to this word's exit call
rp@ ! ; \ make code return to this word's exit call,
\ effectively calling exit twice to pop return
\ stack entry created by >r
\ rotate stack
: rot ( x y z -- y z x ) >r swap r> swap ;
\ if/then/else
: if
['] ?branch , \ compile ?branch to skip if's body when false
here @ \ get address where offset will be written
0 , \ compile dummy offset
; immediate
: then
dup \ duplicate offset address
here @ swap - \ calculate offset from if/else
swap ! \ store calculated offset for ?branch/branch
; immediate
: else
['] branch , \ compile branch to skip else's body when true
here @ \ get address where offset will be written
0 , \ compile dummy offset
swap \ bring if's ?branch offset address to top of stack
dup here @ swap - \ calculate offset from if
swap ! \ store calculated offset for ?branch
; immediate
\ begin...while...repeat and begin...until loops
: begin
here @ \ get location to branch back to
; immediate
: while
['] ?branch , \ compile ?branch to terminate loop when false
here @ \ get address where offset will be written
0 , \ compile dummy offset
; immediate
: repeat
swap \ offset will be negative
['] branch , here @ - , \ compile branch back to begin
dup here @ swap - swap ! \ compile offset from while
; immediate
: until
['] ?branch , here @ - , \ compile ?branch back to begin
; immediate
\ do...loop loops
: do ( end index -- )
here @ \ get location to branch back to
['] >r , ['] >r , \ at runtime, push inputs to return stack
; immediate
: loop
['] r> , ['] r> , \ move current index and end to data stack
['] lit , 1 , ['] + , \ increment index
['] 2dup , ['] = , \ index equals end?
['] ?branch , here @ - , \ when false, branch back to do
['] 2drop , \ discard index and end when loop terminates
; immediate
\ fetch/store bytes
: 0fh lit [ 4 4 4 4 + + + 1 - , ] ;
: ffh lit [ 0fh 2* 2* 2* 2* 0fh or , ] ;
: c@ ( -- c ) @ ffh and ;
: c! ( c addr -- )
dup @ \ fetch memory contents at address
ffh invert and \ zero out low byte
rot ffh and \ zero out high byte of value being stored
or swap ! \ overwrite low byte of existing contents
;
\ compile bytes
: c, ( x -- ) here @ c! here @ 1 + here ! ;
\ read literal string from word body
: litstring ( -- addr len )
rp@ @ dup 2 + rp@ ! @ \ push length to stack
rp@ @ \ push string address to stack
swap
2dup + rp@ ! ; \ move return address past string
\ print string
: type ( addr len -- ) 0 do dup c@ emit 1 + loop drop ;
\ read char from terminal input buffer, advance >in
: in> ( "c<input>" -- c ) tib >in @ + c@ >in dup @ 1 + swap ! ;
\ constant for space char
: bl ( -- spc ) lit [ 1 2* 2* 2* 2* 2* , ] ;
\ parse input with specified delimiter
: parse ( delim "input<delim>" -- addr len )
in> drop \ skip space after parse
tib >in @ + \ put address of parsed input on stack
swap 0 begin \ ( addr delim len )
over in> \ ( addr delim len delim char )
<> while
1 + \ ( addr delim len+1 )
repeat swap \ ( addr len delim )
bl = if
>in dup @ 1 - swap ! \ move >in back 1 char if delimiter is bl,
\ otherwise the interpreter is left in a
\ bad state
then ;
\ parse input with specified delimiter, skipping leading delimiters
: word ( delim "<delims>input<delim>" -- addr len )
in> drop \ skip space after word
begin dup in> <> until \ skip leading delimiters
>in @ 2 - >in ! \ "put back" last char read from tib,
\ and backtrack >in leading char that will
\ be skipped by parse
parse ;
\ parse word, compile first char as literal
: [char] ( "<spcs>input<spc>" -- c )
['] lit , bl word drop c@ , ; immediate
: ." ( "input<quote>" -- )
[char] " parse \ parse input up to "
state @ if
['] litstring , \ compile litstring
dup , \ compile length
0 do dup c@ c, 1 + loop drop \ compile string
['] type , \ display string at runtime
else
type \ display string
then ; immediate
." hello, world"
: hello ." hello, world" ;
hello