R: add step6_file and step7_quote

Change symbols to be special class.

r/core.r

@@ -4,6 +4,8 @@ if(!exists("..types..")) source("types.r")
 if(!exists("..printer..")) source("printer.r")
 
 
+# String functions
+
 pr_str <- function(...) .pr_list(..., print_readably=TRUE, join=" ")
 
 str <- function(...) .pr_list(..., print_readably=FALSE, join="")
@@ -18,6 +20,22 @@ println <- function(...) {
     nil
 }
 
+# Sequence functions
+cons <- function(a,b) {
+    new_lst <- append(list(a), b)
+    class(new_lst) <- "List"
+    new_lst
+}
+
+do_concat <- function(...) {
+    new_lst <- list()
+    for(l in list(...)) {
+        new_lst <- append(new_lst, l)
+    }
+    class(new_lst) <- "List"
+    new_lst
+}
+
 core_ns <- list(
     "="=function(a,b) .equal_q(a,b),
 
@@ -25,6 +43,8 @@ core_ns <- list(
     "str"=str,
     "prn"=prn,
     "println"=println,
+    "read-string"=function(str) read_str(str),
+    "slurp"=function(path) readChar(path, file.info(path)$size),
     "<"=function(a,b) a<b,
     "<="=function(a,b) a<=b,
     ">"=function(a,b) a>b,
@@ -37,6 +57,8 @@ core_ns <- list(
     "list"=function(...) new.list(...),
     "list?"=function(a) .list_q(a),
     "empty?"=function(a) .sequential_q(a) && length(a) == 0,
-    "count"=function(a) length(a)
+    "count"=function(a) length(a),
 
+    "cons"=cons,
+    "concat"=do_concat
 )

r/env.r

@@ -7,9 +7,9 @@ new.Env <- function(outer=emptyenv(), binds=list(), exprs=list()) {
 
     if (length(binds) > 0) {
         for(i in seq(length(binds))) {
-            b <- as.character(binds[[i]])
+            b <- binds[[i]]
             if (b == "&") {
-                e[[as.character(binds[[i+1]])]] <-
+                e[[binds[[i+1]]]] <-
                     slice(exprs, i, length(exprs))
                 break
             } else {
@@ -21,7 +21,6 @@ new.Env <- function(outer=emptyenv(), binds=list(), exprs=list()) {
 }
 
 Env.find <- function(e, key) {
-    key <- as.character(key)
     if (exists(key, envir=e, inherits=FALSE)) {
         e
     } else if (!identical(parent.env(e), emptyenv())) {
@@ -32,13 +31,11 @@ Env.find <- function(e, key) {
 }
 
 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 (.nil_q(e)) throw(concat("'", key, "' not found"))
     e[[key]]

r/printer.r

@@ -31,6 +31,7 @@ if(!exists("..types..")) source("types.r")
                 exp
             }
         },
+        "Symbol"={ exp },
         "nil"={ "nil" },
         "logical"={ tolower(exp) },
         "MalFunc"={

r/reader.r

@@ -27,7 +27,7 @@ tokenize <- function(str) {
     res <- list()
     i <- 1
     for(v in m[[1]]) {
-        if (v == "") next
+        if (v == "" || substr(v,1,1) == ";") next
         res[[i]] <- v
         i <- i+1
     }
@@ -51,7 +51,7 @@ read_atom <- function(rdr) {
     } else if (token == "false") {
         FALSE
     } else {
-        as.symbol(token)
+        new.symbol(token)
     }
 }
 
@@ -75,7 +75,19 @@ read_seq <- function(rdr, start="(", end=")") {
 
 read_form <- function(rdr) {
     token <- Reader.peek(rdr)
-    if (token == ")") {
+    if (token == "'") {
+        . <- Reader.next(rdr);
+        new.list(new.symbol("quote"), read_form(rdr))
+    } else if (token == "`") {
+        . <- Reader.next(rdr);
+        new.list(new.symbol("quasiquote"), read_form(rdr))
+    } else if (token == "~") {
+        . <- Reader.next(rdr);
+        new.list(new.symbol("unquote"), read_form(rdr))
+    } else if (token == "~@") {
+        . <- Reader.next(rdr);
+        new.list(new.symbol("splice-unquote"), read_form(rdr))
+    } else if (token == ")") {
         throw("unexpected ')'")
     } else if (token == "(") {
         new.listl(read_seq(rdr))

r/step2_eval.r

@@ -8,7 +8,7 @@ READ <- function(str) {
 }
 
 eval_ast <- function(ast, env) {
-    if (is.symbol(ast)) {
+    if (.symbol_q(ast)) {
         env[[as.character(ast)]]
     } else if (.list_q(ast)) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))

r/step3_env.r

@@ -9,7 +9,7 @@ READ <- function(str) {
 }
 
 eval_ast <- function(ast, env) {
-    if (is.symbol(ast)) {
+    if (.symbol_q(ast)) {
         Env.get(env, ast)
     } else if (.list_q(ast)) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))

r/step4_if_fn_do.r

@@ -10,7 +10,7 @@ READ <- function(str) {
 }
 
 eval_ast <- function(ast, env) {
-    if (is.symbol(ast)) {
+    if (.symbol_q(ast)) {
         Env.get(env, ast)
     } else if (.list_q(ast)) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))

r/step5_tco.r

@@ -10,7 +10,7 @@ READ <- function(str) {
 }
 
 eval_ast <- function(ast, env) {
-    if (is.symbol(ast)) {
+    if (.symbol_q(ast)) {
         Env.get(env, ast)
     } else if (.list_q(ast)) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))

r/step6_file.r

@@ -0,0 +1,104 @@
+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 (.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 {
+        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]]) }
+Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env))
+Env.set(repl_env, "*ARGV*", function(ast) EVAL(ast, repl_env))
+
+# 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) \")\")))))")
+
+
+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="")
+}

r/step7_quote.r

@@ -0,0 +1,135 @@
+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)))
+    }
+}
+
+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 {
+        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 == "quote") {
+        return(a1)
+    } else if (a0sym == "quasiquote") {
+        ast <- quasiquote(a1)
+    } 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
+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))
+
+# 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) \")\")))))")
+
+
+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="")
+}

