Switch nil from NULL to special class.
--- /dev/null
+..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)
+
+)
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) {
} else if (!identical(parent.env(e), emptyenv())) {
Env.find(parent.env(e), key)
} else {
- NULL
+ nil
}
}
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]]
}
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) })
}
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") {
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)))
}
}
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]]
}
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))
} else {
el <- eval_ast(ast, env)
f <- el[[1]]
- return(do.call(f,el[-1]))
+ return(do.call(f,slice(el,2)))
}
}
--- /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 (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="")
+}
--- /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 (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="")
+}
..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
}
}
+# 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(...)
HCoop / jackhill / mal.git / commitdiff