rexx/step5_tco.rexx

   1 call main
   2 exit
   3
   4 #include "readline.rexx"
   5 #include "reader.rexx"
   6 #include "printer.rexx"
   7 #include "types.rexx"
   8 #include "env.rexx"
   9 #include "core.rexx"
  10
  11 read: procedure expose values. err /* read(str) */
  12   return read_str(arg(1))
  13
  14 eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */
  15   ast = arg(1)
  16   env_idx = arg(2)
  17   type = obj_type(ast)
  18   val = obj_val(ast)
  19   select
  20     when type == "symb" then return env_get(env_idx, val)
  21     when type == "list" then do
  22       res = ""
  23       do i=1 to words(val)
  24         element = eval(word(val, i), env_idx)
  25         if element == "ERR" then return "ERR"
  26         if i > 1 then
  27           res = res || " " || element
  28         else
  29           res = element
  30       end
  31       return new_list(res)
  32     end
  33     when type == "vect" then do
  34       res = ""
  35       do i=1 to words(val)
  36         element = eval(word(val, i), env_idx)
  37         if element == "ERR" then return "ERR"
  38         if i > 1 then
  39           res = res || " " || element
  40         else
  41           res = element
  42       end
  43       return new_vector(res)
  44     end
  45     when type == "hash" then do
  46       res = ""
  47       do i=1 to words(val)
  48         element = eval(word(val, i), env_idx)
  49         if element == "ERR" then return "ERR"
  50         if i > 1 then
  51           res = res || " " || element
  52         else
  53           res = element
  54       end
  55       return new_hashmap(res)
  56     end
  57     otherwise
  58       return ast
  59     end
  60
  61 eval: procedure expose values. env. err /* eval(ast) */
  62   ast = arg(1)
  63   env_idx = arg(2)
  64   do forever
  65     if \list?(ast) then return eval_ast(ast, env_idx)
  66     astval = obj_val(ast)
  67     if words(astval) == 0 then return ast
  68     a0sym = obj_val(word(astval, 1))
  69     select
  70       when a0sym == "def!" then do
  71         a1sym = obj_val(word(astval, 2))
  72         a2 = eval(word(astval, 3), env_idx)
  73         if a2 == "ERR" then return "ERR"
  74         return env_set(env_idx, a1sym, a2)
  75       end
  76       when a0sym == "let*" then do
  77         a1lst = obj_val(word(astval, 2))
  78         letenv_idx = new_env(env_idx)
  79         do i=1 to words(a1lst) by 2
  80           k = obj_val(word(a1lst, i))
  81           v = eval(word(a1lst, i + 1), letenv_idx)
  82           if v == "ERR" then return "ERR"
  83           unused = env_set(letenv_idx, k, v)
  84         end
  85         env_idx = letenv_idx
  86         ast = word(astval, 3)
  87         /* TCO */
  88       end
  89       when a0sym == "do" then do
  90         do i=2 to (words(astval) - 1)
  91           res = eval(word(astval, i), env_idx)
  92           if res == "ERR" then return "ERR"
  93         end
  94         ast = word(astval, words(astval))
  95         /* TCO */
  96       end
  97       when a0sym == "if" then do
  98         condval = eval(word(astval, 2), env_idx)
  99         if false?(condval) | nil?(condval) then
 100           if words(astval) >= 4 then
 101             ast = word(astval, 4)
 102           else
 103             return new_nil()
 104         else
 105           ast = word(astval, 3)
 106         /* TCO */
 107       end
 108       when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2))
 109       otherwise
 110         lst_obj = eval_ast(ast, env_idx)
 111         if lst_obj == "ERR" then return "ERR"
 112         lst = obj_val(lst_obj)
 113         f = word(lst, 1)
 114         select
 115           when nativefn?(f) then do
 116             call_args = subword(lst, 2)
 117             call_list = ""
 118             do i=1 to words(call_args)
 119               element = '"' || word(call_args, i) || '"'
 120               if i > 1 then
 121                 call_list = call_list || ', ' || element
 122               else
 123                 call_list = element
 124             end
 125             res = ""
 126             interpret "res = " || obj_val(f) || "(" || call_list || ")"
 127             return res
 128           end
 129           when func?(f) then do
 130             call_args = new_list(subword(lst, 2))
 131             env_idx = new_env(func_env_idx(f), func_binds(f), call_args)
 132             ast = func_body_ast(f)
 133             /* TCO */
 134           end
 135           otherwise
 136             err = "Unsupported function object type: " || obj_type(f)
 137             return "ERR"
 138           end
 139       end
 140   end
 141
 142 print: procedure expose values. /* print(ast) */
 143   return pr_str(arg(1), 1)
 144
 145 re:  procedure expose values. env. err repl_env_idx /* re(str) */
 146   str = arg(1)
 147   ast = read(str)
 148   if ast == "ERR" then return "ERR"
 149   return eval(ast, repl_env_idx)
 150
 151 rep: procedure expose values. env. err repl_env_idx /* rep(str) */
 152   str = arg(1)
 153   exp = re(str)
 154   if exp == "ERR" then return "ERR"
 155   return print(exp)
 156
 157 main:
 158   values. = ""
 159   values.0 = 0
 160   env. = ""
 161   env.0 = 0
 162   repl_env_idx = new_env(0)
 163
 164   /* core.rexx: defined using Rexx */
 165   core_ns = get_core_ns()
 166   do i=1 to words(core_ns) by 2
 167     x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1)))
 168   end
 169
 170   /* core.mal: defined using the language itself */
 171   x = rep("(def! not (fn* (a) (if a false true)))")
 172
 173   err = ""
 174   do while lines() > 0 /* 1 == 1 */
 175     input_line = readline('user> ')
 176     if length(input_line) > 0 then do
 177       res = rep(input_line)
 178       if res == "ERR" then
 179         call lineout , "Error: " || err
 180       else
 181         call lineout , res
 182     end
 183   end