7 use WORK.pkg_readline.all;
14 architecture test of stepA_mal is
16 shared variable repl_env: env_ptr;
18 procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is
20 read_str(str, ast, err);
21 end procedure mal_READ;
23 procedure starts_with(lst : inout mal_val_ptr;
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;
32 -- Forward declaration
33 procedure quasiquote(ast: inout mal_val_ptr;
34 result: out mal_val_ptr);
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);
42 starts_with(elt, "splice-unquote", sw);
45 new_symbol("concat", seq(0));
46 seq(1) := elt.seq_val(1);
48 new_symbol("cons", seq(0));
49 quasiquote(elt, seq(1));
52 new_seq_obj(mal_list, seq, acc);
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;
60 new_seq_obj(mal_list, seq, acc);
61 for i in xs'reverse_range loop
65 end procedure qq_foldr;
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;
74 starts_with(ast, "unquote", sw);
76 result := ast.seq_val(1);
78 qq_foldr(ast.seq_val, result);
81 seq := new mal_seq(0 to 1);
82 new_symbol("vec", seq(0));
83 qq_foldr(ast.seq_val, seq(1));
84 new_seq_obj(mal_list, seq, result);
85 when mal_symbol | mal_hashmap =>
86 seq := new mal_seq(0 to 1);
87 new_symbol("quote", seq(0));
89 new_seq_obj(mal_list, seq, result);
93 end procedure quasiquote;
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);
98 procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr);
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;
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
113 end procedure is_macro_call;
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;
120 is_macro_call(ast, env, is_macro);
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
129 is_macro_call(ast, env, is_macro);
132 end procedure macroexpand;
134 procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
136 EVAL(args.seq_val(0), repl_env, result, err);
137 end procedure fn_eval;
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;
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
154 atom.seq_val(0) := eval_res;
156 end procedure fn_swap;
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;
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;
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;
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
191 new_seq_obj(mal_list, new_seq, result);
192 end procedure fn_map;
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
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);
205 eval_native_func(func_sym, args, result, err);
207 end procedure apply_native_func;
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;
214 apply_native_func(fn, args, result, err);
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);
219 new_string("not a function", err);
222 end procedure apply_func;
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;
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
235 end procedure eval_ast_seq;
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;
244 env_get(env, ast, val, env_err);
245 if env_err /= null then
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
257 new_seq_obj(ast.val_type, new_seq, result);
263 end procedure eval_ast;
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
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;
273 if ast.val_type /= mal_list then
274 eval_ast(ast, env, result, err);
278 macroexpand(ast, env, ast, sub_err);
279 if sub_err /= null then
283 if ast.val_type /= mal_list then
284 eval_ast(ast, env, result, err);
287 if ast.seq_val'length = 0 then
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
300 env_set(env, ast.seq_val(1), val);
304 elsif a0.string_val.all = "let*" then
305 vars := ast.seq_val(1);
306 new_env(let_env, env);
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
314 env_set(let_env, vars.seq_val(i), val);
318 ast := ast.seq_val(2);
321 elsif a0.string_val.all = "quote" then
322 result := ast.seq_val(1);
325 elsif a0.string_val.all = "quasiquoteexpand" then
326 quasiquote(ast.seq_val(1), result);
329 elsif a0.string_val.all = "quasiquote" then
330 quasiquote(ast.seq_val(1), ast);
333 elsif a0.string_val.all = "defmacro!" then
334 EVAL(ast.seq_val(2), env, fn, sub_err);
335 if sub_err /= null then
339 new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val);
340 val.func_val.f_is_macro := true;
341 env_set(env, ast.seq_val(1), val);
345 elsif a0.string_val.all = "macroexpand" then
346 macroexpand(ast.seq_val(1), env, result, err);
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);
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
375 ast := ast.seq_val(ast.seq_val'high);
378 elsif a0.string_val.all = "if" then
379 EVAL(ast.seq_val(1), env, val, sub_err);
380 if sub_err /= null then
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);
392 ast := ast.seq_val(2);
396 elsif a0.string_val.all = "fn*" then
397 new_fn(ast.seq_val(2), ast.seq_val(1), env, result);
403 eval_ast(ast, env, evaled_ast, sub_err);
404 if sub_err /= null then
408 seq_drop_prefix(evaled_ast, 1, call_args);
409 fn := evaled_ast.seq_val(0);
412 apply_native_func(fn, call_args, result, err);
415 new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args);
417 ast := fn.func_val.f_body;
420 new_string("not a function", err);
426 procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is
428 pr_str(exp, true, result);
429 end procedure mal_PRINT;
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;
434 mal_READ(str, ast, read_err);
435 if read_err /= null then
444 EVAL(ast, env, result, err);
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;
450 RE(str, env, eval_res, eval_err);
451 if eval_err /= null then
456 mal_PRINT(eval_res, result);
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;
463 variable status: file_open_status;
464 variable one_line: line;
465 variable seq: mal_seq_ptr;
466 variable element: mal_val_ptr;
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);
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;
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";
495 new_env(repl_env, outer);
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);
504 -- core.mal: defined using the language itself
505 RE("(def! *host-language* " & '"' & "vhdl" & '"' & ")", repl_env, dummy_val, err);
506 RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err);
507 RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err);
508 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);
510 if program_file /= null then
511 REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err);
515 RE("(println (str " & '"' & "Mal [" & '"' & " *host-language* " & '"' & "]" & '"' & "))", repl_env, dummy_val, err);
517 mal_readline("user> ", is_eof, input_line);
519 next when input_line'length = 0;
520 REP(input_line.all, repl_env, result, err);
522 pr_str(err, false, result);
523 result := new string'("Error: " & result.all);
525 if result /= null then
526 mal_printline(result.all);
536 end architecture test;