R: add step4_if_fn_do and step5_tco.

Switch nil from NULL to special class.

9 files changed, 340 insertions, 21 deletions

diff --git a/r/core.r b/r/core.r
new file mode 100644
index 0000000..a59dfb6
--- /dev/null
+++ b/r/core.r
@@ -0,0 +1,42 @@
+..core.. <- TRUE
+
+if(!exists("..types..")) source("types.r")
+if(!exists("..printer..")) source("printer.r")
+
+
+pr_str <- function(...) .pr_list(..., print_readably=TRUE, join=" ")
+
+str <- function(...) .pr_list(..., print_readably=FALSE, join="")
+
+prn <- function(...) {
+    cat(.pr_list(..., print_readably=TRUE, join=" ")); cat("\n")
+    nil
+}
+
+println <- function(...) {
+    cat(.pr_list(..., print_readably=FALSE, join=" ")); cat("\n")
+    nil
+}
+
+core_ns <- list(
+    "="=function(a,b) .equal_q(a,b),
+
+    "pr-str"=pr_str,
+    "str"=str,
+    "prn"=prn,
+    "println"=println,
+    "<"=function(a,b) a<b,
+    "<="=function(a,b) a<=b,
+    ">"=function(a,b) a>b,
+    ">="=function(a,b) a>=b,
+    "+"=function(a,b) a+b,
+    "-"=function(a,b) a-b,
+    "*"=function(a,b) a*b,
+    "/"=function(a,b) a/b,
+
+    "list"=function(...) new.list(...),
+    "list?"=function(a) .list_q(a),
+    "empty?"=function(a) .sequential_q(a) && length(a) == 0,
+    "count"=function(a) length(a)
+
+)
diff --git a/r/env.r b/r/env.r
index e7ad789..b688b4d 100644
--- a/r/env.r
+++ b/r/env.r
@@ -2,8 +2,22 @@
 
 if(!exists("..types..")) source("types.r")
 
