Change symbols to be special class.
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="")
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),
"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,
"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
)
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 {
}
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.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]]
exp
}
},
+ "Symbol"={ exp },
"nil"={ "nil" },
"logical"={ tolower(exp) },
"MalFunc"={
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
}
} else if (token == "false") {
FALSE
} else {
- as.symbol(token)
+ new.symbol(token)
}
}
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))
}
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)))
}
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)))
}
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)))
}
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)))
--- /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")
+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="")
+}
--- /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")
+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="")
+}
# 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
;=>false
(= 2 (+ 1 1))
;=>true
+(= nil 1)
+;=>true
(> 2 1)
;=>true
+;; 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
-;; 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