# Settings
#
-IMPLS = bash c clojure cs go java js make mal perl php ps python ruby rust
+IMPLS = bash c clojure cs go java js make mal perl php ps python r ruby rust
step0 = step0_repl
step1 = step1_read_print
php_STEP_TO_PROG = php/$($(1)).php
ps_STEP_TO_PROG = ps/$($(1)).ps
python_STEP_TO_PROG = python/$($(1)).py
+r_STEP_TO_PROG = r/$($(1)).r
ruby_STEP_TO_PROG = ruby/$($(1)).rb
rust_STEP_TO_PROG = rust/target/$($(1))
php_RUNSTEP = php ../$(2) $(3)
ps_RUNSTEP = $(4)gs -q -I./ -dNODISPLAY -- ../$(2) $(3)$(4)
python_RUNSTEP = $(PYTHON) ../$(2) $(3)
+r_RUNSTEP = Rscript ../$(2) $(3)
ruby_RUNSTEP = ruby ../$(2) $(3)
rust_RUNSTEP = ../$(2) $(3)
--- /dev/null
+.PHONY:
+libs: lib/rdyncall
+
+lib/rdyncall:
+ curl -O http://cran.r-project.org/src/contrib/Archive/rdyncall/rdyncall_0.7.5.tar.gz
+ mkdir -p lib
+ R CMD INSTALL rdyncall_0.7.5.tar.gz -l lib/
+ rm rdyncall_0.7.5.tar.gz
--- /dev/null
+..env.. <- TRUE
+
+if(!exists("..types..")) source("types.r")
+
+new.Env <- function(outer=emptyenv()) {
+ structure(new.env(parent=outer), class="Env")
+}
+
+Env.find <- function(e, key) {
+ key <- as.character(key)
+ if (exists(key, envir=e, inherits=FALSE)) {
+ e
+ } else if (!identical(parent.env(e), emptyenv())) {
+ Env.find(parent.env(e), key)
+ } else {
+ NULL
+ }
+}
+
+Env.set <- function(e, key, val) {
+ key <- as.character(key)
+ e[[key]] <- val
+ invisible(val)
+}
+
+Env.get <- function(e, key) {
+ key <- as.character(key)
+ e <- Env.find(e, key)
+ if (is.null(e)) throw(concat("'", key, "' not found"))
+ e[[key]]
+}
--- /dev/null
+..printer.. <- TRUE
+
+if(!exists("..types..")) source("types.r")
+
+.pr_str <- function(exp, print_readably=TRUE) {
+ #cat("-", class(exp), as.character(exp), "\n")
+ switch(class(exp),
+ "List"={
+ data <- paste(lapply(exp, function(e) .pr_str(e)),
+ sep="", collapse=" ")
+ paste("(", data, ")", sep="", collapse="")
+ },
+ "Vector"={
+ data <- paste(lapply(exp, function(e) .pr_str(e)),
+ sep=" ", collapse=" ")
+ paste("[", data, "]", sep="", collapse="")
+ },
+ "character"={
+ if (print_readably) {
+ paste("\"", exp, "\"", sep="", collapse="" )
+ } else {
+ exp
+ }
+ },
+ "NULL"={ "nil" },
+ "logical"={ tolower(exp) },
+ "function"={ "<#function>" },
+ { toString(exp) })
+}
+
+
--- /dev/null
+..reader.. <- TRUE
+
+if(!exists("..types..")) source("types.r")
+
+new.Reader <- function(tokens) {
+ e <- structure(new.env(), class="Reader")
+ e$tokens <- tokens
+ e$position <- 1
+ e
+}
+
+Reader.peek <- function(rdr) {
+ if (rdr$position > length(rdr$tokens)) return(NULL)
+ rdr$tokens[[rdr$position]]
+}
+
+Reader.next <- function(rdr) {
+ if (rdr$position > length(rdr$tokens)) return(NULL)
+ rdr$position <- rdr$position + 1
+ rdr$tokens[[rdr$position-1]]
+}
+
+tokenize <- function(str) {
+ re <- "[\\s,]*(~@|[\\[\\]\\{\\}\\(\\)'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;.*|[^\\s\\[\\]\\{\\}\\('\"`,;\\)]*)"
+ m <- lapply(regmatches(str, gregexpr(re, str, perl=TRUE)),
+ function(e) sub("^[\\s,]+", "", e, perl=TRUE))
+ res <- list()
+ i <- 1
+ for(v in m[[1]]) {
+ if (v == "") next
+ res[[i]] <- v
+ i <- i+1
+ }
+ res
+}
+
+re_match <- function(re, str) { length(grep(re, c(str))) > 0 }
+
+read_atom <- function(rdr) {
+ token <- Reader.next(rdr)
+ if (re_match("^-?[0-9][0-9.]*$", token)) {
+ as.numeric(token)
+ } else if (substr(token,1,1) == "\"") {
+ substr(token, 2, nchar(token)-1)
+ } else if (token == "nil") {
+ NULL
+ } else if (token == "true") {
+ TRUE
+ } else if (token == "false") {
+ FALSE
+ } else {
+ as.symbol(token)
+ }
+}
+
+read_seq <- function(rdr, start="(", end=")") {
+ lst <- list()
+ token <- Reader.next(rdr)
+ if (token != start) {
+ throw(concat("expected '", start, "'"))
+ }
+ repeat {
+ token <- Reader.peek(rdr)
+ if (is.null(token)) {
+ throw(concat("expected '", end, "', got EOF"))
+ }
+ if (token == end) break
+ lst[[length(lst)+1]] <- read_form(rdr)
+ }
+ Reader.next(rdr)
+ new.listl(lst)
+}
+
+read_form <- function(rdr) {
+ token <- Reader.peek(rdr)
+ if (token == ")") {
+ throw("unexpected ')'")
+ } else if (token == "(") {
+ new.listl(read_seq(rdr))
+ } else if (token == "]") {
+ throw("unexpected ']'")
+ } else if (token == "[") {
+ new.vectorl(read_seq(rdr, "[", "]"))
+ } else {
+ read_atom(rdr)
+ }
+}
+
+read_str <- function(str) {
+ tokens <- tokenize(str)
+ if (length(tokens) == 0) return(NULL)
+ return(read_form(new.Reader(tokens)))
+}
+
+#cat("---\n")
+#print(tokenize("123"))
+#cat("---\n")
+#print(tokenize(" ( 123 456 abc \"def\" ) "))
+
+#rdr <- new.reader(tokenize(" ( 123 456 abc \"def\" ) "))
+#Reader.peek(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
+#Reader.next(rdr)
--- /dev/null
+..readline.. <- TRUE
+
+library(rdyncall, lib.loc="lib/")
+
+#rllib <- dynfind(c("edit"))
+rllib <- dynfind(c("readline"))
+rl <- .dynsym(rllib,"readline")
+
+readline <- function(prompt) {
+ res <- .dyncall(rl, "Z)p", "user> ")
+ if (is.nullptr(res)) {
+ return(NULL)
+ } else {
+ return(ptr2str(res))
+ }
+}
--- /dev/null
+source("readline.r")
+
+READ <- function(str) {
+ return(str)
+}
+
+EVAL <- function(ast, env) {
+ return(ast)
+}
+
+PRINT <- function(exp) {
+ return(exp)
+}
+
+rep <- function(str) {
+ return(PRINT(EVAL(READ(str), "")))
+}
+
+repeat {
+ line <- readline("user> ")
+ if (is.null(line)) { cat("\n"); break }
+ tryCatch({
+ cat(rep(line),"\n", sep="")
+ }, error=function(err) {
+ cat("Error: ", err$message,"\n", sep="")
+ })
+}
--- /dev/null
+if(!exists("..readline..")) source("readline.r")
+if(!exists("..types..")) source("types.r")
+if(!exists("..reader..")) source("reader.r")
+if(!exists("..printer..")) source("printer.r")
+
+READ <- function(str) {
+ return(read_str(str))
+}
+
+EVAL <- function(ast, env) {
+ return(ast)
+}
+
+PRINT <- function(exp) {
+ return(.pr_str(exp, TRUE))
+}
+
+rep <- function(str) {
+ return(PRINT(EVAL(READ(str), "")))
+}
+
+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="")
+}
--- /dev/null
+if(!exists("..readline..")) source("readline.r")
+if(!exists("..types..")) source("types.r")
+if(!exists("..reader..")) source("reader.r")
+if(!exists("..printer..")) source("printer.r")
+
+READ <- function(str) {
+ return(read_str(str))
+}
+
+eval_ast <- function(ast, env) {
+ if (is.symbol(ast)) {
+ env[[as.character(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 {
+ ast
+ }
+}
+
+EVAL <- function(ast, env) {
+ #cat("EVAL: ", .pr_str(ast,true), "\n", sep="")
+ if (!.list_q(ast)) {
+ return(eval_ast(ast, env))
+ }
+
+
+ # apply list
+ el <- eval_ast(ast, env)
+ f <- el[[1]]
+ return(do.call(f,el[-1]))
+}
+
+PRINT <- function(exp) {
+ return(.pr_str(exp, TRUE))
+}
+
+repl_env <- new.env()
+repl_env[["+"]] <- function(a,b) a+b
+repl_env[["-"]] <- function(a,b) a-b
+repl_env[["*"]] <- function(a,b) a*b
+repl_env[["/"]] <- function(a,b) a/b
+
+rep <- function(str) return(PRINT(EVAL(READ(str), repl_env)))
+
+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="")
+}
--- /dev/null
+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")
+
+READ <- function(str) {
+ return(read_str(str))
+}
+
+eval_ast <- function(ast, env) {
+ if (is.symbol(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 {
+ ast
+ }
+}
+
+EVAL <- function(ast, env) {
+ #cat("EVAL: ", .pr_str(ast,true), "\n", sep="")
+ if (!.list_q(ast)) {
+ return(eval_ast(ast, env))
+ }
+
+ # apply list
+ switch(paste("l",length(ast)),
+ 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 (a0 == "def!") {
+ res <- EVAL(ast[[3]], env)
+ return(Env.set(env, a1, res))
+ } else if (a0 == "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))
+ }
+ return(EVAL(a2, let_env))
+ } else {
+ el <- eval_ast(ast, env)
+ f <- el[[1]]
+ return(do.call(f,el[-1]))
+ }
+}
+
+PRINT <- function(exp) {
+ return(.pr_str(exp, TRUE))
+}
+
+repl_env <- new.Env()
+Env.set(repl_env, "+", function(a,b) a+b)
+Env.set(repl_env, "-", function(a,b) a-b)
+Env.set(repl_env, "*", function(a,b) a*b)
+Env.set(repl_env, "/", function(a,b) a/b)
+
+rep <- function(str) return(PRINT(EVAL(READ(str), repl_env)))
+
+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="")
+}
--- /dev/null
+..types.. <- TRUE
+
+# General type related functions
+concat <- function(...) {
+ paste(..., collapse="", sep="")
+}
+
+# Errors/exceptions
+thrown_error = new.env()
+thrown_error$val = NULL
+throw <- function(obj) {
+ thrown_error$val = obj
+ stop("<mal_exception>")
+}
+get_error <- function(e) {
+ estr <- e$message
+ if (estr == "<mal_exception>") {
+ err <- thrown_error$val
+ thrown_error$val <- NULL
+ err
+ } else {
+ estr
+ }
+}
+
+# Lists
+new.list <- function(...) {
+ lst <- list(...)
+ class(lst) <- "List"
+ lst
+}
+new.listl <- function(lst) {
+ class(lst) <- "List"
+ lst
+}
+.list_q <- function(obj) "List" == class(obj)
+
+# Vectors
+new.vector <- function(...) {
+ lst <- list(...)
+ class(lst) <- "Vector"
+ lst
+}
+new.vectorl <- function(lst) {
+ class(lst) <- "Vector"
+ lst
+}
+.vector_q <- function(obj) "Vector" == class(obj)
+
HCoop / jackhill / mal.git / commitdiff