| 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 |
| 9 | READ <- function(str) { |
| 10 | return(read_str(str)) |
| 11 | } |
| 12 | |
| 13 | # eval |
| 14 | is_pair <- function(x) { |
| 15 | .sequential_q(x) && length(x) > 0 |
| 16 | } |
| 17 | |
| 18 | quasiquote <- function(ast) { |
| 19 | if (!is_pair(ast)) { |
| 20 | new.list(new.symbol("quote"), |
| 21 | ast) |
| 22 | } else if (.symbol_q(ast[[1]]) && ast[[1]] == "unquote") { |
| 23 | ast[[2]] |
| 24 | } else if (is_pair(ast[[1]]) && |
| 25 | .symbol_q(ast[[1]][[1]]) && |
| 26 | ast[[1]][[1]] == "splice-unquote") { |
| 27 | new.list(new.symbol("concat"), |
| 28 | ast[[1]][[2]], |
| 29 | quasiquote(slice(ast, 2))) |
| 30 | } else { |
| 31 | new.list(new.symbol("cons"), |
| 32 | quasiquote(ast[[1]]), |
| 33 | quasiquote(slice(ast, 2))) |
| 34 | } |
| 35 | } |
| 36 | |
| 37 | is_macro_call <- function(ast, env) { |
| 38 | if(.list_q(ast) && |
| 39 | .symbol_q(ast[[1]]) && |
| 40 | (!.nil_q(Env.find(env, ast[[1]])))) { |
| 41 | exp <- Env.get(env, ast[[1]]) |
| 42 | return(.malfunc_q(exp) && exp$ismacro) |
| 43 | } |
| 44 | FALSE |
| 45 | } |
| 46 | |
| 47 | macroexpand <- function(ast, env) { |
| 48 | while(is_macro_call(ast, env)) { |
| 49 | mac <- Env.get(env, ast[[1]]) |
| 50 | ast <- fapply(mac, slice(ast, 2)) |
| 51 | } |
| 52 | ast |
| 53 | } |
| 54 | |
| 55 | eval_ast <- function(ast, env) { |
| 56 | if (.symbol_q(ast)) { |
| 57 | Env.get(env, ast) |
| 58 | } else if (.list_q(ast)) { |
| 59 | new.listl(lapply(ast, function(a) EVAL(a, env))) |
| 60 | } else if (.vector_q(ast)) { |
| 61 | new.vectorl(lapply(ast, function(a) EVAL(a, env))) |
| 62 | } else if (.hash_map_q(ast)) { |
| 63 | lst <- list() |
| 64 | for(k in ls(ast)) { |
| 65 | lst[[length(lst)+1]] = k |
| 66 | lst[[length(lst)+1]] = EVAL(ast[[k]], env) |
| 67 | } |
| 68 | new.hash_mapl(lst) |
| 69 | } else { |
| 70 | ast |
| 71 | } |
| 72 | } |
| 73 | |
| 74 | EVAL <- function(ast, env) { |
| 75 | repeat { |
| 76 | |
| 77 | #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") |
| 78 | if (!.list_q(ast)) { |
| 79 | return(eval_ast(ast, env)) |
| 80 | } |
| 81 | |
| 82 | # apply list |
| 83 | ast <- macroexpand(ast, env) |
| 84 | if (!.list_q(ast)) return(eval_ast(ast, env)) |
| 85 | |
| 86 | switch(paste("l",length(ast),sep=""), |
| 87 | l0={ return(ast) }, |
| 88 | l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, |
| 89 | l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, |
| 90 | { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) |
| 91 | if (length(a0) > 1) a0sym <- "__<*fn*>__" |
| 92 | else a0sym <- as.character(a0) |
| 93 | if (a0sym == "def!") { |
| 94 | res <- EVAL(a2, env) |
| 95 | return(Env.set(env, a1, res)) |
| 96 | } else if (a0sym == "let*") { |
| 97 | let_env <- new.Env(env) |
| 98 | for(i in seq(1,length(a1),2)) { |
| 99 | Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) |
| 100 | } |
| 101 | ast <- a2 |
| 102 | env <- let_env |
| 103 | } else if (a0sym == "quote") { |
| 104 | return(a1) |
| 105 | } else if (a0sym == "quasiquote") { |
| 106 | ast <- quasiquote(a1) |
| 107 | } else if (a0sym == "defmacro!") { |
| 108 | func <- EVAL(a2, env) |
| 109 | func$ismacro = TRUE |
| 110 | return(Env.set(env, a1, func)) |
| 111 | } else if (a0sym == "macroexpand") { |
| 112 | return(macroexpand(a1, env)) |
| 113 | } else if (a0sym == "try*") { |
| 114 | edata <- new.env() |
| 115 | tryCatch({ |
| 116 | return(EVAL(a1, env)) |
| 117 | }, error=function(err) { |
| 118 | edata$exc <- get_error(err) |
| 119 | }) |
| 120 | if ((!is.null(a2)) && a2[[1]] == "catch*") { |
| 121 | return(EVAL(a2[[3]], new.Env(env, |
| 122 | new.list(a2[[2]]), |
| 123 | new.list(edata$exc)))) |
| 124 | } else { |
| 125 | throw(err) |
| 126 | } |
| 127 | } else if (a0sym == "do") { |
| 128 | eval_ast(slice(ast,2,length(ast)-1), env) |
| 129 | ast <- ast[[length(ast)]] |
| 130 | } else if (a0sym == "if") { |
| 131 | cond <- EVAL(a1, env) |
| 132 | if (.nil_q(cond) || identical(cond, FALSE)) { |
| 133 | if (length(ast) < 4) return(nil) |
| 134 | ast <- ast[[4]] |
| 135 | } else { |
| 136 | ast <- a2 |
| 137 | } |
| 138 | } else if (a0sym == "fn*") { |
| 139 | return(malfunc(EVAL, a2, env, a1)) |
| 140 | } else { |
| 141 | el <- eval_ast(ast, env) |
| 142 | f <- el[[1]] |
| 143 | if (class(f) == "MalFunc") { |
| 144 | ast <- f$ast |
| 145 | env <- f$gen_env(slice(el,2)) |
| 146 | } else { |
| 147 | return(do.call(f,slice(el,2))) |
| 148 | } |
| 149 | } |
| 150 | |
| 151 | } |
| 152 | } |
| 153 | |
| 154 | # print |
| 155 | PRINT <- function(exp) { |
| 156 | return(.pr_str(exp, TRUE)) |
| 157 | } |
| 158 | |
| 159 | # repl loop |
| 160 | repl_env <- new.Env() |
| 161 | rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) |
| 162 | |
| 163 | # core.r: defined using R |
| 164 | for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } |
| 165 | Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) |
| 166 | Env.set(repl_env, "*ARGV*", new.list()) |
| 167 | |
| 168 | # core.mal: defined using the language itself |
| 169 | . <- rep("(def! not (fn* (a) (if a false true)))") |
| 170 | . <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") |
| 171 | . <- rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") |
| 172 | . <- rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))") |
| 173 | |
| 174 | |
| 175 | args <- commandArgs(trailingOnly = TRUE) |
| 176 | if (length(args) > 0) { |
| 177 | Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) |
| 178 | tryCatch({ |
| 179 | . <- rep(concat("(load-file \"", args[[1]], "\")")) |
| 180 | }, error=function(err) { |
| 181 | cat("Error: ", get_error(err),"\n", sep="") |
| 182 | }) |
| 183 | quit(save="no", status=0) |
| 184 | } |
| 185 | |
| 186 | repeat { |
| 187 | line <- readline("user> ") |
| 188 | if (is.null(line)) { cat("\n"); break } |
| 189 | tryCatch({ |
| 190 | cat(rep(line),"\n", sep="") |
| 191 | }, error=function(err) { |
| 192 | cat("Error: ", get_error(err),"\n", sep="") |
| 193 | }) |
| 194 | # R debug/fatal with tracebacks: |
| 195 | #cat(rep(line),"\n", sep="") |
| 196 | } |