mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
R: add step6_file and step7_quote
Change symbols to be special class.
This commit is contained in:
parent
01feedfe22
commit
c30efef469
24
r/core.r
24
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
|
||||
)
|
||||
|
7
r/env.r
7
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]]
|
||||
|
@ -31,6 +31,7 @@ if(!exists("..types..")) source("types.r")
|
||||
exp
|
||||
}
|
||||
},
|
||||
"Symbol"={ exp },
|
||||
"nil"={ "nil" },
|
||||
"logical"={ tolower(exp) },
|
||||
"MalFunc"={
|
||||
|
18
r/reader.r
18
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))
|
||||
|
@ -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)))
|
||||
|
@ -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)))
|
||||
|
@ -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)))
|
||||
|
@ -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)))
|
||||
|
104
r/step6_file.r
Normal file
104
r/step6_file.r
Normal file
@ -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="")
|
||||
}
|
135
r/step7_quote.r
Normal file
135
r/step7_quote.r
Normal file
@ -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="")
|
||||
}
|
@ -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
|
||||
|
||||
|
@ -61,6 +61,8 @@
|
||||
;=>false
|
||||
(= 2 (+ 1 1))
|
||||
;=>true
|
||||
(= nil 1)
|
||||
;=>true
|
||||
|
||||
(> 2 1)
|
||||
;=>true
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user