vhdl/stepA_mal.vhdl

   1 entity stepA_mal is
   2 end entity stepA_mal;
   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 stepA_mal 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 is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is
  70     variable f, env_err: mal_val_ptr;
  71   begin
  72     is_macro := false;
  73     if ast.val_type = mal_list and
  74        ast.seq_val'length > 0 and
  75        ast.seq_val(0).val_type = mal_symbol then
  76       env_get(env, ast.seq_val(0), f, env_err);
  77       if env_err = null and f /= null and
  78          f.val_type = mal_fn and f.func_val.f_is_macro then
  79         is_macro := true;
  80       end if;
  81     end if;
  82   end procedure is_macro_call;
  83
  84   procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  85     variable ast, macro_fn, call_args, macro_err: mal_val_ptr;
  86     variable is_macro: boolean;
  87   begin
  88     ast := in_ast;
  89     is_macro_call(ast, env, is_macro);
  90     while is_macro loop
  91       env_get(env, ast.seq_val(0), macro_fn, macro_err);
  92       seq_drop_prefix(ast, 1, call_args);
  93       apply_func(macro_fn, call_args, ast, macro_err);
  94       if macro_err /= null then
  95         err := macro_err;
  96         return;
  97       end if;
  98       is_macro_call(ast, env, is_macro);
  99     end loop;
 100     result := ast;
 101   end procedure macroexpand;
 102
 103   procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 104   begin
 105     EVAL(args.seq_val(0), repl_env, result, err);
 106   end procedure fn_eval;
 107
 108   procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 109     variable atom: mal_val_ptr := args.seq_val(0);
 110     variable fn: mal_val_ptr := args.seq_val(1);
 111     variable call_args_seq: mal_seq_ptr;
 112     variable call_args, eval_res, sub_err: mal_val_ptr;
 113   begin
 114     call_args_seq := new mal_seq(0 to args.seq_val'length - 2);
 115     call_args_seq(0) := atom.seq_val(0);
 116     call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1);
 117     new_seq_obj(mal_list, call_args_seq, call_args);
 118     apply_func(fn, call_args, eval_res, sub_err);
 119     if sub_err /= null then
 120       err := sub_err;
 121       return;
 122     end if;
 123     atom.seq_val(0) := eval_res;
 124     result := eval_res;
 125   end procedure fn_swap;
 126
 127   procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 128     variable fn: mal_val_ptr := args.seq_val(0);
 129     variable rest: mal_val_ptr;
 130     variable mid_args_count, rest_args_count: integer;
 131     variable call_args: mal_val_ptr;
 132     variable call_args_seq: mal_seq_ptr;
 133   begin
 134     rest := args.seq_val(args.seq_val'high);
 135     mid_args_count := args.seq_val'length - 2;
 136     rest_args_count := rest.seq_val'length;
 137     call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1);
 138     call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2);
 139     call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range);
 140     new_seq_obj(mal_list, call_args_seq, call_args);
 141     apply_func(fn, call_args, result, err);
 142   end procedure fn_apply;
 143
 144   procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 145     variable fn: mal_val_ptr := args.seq_val(0);
 146     variable lst: mal_val_ptr := args.seq_val(1);
 147     variable call_args, sub_err: mal_val_ptr;
 148     variable new_seq: mal_seq_ptr;
 149     variable i: integer;
 150   begin
 151     new_seq := new mal_seq(lst.seq_val'range);  -- (0 to lst.seq_val.length - 1);
 152     for i in new_seq'range loop
 153       new_one_element_list(lst.seq_val(i), call_args);
 154       apply_func(fn, call_args, new_seq(i), sub_err);
 155       if sub_err /= null then
 156         err := sub_err;
 157         return;
 158       end if;
 159     end loop;
 160     new_seq_obj(mal_list, new_seq, result);
 161   end procedure fn_map;
 162
 163   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
 164   begin
 165     if func_sym.string_val.all = "eval" then
 166       fn_eval(args, result, err);
 167     elsif func_sym.string_val.all = "swap!" then
 168       fn_swap(args, result, err);
 169     elsif func_sym.string_val.all = "apply" then
 170       fn_apply(args, result, err);
 171     elsif func_sym.string_val.all = "map" then
 172       fn_map(args, result, err);
 173     else
 174       eval_native_func(func_sym, args, result, err);
 175     end if;
 176   end procedure apply_native_func;
 177
 178   procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 179     variable fn_env: env_ptr;
 180   begin
 181     case fn.val_type is
 182       when mal_nativefn =>
 183         apply_native_func(fn, args, result, err);
 184       when mal_fn =>
 185         new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args);
 186         EVAL(fn.func_val.f_body, fn_env, result, err);
 187       when others =>
 188         new_string("not a function", err);
 189         return;
 190     end case;
 191   end procedure apply_func;
 192
 193   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
 194     variable eval_err: mal_val_ptr;
 195   begin
 196     result := new mal_seq(0 to ast_seq'length - 1);
 197     for i in result'range loop
 198       EVAL(ast_seq(i), env, result(i), eval_err);
 199       if eval_err /= null then
 200         err := eval_err;
 201         return;
 202       end if;
 203     end loop;
 204   end procedure eval_ast_seq;
 205
 206   procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 207     variable key, val, eval_err, env_err: mal_val_ptr;
 208     variable new_seq: mal_seq_ptr;
 209     variable i: integer;
 210   begin
 211     case ast.val_type is
 212       when mal_symbol =>
 213         env_get(env, ast, val, env_err);
 214         if env_err /= null then
 215           err := env_err;
 216           return;
 217         end if;
 218         result := val;
 219         return;
 220       when mal_list | mal_vector | mal_hashmap =>
 221         eval_ast_seq(ast.seq_val, env, new_seq, eval_err);
 222         if eval_err /= null then
 223           err := eval_err;
 224           return;
 225         end if;
 226         new_seq_obj(ast.val_type, new_seq, result);
 227         return;
 228       when others =>
 229         result := ast;
 230         return;
 231     end case;
 232   end procedure eval_ast;
 233
 234   procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 235     variable i: integer;
 236     variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr;
 237     variable env, let_env, catch_env, fn_env: env_ptr;
 238   begin
 239     ast := in_ast;
 240     env := in_env;
 241     loop
 242       if ast.val_type /= mal_list then
 243         eval_ast(ast, env, result, err);
 244         return;
 245       end if;
 246
 247       macroexpand(ast, env, ast, sub_err);
 248       if sub_err /= null then
 249         err := sub_err;
 250         return;
 251       end if;
 252       if ast.val_type /= mal_list then
 253         eval_ast(ast, env, result, err);
 254         return;
 255       end if;
 256       if ast.seq_val'length = 0 then
 257         result := ast;
 258         return;
 259       end if;
 260
 261       a0 := ast.seq_val(0);
 262       if a0.val_type = mal_symbol then
 263         if a0.string_val.all = "def!" then
 264           EVAL(ast.seq_val(2), env, val, sub_err);
 265           if sub_err /= null then
 266             err := sub_err;
 267             return;
 268           end if;
 269           env_set(env, ast.seq_val(1), val);
 270           result := val;
 271           return;
 272
 273         elsif a0.string_val.all = "let*" then
 274           vars := ast.seq_val(1);
 275           new_env(let_env, env);
 276           i := 0;
 277           while i < vars.seq_val'length loop
 278             EVAL(vars.seq_val(i + 1), let_env, val, sub_err);
 279             if sub_err /= null then
 280               err := sub_err;
 281               return;
 282             end if;
 283             env_set(let_env, vars.seq_val(i), val);
 284             i := i + 2;
 285           end loop;
 286           env := let_env;
 287           ast := ast.seq_val(2);
 288           next; -- TCO
 289
 290         elsif a0.string_val.all = "quote" then
 291           result := ast.seq_val(1);
 292           return;
 293
 294         elsif a0.string_val.all = "quasiquote" then
 295           quasiquote(ast.seq_val(1), ast);
 296           next; -- TCO
 297
 298         elsif a0.string_val.all = "defmacro!" then
 299           EVAL(ast.seq_val(2), env, val, sub_err);
 300           if sub_err /= null then
 301             err := sub_err;
 302             return;
 303           end if;
 304           val.func_val.f_is_macro := true;
 305           env_set(env, ast.seq_val(1), val);
 306           result := val;
 307           return;
 308
 309         elsif a0.string_val.all = "macroexpand" then
 310           macroexpand(ast.seq_val(1), env, result, err);
 311           return;
 312
 313         elsif a0.string_val.all = "try*" then
 314           EVAL(ast.seq_val(1), env, result, sub_err);
 315           if sub_err /= null then
 316             if ast.seq_val'length > 2 and
 317                ast.seq_val(2).val_type = mal_list and
 318                ast.seq_val(2).seq_val(0).val_type = mal_symbol and
 319                ast.seq_val(2).seq_val(0).string_val.all = "catch*" then
 320               new_one_element_list(ast.seq_val(2).seq_val(1), vars);
 321               new_one_element_list(sub_err, call_args);
 322               new_env(catch_env, env, vars, call_args);
 323               EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err);
 324             else
 325               new_nil(result);
 326             end if;
 327           end if;
 328           return;
 329
 330         elsif a0.string_val.all = "do" then
 331           for i in 1 to ast.seq_val'high - 1 loop
 332             EVAL(ast.seq_val(i), env, result, sub_err);
 333             if sub_err /= null then
 334               err := sub_err;
 335               return;
 336             end if;
 337           end loop;
 338           ast := ast.seq_val(ast.seq_val'high);
 339           next; -- TCO
 340
 341         elsif a0.string_val.all = "if" then
 342           EVAL(ast.seq_val(1), env, val, sub_err);
 343           if sub_err /= null then
 344             err := sub_err;
 345             return;
 346           end if;
 347           if val.val_type = mal_nil or val.val_type = mal_false then
 348             if ast.seq_val'length > 3 then
 349               ast := ast.seq_val(3);
 350             else
 351               new_nil(result);
 352               return;
 353             end if;
 354           else
 355             ast := ast.seq_val(2);
 356           end if;
 357           next; -- TCO
 358
 359         elsif a0.string_val.all = "fn*" then
 360           new_fn(ast.seq_val(2), ast.seq_val(1), env, result);
 361           return;
 362
 363         end if;
 364       end if;
 365
 366       eval_ast(ast, env, evaled_ast, sub_err);
 367       if sub_err /= null then
 368         err := sub_err;
 369         return;
 370       end if;
 371       seq_drop_prefix(evaled_ast, 1, call_args);
 372       fn := evaled_ast.seq_val(0);
 373       case fn.val_type is
 374         when mal_nativefn =>
 375           apply_native_func(fn, call_args, result, err);
 376           return;
 377         when mal_fn =>
 378           new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args);
 379           env := fn_env;
 380           ast := fn.func_val.f_body;
 381           next; -- TCO
 382         when others =>
 383           new_string("not a function", err);
 384           return;
 385       end case;
 386     end loop;
 387   end procedure EVAL;
 388
 389   procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is
 390   begin
 391     pr_str(exp, true, result);
 392   end procedure mal_PRINT;
 393
 394   procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 395     variable ast, read_err: mal_val_ptr;
 396   begin
 397     mal_READ(str, ast, read_err);
 398     if read_err /= null then
 399       err := read_err;
 400       result := null;
 401       return;
 402     end if;
 403     if ast = null then
 404       result := null;
 405       return;
 406     end if;
 407     EVAL(ast, env, result, err);
 408   end procedure RE;
 409
 410   procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is
 411     variable eval_res, eval_err: mal_val_ptr;
 412   begin
 413     RE(str, env, eval_res, eval_err);
 414     if eval_err /= null then
 415       err := eval_err;
 416       result := null;
 417       return;
 418     end if;
 419     mal_PRINT(eval_res, result);
 420   end procedure REP;
 421
 422   procedure set_argv(e: inout env_ptr; program_file: inout line) is
 423     variable argv_var_name: string(1 to 6) := "*ARGV*";
 424     variable argv_sym, argv_list: mal_val_ptr;
 425     file f: text;
 426     variable status: file_open_status;
 427     variable one_line: line;
 428     variable seq: mal_seq_ptr;
 429     variable element: mal_val_ptr;
 430   begin
 431     program_file := null;
 432     seq := new mal_seq(0 to -1);
 433     file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode);
 434     if status = open_ok then
 435       if not endfile(f) then
 436         readline(f, program_file);
 437         while not endfile(f) loop
 438           readline(f, one_line);
 439           new_string(one_line.all, element);
 440           seq := new mal_seq'(seq.all & element);
 441         end loop;
 442       end if;
 443       file_close(f);
 444     end if;
 445     new_seq_obj(mal_list, seq, argv_list);
 446     new_symbol(argv_var_name, argv_sym);
 447     env_set(e, argv_sym, argv_list);
 448   end procedure set_argv;
 449
 450   procedure repl is
 451     variable is_eof: boolean;
 452     variable program_file, input_line, result: line;
 453     variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr;
 454     variable outer: env_ptr;
 455     variable eval_func_name: string(1 to 4) := "eval";
 456   begin
 457     outer := null;
 458     new_env(repl_env, outer);
 459
 460     -- core.EXT: defined using VHDL (see core.vhdl)
 461     define_core_functions(repl_env);
 462     new_symbol(eval_func_name, eval_sym);
 463     new_nativefn(eval_func_name, eval_fn);
 464     env_set(repl_env, eval_sym, eval_fn);
 465     set_argv(repl_env, program_file);
 466
 467     -- core.mal: defined using the language itself
 468     RE("(def! *host-language* " & '"' & "vhdl" & '"' & ")", repl_env, dummy_val, err);
 469     RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err);
 470     RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & ")" & '"' & ")))))", repl_env, dummy_val, err);
 471     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);
 472     RE("(def! *gensym-counter* (atom 0))", repl_env, dummy_val, err);
 473     RE("(def! gensym (fn* [] (symbol (str " & '"' & "G__" & '"' & " (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))", repl_env, dummy_val, err);
 474     RE("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", repl_env, dummy_val, err);
 475
 476     if program_file /= null then
 477       REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err);
 478       return;
 479     end if;
 480
 481     RE("(println (str " & '"' & "Mal [" & '"' & " *host-language* " & '"' & "]" & '"' & "))", repl_env, dummy_val, err);
 482     loop
 483       mal_readline("user> ", is_eof, input_line);
 484       exit when is_eof;
 485       next when input_line'length = 0;
 486       REP(input_line.all, repl_env, result, err);
 487       if err /= null then
 488         pr_str(err, false, result);
 489         result := new string'("Error: " & result.all);
 490       end if;
 491       if result /= null then
 492         mal_printline(result.all);
 493       end if;
 494       deallocate(result);
 495       deallocate(err);
 496     end loop;
 497     mal_printline("");
 498   end procedure repl;
 499
 500 begin
 501   repl;
 502 end architecture test;