Commit | Line | Data |
---|---|---|
36e91db4 DM |
1 | entity step6_file is |
2 | end entity step6_file; | |
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 step6_file 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 | ||
23 | -- Forward declaration | |
24 | procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); | |
25 | ||
26 | procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); | |
27 | ||
28 | procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
29 | begin | |
30 | EVAL(args.seq_val(0), repl_env, result, err); | |
31 | end procedure fn_eval; | |
32 | ||
33 | procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
34 | variable atom: mal_val_ptr := args.seq_val(0); | |
35 | variable fn: mal_val_ptr := args.seq_val(1); | |
36 | variable call_args_seq: mal_seq_ptr; | |
37 | variable call_args, eval_res, sub_err: mal_val_ptr; | |
38 | begin | |
39 | call_args_seq := new mal_seq(0 to args.seq_val'length - 2); | |
40 | call_args_seq(0) := atom.seq_val(0); | |
41 | call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); | |
42 | new_seq_obj(mal_list, call_args_seq, call_args); | |
43 | apply_func(fn, call_args, eval_res, sub_err); | |
44 | if sub_err /= null then | |
45 | err := sub_err; | |
46 | return; | |
47 | end if; | |
48 | atom.seq_val(0) := eval_res; | |
49 | result := eval_res; | |
50 | end procedure fn_swap; | |
51 | ||
52 | 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 | |
53 | begin | |
54 | if func_sym.string_val.all = "eval" then | |
55 | fn_eval(args, result, err); | |
56 | elsif func_sym.string_val.all = "swap!" then | |
57 | fn_swap(args, result, err); | |
58 | else | |
59 | eval_native_func(func_sym, args, result, err); | |
60 | end if; | |
61 | end procedure apply_native_func; | |
62 | ||
63 | procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
64 | variable fn_env: env_ptr; | |
65 | begin | |
66 | case fn.val_type is | |
67 | when mal_nativefn => | |
68 | apply_native_func(fn, args, result, err); | |
69 | when mal_fn => | |
70 | new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); | |
71 | EVAL(fn.func_val.f_body, fn_env, result, err); | |
72 | when others => | |
73 | new_string("not a function", err); | |
74 | return; | |
75 | end case; | |
76 | end procedure apply_func; | |
77 | ||
78 | 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 | |
79 | variable eval_err: mal_val_ptr; | |
80 | begin | |
81 | result := new mal_seq(0 to ast_seq'length - 1); | |
82 | for i in result'range loop | |
83 | EVAL(ast_seq(i), env, result(i), eval_err); | |
84 | if eval_err /= null then | |
85 | err := eval_err; | |
86 | return; | |
87 | end if; | |
88 | end loop; | |
89 | end procedure eval_ast_seq; | |
90 | ||
91 | procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
92 | variable key, val, eval_err, env_err: mal_val_ptr; | |
93 | variable new_seq: mal_seq_ptr; | |
94 | variable i: integer; | |
95 | begin | |
96 | case ast.val_type is | |
97 | when mal_symbol => | |
98 | env_get(env, ast, val, env_err); | |
99 | if env_err /= null then | |
100 | err := env_err; | |
101 | return; | |
102 | end if; | |
103 | result := val; | |
104 | return; | |
105 | when mal_list | mal_vector | mal_hashmap => | |
106 | eval_ast_seq(ast.seq_val, env, new_seq, eval_err); | |
107 | if eval_err /= null then | |
108 | err := eval_err; | |
109 | return; | |
110 | end if; | |
111 | new_seq_obj(ast.val_type, new_seq, result); | |
112 | return; | |
113 | when others => | |
114 | result := ast; | |
115 | return; | |
116 | end case; | |
117 | end procedure eval_ast; | |
118 | ||
119 | procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
120 | variable i: integer; | |
121 | variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; | |
122 | variable env, let_env, fn_env: env_ptr; | |
123 | begin | |
124 | ast := in_ast; | |
125 | env := in_env; | |
126 | loop | |
127 | if ast.val_type /= mal_list then | |
128 | eval_ast(ast, env, result, err); | |
129 | return; | |
130 | end if; | |
131 | ||
132 | if ast.seq_val'length = 0 then | |
133 | result := ast; | |
134 | return; | |
135 | end if; | |
136 | ||
137 | a0 := ast.seq_val(0); | |
138 | if a0.val_type = mal_symbol then | |
139 | if a0.string_val.all = "def!" then | |
140 | EVAL(ast.seq_val(2), env, val, sub_err); | |
141 | if sub_err /= null then | |
142 | err := sub_err; | |
143 | return; | |
144 | end if; | |
145 | env_set(env, ast.seq_val(1), val); | |
146 | result := val; | |
147 | return; | |
148 | ||
149 | elsif a0.string_val.all = "let*" then | |
150 | vars := ast.seq_val(1); | |
151 | new_env(let_env, env); | |
152 | i := 0; | |
153 | while i < vars.seq_val'length loop | |
154 | EVAL(vars.seq_val(i + 1), let_env, val, sub_err); | |
155 | if sub_err /= null then | |
156 | err := sub_err; | |
157 | return; | |
158 | end if; | |
159 | env_set(let_env, vars.seq_val(i), val); | |
160 | i := i + 2; | |
161 | end loop; | |
162 | env := let_env; | |
163 | ast := ast.seq_val(2); | |
164 | next; -- TCO | |
165 | ||
166 | elsif a0.string_val.all = "do" then | |
167 | for i in 1 to ast.seq_val'high - 1 loop | |
168 | EVAL(ast.seq_val(i), env, result, sub_err); | |
169 | if sub_err /= null then | |
170 | err := sub_err; | |
171 | return; | |
172 | end if; | |
173 | end loop; | |
174 | ast := ast.seq_val(ast.seq_val'high); | |
175 | next; -- TCO | |
176 | ||
177 | elsif a0.string_val.all = "if" then | |
178 | EVAL(ast.seq_val(1), env, val, sub_err); | |
179 | if sub_err /= null then | |
180 | err := sub_err; | |
181 | return; | |
182 | end if; | |
183 | if val.val_type = mal_nil or val.val_type = mal_false then | |
184 | if ast.seq_val'length > 3 then | |
185 | ast := ast.seq_val(3); | |
186 | else | |
187 | new_nil(result); | |
188 | return; | |
189 | end if; | |
190 | else | |
191 | ast := ast.seq_val(2); | |
192 | end if; | |
193 | next; -- TCO | |
194 | ||
195 | elsif a0.string_val.all = "fn*" then | |
196 | new_fn(ast.seq_val(2), ast.seq_val(1), env, result); | |
197 | return; | |
198 | ||
199 | end if; | |
200 | end if; | |
201 | ||
202 | eval_ast(ast, env, evaled_ast, sub_err); | |
203 | if sub_err /= null then | |
204 | err := sub_err; | |
205 | return; | |
206 | end if; | |
207 | seq_drop_prefix(evaled_ast, 1, call_args); | |
208 | fn := evaled_ast.seq_val(0); | |
209 | case fn.val_type is | |
210 | when mal_nativefn => | |
211 | apply_native_func(fn, call_args, result, err); | |
212 | return; | |
213 | when mal_fn => | |
214 | new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); | |
215 | env := fn_env; | |
216 | ast := fn.func_val.f_body; | |
217 | next; -- TCO | |
218 | when others => | |
219 | new_string("not a function", err); | |
220 | return; | |
221 | end case; | |
222 | end loop; | |
223 | end procedure EVAL; | |
224 | ||
225 | procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is | |
226 | begin | |
227 | pr_str(exp, true, result); | |
228 | end procedure mal_PRINT; | |
229 | ||
230 | procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
231 | variable ast, read_err: mal_val_ptr; | |
232 | begin | |
233 | mal_READ(str, ast, read_err); | |
234 | if read_err /= null then | |
235 | err := read_err; | |
236 | result := null; | |
237 | return; | |
238 | end if; | |
239 | if ast = null then | |
240 | result := null; | |
241 | return; | |
242 | end if; | |
243 | EVAL(ast, env, result, err); | |
244 | end procedure RE; | |
245 | ||
246 | procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is | |
247 | variable eval_res, eval_err: mal_val_ptr; | |
248 | begin | |
249 | RE(str, env, eval_res, eval_err); | |
250 | if eval_err /= null then | |
251 | err := eval_err; | |
252 | result := null; | |
253 | return; | |
254 | end if; | |
255 | mal_PRINT(eval_res, result); | |
256 | end procedure REP; | |
257 | ||
258 | procedure set_argv(e: inout env_ptr; program_file: inout line) is | |
259 | variable argv_var_name: string(1 to 6) := "*ARGV*"; | |
260 | variable argv_sym, argv_list: mal_val_ptr; | |
261 | file f: text; | |
262 | variable status: file_open_status; | |
263 | variable one_line: line; | |
264 | variable seq: mal_seq_ptr; | |
265 | variable element: mal_val_ptr; | |
266 | begin | |
267 | program_file := null; | |
268 | seq := new mal_seq(0 to -1); | |
269 | file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); | |
270 | if status = open_ok then | |
271 | if not endfile(f) then | |
272 | readline(f, program_file); | |
273 | while not endfile(f) loop | |
274 | readline(f, one_line); | |
275 | new_string(one_line.all, element); | |
276 | seq := new mal_seq'(seq.all & element); | |
277 | end loop; | |
278 | end if; | |
279 | file_close(f); | |
280 | end if; | |
281 | new_seq_obj(mal_list, seq, argv_list); | |
282 | new_symbol(argv_var_name, argv_sym); | |
283 | env_set(e, argv_sym, argv_list); | |
284 | end procedure set_argv; | |
285 | ||
286 | procedure repl is | |
287 | variable is_eof: boolean; | |
288 | variable program_file, input_line, result: line; | |
289 | variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; | |
290 | variable outer: env_ptr; | |
291 | variable eval_func_name: string(1 to 4) := "eval"; | |
292 | begin | |
293 | outer := null; | |
294 | new_env(repl_env, outer); | |
295 | ||
296 | -- core.EXT: defined using VHDL (see core.vhdl) | |
297 | define_core_functions(repl_env); | |
298 | new_symbol(eval_func_name, eval_sym); | |
299 | new_nativefn(eval_func_name, eval_fn); | |
300 | env_set(repl_env, eval_sym, eval_fn); | |
301 | set_argv(repl_env, program_file); | |
302 | ||
303 | -- core.mal: defined using the language itself | |
304 | RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); | |
e6d41de4 | 305 | RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); |
36e91db4 DM |
306 | |
307 | if program_file /= null then | |
308 | REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); | |
309 | return; | |
310 | end if; | |
311 | ||
312 | loop | |
313 | mal_readline("user> ", is_eof, input_line); | |
314 | exit when is_eof; | |
315 | next when input_line'length = 0; | |
316 | REP(input_line.all, repl_env, result, err); | |
317 | if err /= null then | |
318 | pr_str(err, false, result); | |
319 | result := new string'("Error: " & result.all); | |
320 | end if; | |
321 | if result /= null then | |
322 | mal_printline(result.all); | |
323 | end if; | |
324 | deallocate(result); | |
325 | deallocate(err); | |
326 | end loop; | |
327 | mal_printline(""); | |
328 | end procedure repl; | |
329 | ||
330 | begin | |
331 | repl; | |
332 | end architecture test; |