Commit | Line | Data |
---|---|---|
36e91db4 DM |
1 | entity step4_if_fn_do is |
2 | end entity step4_if_fn_do; | |
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 step4_if_fn_do is | |
15 | procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is | |
16 | begin | |
17 | read_str(str, ast, err); | |
18 | end procedure mal_READ; | |
19 | ||
20 | -- Forward declaration | |
21 | procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); | |
22 | ||
23 | 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 | |
24 | variable eval_err: mal_val_ptr; | |
25 | begin | |
26 | result := new mal_seq(0 to ast_seq'length - 1); | |
27 | for i in result'range loop | |
28 | EVAL(ast_seq(i), env, result(i), eval_err); | |
29 | if eval_err /= null then | |
30 | err := eval_err; | |
31 | return; | |
32 | end if; | |
33 | end loop; | |
34 | end procedure eval_ast_seq; | |
35 | ||
36 | procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
37 | variable key, val, eval_err, env_err: mal_val_ptr; | |
38 | variable new_seq: mal_seq_ptr; | |
39 | variable i: integer; | |
40 | begin | |
41 | case ast.val_type is | |
42 | when mal_symbol => | |
43 | env_get(env, ast, val, env_err); | |
44 | if env_err /= null then | |
45 | err := env_err; | |
46 | return; | |
47 | end if; | |
48 | result := val; | |
49 | return; | |
50 | when mal_list | mal_vector | mal_hashmap => | |
51 | eval_ast_seq(ast.seq_val, env, new_seq, eval_err); | |
52 | if eval_err /= null then | |
53 | err := eval_err; | |
54 | return; | |
55 | end if; | |
56 | new_seq_obj(ast.val_type, new_seq, result); | |
57 | return; | |
58 | when others => | |
59 | result := ast; | |
60 | return; | |
61 | end case; | |
62 | end procedure eval_ast; | |
63 | ||
64 | procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
65 | variable i: integer; | |
66 | variable evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; | |
67 | variable let_env, fn_env: env_ptr; | |
68 | begin | |
69 | if ast.val_type /= mal_list then | |
70 | eval_ast(ast, env, result, err); | |
71 | return; | |
72 | end if; | |
73 | ||
74 | if ast.seq_val'length = 0 then | |
75 | result := ast; | |
76 | return; | |
77 | end if; | |
78 | ||
79 | a0 := ast.seq_val(0); | |
80 | if a0.val_type = mal_symbol then | |
81 | if a0.string_val.all = "def!" then | |
82 | EVAL(ast.seq_val(2), env, val, sub_err); | |
83 | if sub_err /= null then | |
84 | err := sub_err; | |
85 | return; | |
86 | end if; | |
87 | env_set(env, ast.seq_val(1), val); | |
88 | result := val; | |
89 | return; | |
90 | ||
91 | elsif a0.string_val.all = "let*" then | |
92 | vars := ast.seq_val(1); | |
93 | new_env(let_env, env); | |
94 | i := 0; | |
95 | while i < vars.seq_val'length loop | |
96 | EVAL(vars.seq_val(i + 1), let_env, val, sub_err); | |
97 | if sub_err /= null then | |
98 | err := sub_err; | |
99 | return; | |
100 | end if; | |
101 | env_set(let_env, vars.seq_val(i), val); | |
102 | i := i + 2; | |
103 | end loop; | |
104 | EVAL(ast.seq_val(2), let_env, result, err); | |
105 | return; | |
106 | ||
107 | elsif a0.string_val.all = "do" then | |
108 | for i in 1 to ast.seq_val'high loop | |
109 | EVAL(ast.seq_val(i), env, result, sub_err); | |
110 | if sub_err /= null then | |
111 | err := sub_err; | |
112 | return; | |
113 | end if; | |
114 | end loop; | |
115 | return; | |
116 | ||
117 | elsif a0.string_val.all = "if" then | |
118 | EVAL(ast.seq_val(1), env, val, sub_err); | |
119 | if sub_err /= null then | |
120 | err := sub_err; | |
121 | return; | |
122 | end if; | |
123 | if val.val_type = mal_nil or val.val_type = mal_false then | |
124 | if ast.seq_val'length > 3 then | |
125 | EVAL(ast.seq_val(3), env, result, err); | |
126 | else | |
127 | new_nil(result); | |
128 | end if; | |
129 | else | |
130 | EVAL(ast.seq_val(2), env, result, err); | |
131 | end if; | |
132 | return; | |
133 | ||
134 | elsif a0.string_val.all = "fn*" then | |
135 | new_fn(ast.seq_val(2), ast.seq_val(1), env, result); | |
136 | return; | |
137 | ||
138 | end if; | |
139 | end if; | |
140 | ||
141 | eval_ast(ast, env, evaled_ast, sub_err); | |
142 | if sub_err /= null then | |
143 | err := sub_err; | |
144 | return; | |
145 | end if; | |
146 | seq_drop_prefix(evaled_ast, 1, call_args); | |
147 | fn := evaled_ast.seq_val(0); | |
148 | case fn.val_type is | |
149 | when mal_nativefn => | |
150 | eval_native_func(fn, call_args, result, err); | |
151 | when mal_fn => | |
152 | new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); | |
153 | EVAL(fn.func_val.f_body, fn_env, result, err); | |
154 | when others => | |
155 | new_string("not a function", err); | |
156 | end case; | |
157 | end procedure EVAL; | |
158 | ||
159 | procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is | |
160 | begin | |
161 | pr_str(exp, true, result); | |
162 | end procedure mal_PRINT; | |
163 | ||
164 | procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is | |
165 | variable ast, read_err: mal_val_ptr; | |
166 | begin | |
167 | mal_READ(str, ast, read_err); | |
168 | if read_err /= null then | |
169 | err := read_err; | |
170 | result := null; | |
171 | return; | |
172 | end if; | |
173 | if ast = null then | |
174 | result := null; | |
175 | return; | |
176 | end if; | |
177 | EVAL(ast, env, result, err); | |
178 | end procedure RE; | |
179 | ||
180 | procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is | |
181 | variable eval_res, eval_err: mal_val_ptr; | |
182 | begin | |
183 | RE(str, env, eval_res, eval_err); | |
184 | if eval_err /= null then | |
185 | err := eval_err; | |
186 | result := null; | |
187 | return; | |
188 | end if; | |
189 | mal_PRINT(eval_res, result); | |
190 | end procedure REP; | |
191 | ||
192 | procedure repl is | |
193 | variable is_eof: boolean; | |
194 | variable input_line, result: line; | |
195 | variable dummy_val, err: mal_val_ptr; | |
196 | variable outer, repl_env: env_ptr; | |
197 | begin | |
198 | outer := null; | |
199 | new_env(repl_env, outer); | |
200 | ||
201 | -- core.EXT: defined using VHDL (see core.vhdl) | |
202 | define_core_functions(repl_env); | |
203 | ||
204 | -- core.mal: defined using the language itself | |
205 | RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); | |
206 | ||
207 | loop | |
208 | mal_readline("user> ", is_eof, input_line); | |
209 | exit when is_eof; | |
210 | next when input_line'length = 0; | |
211 | REP(input_line.all, repl_env, result, err); | |
212 | if err /= null then | |
213 | pr_str(err, false, result); | |
214 | result := new string'("Error: " & result.all); | |
215 | end if; | |
216 | if result /= null then | |
217 | mal_printline(result.all); | |
218 | end if; | |
219 | deallocate(result); | |
220 | deallocate(err); | |
221 | end loop; | |
222 | mal_printline(""); | |
223 | end procedure repl; | |
224 | ||
225 | begin | |
226 | repl; | |
227 | end architecture test; |