impls/vhdl/step9_try.vhdl

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