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