From 90f618cbe7ac7740accf501a75be6972bd95be1a Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Sat, 28 Feb 2015 11:09:54 -0600 Subject: All: rename stepA_interop to stepA_mal Also, add missed postscript interop tests. --- r/Makefile | 2 +- r/stepA_interop.r | 198 ------------------------------------------------------ r/stepA_mal.r | 198 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 199 insertions(+), 199 deletions(-) delete mode 100644 r/stepA_interop.r create mode 100644 r/stepA_mal.r (limited to 'r') diff --git a/r/Makefile b/r/Makefile index 9d1a35d..4d1ec24 100644 --- a/r/Makefile +++ b/r/Makefile @@ -1,7 +1,7 @@ TESTS = SOURCES_BASE = readline.r types.r reader.r printer.r -SOURCES_LISP = env.r core.r stepA_interop.r +SOURCES_LISP = env.r core.r stepA_mal.r SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) all: libs 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="") -} diff --git a/r/stepA_mal.r b/r/stepA_mal.r new file mode 100644 index 0000000..e699048 --- /dev/null +++ b/r/stepA_mal.r @@ -0,0 +1,198 @@ +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="") +} -- cgit v1.2.3