impls/awk/step3_env.awk

   1 @include "types.awk"
   2 @include "reader.awk"
   3 @include "printer.awk"
   4 @include "env.awk"
   5
   6 function READ(str)
   7 {
   8         return reader_read_str(str)
   9 }
  10
  11 function eval_ast(ast, env,    i, idx, len, new_idx, ret)
  12 {
  13         switch (ast) {
  14         case /^'/:
  15                 ret = env_get(env, ast)
  16                 if (ret !~ /^!/) {
  17                         types_addref(ret)
  18                 }
  19                 return ret
  20         case /^[([]/:
  21                 idx = substr(ast, 2)
  22                 len = types_heap[idx]["len"]
  23                 new_idx = types_allocate()
  24                 for (i = 0; i < len; ++i) {
  25                         ret = EVAL(types_addref(types_heap[idx][i]), env)
  26                         if (ret ~ /^!/) {
  27                                 types_heap[new_idx]["len"] = i
  28                                 types_release(substr(ast, 1, 1) new_idx)
  29                                 return ret
  30                         }
  31                         types_heap[new_idx][i] = ret
  32                 }
  33                 types_heap[new_idx]["len"] = len
  34                 return substr(ast, 1, 1) new_idx
  35         case /^\{/:
  36                 idx = substr(ast, 2)
  37                 new_idx = types_allocate()
  38                 for (i in types_heap[idx]) {
  39                         if (i ~ /^[":]/) {
  40                                 ret = EVAL(types_addref(types_heap[idx][i]), env)
  41                                 if (ret ~ /^!/) {
  42                                         types_release("{" new_idx)
  43                                         return ret
  44                                 }
  45                                 types_heap[new_idx][i] = ret
  46                         }
  47                 }
  48                 return "{" new_idx
  49         default:
  50                 return ast
  51         }
  52 }
  53
  54 function EVAL_def(ast, env,    idx, sym, ret, len)
  55 {
  56         idx = substr(ast, 2)
  57         if (types_heap[idx]["len"] != 3) {
  58                 len = types_heap[idx]["len"]
  59                 types_release(ast)
  60                 env_release(env)
  61                 return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "."
  62         }
  63         sym = types_heap[idx][1]
  64         if (sym !~ /^'/) {
  65                 types_release(ast)
  66                 env_release(env)
  67                 return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "."
  68         }
  69         ret = EVAL(types_addref(types_heap[idx][2]), env)
  70         if (ret !~ /^!/) {
  71                 env_set(env, sym, ret)
  72                 types_addref(ret)
  73         }
  74         types_release(ast)
  75         env_release(env)
  76         return ret
  77 }
  78
  79 function EVAL_let(ast, env,    idx, params, params_idx, params_len, new_env, i, sym, ret, body, len)
  80 {
  81         idx = substr(ast, 2)
  82         if (types_heap[idx]["len"] != 3) {
  83                 len = types_heap[idx]["len"]
  84                 types_release(ast)
  85                 env_release(env)
  86                 return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "."
  87         }
  88         params = types_heap[idx][1]
  89         if (params !~ /^[([]/) {
  90                 types_release(ast)
  91                 env_release(env)
  92                 return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "."
  93         }
  94         params_idx = substr(params, 2)
  95         params_len = types_heap[params_idx]["len"]
  96         if (params_len % 2 != 0) {
  97                 types_release(ast)
  98                 env_release(env)
  99                 return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "."
 100         }
 101         new_env = env_new(env)
 102         env_release(env)
 103         for (i = 0; i < params_len; i += 2) {
 104                 sym = types_heap[params_idx][i]
 105                 if (sym !~ /^'/) {
 106                         types_release(ast)
 107                         env_release(new_env)
 108                         return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "."
 109                 }
 110                 ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env)
 111                 if (ret ~ /^!/) {
 112                         types_release(ast)
 113                         env_release(new_env)
 114                         return ret
 115                 }
 116                 env_set(new_env, sym, ret)
 117         }
 118         types_addref(body = types_heap[idx][2])
 119         types_release(ast)
 120         ret = EVAL(body, new_env)
 121         env_release(new_env)
 122         return ret
 123 }
 124
 125 function EVAL(ast, env,    new_ast, ret, idx, f, f_idx)
 126 {
 127         env_addref(env)
 128         if (ast !~ /^\(/) {
 129                 ret = eval_ast(ast, env)
 130                 types_release(ast)
 131                 env_release(env)
 132                 return ret
 133         }
 134         idx = substr(ast, 2)
 135         if (types_heap[idx]["len"] == 0) {
 136                 env_release(env)
 137                 return ast
 138         }
 139         switch (types_heap[idx][0]) {
 140         case "'def!":
 141                 return EVAL_def(ast, env)
 142         case "'let*":
 143                 return EVAL_let(ast, env)
 144         default:
 145                 new_ast = eval_ast(ast, env)
 146                 types_release(ast)
 147                 env_release(env)
 148                 if (new_ast ~ /^!/) {
 149                         return new_ast
 150                 }
 151                 idx = substr(new_ast, 2)
 152                 f = types_heap[idx][0]
 153                 if (f ~ /^&/) {
 154                         f_idx = substr(f, 2)
 155                         ret = @f_idx(idx)
 156                         types_release(new_ast)
 157                         return ret
 158                 } else {
 159                         types_release(new_ast)
 160                         return "!\"First element of list must be function, supplied " types_typename(f) "."
 161                 }
 162         }
 163 }
 164
 165 function PRINT(expr,    str)
 166 {
 167         str = printer_pr_str(expr, 1)
 168         types_release(expr)
 169         return str
 170 }
 171
 172 function rep(str,    ast, expr)
 173 {
 174         ast = READ(str)
 175         if (ast ~ /^!/) {
 176                 return ast
 177         }
 178         expr = EVAL(ast, repl_env)
 179         if (expr ~ /^!/) {
 180                 return expr
 181         }
 182         return PRINT(expr)
 183 }
 184
 185 function add(idx,    lhs, rhs)
 186 {
 187         if (types_heap[idx]["len"] != 3) {
 188                 return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
 189         }
 190         lhs = types_heap[idx][1]
 191         if (lhs !~ /^\+/) {
 192                 return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "."
 193         }
 194         rhs = types_heap[idx][2]
 195         if (rhs !~ /^\+/) {
 196                 return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "."
 197         }
 198         return "+" (substr(lhs, 2) + substr(rhs, 2))
 199 }
 200
 201 function subtract(idx,    lhs, rhs)
 202 {
 203         if (types_heap[idx]["len"] != 3) {
 204                 return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
 205         }
 206         lhs = types_heap[idx][1]
 207         if (lhs !~ /^\+/) {
 208                 return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "."
 209         }
 210         rhs = types_heap[idx][2]
 211         if (rhs !~ /^\+/) {
 212                 return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "."
 213         }
 214         return "+" (substr(lhs, 2) - substr(rhs, 2))
 215 }
 216
 217 function multiply(idx,    lhs, rhs)
 218 {
 219         if (types_heap[idx]["len"] != 3) {
 220                 return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
 221         }
 222         lhs = types_heap[idx][1]
 223         if (lhs !~ /^\+/) {
 224                 return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "."
 225         }
 226         rhs = types_heap[idx][2]
 227         if (rhs !~ /^\+/) {
 228                 return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "."
 229         }
 230         return "+" (substr(lhs, 2) * substr(rhs, 2))
 231 }
 232
 233 function divide(idx,    lhs, rhs)
 234 {
 235         if (types_heap[idx]["len"] != 3) {
 236                 return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
 237         }
 238         lhs = types_heap[idx][1]
 239         if (lhs !~ /^\+/) {
 240                 return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "."
 241         }
 242         rhs = types_heap[idx][2]
 243         if (rhs !~ /^\+/) {
 244                 return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "."
 245         }
 246         return "+" int(substr(lhs, 2) / substr(rhs, 2))
 247 }
 248
 249 function main(str, ret)
 250 {
 251         repl_env = env_new()
 252         env_set(repl_env, "'+", "&add")
 253         env_set(repl_env, "'-", "&subtract")
 254         env_set(repl_env, "'*", "&multiply")
 255         env_set(repl_env, "'/", "&divide")
 256
 257         while (1) {
 258                 printf("user> ")
 259                 if (getline str <= 0) {
 260                         break
 261                 }
 262                 ret = rep(str)
 263                 if (ret ~ /^!/) {
 264                         print "ERROR: " printer_pr_str(substr(ret, 2))
 265                 } else {
 266                         print ret
 267                 }
 268         }
 269 }
 270
 271 BEGIN {
 272         main()
 273         env_check(0)
 274         env_dump()
 275         types_dump()
 276         exit(0)
 277 }