r/types.r

@@ -66,6 +66,8 @@ get_error <- function(e) {
 # Scalars
 nil <- structure("malnil", class="nil")
 .nil_q <- function(obj) "nil" == class(obj)
+new.symbol <- function(name) structure(name, class="Symbol")
+.symbol_q <- function(obj) "Symbol" == class(obj)
 
 # Functions
 

tests/step4_if_fn_do.mal

@@ -61,6 +61,8 @@
 ;=>false
 (= 2 (+ 1 1))
 ;=>true
+(= nil 1)
+;=>true
 
 (> 2 1)
 ;=>true

tests/step7_quote.mal

@@ -1,3 +1,26 @@
+;; Testing cons function
+(cons 1 (list))
+;=>(1)
+(cons 1 (list 2))
+;=>(1 2)
+(cons 1 (list 2 3))
+;=>(1 2 3)
+(cons (list 1) (list 2 3))
+;=>((1) 2 3)
+
+;; Testing concat function
+(concat)
+;=>()
+(concat (list 1 2))
+;=>(1 2)
+(concat (list 1 2) (list 3 4))
+;=>(1 2 3 4)
+(concat (list 1 2) (list 3 4) (list 5 6))
+;=>(1 2 3 4 5 6)
+(concat (concat))
+;=>()
+
+
 ;; Testing regular quote
 (quote 7)
 ;=>7

tests/step8_macros.mal

@@ -1,25 +1,3 @@
-;; Testing cons function
-(cons 1 (list))
-;=>(1)
-(cons 1 (list 2))
-;=>(1 2)
-(cons 1 (list 2 3))
-;=>(1 2 3)
-(cons (list 1) (list 2 3))
-;=>((1) 2 3)
-
-;; Testing concat function
-(concat)
-;=>()
-(concat (list 1 2))
-;=>(1 2)
-(concat (list 1 2) (list 3 4))
-;=>(1 2 3 4)
-(concat (list 1 2) (list 3 4) (list 5 6))
-;=>(1 2 3 4 5 6)
-(concat (concat))
-;=>()
-
 ;; Testing first function
 (first '())
 ;=>nil