-new.Env <- function(outer=emptyenv()) {
-    structure(new.env(parent=outer), class="Env")
+new.Env <- function(outer=emptyenv(), binds=list(), exprs=list()) {
+    e <- structure(new.env(parent=outer), class="Env")
+
+    if (length(binds) > 0) {
+        for(i in seq(length(binds))) {
+            b <- as.character(binds[[i]])
+            if (b == "&") {
+                e[[as.character(binds[[i+1]])]] <-
+                    slice(exprs, i, length(exprs))
+                break
+            } else {
+                e[[b]] <- exprs[[i]]
+            }
+        }
+    }
+    e
 }
 
 Env.find <- function(e, key) {
@@ -13,7 +27,7 @@ Env.find <- function(e, key) {
     } else if (!identical(parent.env(e), emptyenv())) {
         Env.find(parent.env(e), key)
     } else {
-        NULL
+        nil
     }
 }
 
@@ -26,6 +40,6 @@ Env.set <- function(e, key, val) {
 Env.get <- function(e, key) {
     key <- as.character(key)
     e <- Env.find(e, key)
-    if (is.null(e)) throw(concat("'", key, "' not found"))
+    if (.nil_q(e)) throw(concat("'", key, "' not found"))
     e[[key]]
 }
diff --git a/r/printer.r b/r/printer.r
index 1695439..0a10d37 100644
--- a/r/printer.r
+++ b/r/printer.r
@@ -2,28 +2,41 @@
 
 if(!exists("..types..")) source("types.r")
 
+.pr_list <- function(..., print_readably=TRUE, join="") {
+    concatl(lapply(list(...),
+                   function(e) .pr_str(e, print_readably)), sep=join)
+}
+
 .pr_str <- function(exp, print_readably=TRUE) {
-    #cat("-", class(exp), as.character(exp), "\n")
+    pr <- print_readably
     switch(class(exp),
         "List"={
-            data <- paste(lapply(exp, function(e) .pr_str(e)),
+            data <- paste(lapply(exp, function(e) .pr_str(e, pr)),
                           sep="", collapse=" ")
             paste("(", data, ")", sep="", collapse="")
         },
         "Vector"={
-            data <- paste(lapply(exp, function(e) .pr_str(e)),
+            data <- paste(lapply(exp, function(e) .pr_str(e, pr)),
                           sep=" ", collapse=" ")
             paste("[", data, "]", sep="", collapse="")
         },
         "character"={
             if (print_readably) {
-                paste("\"", exp, "\"", sep="", collapse="" )
+                paste("\"",
+                      gsub("\\n", "\\\\n",
+                           gsub("\\\"", "\\\\\"",
+                                gsub("\\\\", "\\\\\\\\", exp))),
+                      "\"", sep="", collapse="")
             } else {
                 exp
             }
         },
-        "NULL"={ "nil" },
+        "nil"={ "nil" },
         "logical"={ tolower(exp) },
+        "MalFunc"={
+            paste("(fn* ", .pr_str(exp$params,TRUE),
+                  " ", .pr_str(exp$ast, FALSE), ")", sep="")
+        },
         "function"={ "<#function>" },
         { toString(exp) })
 }
diff --git a/r/reader.r b/r/reader.r
index d2ab486..46a3cdf 100644
--- a/r/reader.r
+++ b/r/reader.r
@@ -41,9 +41,11 @@ read_atom <- function(rdr) {
     if (re_match("^-?[0-9][0-9.]*$", token)) {
         as.numeric(token)
     } else if (substr(token,1,1) == "\"") {
-        substr(token, 2, nchar(token)-1)
+        gsub("\\\\n", "\\n",
+             gsub("\\\\\"", "\"",
+                  substr(token, 2, nchar(token)-1)))
     } else if (token == "nil") {
-        NULL
+        nil
     } else if (token == "true") {
         TRUE
     } else if (token == "false") {
@@ -88,7 +90,7 @@ read_form <- function(rdr) {
 
 read_str <- function(str) {
     tokens <- tokenize(str)
-    if (length(tokens) == 0) return(NULL)
+    if (length(tokens) == 0) return(nil)
     return(read_form(new.Reader(tokens)))
 }
 
diff --git a/r/step2_eval.r b/r/step2_eval.r
index d4050d1..265a431 100644
--- a/r/step2_eval.r
+++ b/r/step2_eval.r
@@ -20,12 +20,11 @@ eval_ast <- function(ast, env) {
 }
 
 EVAL <- function(ast, env) {
-    #cat("EVAL: ", .pr_str(ast,true), "\n", sep="")
+    #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]]
diff --git a/r/step3_env.r b/r/step3_env.r
index 793706f..34bc354 100644
--- a/r/step3_env.r
+++ b/r/step3_env.r
@@ -21,21 +21,22 @@ eval_ast <- function(ast, env) {
 }
 
 EVAL <- function(ast, env) {
-    #cat("EVAL: ", .pr_str(ast,true), "\n", sep="")
+    #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="")
     if (!.list_q(ast)) {
         return(eval_ast(ast, env))
     }
 
     # apply list
-    switch(paste("l",length(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 (a0 == "def!") {
+    a0sym <- as.character(a0)
+    if (a0sym == "def!") {
         res <- EVAL(ast[[3]], env)
         return(Env.set(env, a1, res))
-    } else if (a0 == "let*") {
+    } 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))
@@ -44,7 +45,7 @@ EVAL <- function(ast, env) {
     } else {
         el <- eval_ast(ast, env)
         f <- el[[1]]
-        return(do.call(f,el[-1]))
+        return(do.call(f,slice(el,2)))
     }
 }
 
diff --git a/r/step4_if_fn_do.r b/r/step4_if_fn_do.r
new file mode 100644
index 0000000..aada586
--- /dev/null
+++ b/r/step4_if_fn_do.r
@@ -0,0 +1,93 @@
+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 <- 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),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(ast[[3]], 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))
+        }
+        return(EVAL(a2, let_env))
+    } else if (a0sym == "do") {
+        el <- eval_ast(slice(ast,2), env)
+        return(el[[length(el)]])
+    } else if (a0sym == "if") {
+        cond <- EVAL(a1, env)
+        if (.nil_q(cond) || identical(cond, FALSE)) {
+            if (length(ast) < 4) return(nil)
+            return(EVAL(ast[[4]], env))
+        } else {
+            return(EVAL(a2, env))
+        }
+    } else if (a0sym == "fn*") {
+        return(function(...) {
+            EVAL(a2, new.Env(env, a1, list(...)))
+        })
+    } else {
+        el <- eval_ast(ast, env)
+        f <- el[[1]]
+        return(do.call(f,slice(el,2)))
+    }
+}
+
+PRINT <- function(exp) {
+    return(.pr_str(exp, TRUE))
+}
+
+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]]) }
+
+# core.mal: defined using the language itself
+. <- rep("(def! not (fn* (a) (if a false true)))")
+
+
+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/step5_tco.r b/r/step5_tco.r
new file mode 100644
index 0000000..95b2e85
--- /dev/null
+++ b/r/step5_tco.r
@@ -0,0 +1,101 @@
+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 <- 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) {
+    repeat {
+
+    #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="")
+    if (!.list_q(ast)) {
+        return(eval_ast(ast, env))
+    }
+
+    # apply list
+    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 == "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(NULL)
+            ast <- ast[[4]]
+        } else {
+            ast <- a2
+        }
+    } else if (a0sym == "fn*") {
+        return(malfunc(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 <- function(exp) {
+    return(.pr_str(exp, TRUE))
+}
+
+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]]) }
+
+# core.mal: defined using the language itself
+. <- rep("(def! not (fn* (a) (if a false true)))")
+
+
+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
index cbd5317..2816143 100644
--- a/r/types.r
+++ b/r/types.r
@@ -1,8 +1,48 @@
 ..types.. <- TRUE
 
