r/step5_tco.r

   1 if(!exists("..readline..")) source("readline.r")
   2 if(!exists("..types..")) source("types.r")
   3 if(!exists("..reader..")) source("reader.r")
   4 if(!exists("..printer..")) source("printer.r")
   5 if(!exists("..env..")) source("env.r")
   6 if(!exists("..core..")) source("core.r")
   7
   8 READ <- function(str) {
   9     return(read_str(str))
  10 }
  11
  12 eval_ast <- function(ast, env) {
  13     if (.symbol_q(ast)) {
  14         Env.get(env, ast)
  15     } else if (.list_q(ast)) {
  16         new.listl(lapply(ast, function(a) EVAL(a, env)))
  17     } else if (.vector_q(ast)) {
  18         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
  19     } else if (.hash_map_q(ast)) {
  20         lst <- list()
  21         for(k in ls(ast)) {
  22             lst[[length(lst)+1]] = k
  23             lst[[length(lst)+1]] = EVAL(ast[[k]], env)
  24         }
  25         new.hash_mapl(lst)
  26     } else {
  27         ast
  28     }
  29 }
  30
  31 EVAL <- function(ast, env) {
  32     repeat {
  33
  34     #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="")
  35     if (!.list_q(ast)) {
  36         return(eval_ast(ast, env))
  37     }
  38
  39     # apply list
  40     switch(paste("l",length(ast),sep=""),
  41            l0={ return(ast) },
  42            l1={ a0 <- ast[[1]]; a1 <- NULL;     a2 <- NULL },
  43            l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL },
  44               { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] })
  45     if (length(a0) > 1) a0sym <- "__<*fn*>__"
  46     else                a0sym <- as.character(a0)
  47     if (a0sym == "def!") {
  48         res <- EVAL(a2, env)
  49         return(Env.set(env, a1, res))
  50     } else if (a0sym == "let*") {
  51         let_env <- new.Env(env)
  52         for(i in seq(1,length(a1),2)) {
  53             Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env))
  54         }
  55         ast <- a2
  56         env <- let_env
  57     } else if (a0sym == "do") {
  58         eval_ast(slice(ast,2,length(ast)-1), env)
  59         ast <- ast[[length(ast)]]
  60     } else if (a0sym == "if") {
  61         cond <- EVAL(a1, env)
  62         if (.nil_q(cond) || identical(cond, FALSE)) {
  63             if (length(ast) < 4) return(nil)
  64             ast <- ast[[4]]
  65         } else {
  66             ast <- a2
  67         }
  68     } else if (a0sym == "fn*") {
  69         return(malfunc(EVAL, a2, env, a1))
  70     } else {
  71         el <- eval_ast(ast, env)
  72         f <- el[[1]]
  73         if (class(f) == "MalFunc") {
  74             ast <- f$ast
  75             env <- f$gen_env(slice(el,2))
  76         } else {
  77             return(do.call(f,slice(el,2)))
  78         }
  79     }
  80
  81     }
  82 }
  83
  84 PRINT <- function(exp) {
  85     return(.pr_str(exp, TRUE))
  86 }
  87
  88 repl_env <- new.Env()
  89 rep <- function(str) return(PRINT(EVAL(READ(str), repl_env)))
  90
  91 # core.r: defined using R
  92 for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) }
  93
  94 # core.mal: defined using the language itself
  95 . <- rep("(def! not (fn* (a) (if a false true)))")
  96
  97
  98 repeat {
  99     line <- readline("user> ")
 100     if (is.null(line)) { cat("\n"); break }
 101     tryCatch({
 102         cat(rep(line),"\n", sep="")
 103     }, error=function(err) {
 104         cat("Error: ", get_error(err),"\n", sep="")
 105     })
 106     # R debug/fatal with tracebacks:
 107     #cat(rep(line),"\n", sep="")
 108 }