vhdl/core.vhdl

   1 library STD;
   2 use STD.textio.all;
   3 library WORK;
   4 use WORK.types.all;
   5 use WORK.env.all;
   6 use WORK.reader.all;
   7 use WORK.printer.all;
   8 use WORK.pkg_readline.all;
   9
  10 package core is
  11   procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr);
  12   procedure define_core_functions(e: inout env_ptr);
  13 end package core;
  14
  15 package body core is
  16
  17   procedure fn_equal(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  18     variable is_equal: boolean;
  19   begin
  20     equal_q(args.seq_val(0), args.seq_val(1), is_equal);
  21     new_boolean(is_equal, result);
  22   end procedure fn_equal;
  23
  24   procedure fn_throw(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  25   begin
  26     err := args.seq_val(0);
  27   end procedure fn_throw;
  28
  29   procedure fn_nil_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  30   begin
  31     new_boolean(args.seq_val(0).val_type = mal_nil, result);
  32   end procedure fn_nil_q;
  33
  34   procedure fn_true_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  35   begin
  36     new_boolean(args.seq_val(0).val_type = mal_true, result);
  37   end procedure fn_true_q;
  38
  39   procedure fn_false_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  40   begin
  41     new_boolean(args.seq_val(0).val_type = mal_false, result);
  42   end procedure fn_false_q;
  43
  44   procedure fn_string_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  45   begin
  46     new_boolean(args.seq_val(0).val_type = mal_string, result);
  47   end procedure fn_string_q;
  48
  49   procedure fn_symbol(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  50   begin
  51     new_symbol(args.seq_val(0).string_val, result);
  52   end procedure fn_symbol;
  53
  54   procedure fn_symbol_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  55   begin
  56     new_boolean(args.seq_val(0).val_type = mal_symbol, result);
  57   end procedure fn_symbol_q;
  58
  59   procedure fn_keyword(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  60   begin
  61     new_keyword(args.seq_val(0).string_val, result);
  62   end procedure fn_keyword;
  63
  64   procedure fn_keyword_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  65   begin
  66     new_boolean(args.seq_val(0).val_type = mal_keyword, result);
  67   end procedure fn_keyword_q;
  68
  69   procedure fn_number_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  70   begin
  71     new_boolean(args.seq_val(0).val_type = mal_number, result);
  72   end procedure fn_number_q;
  73
  74   procedure fn_function_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  75   begin
  76     new_boolean((args.seq_val(0).val_type = mal_fn and not args.seq_val(0).func_val.f_is_macro) or args.seq_val(0).val_type = mal_nativefn, result);
  77   end procedure fn_function_q;
  78
  79   procedure fn_macro_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  80   begin
  81     new_boolean(args.seq_val(0).val_type = mal_fn and args.seq_val(0).func_val.f_is_macro, result);
  82   end procedure fn_macro_q;
  83
  84   procedure fn_pr_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  85     variable s: line;
  86   begin
  87     pr_seq("", "", " ", args.seq_val, true, s);
  88     new_string(s, result);
  89   end procedure fn_pr_str;
  90
  91   procedure fn_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  92     variable s: line;
  93   begin
  94     pr_seq("", "", "", args.seq_val, false, s);
  95     new_string(s, result);
  96   end procedure fn_str;
  97
  98   procedure fn_prn(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
  99     variable s: line;
 100   begin
 101     pr_seq("", "", " ", args.seq_val, true, s);
 102     mal_printline(s.all);
 103     new_nil(result);
 104   end procedure fn_prn;
 105
 106   procedure fn_println(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 107     variable s: line;
 108   begin
 109     pr_seq("", "", " ", args.seq_val, false, s);
 110     mal_printline(s.all);
 111     new_nil(result);
 112   end procedure fn_println;
 113
 114   procedure fn_read_string(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 115     variable ast: mal_val_ptr;
 116   begin
 117     read_str(args.seq_val(0).string_val.all, ast, err);
 118     if ast = null then
 119       new_nil(result);
 120     else
 121       result := ast;
 122     end if;
 123   end procedure fn_read_string;
 124
 125   procedure fn_readline(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 126     variable input_line: line;
 127     variable is_eof: boolean;
 128   begin
 129     mal_readline(args.seq_val(0).string_val.all, is_eof, input_line);
 130     if is_eof then
 131       new_nil(result);
 132     else
 133       new_string(input_line, result);
 134     end if;
 135   end procedure fn_readline;
 136
 137   procedure fn_slurp(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 138     file f: text;
 139     variable status: file_open_status;
 140     variable save_content, content, one_line: line;
 141   begin
 142     file_open(status, f, external_name => args.seq_val(0).string_val.all, open_kind => read_mode);
 143     if status = open_ok then
 144       content := new string'("");
 145       while not endfile(f) loop
 146         readline(f, one_line);
 147         save_content := content;
 148         content := new string'(save_content.all & one_line.all & LF);
 149         deallocate(save_content);
 150       end loop;
 151       file_close(f);
 152       new_string(content, result);
 153     else
 154       new_string("Error opening file", err);
 155     end if;
 156   end procedure fn_slurp;
 157
 158   procedure fn_lt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 159   begin
 160     new_boolean(args.seq_val(0).number_val < args.seq_val(1).number_val, result);
 161   end procedure fn_lt;
 162
 163   procedure fn_lte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 164   begin
 165     new_boolean(args.seq_val(0).number_val <= args.seq_val(1).number_val, result);
 166   end procedure fn_lte;
 167
 168   procedure fn_gt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 169   begin
 170     new_boolean(args.seq_val(0).number_val > args.seq_val(1).number_val, result);
 171   end procedure fn_gt;
 172
 173   procedure fn_gte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 174   begin
 175     new_boolean(args.seq_val(0).number_val >= args.seq_val(1).number_val, result);
 176   end procedure fn_gte;
 177
 178   procedure fn_add(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 179   begin
 180     new_number(args.seq_val(0).number_val + args.seq_val(1).number_val, result);
 181   end procedure fn_add;
 182
 183   procedure fn_sub(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 184   begin
 185     new_number(args.seq_val(0).number_val - args.seq_val(1).number_val, result);
 186   end procedure fn_sub;
 187
 188   procedure fn_mul(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 189   begin
 190     new_number(args.seq_val(0).number_val * args.seq_val(1).number_val, result);
 191   end procedure fn_mul;
 192
 193   procedure fn_div(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 194   begin
 195     new_number(args.seq_val(0).number_val / args.seq_val(1).number_val, result);
 196   end procedure fn_div;
 197
 198   -- Define physical types (c_seconds64, c_microseconds64) because these are
 199   -- represented as 64-bit words when passed to C functions
 200   type c_seconds64 is range 0 to 1E16
 201     units
 202       c_sec;
 203     end units c_seconds64;
 204
 205   type c_microseconds64 is range 0 to 1E6
 206     units
 207       c_usec;
 208     end units c_microseconds64;
 209
 210   type c_timeval is record
 211     tv_sec: c_seconds64;
 212     tv_usec: c_microseconds64;
 213   end record c_timeval;
 214
 215   -- Leave enough room for two 64-bit words
 216   type c_timezone is record
 217     dummy_1: c_seconds64;
 218     dummy_2: c_seconds64;
 219   end record c_timezone;
 220
 221   function gettimeofday(tv: c_timeval; tz: c_timezone) return integer;
 222   attribute foreign of gettimeofday: function is "VHPIDIRECT gettimeofday";
 223
 224   function gettimeofday(tv: c_timeval; tz: c_timezone) return integer is
 225   begin
 226     assert false severity failure;
 227   end function gettimeofday;
 228
 229   -- Returns the number of milliseconds since last midnight UTC because a
 230   -- standard VHDL integer is 32-bit and therefore cannot hold the number of
 231   -- milliseconds since 1970-01-01.
 232   procedure fn_time_ms(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 233     variable tv: c_timeval;
 234     variable dummy: c_timezone;
 235     variable rc: integer;
 236   begin
 237     rc := gettimeofday(tv, dummy);
 238     new_number(((tv.tv_sec / 1 c_sec) mod 86400) * 1000 + (tv.tv_usec / 1000 c_usec), result);
 239   end procedure fn_time_ms;
 240
 241   procedure fn_list(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 242   begin
 243     result := args;
 244   end procedure fn_list;
 245
 246   procedure fn_list_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 247   begin
 248     new_boolean(args.seq_val(0).val_type = mal_list, result);
 249   end procedure fn_list_q;
 250
 251   procedure fn_vector(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 252   begin
 253     args.val_type := mal_vector;
 254     result := args;
 255   end procedure fn_vector;
 256
 257   procedure fn_vector_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 258   begin
 259     new_boolean(args.seq_val(0).val_type = mal_vector, result);
 260   end procedure fn_vector_q;
 261
 262   procedure fn_hash_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 263   begin
 264     args.val_type := mal_hashmap;
 265     result := args;
 266   end procedure fn_hash_map;
 267
 268   procedure fn_map_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 269   begin
 270     new_boolean(args.seq_val(0).val_type = mal_hashmap, result);
 271   end procedure fn_map_q;
 272
 273   procedure fn_assoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 274     variable new_hashmap: mal_val_ptr;
 275     variable i: integer;
 276   begin
 277     hashmap_copy(args.seq_val(0), new_hashmap);
 278     i := 1;
 279     while i < args.seq_val'length loop
 280       hashmap_put(new_hashmap, args.seq_val(i), args.seq_val(i + 1));
 281       i := i + 2;
 282     end loop;
 283     result := new_hashmap;
 284   end procedure fn_assoc;
 285
 286   procedure fn_dissoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 287     variable new_hashmap: mal_val_ptr;
 288     variable i: integer;
 289   begin
 290     hashmap_copy(args.seq_val(0), new_hashmap);
 291     for i in 1 to args.seq_val'high loop
 292       hashmap_delete(new_hashmap, args.seq_val(i));
 293     end loop;
 294     result := new_hashmap;
 295   end procedure fn_dissoc;
 296
 297   procedure fn_get(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 298     variable a0: mal_val_ptr := args.seq_val(0);
 299     variable a1: mal_val_ptr := args.seq_val(1);
 300     variable val: mal_val_ptr;
 301   begin
 302     if a0.val_type = mal_nil then
 303       new_nil(result);
 304     else
 305       hashmap_get(a0, a1, val);
 306       if val = null then
 307         new_nil(result);
 308       else
 309         result := val;
 310       end if;
 311     end if;
 312   end procedure fn_get;
 313
 314   procedure fn_contains_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 315     variable a0: mal_val_ptr := args.seq_val(0);
 316     variable a1: mal_val_ptr := args.seq_val(1);
 317     variable found: boolean;
 318   begin
 319     hashmap_contains(a0, a1, found);
 320     new_boolean(found, result);
 321   end procedure fn_contains_q;
 322
 323   procedure fn_keys(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 324     variable a0: mal_val_ptr := args.seq_val(0);
 325     variable seq: mal_seq_ptr;
 326   begin
 327     seq := new mal_seq(0 to a0.seq_val'length / 2 - 1);
 328     for i in seq'range loop
 329       seq(i) := a0.seq_val(i * 2);
 330     end loop;
 331     new_seq_obj(mal_list, seq, result);
 332   end procedure fn_keys;
 333
 334   procedure fn_vals(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 335     variable a0: mal_val_ptr := args.seq_val(0);
 336     variable seq: mal_seq_ptr;
 337   begin
 338     seq := new mal_seq(0 to a0.seq_val'length / 2 - 1);
 339     for i in seq'range loop
 340       seq(i) := a0.seq_val(i * 2 + 1);
 341     end loop;
 342     new_seq_obj(mal_list, seq, result);
 343   end procedure fn_vals;
 344
 345   procedure cons_helper(a0: inout mal_val_ptr; a1: inout mal_val_ptr; result: out mal_val_ptr) is
 346     variable seq: mal_seq_ptr;
 347   begin
 348     seq := new mal_seq(0 to a1.seq_val'length);
 349     seq(0) := a0;
 350     seq(1 to seq'length - 1) := a1.seq_val(0 to a1.seq_val'length - 1);
 351     new_seq_obj(mal_list, seq, result);
 352   end procedure cons_helper;
 353
 354   procedure fn_cons(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 355     variable a0: mal_val_ptr := args.seq_val(0);
 356     variable a1: mal_val_ptr := args.seq_val(1);
 357     variable seq: mal_seq_ptr;
 358   begin
 359     cons_helper(a0, a1, result);
 360   end procedure fn_cons;
 361
 362   procedure fn_sequential_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 363   begin
 364     new_boolean(is_sequential_type(args.seq_val(0).val_type), result);
 365   end procedure fn_sequential_q;
 366
 367   procedure fn_concat(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 368     variable seq: mal_seq_ptr;
 369     variable i: integer;
 370   begin
 371     seq := new mal_seq(0 to -1);
 372     for i in args.seq_val'range loop
 373       seq := new mal_seq'(seq.all & args.seq_val(i).seq_val.all);
 374     end loop;
 375     new_seq_obj(mal_list, seq, result);
 376   end procedure fn_concat;
 377
 378   procedure fn_nth(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 379     variable lst_seq: mal_seq_ptr := args.seq_val(0).seq_val;
 380     variable index: integer := args.seq_val(1).number_val;
 381   begin
 382     if index >= lst_seq'length then
 383       new_string("nth: index out of range", err);
 384     else
 385       result := lst_seq(index);
 386     end if;
 387   end procedure fn_nth;
 388
 389   procedure fn_first(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 390     variable a0: mal_val_ptr := args.seq_val(0);
 391   begin
 392     if a0.val_type = mal_nil or a0.seq_val'length = 0 then
 393       new_nil(result);
 394     else
 395       result := a0.seq_val(0);
 396     end if;
 397   end procedure fn_first;
 398
 399   procedure fn_rest(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 400     variable a0: mal_val_ptr := args.seq_val(0);
 401     variable seq: mal_seq_ptr;
 402     variable new_list: mal_val_ptr;
 403   begin
 404     if a0.val_type = mal_nil or a0.seq_val'length = 0 then
 405       seq := new mal_seq(0 to -1);
 406       new_seq_obj(mal_list, seq, result);
 407     else
 408       seq_drop_prefix(a0, 1, new_list);
 409       new_list.val_type := mal_list;
 410       result := new_list;
 411     end if;
 412   end procedure fn_rest;
 413
 414   procedure fn_empty_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 415     variable is_empty: boolean;
 416   begin
 417     case args.seq_val(0).val_type is
 418       when mal_nil => new_boolean(true, result);
 419       when mal_list | mal_vector => new_boolean(args.seq_val(0).seq_val'length = 0, result);
 420       when others => new_string("empty?: invalid argument type", err);
 421     end case;
 422   end procedure fn_empty_q;
 423
 424   procedure fn_count(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 425     variable count: integer;
 426   begin
 427     case args.seq_val(0).val_type is
 428       when mal_nil => new_number(0, result);
 429       when mal_list | mal_vector => new_number(args.seq_val(0).seq_val'length, result);
 430       when others => new_string("count: invalid argument type", err);
 431     end case;
 432   end procedure fn_count;
 433
 434   procedure fn_conj(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 435     variable a0: mal_val_ptr := args.seq_val(0);
 436     variable r: mal_val_ptr;
 437     variable seq: mal_seq_ptr;
 438   begin
 439     case a0.val_type is
 440       when mal_list =>
 441         r := a0;
 442         for i in 1 to args.seq_val'high loop
 443           cons_helper(args.seq_val(i), r, r);
 444         end loop;
 445         result := r;
 446       when mal_vector =>
 447         seq := new mal_seq(0 to a0.seq_val'length + args.seq_val'length - 2);
 448         seq(0 to a0.seq_val'high) := a0.seq_val(a0.seq_val'range);
 449         seq(a0.seq_val'high + 1 to seq'high) := args.seq_val(1 to args.seq_val'high);
 450         new_seq_obj(mal_vector, seq, result);
 451       when others =>
 452         new_string("conj requires list or vector", err);
 453     end case;
 454   end procedure fn_conj;
 455
 456   procedure fn_seq(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 457     variable a0: mal_val_ptr := args.seq_val(0);
 458     variable new_seq: mal_seq_ptr;
 459   begin
 460     case a0.val_type is
 461       when mal_string =>
 462         if a0.string_val'length = 0 then
 463           new_nil(result);
 464         else
 465           new_seq := new mal_seq(0 to a0.string_val'length - 1);
 466           for i in new_seq'range loop
 467             new_string("" & a0.string_val(i + 1), new_seq(i));
 468           end loop;
 469           new_seq_obj(mal_list, new_seq, result);
 470         end if;
 471       when mal_list =>
 472         if a0.seq_val'length = 0 then
 473           new_nil(result);
 474         else
 475           result := a0;
 476         end if;
 477       when mal_vector =>
 478         if a0.seq_val'length = 0 then
 479           new_nil(result);
 480         else
 481           new_seq_obj(mal_list, a0.seq_val, result);
 482         end if;
 483       when mal_nil =>
 484         new_nil(result);
 485       when others =>
 486         new_string("seq requires string or list or vector or nil", err);
 487     end case;
 488   end procedure fn_seq;
 489
 490   procedure fn_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 491     variable meta_val: mal_val_ptr;
 492   begin
 493     meta_val := args.seq_val(0).meta_val;
 494     if meta_val = null then
 495       new_nil(result);
 496     else
 497       result := meta_val;
 498     end if;
 499   end procedure fn_meta;
 500
 501   procedure fn_with_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 502     variable a0: mal_val_ptr := args.seq_val(0);
 503   begin
 504     result := new mal_val'(val_type => a0.val_type, number_val => a0.number_val, string_val => a0.string_val, seq_val => a0.seq_val, func_val => a0.func_val, meta_val => args.seq_val(1));
 505   end procedure fn_with_meta;
 506
 507   procedure fn_atom(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 508   begin
 509     new_atom(args.seq_val(0), result);
 510   end procedure fn_atom;
 511
 512   procedure fn_atom_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 513     variable a0: mal_val_ptr := args.seq_val(0);
 514   begin
 515     new_boolean(a0.val_type = mal_atom, result);
 516   end procedure fn_atom_q;
 517
 518   procedure fn_deref(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 519     variable a0: mal_val_ptr := args.seq_val(0);
 520   begin
 521     result := a0.seq_val(0);
 522   end procedure fn_deref;
 523
 524   procedure fn_reset(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 525     variable a0: mal_val_ptr := args.seq_val(0);
 526     variable a1: mal_val_ptr := args.seq_val(1);
 527   begin
 528     a0.seq_val(0) := a1;
 529     result := a1;
 530   end procedure fn_reset;
 531
 532   procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is
 533     variable f: line;
 534   begin
 535     if func_sym.val_type /= mal_nativefn then
 536       new_string("not a native function!", err);
 537       return;
 538     end if;
 539     f := func_sym.string_val;
 540     if    f.all = "="           then fn_equal(args, result, err);
 541     elsif f.all = "throw"       then fn_throw(args, result, err);
 542     elsif f.all = "nil?"        then fn_nil_q(args, result, err);
 543     elsif f.all = "true?"       then fn_true_q(args, result, err);
 544     elsif f.all = "false?"      then fn_false_q(args, result, err);
 545     elsif f.all = "string?"     then fn_string_q(args, result, err);
 546     elsif f.all = "symbol"      then fn_symbol(args, result, err);
 547     elsif f.all = "symbol?"     then fn_symbol_q(args, result, err);
 548     elsif f.all = "keyword"     then fn_keyword(args, result, err);
 549     elsif f.all = "keyword?"    then fn_keyword_q(args, result, err);
 550     elsif f.all = "number?"     then fn_number_q(args, result, err);
 551     elsif f.all = "fn?"         then fn_function_q(args, result, err);
 552     elsif f.all = "macro?"      then fn_macro_q(args, result, err);
 553     elsif f.all = "pr-str"      then fn_pr_str(args, result, err);
 554     elsif f.all = "str"         then fn_str(args, result, err);
 555     elsif f.all = "prn"         then fn_prn(args, result, err);
 556     elsif f.all = "println"     then fn_println(args, result, err);
 557     elsif f.all = "read-string" then fn_read_string(args, result, err);
 558     elsif f.all = "readline"    then fn_readline(args, result, err);
 559     elsif f.all = "slurp"       then fn_slurp(args, result, err);
 560     elsif f.all = "<"           then fn_lt(args, result, err);
 561     elsif f.all = "<="          then fn_lte(args, result, err);
 562     elsif f.all = ">"           then fn_gt(args, result, err);
 563     elsif f.all = ">="          then fn_gte(args, result, err);
 564     elsif f.all = "+"           then fn_add(args, result, err);
 565     elsif f.all = "-"           then fn_sub(args, result, err);
 566     elsif f.all = "*"           then fn_mul(args, result, err);
 567     elsif f.all = "/"           then fn_div(args, result, err);
 568     elsif f.all = "time-ms"     then fn_time_ms(args, result, err);
 569     elsif f.all = "list"        then fn_list(args, result, err);
 570     elsif f.all = "list?"       then fn_list_q(args, result, err);
 571     elsif f.all = "vector"      then fn_vector(args, result, err);
 572     elsif f.all = "vector?"     then fn_vector_q(args, result, err);
 573     elsif f.all = "hash-map"    then fn_hash_map(args, result, err);
 574     elsif f.all = "map?"        then fn_map_q(args, result, err);
 575     elsif f.all = "assoc"       then fn_assoc(args, result, err);
 576     elsif f.all = "dissoc"      then fn_dissoc(args, result, err);
 577     elsif f.all = "get"         then fn_get(args, result, err);
 578     elsif f.all = "contains?"   then fn_contains_q(args, result, err);
 579     elsif f.all = "keys"        then fn_keys(args, result, err);
 580     elsif f.all = "vals"        then fn_vals(args, result, err);
 581     elsif f.all = "sequential?" then fn_sequential_q(args, result, err);
 582     elsif f.all = "cons"        then fn_cons(args, result, err);
 583     elsif f.all = "concat"      then fn_concat(args, result, err);
 584     elsif f.all = "nth"         then fn_nth(args, result, err);
 585     elsif f.all = "first"       then fn_first(args, result, err);
 586     elsif f.all = "rest"        then fn_rest(args, result, err);
 587     elsif f.all = "empty?"      then fn_empty_q(args, result, err);
 588     elsif f.all = "count"       then fn_count(args, result, err);
 589     elsif f.all = "conj"        then fn_conj(args, result, err);
 590     elsif f.all = "seq"         then fn_seq(args, result, err);
 591     elsif f.all = "meta"        then fn_meta(args, result, err);
 592     elsif f.all = "with-meta"   then fn_with_meta(args, result, err);
 593     elsif f.all = "atom"        then fn_atom(args, result, err);
 594     elsif f.all = "atom?"       then fn_atom_q(args, result, err);
 595     elsif f.all = "deref"       then fn_deref(args, result, err);
 596     elsif f.all = "reset!"      then fn_reset(args, result, err);
 597     else
 598       result := null;
 599     end if;
 600   end procedure eval_native_func;
 601
 602   procedure define_core_function(e: inout env_ptr; func_name: in string) is
 603     variable sym: mal_val_ptr;
 604     variable fn: mal_val_ptr;
 605   begin
 606     new_symbol(func_name, sym);
 607     new_nativefn(func_name, fn);
 608     env_set(e, sym, fn);
 609   end procedure define_core_function;
 610
 611   procedure define_core_functions(e: inout env_ptr) is
 612   begin
 613     define_core_function(e, "=");
 614     define_core_function(e, "throw");
 615     define_core_function(e, "nil?");
 616     define_core_function(e, "true?");
 617     define_core_function(e, "false?");
 618     define_core_function(e, "string?");
 619     define_core_function(e, "symbol");
 620     define_core_function(e, "symbol?");
 621     define_core_function(e, "keyword");
 622     define_core_function(e, "keyword?");
 623     define_core_function(e, "number?");
 624     define_core_function(e, "fn?");
 625     define_core_function(e, "macro?");
 626     define_core_function(e, "pr-str");
 627     define_core_function(e, "str");
 628     define_core_function(e, "prn");
 629     define_core_function(e, "println");
 630     define_core_function(e, "read-string");
 631     define_core_function(e, "readline");
 632     define_core_function(e, "slurp");
 633     define_core_function(e, "<");
 634     define_core_function(e, "<=");
 635     define_core_function(e, ">");
 636     define_core_function(e, ">=");
 637     define_core_function(e, "+");
 638     define_core_function(e, "-");
 639     define_core_function(e, "*");
 640     define_core_function(e, "/");
 641     define_core_function(e, "time-ms");
 642     define_core_function(e, "list");
 643     define_core_function(e, "list?");
 644     define_core_function(e, "vector");
 645     define_core_function(e, "vector?");
 646     define_core_function(e, "hash-map");
 647     define_core_function(e, "map?");
 648     define_core_function(e, "assoc");
 649     define_core_function(e, "dissoc");
 650     define_core_function(e, "get");
 651     define_core_function(e, "contains?");
 652     define_core_function(e, "keys");
 653     define_core_function(e, "vals");
 654     define_core_function(e, "sequential?");
 655     define_core_function(e, "cons");
 656     define_core_function(e, "concat");
 657     define_core_function(e, "nth");
 658     define_core_function(e, "first");
 659     define_core_function(e, "rest");
 660     define_core_function(e, "empty?");
 661     define_core_function(e, "count");
 662     define_core_function(e, "apply");   -- implemented in the stepN_XXX files
 663     define_core_function(e, "map");     -- implemented in the stepN_XXX files
 664     define_core_function(e, "conj");
 665     define_core_function(e, "seq");
 666     define_core_function(e, "meta");
 667     define_core_function(e, "with-meta");
 668     define_core_function(e, "atom");
 669     define_core_function(e, "atom?");
 670     define_core_function(e, "deref");
 671     define_core_function(e, "reset!");
 672     define_core_function(e, "swap!");   -- implemented in the stepN_XXX files
 673   end procedure define_core_functions;
 674
 675 end package body core;