Commit | Line | Data |
---|---|---|
580c4eef C |
1 | require reader.fs |
2 | require printer.fs | |
3 | require core.fs | |
4 | ||
5 | core MalEnv. constant repl-env | |
6 | ||
580c4eef 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 | |
224e09ed | 25 | extend eval-invoke { env list kw -- val } |
580c4eef 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 ;; | |
224e09ed C |
35 | extend invoke { argv argc kw -- val } |
36 | 0 kw argv @ get | |
37 | ?dup 0= if | |
38 | argc 1 > if | |
39 | argv cell+ @ | |
40 | else | |
41 | mal-nil | |
42 | endif | |
43 | endif ;; | |
580c4eef C |
44 | drop |
45 | ||
46 | \ eval all but the first item of list | |
47 | : eval-rest { env list -- argv argc } | |
48 | list MalList/start @ cell+ { expr-start } | |
49 | list MalList/count @ 1- { argc } | |
50 | argc cells allocate throw { target } | |
51 | argc 0 ?do | |
52 | env expr-start i cells + @ eval | |
53 | target i cells + ! | |
54 | loop | |
55 | target argc ; | |
56 | ||
57 | MalNativeFn | |
224e09ed C |
58 | extend eval-invoke { env list this -- list } |
59 | env list eval-rest ( argv argc ) | |
60 | this invoke ;; | |
61 | extend invoke ( argv argc this -- val ) | |
62 | MalNativeFn/xt @ execute ;; | |
580c4eef C |
63 | drop |
64 | ||
65 | SpecialOp | |
224e09ed | 66 | extend eval-invoke ( env list this -- list ) |
580c4eef C |
67 | SpecialOp/xt @ execute ;; |
68 | drop | |
69 | ||
70 | : install-special ( symbol xt ) | |
71 | SpecialOp. repl-env env/set ; | |
72 | ||
73 | : defspecial | |
74 | parse-allot-name MalSymbol. | |
75 | ['] install-special | |
76 | :noname | |
77 | ; | |
78 | ||
79 | : is-pair? ( obj -- bool ) | |
80 | empty? mal-false = ; | |
81 | ||
82 | defspecial quote ( env list -- form ) | |
83 | nip MalList/start @ cell+ @ ;; | |
84 | ||
85 | s" concat" MalSymbol. constant concat-sym | |
86 | s" cons" MalSymbol. constant cons-sym | |
87 | ||
88 | defer quasiquote | |
89 | : quasiquote0 { ast -- form } | |
90 | ast is-pair? 0= if | |
91 | here quote-sym , ast , here>MalList | |
92 | else | |
93 | ast to-list MalList/start @ { ast-start } | |
94 | ast-start @ { ast[0] } | |
95 | ast[0] unquote-sym m= if | |
96 | ast-start cell+ @ | |
97 | else | |
98 | ast[0] is-pair? if | |
99 | ast[0] to-list MalList/start @ { ast[0]-start } | |
100 | ast[0]-start @ splice-unquote-sym m= if | |
101 | here | |
102 | concat-sym , | |
103 | ast[0]-start cell+ @ , | |
104 | ast to-list MalList/rest quasiquote , | |
105 | here>MalList | |
106 | false | |
107 | else true endif | |
108 | else true endif | |
109 | if | |
110 | here | |
111 | cons-sym , | |
112 | ast[0] quasiquote , | |
113 | ast to-list MalList/rest quasiquote , | |
114 | here>MalList | |
115 | endif | |
116 | endif | |
117 | endif ; | |
118 | ' quasiquote0 is quasiquote | |
119 | ||
120 | defspecial quasiquote ( env list ) | |
121 | MalList/start @ cell+ @ ( ast ) | |
122 | quasiquote TCO-eval ;; | |
123 | ||
124 | defspecial def! { env list -- val } | |
125 | list MalList/start @ cell+ { arg0 } | |
126 | arg0 @ ( key ) | |
127 | env arg0 cell+ @ eval dup { val } ( key val ) | |
128 | env env/set val ;; | |
129 | ||
130 | defspecial defmacro! { env list -- val } | |
131 | list MalList/start @ cell+ { arg0 } | |
132 | arg0 @ ( key ) | |
133 | env arg0 cell+ @ eval { val } | |
134 | true val MalUserFn/is-macro? ! | |
135 | val env env/set | |
136 | val ;; | |
137 | ||
138 | defspecial let* { old-env list -- val } | |
139 | old-env MalEnv. { env } | |
140 | list MalList/start @ cell+ dup { arg0 } | |
141 | @ to-list | |
142 | dup MalList/start @ { bindings-start } ( list ) | |
143 | MalList/count @ 0 +do | |
144 | bindings-start i cells + dup @ swap cell+ @ ( sym expr ) | |
145 | env swap eval | |
146 | env env/set | |
147 | 2 +loop | |
148 | env arg0 cell+ @ TCO-eval | |
149 | \ TODO: dec refcount of env | |
150 | ;; | |
151 | ||
152 | defspecial do { env list -- val } | |
153 | list MalList/start @ { start } | |
154 | list MalList/count @ dup 1- { last } 1 ?do | |
155 | env start i cells + @ | |
156 | i last = if | |
157 | TCO-eval | |
158 | else | |
159 | eval drop | |
160 | endif | |
161 | loop ;; | |
162 | ||
163 | defspecial if { env list -- val } | |
164 | list MalList/start @ cell+ { arg0 } | |
165 | env arg0 @ eval ( test-val ) | |
166 | dup mal-false = if | |
167 | drop -1 | |
168 | else | |
169 | mal-nil = | |
170 | endif | |
171 | if | |
172 | \ branch to false | |
173 | list MalList/count @ 3 > if | |
174 | env arg0 cell+ cell+ @ TCO-eval | |
175 | else | |
176 | mal-nil | |
177 | endif | |
178 | else | |
179 | \ branch to true | |
180 | env arg0 cell+ @ TCO-eval | |
181 | endif ;; | |
182 | ||
183 | s" &" MalSymbol. constant &-sym | |
184 | ||
185 | : new-user-fn-env { argv argc mal-fn -- env } | |
186 | mal-fn MalUserFn/formal-args @ { f-args-list } | |
187 | mal-fn MalUserFn/env @ MalEnv. { env } | |
188 | ||
189 | f-args-list MalList/start @ { f-args } | |
190 | f-args-list MalList/count @ ?dup 0= if else | |
191 | \ pass nil for last arg, unless overridden below | |
192 | 1- cells f-args + @ mal-nil env env/set | |
193 | endif | |
194 | argc 0 ?do | |
195 | f-args i cells + @ | |
196 | dup &-sym m= if | |
197 | drop | |
224e09ed C |
198 | argc i - { c } |
199 | c cells allocate throw { start } | |
580c4eef | 200 | argv i cells + start c cells cmove |
224e09ed C |
201 | f-args i 1+ cells + @ ( more-args-symbol ) |
202 | start c MalList. env env/set | |
580c4eef C |
203 | leave |
204 | endif | |
205 | argv i cells + @ | |
206 | env env/set | |
207 | loop | |
208 | env ; | |
209 | ||
210 | MalUserFn | |
224e09ed | 211 | extend eval-invoke { call-env list mal-fn -- list } |
580c4eef | 212 | mal-fn MalUserFn/is-macro? @ if |
45c1894b C |
213 | list MalList/start @ cell+ \ argv |
214 | list MalList/count @ 1- \ argc | |
215 | mal-fn new-user-fn-env { env } | |
216 | env mal-fn MalUserFn/body @ eval | |
217 | call-env swap TCO-eval | |
580c4eef C |
218 | else |
219 | call-env list eval-rest | |
45c1894b C |
220 | mal-fn invoke |
221 | endif ;; | |
224e09ed C |
222 | |
223 | extend invoke ( argv argc mal-fn ) | |
224 | dup { mal-fn } new-user-fn-env { env } | |
45c1894b | 225 | env mal-fn MalUserFn/body @ TCO-eval ;; |
580c4eef C |
226 | drop |
227 | ||
228 | defspecial fn* { env list -- val } | |
229 | list MalList/start @ cell+ { arg0 } | |
230 | MalUserFn new | |
224e09ed | 231 | false over MalUserFn/is-macro? ! |
580c4eef C |
232 | env over MalUserFn/env ! |
233 | arg0 @ to-list over MalUserFn/formal-args ! | |
234 | arg0 cell+ @ over MalUserFn/body ! ;; | |
235 | ||
236 | defspecial macroexpand ( env list[_,form] -- form ) | |
237 | MalList/start @ cell+ @ swap over ( form env form ) | |
238 | MalList/start @ @ ( form env macro-name-expr ) | |
239 | eval { macro-fn } ( form ) | |
240 | dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) | |
241 | new-user-fn-env ( env ) | |
242 | macro-fn MalUserFn/body @ TCO-eval ;; | |
243 | ||
244 | 5555555555 constant pre-try | |
245 | ||
246 | defspecial try* { env list -- val } | |
247 | list MalList/start @ cell+ { arg0 } | |
248 | pre-try | |
249 | env arg0 @ ['] eval catch ?dup 0= if | |
250 | nip | |
251 | else { errno } | |
252 | begin pre-try = until | |
253 | errno 1 <> if | |
254 | s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc | |
255 | to exception-object | |
256 | endif | |
257 | arg0 cell+ @ ( list[catch*,sym,form] ) | |
258 | MalList/start @ cell+ { catch0 } | |
259 | env MalEnv. { catch-env } | |
260 | catch0 @ exception-object catch-env env/set | |
261 | catch-env catch0 cell+ @ TCO-eval | |
262 | endif ;; | |
263 | ||
580c4eef C |
264 | MalSymbol |
265 | extend mal-eval { env sym -- val } | |
3a17cb96 | 266 | sym env env/get-addr |
580c4eef C |
267 | dup 0= if |
268 | drop | |
a631063f | 269 | 0 0 s" ' not found" sym pr-str s" '" ...throw-str |
3a17cb96 C |
270 | else |
271 | @ | |
580c4eef C |
272 | endif ;; |
273 | drop | |
274 | ||
275 | : eval-ast { env list -- list } | |
276 | here | |
277 | list MalList/start @ { expr-start } | |
278 | list MalList/count @ 0 ?do | |
279 | env expr-start i cells + @ eval , | |
280 | loop | |
281 | here>MalList ; | |
282 | ||
283 | MalList | |
284 | extend mal-eval { env list -- val } | |
285 | env list MalList/start @ @ eval | |
224e09ed | 286 | env list rot eval-invoke ;; |
580c4eef C |
287 | drop |
288 | ||
289 | MalVector | |
290 | extend mal-eval ( env vector -- vector ) | |
291 | MalVector/list @ eval-ast | |
292 | MalVector new swap over MalVector/list ! ;; | |
293 | drop | |
294 | ||
295 | MalMap | |
296 | extend mal-eval ( env map -- map ) | |
297 | MalMap/list @ eval-ast | |
298 | MalMap new swap over MalMap/list ! ;; | |
299 | drop | |
300 | ||
301 | defcore eval ( argv argc ) | |
302 | drop @ repl-env swap eval ;; | |
303 | ||
45c1894b | 304 | : rep ( str-addr str-len -- str-addr str-len ) |
580c4eef C |
305 | read |
306 | repl-env swap eval | |
307 | print ; | |
308 | ||
309 | : mk-args-list ( -- ) | |
310 | here | |
311 | begin | |
312 | next-arg 2dup 0 0 d<> while | |
313 | MalString. , | |
314 | repeat | |
315 | 2drop here>MalList ; | |
316 | ||
224e09ed C |
317 | create buff 128 allot |
318 | 77777777777 constant stack-leak-detect | |
319 | ||
320 | : nop ; | |
321 | ||
322 | defcore map ( argv argc -- list ) | |
323 | drop dup @ swap cell+ @ to-list { fn list } | |
324 | here | |
325 | list MalList/start @ list MalList/count @ cells over + swap +do | |
326 | i 1 fn invoke | |
327 | dup TCO-eval = if drop eval endif | |
328 | , | |
329 | cell +loop | |
330 | here>MalList ;; | |
331 | ||
332 | defcore readline ( argv argc -- mal-string ) | |
45c1894b | 333 | drop @ unpack-str type stdout flush-file drop |
224e09ed | 334 | buff 128 stdin read-line throw |
45c1894b | 335 | if buff swap MalString. else drop mal-nil endif ;; |
224e09ed | 336 | |
45c1894b C |
337 | s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop |
338 | s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop | |
339 | s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop | |
340 | s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop | |
580c4eef C |
341 | |
342 | : repl ( -- ) | |
343 | begin | |
344 | ." user> " | |
345 | stack-leak-detect | |
346 | buff 128 stdin read-line throw | |
347 | while ( num-bytes-read ) | |
348 | buff swap ( str-addr str-len ) | |
349 | ['] rep | |
45c1894b | 350 | \ execute ['] nop \ uncomment to see stack traces |
580c4eef C |
351 | catch ?dup 0= if |
352 | safe-type cr | |
353 | stack-leak-detect <> if ." --stack leak--" cr endif | |
354 | else { errno } | |
355 | begin stack-leak-detect = until | |
356 | errno 1 <> if | |
357 | s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc | |
358 | to exception-object | |
359 | endif | |
360 | ." Uncaught exception: " | |
361 | exception-object pr-str safe-type cr | |
362 | endif | |
363 | repeat ; | |
364 | ||
365 | : main ( -- ) | |
366 | mk-args-list { args-list } | |
367 | args-list MalList/count @ 0= if | |
368 | s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set | |
369 | repl | |
370 | else | |
371 | args-list MalList/start @ @ { filename } | |
372 | s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set | |
373 | ||
374 | repl-env | |
375 | here s" load-file" MalSymbol. , filename , here>MalList | |
376 | eval print | |
377 | endif ; | |
378 | ||
379 | main | |
380 | cr | |
381 | bye |