diff options
| author | Joel Martin <github@martintribe.org> | 2015-02-28 11:09:54 -0600 |
|---|---|---|
| committer | Joel Martin <github@martintribe.org> | 2015-02-28 11:09:54 -0600 |
| commit | 90f618cbe7ac7740accf501a75be6972bd95be1a (patch) | |
| tree | 33a2a221e09f012a25e9ad8317a95bae6ffe1b08 /r/stepA_interop.r | |
| parent | 699f0ad23aca21076edb6a51838d879ca580ffd5 (diff) | |
| download | mal-90f618cbe7ac7740accf501a75be6972bd95be1a.tar.gz mal-90f618cbe7ac7740accf501a75be6972bd95be1a.zip | |
All: rename stepA_interop to stepA_mal
Also, add missed postscript interop tests.
Diffstat (limited to 'r/stepA_interop.r')
| -rw-r--r-- | r/stepA_interop.r | 198 |
1 files changed, 0 insertions, 198 deletions
diff --git a/r/stepA_interop.r b/r/stepA_interop.r deleted file mode 100644 index e699048..0000000 --- a/r/stepA_interop.r +++ /dev/null @@ -1,198 +0,0 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -# eval -is_pair <- function(x) { - .sequential_q(x) && length(x) > 0 -} - -quasiquote <- function(ast) { - if (!is_pair(ast)) { - new.list(new.symbol("quote"), - ast) - } else if (.symbol_q(ast[[1]]) && ast[[1]] == "unquote") { - ast[[2]] - } else if (is_pair(ast[[1]]) && - .symbol_q(ast[[1]][[1]]) && - ast[[1]][[1]] == "splice-unquote") { - new.list(new.symbol("concat"), - ast[[1]][[2]], - quasiquote(slice(ast, 2))) - } else { - new.list(new.symbol("cons"), - quasiquote(ast[[1]]), - quasiquote(slice(ast, 2))) - } -} - -is_macro_call <- function(ast, env) { - if(.list_q(ast) && - .symbol_q(ast[[1]]) && - (!.nil_q(Env.find(env, ast[[1]])))) { - exp <- Env.get(env, ast[[1]]) - return(.malfunc_q(exp) && exp$ismacro) - } - FALSE -} - -macroexpand <- function(ast, env) { - while(is_macro_call(ast, env)) { - mac <- Env.get(env, ast[[1]]) - ast <- fapply(mac, slice(ast, 2)) - } - ast -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - ast <- macroexpand(ast, env) - if (!.list_q(ast)) return(ast) - - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "quote") { - return(a1) - } else if (a0sym == "quasiquote") { - ast <- quasiquote(a1) - } else if (a0sym == "defmacro!") { - func <- EVAL(a2, env) - func$ismacro = TRUE - return(Env.set(env, a1, func)) - } else if (a0sym == "macroexpand") { - return(macroexpand(a1, env)) - } else if (a0sym == "try*") { - edata <- new.env() - tryCatch({ - return(EVAL(a1, env)) - }, error=function(err) { - edata$exc <- get_error(err) - }) - if ((!is.null(a2)) && a2[[1]] == "catch*") { - return(EVAL(a2[[3]], new.Env(env, - new.list(a2[[2]]), - new.list(edata$exc)))) - } else { - throw(err) - } - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! *host-language* \"R\")") -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") -. <- 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)))))))") -. <- 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))))))))") - - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(list(args),2))) - tryCatch({ - . <- rep(concat("(load-file \"", args[[1]], "\")")) - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - quit(save="no", status=0) -} - -. <- rep("(println (str \"Mal [\" *host-language* \"]\"))") -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} |
