R: atom support, fixes for self-hosting.

13 files changed, 303 insertions, 13 deletions

diff --git a/r/Makefile b/r/Makefile
index e84ea4f..9d1a35d 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 step9_try.r
+SOURCES_LISP = env.r core.r stepA_interop.r
 SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
 
 all: libs
diff --git a/r/core.r b/r/core.r
index d65607c..d0443b0 100644
--- a/r/core.r
+++ b/r/core.r
@@ -24,6 +24,11 @@ println <- function(...) {
     nil
 }
 
+do_readline <- function(prompt) {
+    l <- readline(prompt)
+    if (is.null(l)) nil else l
+}
+
 # Hash Map functions
 do_get <- function(hm,k) {
     if (class(hm) == "nil") return(nil)
@@ -62,7 +67,25 @@ do_apply <- function(f, ...) {
 }
 
 map <- function(f, seq) {
-    new.listl(lapply(seq, function(el) fapply(f, el)))
+    new.listl(lapply(seq, function(el) fapply(f, list(el))))
+}
+
+conj <- function(obj, ...) {
+    p <- list(...)
+    new_obj <- .clone(obj)
+    if (.list_q(obj)) {
+        if (length(p) > 0) {
+            for(l in p) new_obj <- append(list(l), new_obj)
+        }
+        new.listl(new_obj)
+    } else if (.vector_q(obj)) {
+        if (length(p) > 0) {
+            for(l in p) new_obj <- append(new_obj, list(l))
+        }
+        new.vectorl(new_obj)
+    } else {
+        throw("conj called on non-sequence")
+    }
 }
 
 # Metadata functions
@@ -77,6 +100,18 @@ meta <- function(obj) {
     if (is.null(m)) nil else m
 }
 
+# Atom functions
+deref <- function(atm) atm$val
+reset_bang <- function (atm, val) { atm$val <- val; val }
+swap_bang <- function (atm, f, ...) {
+    p <- list(...)
+    args <- list(atm$val)
+    if (length(p) > 0) {
+        for(l in p) args[[length(args)+1]] <- l
+    }
+    atm$val <- fapply(f, args)
+}
+
 core_ns <- list(
     "="=function(a,b) .equal_q(a,b),
     "throw"=function(err) throw(err),
@@ -91,7 +126,7 @@ core_ns <- list(
     "str"=str,
     "prn"=prn,
     "println"=println,
-    "readline"=readline,
+    "readline"=do_readline,
     "read-string"=function(str) read_str(str),
     "slurp"=function(path) readChar(path, file.info(path)$size),
     "<"=function(a,b) a<b,
@@ -126,7 +161,13 @@ core_ns <- list(
     "count"=function(a) length(a),
     "apply"=do_apply,
     "map"=map,
+    "conj"=conj,
 
     "with-meta"=with_meta,
-    "meta"=meta
+    "meta"=meta,
+    "atom"=new.atom,
+    "atom?"=.atom_q,
+    "deref"=deref,
+    "reset!"=reset_bang,
+    "swap!"=swap_bang
 )
diff --git a/r/printer.r b/r/printer.r
index 1957210..e684b03 100644
--- a/r/printer.r
+++ b/r/printer.r
@@ -42,10 +42,11 @@ if(!exists("..types..")) source("types.r")
         "logical"={ tolower(exp) },
         "MalFunc"={
             paste("(fn* ", .pr_str(exp$params,TRUE),
-                  " ", .pr_str(exp$ast, FALSE), ")", sep="")
+                  " ", .pr_str(exp$ast, TRUE), ")", sep="")
         },
         "function"={ "<#function>" },
+        "Atom"={
+            paste("(atom ", .pr_str(exp$val,TRUE), ")", sep="")
+        },
         { toString(exp) })
 }
-
-
diff --git a/r/step6_file.r b/r/step6_file.r
index c3cc191..a1e5947 100644
--- a/r/step6_file.r
+++ b/r/step6_file.r
@@ -5,6 +5,7 @@ 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))
 }
@@ -81,22 +82,30 @@ EVAL <- function(ast, env) {
     }
 }
 
+# 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*", function(ast) EVAL(ast, repl_env))
+Env.set(repl_env, "*ARGV*", new.list())
 
 # core.mal: defined using the language itself
 . <- rep("(def! not (fn* (a) (if a false true)))")
 . <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 
