Commit | Line | Data |
---|---|---|
36e91db4 DM |
1 | entity step9_try is |
2 | end entity step9_try; | |
3 | ||
4 | library STD; | |
5 | use STD.textio.all; | |
6 | library WORK; | |
7 | use WORK.pkg_readline.all; | |
8 | use WORK.types.all; | |
9 | use WORK.printer.all; | |
10 | use WORK.reader.all; | |
11 | use WORK.env.all; | |
12 | use WORK.core.all; | |
13 | ||
14 | architecture test of step9_try is | |
15 | ||
16 | shared variable repl_env: env_ptr; | |
17 | ||
18 | procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is | |
19 | begin | |
20 | read_str(str, ast, err); | |
21 | end procedure mal_READ; | |
22 | ||
fbfe6784 NB |
23 | procedure starts_with(lst : inout mal_val_ptr; |
24 | sym : in string; | |
25 | res : out boolean) is | |
36e91db4 | 26 | begin |
fbfe6784 NB |
27 | res := lst.seq_val.all'length = 2 |
28 | and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol | |
29 | and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; | |
30 | end starts_with; | |
36e91db4 | 31 | |
fbfe6784 NB |
32 | -- Forward declaration |
33 | procedure quasiquote(ast: inout mal_val_ptr; | |
34 | result: out mal_val_ptr); | |
35 | ||
36 | procedure qq_loop(elt : inout mal_val_ptr; | |
37 | acc : inout mal_val_ptr) is | |
38 | variable sw : boolean := elt.val_type = mal_list; | |
39 | variable seq : mal_seq_ptr := new mal_seq(0 to 2); | |
36e91db4 | 40 | begin |
fbfe6784 NB |
41 | if sw then |
42 | starts_with(elt, "splice-unquote", sw); | |
36e91db4 | 43 | end if; |
fbfe6784 NB |
44 | if sw then |
45 | new_symbol("concat", seq(0)); | |
46 | seq(1) := elt.seq_val(1); | |
36e91db4 | 47 | else |
fbfe6784 NB |
48 | new_symbol("cons", seq(0)); |
49 | quasiquote(elt, seq(1)); | |
50 | end if; | |
51 | seq(2) := acc; | |
52 | new_seq_obj(mal_list, seq, acc); | |
53 | end qq_loop; | |
54 | ||
55 | procedure qq_foldr (xs : inout mal_seq_ptr; | |
56 | res : out mal_val_ptr) is | |
57 | variable seq : mal_seq_ptr := new mal_seq(0 to -1); | |
58 | variable acc : mal_val_ptr; | |
59 | begin | |
60 | new_seq_obj(mal_list, seq, acc); | |
61 | for i in xs'reverse_range loop | |
62 | qq_loop (xs(i), acc); | |
63 | end loop; | |
64 | res := acc; | |
65 | end procedure qq_foldr; | |
66 | ||
67 | procedure quasiquote(ast: inout mal_val_ptr; | |
68 | result: out mal_val_ptr) is | |
69 | variable sw : boolean; | |
70 | variable seq : mal_seq_ptr; | |
71 | begin | |
72 | case ast.val_type is | |
73 | when mal_list => | |
74 | starts_with(ast, "unquote", sw); | |
75 | if sw then | |
76 | result := ast.seq_val(1); | |
77 | else | |
78 | qq_foldr(ast.seq_val, result); | |
79 | end if; | |
80 | when mal_vector => | |
81 | seq := new mal_seq(0 to 1); | |
82 | new_symbol("vec", seq(0)); | |
83 | qq_foldr(ast.seq_val, seq(1)); | |
36e91db4 | 84 | new_seq_obj(mal_list, seq, result); |
fbfe6784 NB |
85 | when mal_symbol | mal_hashmap => |
86 | seq := new mal_seq(0 to 1); | |
87 | new_symbol("quote", seq(0)); | |
88 | seq(1) := ast; | |
36e91db4 | 89 | new_seq_obj(mal_list, seq, result); |
fbfe6784 NB |
90 | when others => |
91 | result := ast; | |
92 | end case; | |
36e91db4 DM |
93 | end procedure quasiquote; |
94 | ||
95 | -- Forward declaration | |
96 | procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); | |
97 | ||
98 | procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); | |
99 | ||
100 | procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is | |
101 | variable f, env_err: mal_val_ptr; | |
102 | begin | |
103 | is_macro := false; | |
104 | if ast.val_type = mal_list and | |
105 | ast.seq_val'length > 0 and | |
106 | ast.seq_val(0).val_type = mal_symbol then | |
107 | env_get(env, ast.seq_val(0), f, env_err); | |
108 | if env_err = null and f /= null and | |
109 | f.val_type = mal_fn and f.func_val.f_is_macro then | |
110 | is_macro := true; | |
111 | end if; | |
112 | end if; | |
113 | end procedure is_macro_call; | |
114 | ||
115 | procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
116 | variable ast, macro_fn, call_args, macro_err: mal_val_ptr; | |
117 | variable is_macro: boolean; | |
118 | begin | |
119 | ast := in_ast; | |
120 | is_macro_call(ast, env, is_macro); | |
121 | while is_macro loop | |
122 | env_get(env, ast.seq_val(0), macro_fn, macro_err); | |
123 | seq_drop_prefix(ast, 1, call_args); | |
124 | apply_func(macro_fn, call_args, ast, macro_err); | |
125 | if macro_err /= null then | |
126 | err := macro_err; | |
127 | return; | |
128 | end if; | |
129 | is_macro_call(ast, env, is_macro); | |
130 | end loop; | |
131 | result := ast; | |
132 | end procedure macroexpand; | |
133 | ||
134 | procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
135 | begin | |
136 | EVAL(args.seq_val(0), repl_env, result, err); | |
137 | end procedure fn_eval; | |
138 | ||
139 | procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
140 | variable atom: mal_val_ptr := args.seq_val(0); | |
141 | variable fn: mal_val_ptr := args.seq_val(1); | |
142 | variable call_args_seq: mal_seq_ptr; | |
143 | variable call_args, eval_res, sub_err: mal_val_ptr; | |
144 | begin | |
145 | call_args_seq := new mal_seq(0 to args.seq_val'length - 2); | |
146 | call_args_seq(0) := atom.seq_val(0); | |
147 | call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); | |
148 | new_seq_obj(mal_list, call_args_seq, call_args); | |
149 | apply_func(fn, call_args, eval_res, sub_err); | |
150 | if sub_err /= null then | |
151 | err := sub_err; | |
152 | return; | |
153 | end if; | |
154 | atom.seq_val(0) := eval_res; | |
155 | result := eval_res; | |
156 | end procedure fn_swap; | |
157 | ||
158 | procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
159 | variable fn: mal_val_ptr := args.seq_val(0); | |
160 | variable rest: mal_val_ptr; | |
161 | variable mid_args_count, rest_args_count: integer; | |
162 | variable call_args: mal_val_ptr; | |
163 | variable call_args_seq: mal_seq_ptr; | |
164 | begin | |
165 | rest := args.seq_val(args.seq_val'high); | |
166 | mid_args_count := args.seq_val'length - 2; | |
167 | rest_args_count := rest.seq_val'length; | |
168 | call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1); | |
169 | call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2); | |
170 | call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range); | |
171 | new_seq_obj(mal_list, call_args_seq, call_args); | |
172 | apply_func(fn, call_args, result, err); | |
173 | end procedure fn_apply; | |
174 | ||
175 | procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
176 | variable fn: mal_val_ptr := args.seq_val(0); | |
177 | variable lst: mal_val_ptr := args.seq_val(1); | |
178 | variable call_args, sub_err: mal_val_ptr; | |
179 | variable new_seq: mal_seq_ptr; | |
180 | variable i: integer; | |
181 | begin | |
182 | new_seq := new mal_seq(lst.seq_val'range); -- (0 to lst.seq_val.length - 1); | |
183 | for i in new_seq'range loop | |
184 | new_one_element_list(lst.seq_val(i), call_args); | |
185 | apply_func(fn, call_args, new_seq(i), sub_err); | |
186 | if sub_err /= null then | |
187 | err := sub_err; | |
188 | return; | |
189 | end if; | |
190 | end loop; | |
191 | new_seq_obj(mal_list, new_seq, result); | |
192 | end procedure fn_map; | |
193 | ||
194 | procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
195 | begin | |
196 | if func_sym.string_val.all = "eval" then | |
197 | fn_eval(args, result, err); | |
198 | elsif func_sym.string_val.all = "swap!" then | |
199 | fn_swap(args, result, err); | |
200 | elsif func_sym.string_val.all = "apply" then | |
201 | fn_apply(args, result, err); | |
202 | elsif func_sym.string_val.all = "map" then | |
203 | fn_map(args, result, err); | |
204 | else | |
205 | eval_native_func(func_sym, args, result, err); | |
206 | end if; | |
207 | end procedure apply_native_func; | |
208 | ||
209 | procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
210 | variable fn_env: env_ptr; | |
211 | begin | |
212 | case fn.val_type is | |
213 | when mal_nativefn => | |
214 | apply_native_func(fn, args, result, err); | |
215 | when mal_fn => | |
216 | new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); | |
217 | EVAL(fn.func_val.f_body, fn_env, result, err); | |
218 | when others => | |
219 | new_string("not a function", err); | |
220 | return; | |
221 | end case; | |
222 | end procedure apply_func; | |
223 | ||
224 | procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is | |
225 | variable eval_err: mal_val_ptr; | |
226 | begin | |
227 | result := new mal_seq(0 to ast_seq'length - 1); | |
228 | for i in result'range loop | |
229 | EVAL(ast_seq(i), env, result(i), eval_err); | |
230 | if eval_err /= null then | |
231 | err := eval_err; | |
232 | return; | |
233 | end if; | |
234 | end loop; | |
235 | end procedure eval_ast_seq; | |
236 | ||
237 | procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
238 | variable key, val, eval_err, env_err: mal_val_ptr; | |
239 | variable new_seq: mal_seq_ptr; | |
240 | variable i: integer; | |
241 | begin | |
242 | case ast.val_type is | |
243 | when mal_symbol => | |
244 | env_get(env, ast, val, env_err); | |
245 | if env_err /= null then | |
246 | err := env_err; | |
247 | return; | |
248 | end if; | |
249 | result := val; | |
250 | return; | |
251 | when mal_list | mal_vector | mal_hashmap => | |
252 | eval_ast_seq(ast.seq_val, env, new_seq, eval_err); | |
253 | if eval_err /= null then | |
254 | err := eval_err; | |
255 | return; | |
256 | end if; | |
257 | new_seq_obj(ast.val_type, new_seq, result); | |
258 | return; | |
259 | when others => | |
260 | result := ast; | |
261 | return; | |
262 | end case; | |
263 | end procedure eval_ast; | |
264 | ||
265 | procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
266 | variable i: integer; | |
267 | variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; | |
268 | variable env, let_env, catch_env, fn_env: env_ptr; | |
269 | begin | |
270 | ast := in_ast; | |
271 | env := in_env; | |
272 | loop | |
273 | if ast.val_type /= mal_list then | |
274 | eval_ast(ast, env, result, err); | |
275 | return; | |
276 | end if; | |
277 | ||
278 | macroexpand(ast, env, ast, sub_err); | |
279 | if sub_err /= null then | |
280 | err := sub_err; | |
281 | return; | |
282 | end if; | |
283 | if ast.val_type /= mal_list then | |
284 | eval_ast(ast, env, result, err); | |
285 | return; | |
286 | end if; | |
287 | if ast.seq_val'length = 0 then | |
288 | result := ast; | |
289 | return; | |
290 | end if; | |
291 | ||
292 | a0 := ast.seq_val(0); | |
293 | if a0.val_type = mal_symbol then | |
294 | if a0.string_val.all = "def!" then | |
295 | EVAL(ast.seq_val(2), env, val, sub_err); | |
296 | if sub_err /= null then | |
297 | err := sub_err; | |
298 | return; | |
299 | end if; | |
300 | env_set(env, ast.seq_val(1), val); | |
301 | result := val; | |
302 | return; | |
303 | ||
304 | elsif a0.string_val.all = "let*" then | |
305 | vars := ast.seq_val(1); | |
306 | new_env(let_env, env); | |
307 | i := 0; | |
308 | while i < vars.seq_val'length loop | |
309 | EVAL(vars.seq_val(i + 1), let_env, val, sub_err); | |
310 | if sub_err /= null then | |
311 | err := sub_err; | |
312 | return; | |
313 | end if; | |
314 | env_set(let_env, vars.seq_val(i), val); | |
315 | i := i + 2; | |
316 | end loop; | |
317 | env := let_env; | |
318 | ast := ast.seq_val(2); | |
319 | next; -- TCO | |
320 | ||
321 | elsif a0.string_val.all = "quote" then | |
322 | result := ast.seq_val(1); | |
323 | return; | |
324 | ||
fbfe6784 NB |
325 | elsif a0.string_val.all = "quasiquoteexpand" then |
326 | quasiquote(ast.seq_val(1), result); | |
327 | return; | |
328 | ||
36e91db4 DM |
329 | elsif a0.string_val.all = "quasiquote" then |
330 | quasiquote(ast.seq_val(1), ast); | |
331 | next; -- TCO | |
332 | ||
333 | elsif a0.string_val.all = "defmacro!" then | |
fdd4e53f | 334 | EVAL(ast.seq_val(2), env, fn, sub_err); |
36e91db4 DM |
335 | if sub_err /= null then |
336 | err := sub_err; | |
337 | return; | |
338 | end if; | |
fdd4e53f | 339 | new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); |
36e91db4 DM |
340 | val.func_val.f_is_macro := true; |
341 | env_set(env, ast.seq_val(1), val); | |
342 | result := val; | |
343 | return; | |
344 | ||
345 | elsif a0.string_val.all = "macroexpand" then | |
346 | macroexpand(ast.seq_val(1), env, result, err); | |
347 | return; | |
348 | ||
349 | elsif a0.string_val.all = "try*" then | |
350 | EVAL(ast.seq_val(1), env, result, sub_err); | |
351 | if sub_err /= null then | |
352 | if ast.seq_val'length > 2 and | |
353 | ast.seq_val(2).val_type = mal_list and | |
354 | ast.seq_val(2).seq_val(0).val_type = mal_symbol and | |
355 | ast.seq_val(2).seq_val(0).string_val.all = "catch*" then | |
356 | new_one_element_list(ast.seq_val(2).seq_val(1), vars); | |
357 | new_one_element_list(sub_err, call_args); | |
358 | new_env(catch_env, env, vars, call_args); | |
359 | EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); | |
360 | else | |
9993f053 DM |
361 | err := sub_err; |
362 | return; | |
36e91db4 DM |
363 | end if; |
364 | end if; | |
365 | return; | |
366 | ||
367 | elsif a0.string_val.all = "do" then | |
368 | for i in 1 to ast.seq_val'high - 1 loop | |
369 | EVAL(ast.seq_val(i), env, result, sub_err); | |
370 | if sub_err /= null then | |
371 | err := sub_err; | |
372 | return; | |
373 | end if; | |
374 | end loop; | |
375 | ast := ast.seq_val(ast.seq_val'high); | |
376 | next; -- TCO | |
377 | ||
378 | elsif a0.string_val.all = "if" then | |
379 | EVAL(ast.seq_val(1), env, val, sub_err); | |
380 | if sub_err /= null then | |
381 | err := sub_err; | |
382 | return; | |
383 | end if; | |
384 | if val.val_type = mal_nil or val.val_type = mal_false then | |
385 | if ast.seq_val'length > 3 then | |
386 | ast := ast.seq_val(3); | |
387 | else | |
388 | new_nil(result); | |
389 | return; | |
390 | end if; | |
391 | else | |
392 | ast := ast.seq_val(2); | |
393 | end if; | |
394 | next; -- TCO | |
395 | ||
396 | elsif a0.string_val.all = "fn*" then | |
397 | new_fn(ast.seq_val(2), ast.seq_val(1), env, result); | |
398 | return; | |
399 | ||
400 | end if; | |
401 | end if; | |
402 | ||
403 | eval_ast(ast, env, evaled_ast, sub_err); | |
404 | if sub_err /= null then | |
405 | err := sub_err; | |
406 | return; | |
407 | end if; | |
408 | seq_drop_prefix(evaled_ast, 1, call_args); | |
409 | fn := evaled_ast.seq_val(0); | |
410 | case fn.val_type is | |
411 | when mal_nativefn => | |
412 | apply_native_func(fn, call_args, result, err); | |
413 | return; | |
414 | when mal_fn => | |
415 | new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); | |
416 | env := fn_env; | |
417 | ast := fn.func_val.f_body; | |
418 | next; -- TCO | |
419 | when others => | |
420 | new_string("not a function", err); | |
421 | return; | |
422 | end case; | |
423 | end loop; | |
424 | end procedure EVAL; | |
425 | ||
426 | procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is | |
427 | begin | |
428 | pr_str(exp, true, result); | |
429 | end procedure mal_PRINT; | |
430 | ||
431 | procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
432 | variable ast, read_err: mal_val_ptr; | |
433 | begin | |
434 | mal_READ(str, ast, read_err); | |
435 | if read_err /= null then | |
436 | err := read_err; | |
437 | result := null; | |
438 | return; | |
439 | end if; | |
440 | if ast = null then | |
441 | result := null; | |
442 | return; | |
443 | end if; | |
444 | EVAL(ast, env, result, err); | |
445 | end procedure RE; | |
446 | ||
447 | procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is | |
448 | variable eval_res, eval_err: mal_val_ptr; | |
449 | begin | |
450 | RE(str, env, eval_res, eval_err); | |
451 | if eval_err /= null then | |
452 | err := eval_err; | |
453 | result := null; | |
454 | return; | |
455 | end if; | |
456 | mal_PRINT(eval_res, result); | |
457 | end procedure REP; | |
458 | ||
459 | procedure set_argv(e: inout env_ptr; program_file: inout line) is | |
460 | variable argv_var_name: string(1 to 6) := "*ARGV*"; | |
461 | variable argv_sym, argv_list: mal_val_ptr; | |
462 | file f: text; | |
463 | variable status: file_open_status; | |
464 | variable one_line: line; | |
465 | variable seq: mal_seq_ptr; | |
466 | variable element: mal_val_ptr; | |
467 | begin | |
468 | program_file := null; | |
469 | seq := new mal_seq(0 to -1); | |
470 | file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); | |
471 | if status = open_ok then | |
472 | if not endfile(f) then | |
473 | readline(f, program_file); | |
474 | while not endfile(f) loop | |
475 | readline(f, one_line); | |
476 | new_string(one_line.all, element); | |
477 | seq := new mal_seq'(seq.all & element); | |
478 | end loop; | |
479 | end if; | |
480 | file_close(f); | |
481 | end if; | |
482 | new_seq_obj(mal_list, seq, argv_list); | |
483 | new_symbol(argv_var_name, argv_sym); | |
484 | env_set(e, argv_sym, argv_list); | |
485 | end procedure set_argv; | |
486 | ||
487 | procedure repl is | |
488 | variable is_eof: boolean; | |
489 | variable program_file, input_line, result: line; | |
490 | variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; | |
491 | variable outer: env_ptr; | |
492 | variable eval_func_name: string(1 to 4) := "eval"; | |
493 | begin | |
494 | outer := null; | |
495 | new_env(repl_env, outer); | |
496 | ||
497 | -- core.EXT: defined using VHDL (see core.vhdl) | |
498 | define_core_functions(repl_env); | |
499 | new_symbol(eval_func_name, eval_sym); | |
500 | new_nativefn(eval_func_name, eval_fn); | |
501 | env_set(repl_env, eval_sym, eval_fn); | |
502 | set_argv(repl_env, program_file); | |
503 | ||
504 | -- core.mal: defined using the language itself | |
505 | RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); | |
e6d41de4 | 506 | RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); |
36e91db4 | 507 | RE("(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)))))))", repl_env, dummy_val, err); |
36e91db4 DM |
508 | |
509 | if program_file /= null then | |
510 | REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); | |
511 | return; | |
512 | end if; | |
513 | ||
514 | loop | |
515 | mal_readline("user> ", is_eof, input_line); | |
516 | exit when is_eof; | |
517 | next when input_line'length = 0; | |
518 | REP(input_line.all, repl_env, result, err); | |
519 | if err /= null then | |
520 | pr_str(err, false, result); | |
521 | result := new string'("Error: " & result.all); | |
522 | end if; | |
523 | if result /= null then | |
524 | mal_printline(result.all); | |
525 | end if; | |
526 | deallocate(result); | |
527 | deallocate(err); | |
528 | end loop; | |
529 | mal_printline(""); | |
530 | end procedure repl; | |
531 | ||
532 | begin | |
533 | repl; | |
534 | end architecture test; |