+if(!exists("..env..")) source("env.r")
+
 # General type related functions
-concat <- function(...) {
-    paste(..., collapse="", sep="")
+concat <- function(..., sep="")  paste(..., collapse="", sep=sep)
+concatl <- function(lst, sep="") paste(lst, collapse=sep, sep=sep)
+
+slice <- function(seq, start=1, end=-1) {
+    if (end == -1) end <- length(seq)
+    if (start > length(seq)) lst <- list() else lst <- seq[start:end]
+    switch(class(seq),
+        list={ new.listl(lst) },
+        List={ new.listl(lst) },
+        Vector={ new.vectorl(lst) },
+        { throw("slice called on non-sequence") })
+}
+
+.sequential_q <- function(obj) .list_q(obj) || .vector_q(obj)
+
+.equal_q <- function(a,b) {
+    ota <- class(a); otb <- class(b)
+    if (!((ota == otb) || (.sequential_q(a) && .sequential_q(b)))) {
+        return(FALSE)
+    }
+    switch(ota,
+    "List"={
+        if (length(a) != length(b)) return(FALSE)
+        if (length(a) == 0) return(TRUE)
+        for(i in seq(length(a))) {
+            if (!.equal_q(a[[i]],b[[i]])) return(FALSE)
+        }
+        TRUE
+    },
+    "Vector"={
+        if (length(a) != length(b)) return(FALSE)
+        if (length(a) == 0) return(TRUE)
+        for(i in seq(length(a))) {
+            if (!.equal_q(a[[i]],b[[i]])) return(FALSE)
+        }
+        TRUE
+    },
+    {
+        a == b
+    })
 }
 
 # Errors/exceptions
@@ -23,6 +63,20 @@ get_error <- function(e) {
     }
 }
 
+# Scalars
+nil <- structure("malnil", class="nil")
+.nil_q <- function(obj) "nil" == class(obj)
+
+# Functions
+
+malfunc <- function(ast, env, params) {
+    gen_env <- function(args) new.Env(env, params, args)
+    structure(list(ast=ast,
+                   env=env,
+                   params=params,
+                   gen_env=gen_env), class="MalFunc")
+}
+
 # Lists
 new.list <- function(...) {
     lst <- list(...)