+args <- commandArgs(trailingOnly = TRUE)
+if (length(args) > 0) {
+    Env.set(repl_env, "*ARGV*", new.listl(slice(list(args),2)))
+    . <- rep(concat("(load-file \"", args[[1]], "\")"))
+    quit(save="no", status=0)
+}
 
 repeat {
     line <- readline("user> ")
diff --git a/r/step7_quote.r b/r/step7_quote.r
index 8263ac9..9abfdde 100644
--- a/r/step7_quote.r
+++ b/r/step7_quote.r
@@ -122,12 +122,18 @@ 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*", function(ast) EVAL(ast, repl_env))
+Env.set(repl_env, "*ARGV*", new.list())
 
 # core.mal: defined using the language itself
 . <- rep("(def! not (fn* (a) (if a false true)))")
 . <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 
+args <- commandArgs(trailingOnly = TRUE)
+if (length(args) > 0) {
+    Env.set(repl_env, "*ARGV*", new.listl(slice(list(args),2)))
+    . <- rep(concat("(load-file \"", args[[1]], "\")"))
+    quit(save="no", status=0)
+}
 
 repeat {
     line <- readline("user> ")
diff --git a/r/step8_macros.r b/r/step8_macros.r
index fd81ece..00931d8 100644
--- a/r/step8_macros.r
+++ b/r/step8_macros.r
@@ -149,7 +149,7 @@ 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*", function(ast) EVAL(ast, repl_env))
+Env.set(repl_env, "*ARGV*", new.list())
 
 # core.mal: defined using the language itself
 . <- rep("(def! not (fn* (a) (if a false true)))")
@@ -158,6 +158,12 @@ Env.set(repl_env, "*ARGV*", function(ast) EVAL(ast, repl_env))
 . <- 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)))
+    . <- rep(concat("(load-file \"", args[[1]], "\")"))
+    quit(save="no", status=0)
+}
 
 repeat {
     line <- readline("user> ")
diff --git a/r/step9_try.r b/r/step9_try.r
index 64c65b5..b37fe38 100644
--- a/r/step9_try.r
+++ b/r/step9_try.r
@@ -163,16 +163,24 @@ 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*", 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)))
+    . <- rep(concat("(load-file \"", args[[1]], "\")"))
+    quit(save="no", status=0)
+}
 
+. <- rep("(println (str \"Mal [\" *host-language* \"]\"))")
 repeat {
     line <- readline("user> ")
     if (is.null(line)) { cat("\n"); break }
diff --git a/r/stepA_interop.r b/r/stepA_interop.r
new file mode 100644
index 0000000..b37fe38
--- /dev/null
+++ b/r/stepA_interop.r
@@ -0,0 +1,194 @@
+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)))
+    . <- rep(concat("(load-file \"", args[[1]], "\")"))
+    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/types.r b/r/types.r
index 06fe5a7..1f749a5 100644
--- a/r/types.r
+++ b/r/types.r
@@ -8,7 +8,7 @@ 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]
+    if (start > end) lst <- list() else lst <- seq[start:end]
     switch(class(seq),
         list={ new.listl(lst) },
         List={ new.listl(lst) },
@@ -91,7 +91,7 @@ malfunc <- function(eval, ast, env, params) {
                    env=env,
                    params=params,
                    gen_env=gen_env,
-                   ismacro=TRUE), class="MalFunc")
+                   ismacro=FALSE), class="MalFunc")
 }
 .malfunc_q <- function(obj) "MalFunc" == class(obj)
 
@@ -143,3 +143,12 @@ new.hash_mapl <- function(lst) {
     hm
 }
 .hash_map_q <- function(obj) "HashMap" == class(obj)
+
+# Atoms
+new.atom <- function(val) {
+    atm <- new.env()
+    class(atm) <- "Atom"
+    atm$val <- .clone(val)
+    atm
+}
+.atom_q <- function(obj) "Atom" == class(obj)
diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal
index 51ddbe9..ee30ea3 100644
--- a/tests/step4_if_fn_do.mal
+++ b/tests/step4_if_fn_do.mal
@@ -62,6 +62,8 @@
 (= 2 (+ 1 1))
 ;=>true
 (= nil 1)
+;=>false
+(= nil nil)
 ;=>true
 
 (> 2 1)
diff --git a/tests/step6_file.mal b/tests/step6_file.mal
index 8198391..f102c34 100644
--- a/tests/step6_file.mal
+++ b/tests/step6_file.mal
@@ -22,6 +22,11 @@
 ;=>12
 
 ;;
+;; Testing that (do (do)) not broken by TCO
+(do (do 1 2))
+;=>2
+
+;;
 ;; -------- Optional Functionality --------
 
 (load-file "../tests/incB.mal")
diff --git a/tests/step8_macros.mal b/tests/step8_macros.mal
index 93f3ea9..f2f62dc 100644
--- a/tests/step8_macros.mal
+++ b/tests/step8_macros.mal
@@ -15,6 +15,13 @@
 ;=>(8 9)
 
 
+;; Testing non-macro function
+(not (= 1 1))
+;=>false
+;;; This should fail if it is a macro
+(not (= 1 2))
+;=>true
+
 
 ;; Testing trivial macros
 (defmacro! one (fn* () 1))
diff --git a/tests/step9_try.mal b/tests/step9_try.mal
index f5bcb58..aee7908 100644
--- a/tests/step9_try.mal
+++ b/tests/step9_try.mal
@@ -61,6 +61,8 @@
 ;=>6
 (map double nums) 
 ;=>(2 4 6)
+(map (fn* [x] (symbol? x)) (list 1 (symbol "two") "three"))
+;=>(false true false)
 
 ;;
 ;; Testing read-str and eval