awk/step7_quote.awk

   1 @include "types.awk"
   2 @include "reader.awk"
   3 @include "printer.awk"
   4 @include "env.awk"
   5 @include "core.awk"
   6
   7 function READ(str)
   8 {
   9         return reader_read_str(str)
  10 }
  11
  12 function is_pair(ast)
  13 {
  14         return ast ~ /^[([]/ && types_heap[substr(ast, 2)]["len"] != 0
  15 }
  16
  17 function quasiquote(ast,    i, len, new_idx, idx, lst_idx, first, first_idx, verb, ret)
  18 {
  19         if (!is_pair(ast)) {
  20                 new_idx = types_allocate()
  21                 types_heap[new_idx][0] = "'quote"
  22                 types_heap[new_idx][1] = ast
  23                 types_heap[new_idx]["len"] = 2
  24                 return "(" new_idx
  25         }
  26         idx = substr(ast, 2)
  27         first = types_heap[idx][0]
  28         if (first == "'unquote") {
  29                 if (types_heap[idx]["len"] != 2) {
  30                         len = types_heap[idx]["len"]
  31                         types_release(ast)
  32                         return "!\"Invalid argument length for 'unquote'. Expects exactly 1 argument, supplied " (len - 1) "."
  33                 }
  34                 types_addref(ret = types_heap[idx][1])
  35                 types_release(ast)
  36                 return ret
  37         }
  38
  39         first_idx = substr(first, 2)
  40         if (is_pair(first) && types_heap[first_idx][0] == "'splice-unquote") {
  41                 if (types_heap[first_idx]["len"] != 2) {
  42                         len = types_heap[first_idx]["len"]
  43                         types_release(ast)
  44                         return "!\"Invalid argument length for 'splice-unquote'. Expects exactly 1 argument, supplied " (len - 1) "."
  45                 }
  46                 types_addref(first = types_heap[first_idx][1])
  47                 verb = "'concat"
  48         } else {
  49                 types_addref(first)
  50                 first = quasiquote(first)
  51                 if (first ~ /^!/) {
  52                         types_release(ast)
  53                         return first
  54                 }
  55                 verb = "'cons"
  56         }
  57         lst_idx = types_allocate()
  58         len = types_heap[idx]["len"]
  59         for (i = 1; i < len; ++i) {
  60                 types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i])
  61         }
  62         types_heap[lst_idx]["len"] = len - 1
  63         types_release(ast)
  64         ret = quasiquote("(" lst_idx)
  65         if (ret ~ /^!/) {
  66                 types_release(first)
  67                 return ret
  68         }
  69
  70         new_idx = types_allocate()
  71         types_heap[new_idx][0] = verb
  72         types_heap[new_idx][1] = first
  73         types_heap[new_idx][2] = ret
  74         types_heap[new_idx]["len"] = 3
  75         return "(" new_idx
  76 }
  77
  78 function eval_ast(ast, env,    i, idx, len, new_idx, ret)
  79 {
  80         switch (ast) {
  81         case /^'/:
  82                 ret = env_get(env, ast)
  83                 if (ret !~ /^!/) {
  84                         types_addref(ret)
  85                 }
  86                 return ret
  87         case /^[([]/:
  88                 idx = substr(ast, 2)
  89                 len = types_heap[idx]["len"]
  90                 new_idx = types_allocate()
  91                 for (i = 0; i < len; ++i) {
  92                         ret = EVAL(types_addref(types_heap[idx][i]), env)
  93                         if (ret ~ /^!/) {
  94                                 types_heap[new_idx]["len"] = i
  95                                 types_release(substr(ast, 1, 1) new_idx)
  96                                 return ret
  97                         }
  98                         types_heap[new_idx][i] = ret
  99                 }
 100                 types_heap[new_idx]["len"] = len
 101                 return substr(ast, 1, 1) new_idx
 102         case /^\{/:
 103                 idx = substr(ast, 2)
 104                 new_idx = types_allocate()
 105                 for (i in types_heap[idx]) {
 106                         if (i ~ /^[":]/) {
 107                                 ret = EVAL(types_addref(types_heap[idx][i]), env)
 108                                 if (ret ~ /^!/) {
 109                                         types_release("{" new_idx)
 110                                         return ret
 111                                 }
 112                                 types_heap[new_idx][i] = ret
 113                         }
 114                 }
 115                 return "{" new_idx
 116         default:
 117                 return ast
 118         }
 119 }
 120
 121 function EVAL_def(ast, env,    idx, sym, ret, len)
 122 {
 123         idx = substr(ast, 2)
 124         if (types_heap[idx]["len"] != 3) {
 125                 len = types_heap[idx]["len"]
 126                 types_release(ast)
 127                 env_release(env)
 128                 return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "."
 129         }
 130         sym = types_heap[idx][1]
 131         if (sym !~ /^'/) {
 132                 types_release(ast)
 133                 env_release(env)
 134                 return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "."
 135         }
 136         ret = EVAL(types_addref(types_heap[idx][2]), env)
 137         if (ret !~ /^!/) {
 138                 env_set(env, sym, ret)
 139                 types_addref(ret)
 140         }
 141         types_release(ast)
 142         env_release(env)
 143         return ret
 144 }
 145
 146 function EVAL_let(ast, env,    ret_env,    idx, params, params_idx, params_len, new_env, i, sym, ret, body, len)
 147 {
 148         idx = substr(ast, 2)
 149         if (types_heap[idx]["len"] != 3) {
 150                 len = types_heap[idx]["len"]
 151                 types_release(ast)
 152                 env_release(env)
 153                 return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "."
 154         }
 155         params = types_heap[idx][1]
 156         if (params !~ /^[([]/) {
 157                 types_release(ast)
 158                 env_release(env)
 159                 return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "."
 160         }
 161         params_idx = substr(params, 2)
 162         params_len = types_heap[params_idx]["len"]
 163         if (params_len % 2 != 0) {
 164                 types_release(ast)
 165                 env_release(env)
 166                 return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "."
 167         }
 168         new_env = env_new(env)
 169         env_release(env)
 170         for (i = 0; i < params_len; i += 2) {
 171                 sym = types_heap[params_idx][i]
 172                 if (sym !~ /^'/) {
 173                         types_release(ast)
 174                         env_release(new_env)
 175                         return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "."
 176                 }
 177                 ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env)
 178                 if (ret ~ /^!/) {
 179                         types_release(ast)
 180                         env_release(new_env)
 181                         return ret
 182                 }
 183                 env_set(new_env, sym, ret)
 184         }
 185         types_addref(body = types_heap[idx][2])
 186         types_release(ast)
 187         ret_env[0] = new_env
 188         return body
 189 }
 190
 191 function EVAL_do(ast, env,    idx, len, i, body, ret)
 192 {
 193         idx = substr(ast, 2)
 194         len = types_heap[idx]["len"]
 195         if (len == 1) {
 196                 types_release(ast)
 197                 env_release(env)
 198                 return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "."
 199         }
 200         for (i = 1; i < len - 1; ++i) {
 201                 ret = EVAL(types_addref(types_heap[idx][i]), env)
 202                 if (ret ~ /^!/) {
 203                         types_release(ast)
 204                         env_release(env)
 205                         return ret
 206                 }
 207                 types_release(ret)
 208         }
 209         types_addref(body = types_heap[idx][len - 1])
 210         types_release(ast)
 211         return body
 212 }
 213
 214 function EVAL_if(ast, env,    idx, len, ret, body)
 215 {
 216         idx = substr(ast, 2)
 217         len = types_heap[idx]["len"]
 218         if (len != 3 && len != 4) {
 219                 types_release(ast)
 220                 return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "."
 221         }
 222         ret = EVAL(types_addref(types_heap[idx][1]), env)
 223         if (ret ~ /^!/) {
 224                 types_release(ast)
 225                 return ret
 226         }
 227         types_release(ret)
 228         switch (ret) {
 229         case "#nil":
 230         case "#false":
 231                 if (len == 3) {
 232                         body = "#nil"
 233                 } else {
 234                         types_addref(body = types_heap[idx][3])
 235                 }
 236                 break
 237         default:
 238                 types_addref(body = types_heap[idx][2])
 239                 break
 240         }
 241         types_release(ast)
 242         return body
 243 }
 244
 245 function EVAL_fn(ast, env,    idx, params, params_idx, params_len, i, sym, f_idx, len)
 246 {
 247         idx = substr(ast, 2)
 248         if (types_heap[idx]["len"] != 3) {
 249                 len = types_heap[idx]["len"]
 250                 types_release(ast)
 251                 env_release(env)
 252                 return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "."
 253         }
 254         params = types_heap[idx][1]
 255         if (params !~ /^[([]/) {
 256                 types_release(ast)
 257                 env_release(env)
 258                 return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "."
 259         }
 260         params_idx = substr(params, 2)
 261         params_len = types_heap[params_idx]["len"]
 262         for (i = 0; i < params_len; ++i) {
 263                 sym = types_heap[params_idx][i]
 264                 if (sym !~ /^'/) {
 265                         types_release(ast)
 266                         env_release(env)
 267                         return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "."
 268                 }
 269                 if (sym == "'&" && i + 2 != params_len) {
 270                         types_release(ast)
 271                         env_release(env)
 272                         return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "."
 273                 }
 274         }
 275         f_idx = types_allocate()
 276         types_addref(types_heap[f_idx]["params"] = types_heap[idx][1])
 277         types_addref(types_heap[f_idx]["body"] = types_heap[idx][2])
 278         types_heap[f_idx]["env"] = env
 279         types_release(ast)
 280         return "$" f_idx
 281 }
 282
 283 function EVAL(ast, env,    body, new_ast, ret, idx, len, f, f_idx, ret_env)
 284 {
 285         env_addref(env)
 286         for (;;) {
 287                 if (ast !~ /^\(/) {
 288                         ret = eval_ast(ast, env)
 289                         types_release(ast)
 290                         env_release(env)
 291                         return ret
 292                 }
 293                 idx = substr(ast, 2)
 294                 len = types_heap[idx]["len"]
 295                 if (len == 0) {
 296                         env_release(env)
 297                         return ast
 298                 }
 299                 switch (types_heap[idx][0]) {
 300                 case "'def!":
 301                         return EVAL_def(ast, env)
 302                 case "'let*":
 303                         ast = EVAL_let(ast, env,    ret_env)
 304                         if (ast ~ /^!/) {
 305                                 return ast
 306                         }
 307                         env = ret_env[0]
 308                         continue
 309                 case "'quote":
 310                         if (len != 2) {
 311                                 types_release(ast)
 312                                 env_release(env)
 313                                 return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "."
 314                         }
 315                         types_addref(body = types_heap[idx][1])
 316                         types_release(ast)
 317                         env_release(env)
 318                         return body
 319                 case "'quasiquote":
 320                         if (len != 2) {
 321                                 types_release(ast)
 322                                 env_release(env)
 323                                 return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "."
 324                         }
 325                         types_addref(body = types_heap[idx][1])
 326                         types_release(ast)
 327                         ast = quasiquote(body)
 328                         if (ast ~ /^!/) {
 329                                 env_release(env)
 330                                 return ast
 331                         }
 332                         continue
 333                 case "'do":
 334                         ast = EVAL_do(ast, env)
 335                         if (ast ~ /^!/) {
 336                                 return ast
 337                         }
 338                         continue
 339                 case "'if":
 340                         ast = EVAL_if(ast, env)
 341                         if (ast !~ /^['([{]/) {
 342                                 env_release(env)
 343                                 return ast
 344                         }
 345                         continue
 346                 case "'fn*":
 347                         return EVAL_fn(ast, env)
 348                 default:
 349                         new_ast = eval_ast(ast, env)
 350                         types_release(ast)
 351                         env_release(env)
 352                         if (new_ast ~ /^!/) {
 353                                 return new_ast
 354                         }
 355                         idx = substr(new_ast, 2)
 356                         f = types_heap[idx][0]
 357                         f_idx = substr(f, 2)
 358                         switch (f) {
 359                         case /^\$/:
 360                                 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
 361                                 if (env ~ /^!/) {
 362                                         types_release(new_ast)
 363                                         return env
 364                                 }
 365                                 types_addref(ast = types_heap[f_idx]["body"])
 366                                 types_release(new_ast)
 367                                 continue
 368                         case /^&/:
 369                                 ret = @f_idx(idx)
 370                                 types_release(new_ast)
 371                                 return ret
 372                         default:
 373                                 types_release(new_ast)
 374                                 return "!\"First element of list must be function, supplied " types_typename(f) "."
 375                         }
 376                 }
 377         }
 378 }
 379
 380 function PRINT(expr,    str)
 381 {
 382         str = printer_pr_str(expr, 1)
 383         types_release(expr)
 384         return str
 385 }
 386
 387 function rep(str,    ast, expr)
 388 {
 389         ast = READ(str)
 390         if (ast ~ /^!/) {
 391                 return ast
 392         }
 393         expr = EVAL(ast, repl_env)
 394         if (expr ~ /^!/) {
 395                 return expr
 396         }
 397         return PRINT(expr)
 398 }
 399
 400 function eval(idx)
 401 {
 402         if (types_heap[idx]["len"] != 2) {
 403                 return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
 404         }
 405         return EVAL(types_addref(types_heap[idx][1]), repl_env)
 406 }
 407
 408 function main(str, ret, i, idx)
 409 {
 410         repl_env = env_new()
 411         for (i in core_ns) {
 412                 env_set(repl_env, i, core_ns[i])
 413         }
 414
 415         env_set(repl_env, "'eval", "&eval")
 416
 417         rep("(def! not (fn* (a) (if a false true)))")
 418         rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))")
 419
 420         idx = types_allocate()
 421         env_set(repl_env, "'*ARGV*", "(" idx)
 422         if (ARGC > 1) {
 423                 for (i = 2; i < ARGC; ++i) {
 424                         types_heap[idx][i - 2] = "\"" ARGV[i]
 425                 }
 426                 types_heap[idx]["len"] = ARGC - 2
 427                 ARGC = 1
 428                 rep("(load-file \"" ARGV[1] "\")")
 429                 return
 430         }
 431         types_heap[idx]["len"] = 0
 432
 433         while (1) {
 434                 printf("user> ")
 435                 if (getline str <= 0) {
 436                         break
 437                 }
 438                 ret = rep(str)
 439                 if (ret ~ /^!/) {
 440                         print "ERROR: " printer_pr_str(substr(ret, 2))
 441                 } else {
 442                         print ret
 443                 }
 444         }
 445 }
 446
 447 BEGIN {
 448         main()
 449         env_check(0)
 450         env_dump()
 451         types_dump()
 452         exit(0)
 453 }