R: step0-3, readline FFI.

11 files changed, 435 insertions, 1 deletions

diff --git a/Makefile b/Makefile
index a10aff8..860821a 100644
--- a/Makefile
+++ b/Makefile
@@ -10,7 +10,7 @@ PYTHON = python
 # 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
@@ -60,6 +60,7 @@ perl_STEP_TO_PROG =    perl/$($(1)).pl
 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))
 
@@ -77,6 +78,7 @@ perl_RUNSTEP =    perl ../$(2) $(3)
 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)
 
diff --git a/r/Makefile b/r/Makefile
new file mode 100644
index 0000000..5dcfdb4
--- /dev/null
+++ b/r/Makefile
@@ -0,0 +1,8 @@
+.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
diff --git a/r/env.r b/r/env.r
new file mode 100644
index 0000000..e7ad789
--- /dev/null
+++ b/r/env.r
@@ -0,0 +1,31 @@
+..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]]
+}
diff --git a/r/printer.r b/r/printer.r
new file mode 100644
index 0000000..1695439
--- /dev/null
+++ b/r/printer.r
@@ -0,0 +1,31 @@
+..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) })
+}
+
+
diff --git a/r/reader.r b/r/reader.r
new file mode 100644
index 0000000..d2ab486
--- /dev/null
+++ b/r/reader.r
@@ -0,0 +1,108 @@
+..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)
diff --git a/r/readline.r b/r/readline.r
new file mode 100644
index 0000000..3e7707c
--- /dev/null
+++ b/r/readline.r
@@ -0,0 +1,16 @@
+..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))
+    }
+}
diff --git a/r/step0_repl.r b/r/step0_repl.r
new file mode 100644
index 0000000..7b03dd3
--- /dev/null
+++ b/r/step0_repl.r
@@ -0,0 +1,27 @@
+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="")
+    })
+}
diff --git a/r/step1_read_print.r b/r/step1_read_print.r
new file mode 100644
index 0000000..39d189b
--- /dev/null
+++ b/r/step1_read_print.r
@@ -0,0 +1,32 @@
+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="")
+}
diff --git a/r/step2_eval.r b/r/step2_eval.r
new file mode 100644
index 0000000..d4050d1
--- /dev/null
+++ b/r/step2_eval.r
@@ -0,0 +1,57 @@
+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="")
+}
diff --git a/r/step3_env.r b/r/step3_env.r
new file mode 100644
index 0000000..793706f
--- /dev/null
+++ b/r/step3_env.r
@@ -0,0 +1,73 @@
+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="")
+}
diff --git a/r/types.r b/r/types.r
new file mode 100644
index 0000000..cbd5317
--- /dev/null
+++ b/r/types.r
@@ -0,0 +1,49 @@
+..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)
+