Commit | Line | Data |
---|---|---|
794bfca1 C |
1 | require reader.fs |
2 | require printer.fs | |
3 | require core.fs | |
4 | ||
5 | core MalEnv. constant repl-env | |
6 | ||
794bfca1 C |
7 | 99999999 constant TCO-eval |
8 | ||
9 | : read read-str ; | |
10 | : eval ( env obj ) | |
11 | begin | |
12 | \ ." eval-> " dup pr-str safe-type cr | |
13 | mal-eval | |
14 | dup TCO-eval = | |
15 | while | |
16 | drop | |
17 | repeat ; | |
18 | ||
19 | \ ." Type: " dup mal-type @ type-name safe-type cr | |
20 | pr-str ; | |
21 | ||
22 | MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself | |
23 | ||
24 | MalKeyword | |
45c1894b | 25 | extend eval-invoke { env list kw -- val } |
794bfca1 C |
26 | 0 kw env list MalList/start @ cell+ @ eval get |
27 | ?dup 0= if | |
28 | \ compute not-found value | |
29 | list MalList/count @ 1 > if | |
30 | env list MalList/start @ 2 cells + @ TCO-eval | |
31 | else | |
32 | mal-nil | |
33 | endif | |
34 | endif ;; | |
35 | drop | |
36 | ||
37 | \ eval all but the first item of list | |
38 | : eval-rest { env list -- argv argc } | |
39 | list MalList/start @ cell+ { expr-start } | |
40 | list MalList/count @ 1- { argc } | |
41 | argc cells allocate throw { target } | |
42 | argc 0 ?do | |
43 | env expr-start i cells + @ eval | |
44 | target i cells + ! | |
45 | loop | |
46 | target argc ; | |
47 | ||
48 | MalNativeFn | |
7148ddb6 DM |
49 | extend eval-invoke { env list this -- list } |
50 | env list eval-rest ( argv argc ) | |
51 | this invoke ;; | |
52 | extend invoke ( argv argc this -- val ) | |
53 | MalNativeFn/xt @ execute ;; | |
794bfca1 C |
54 | drop |
55 | ||
56 | SpecialOp | |
45c1894b | 57 | extend eval-invoke ( env list this -- list ) |
794bfca1 C |
58 | SpecialOp/xt @ execute ;; |
59 | drop | |
60 | ||
61 | : install-special ( symbol xt ) | |
62 | SpecialOp. repl-env env/set ; | |
63 | ||
64 | : defspecial | |
65 | parse-allot-name MalSymbol. | |
66 | ['] install-special | |
67 | :noname | |
68 | ; | |
69 | ||
70 | : is-pair? ( obj -- bool ) | |
71 | empty? mal-false = ; | |
72 | ||
73 | defspecial quote ( env list -- form ) | |
74 | nip MalList/start @ cell+ @ ;; | |
75 | ||
76 | s" concat" MalSymbol. constant concat-sym | |
77 | s" cons" MalSymbol. constant cons-sym | |
78 | ||
79 | defer quasiquote | |
80 | : quasiquote0 { ast -- form } | |
81 | ast is-pair? 0= if | |
82 | here quote-sym , ast , here>MalList | |
83 | else | |
84 | ast to-list MalList/start @ { ast-start } | |
85 | ast-start @ { ast[0] } | |
86 | ast[0] unquote-sym m= if | |
87 | ast-start cell+ @ | |
88 | else | |
89 | ast[0] is-pair? if | |
90 | ast[0] to-list MalList/start @ { ast[0]-start } | |
91 | ast[0]-start @ splice-unquote-sym m= if | |
92 | here | |
93 | concat-sym , | |
94 | ast[0]-start cell+ @ , | |
95 | ast to-list MalList/rest quasiquote , | |
96 | here>MalList | |
97 | false | |
98 | else true endif | |
99 | else true endif | |
100 | if | |
101 | here | |
102 | cons-sym , | |
103 | ast[0] quasiquote , | |
104 | ast to-list MalList/rest quasiquote , | |
105 | here>MalList | |
106 | endif | |
107 | endif | |
108 | endif ; | |
109 | ' quasiquote0 is quasiquote | |
110 | ||
111 | defspecial quasiquote ( env list ) | |
112 | MalList/start @ cell+ @ ( ast ) | |
113 | quasiquote TCO-eval ;; | |
114 | ||
115 | defspecial def! { env list -- val } | |
116 | list MalList/start @ cell+ { arg0 } | |
117 | arg0 @ ( key ) | |
118 | env arg0 cell+ @ eval dup { val } ( key val ) | |
45c1894b | 119 | env env/set val ;; |
794bfca1 C |
120 | |
121 | defspecial let* { old-env list -- val } | |
122 | old-env MalEnv. { env } | |
123 | list MalList/start @ cell+ dup { arg0 } | |
124 | @ to-list | |
125 | dup MalList/start @ { bindings-start } ( list ) | |
126 | MalList/count @ 0 +do | |
127 | bindings-start i cells + dup @ swap cell+ @ ( sym expr ) | |
128 | env swap eval | |
129 | env env/set | |
130 | 2 +loop | |
131 | env arg0 cell+ @ TCO-eval | |
132 | \ TODO: dec refcount of env | |
133 | ;; | |
134 | ||
135 | defspecial do { env list -- val } | |
136 | list MalList/start @ { start } | |
137 | list MalList/count @ dup 1- { last } 1 ?do | |
138 | env start i cells + @ | |
139 | i last = if | |
140 | TCO-eval | |
141 | else | |
142 | eval drop | |
143 | endif | |
144 | loop ;; | |
145 | ||
146 | defspecial if { env list -- val } | |
147 | list MalList/start @ cell+ { arg0 } | |
148 | env arg0 @ eval ( test-val ) | |
149 | dup mal-false = if | |
150 | drop -1 | |
151 | else | |
152 | mal-nil = | |
153 | endif | |
154 | if | |
155 | \ branch to false | |
156 | list MalList/count @ 3 > if | |
157 | env arg0 cell+ cell+ @ TCO-eval | |
158 | else | |
159 | mal-nil | |
160 | endif | |
161 | else | |
162 | \ branch to true | |
163 | env arg0 cell+ @ TCO-eval | |
164 | endif ;; | |
165 | ||
166 | s" &" MalSymbol. constant &-sym | |
167 | ||
7148ddb6 | 168 | : new-user-fn-env { argv argc mal-fn -- env } |
794bfca1 C |
169 | mal-fn MalUserFn/formal-args @ { f-args-list } |
170 | mal-fn MalUserFn/env @ MalEnv. { env } | |
171 | ||
172 | f-args-list MalList/start @ { f-args } | |
173 | f-args-list MalList/count @ ?dup 0= if else | |
fe364a97 DM |
174 | \ pass empty list for last arg, unless overridden below |
175 | 1- cells f-args + @ MalList new env env/set | |
794bfca1 C |
176 | endif |
177 | argc 0 ?do | |
178 | f-args i cells + @ | |
179 | dup &-sym m= if | |
180 | drop | |
7148ddb6 DM |
181 | argc i - { c } |
182 | c cells allocate throw { start } | |
794bfca1 | 183 | argv i cells + start c cells cmove |
7148ddb6 DM |
184 | f-args i 1+ cells + @ ( more-args-symbol ) |
185 | start c MalList. env env/set | |
794bfca1 C |
186 | leave |
187 | endif | |
188 | argv i cells + @ | |
189 | env env/set | |
190 | loop | |
7148ddb6 | 191 | env ; |
794bfca1 | 192 | |
7148ddb6 DM |
193 | MalUserFn |
194 | extend eval-invoke { call-env list mal-fn -- list } | |
195 | call-env list eval-rest | |
196 | mal-fn invoke ;; | |
197 | ||
198 | extend invoke ( argv argc mal-fn ) | |
199 | dup { mal-fn } new-user-fn-env { env } | |
794bfca1 C |
200 | env mal-fn MalUserFn/body @ TCO-eval ;; |
201 | drop | |
202 | ||
203 | defspecial fn* { env list -- val } | |
204 | list MalList/start @ cell+ { arg0 } | |
205 | MalUserFn new | |
206 | env over MalUserFn/env ! | |
207 | arg0 @ to-list over MalUserFn/formal-args ! | |
208 | arg0 cell+ @ over MalUserFn/body ! ;; | |
209 | ||
210 | MalSymbol | |
211 | extend mal-eval { env sym -- val } | |
a631063f | 212 | sym env env/get-addr |
794bfca1 C |
213 | dup 0= if |
214 | drop | |
9e2a4ab0 | 215 | 0 0 s" ' not found" sym pr-str s" '" ...throw-str |
a631063f C |
216 | else |
217 | @ | |
794bfca1 C |
218 | endif ;; |
219 | drop | |
220 | ||
221 | : eval-ast { env list -- list } | |
222 | here | |
223 | list MalList/start @ { expr-start } | |
224 | list MalList/count @ 0 ?do | |
225 | env expr-start i cells + @ eval , | |
226 | loop | |
227 | here>MalList ; | |
228 | ||
229 | MalList | |
230 | extend mal-eval { env list -- val } | |
4e258d3a DM |
231 | list MalList/count @ 0= if |
232 | list | |
233 | else | |
234 | env list MalList/start @ @ eval | |
235 | env list rot eval-invoke | |
236 | endif ;; | |
794bfca1 C |
237 | drop |
238 | ||
239 | MalVector | |
240 | extend mal-eval ( env vector -- vector ) | |
241 | MalVector/list @ eval-ast | |
242 | MalVector new swap over MalVector/list ! ;; | |
243 | drop | |
244 | ||
245 | MalMap | |
246 | extend mal-eval ( env map -- map ) | |
247 | MalMap/list @ eval-ast | |
248 | MalMap new swap over MalMap/list ! ;; | |
249 | drop | |
250 | ||
251 | defcore eval ( argv argc ) | |
252 | drop @ repl-env swap eval ;; | |
253 | ||
45c1894b | 254 | : rep ( str-addr str-len -- str-addr str-len ) |
794bfca1 C |
255 | read |
256 | repl-env swap eval | |
257 | print ; | |
258 | ||
259 | : mk-args-list ( -- ) | |
260 | here | |
261 | begin | |
262 | next-arg 2dup 0 0 d<> while | |
263 | MalString. , | |
264 | repeat | |
265 | 2drop here>MalList ; | |
266 | ||
794bfca1 C |
267 | create buff 128 allot |
268 | 77777777777 constant stack-leak-detect | |
269 | ||
7148ddb6 DM |
270 | : nop ; |
271 | ||
272 | defcore swap! { argv argc -- val } | |
273 | \ argv is (atom fn args...) | |
274 | argv @ { atom } | |
275 | argv cell+ @ { fn } | |
276 | argc 1- { call-argc } | |
277 | call-argc cells allocate throw { call-argv } | |
278 | atom Atom/val call-argv 1 cells cmove | |
279 | argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove | |
280 | call-argv call-argc fn invoke | |
281 | dup TCO-eval = if drop eval endif { new-val } | |
282 | new-val atom Atom/val ! | |
283 | new-val ;; | |
284 | ||
c5ea1323 | 285 | s\" (def! not (fn* (x) (if x false true)))" rep 2drop |
e6d41de4 | 286 | s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop |
45c1894b | 287 | |
794bfca1 C |
288 | : repl ( -- ) |
289 | begin | |
290 | ." user> " | |
291 | stack-leak-detect | |
292 | buff 128 stdin read-line throw | |
45c1894b | 293 | while ( num-bytes-read ) |
9e2a4ab0 JMC |
294 | dup 0 <> if |
295 | buff swap ( str-addr str-len ) | |
296 | ['] rep | |
297 | \ execute ['] nop \ uncomment to see stack traces | |
298 | catch ?dup 0= if | |
299 | safe-type cr | |
300 | stack-leak-detect <> if ." --stack leak--" cr endif | |
301 | else { errno } | |
302 | begin stack-leak-detect = until | |
303 | errno 1 <> if | |
304 | s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc | |
305 | to exception-object | |
306 | endif | |
307 | ." Uncaught exception: " | |
308 | exception-object pr-str safe-type cr | |
309 | endif | |
310 | endif | |
794bfca1 C |
311 | repeat ; |
312 | ||
313 | : main ( -- ) | |
314 | mk-args-list { args-list } | |
315 | args-list MalList/count @ 0= if | |
316 | s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set | |
317 | repl | |
318 | else | |
319 | args-list MalList/start @ @ { filename } | |
320 | s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set | |
321 | ||
322 | repl-env | |
323 | here s" load-file" MalSymbol. , filename , here>MalList | |
324 | eval print | |
325 | endif ; | |
326 | ||
327 | main | |
328 | cr | |
329 | bye |