vhdl/step4_if_fn_do.vhdl

   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;