Commit | Line | Data |
---|---|---|
8128c69a JM |
1 | if(!exists("..readline..")) source("readline.r") |
2 | if(!exists("..types..")) source("types.r") | |
3 | if(!exists("..reader..")) source("reader.r") | |
4 | if(!exists("..printer..")) source("printer.r") | |
5 | if(!exists("..env..")) source("env.r") | |
6 | if(!exists("..core..")) source("core.r") | |
7 | ||
8 | # read | |
9 | READ <- function(str) { | |
10 | return(read_str(str)) | |
11 | } | |
12 | ||
13 | # eval | |
14 | is_pair <- function(x) { | |
15 | .sequential_q(x) && length(x) > 0 | |
16 | } | |
17 | ||
18 | quasiquote <- function(ast) { | |
19 | if (!is_pair(ast)) { | |
20 | new.list(new.symbol("quote"), | |
21 | ast) | |
22 | } else if (.symbol_q(ast[[1]]) && ast[[1]] == "unquote") { | |
23 | ast[[2]] | |
24 | } else if (is_pair(ast[[1]]) && | |
25 | .symbol_q(ast[[1]][[1]]) && | |
26 | ast[[1]][[1]] == "splice-unquote") { | |
27 | new.list(new.symbol("concat"), | |
28 | ast[[1]][[2]], | |
29 | quasiquote(slice(ast, 2))) | |
30 | } else { | |
31 | new.list(new.symbol("cons"), | |
32 | quasiquote(ast[[1]]), | |
33 | quasiquote(slice(ast, 2))) | |
34 | } | |
35 | } | |
36 | ||
37 | is_macro_call <- function(ast, env) { | |
38 | if(.list_q(ast) && | |
39 | .symbol_q(ast[[1]]) && | |
40 | (!.nil_q(Env.find(env, ast[[1]])))) { | |
41 | exp <- Env.get(env, ast[[1]]) | |
42 | return(.malfunc_q(exp) && exp$ismacro) | |
43 | } | |
44 | FALSE | |
45 | } | |
46 | ||
47 | macroexpand <- function(ast, env) { | |
48 | while(is_macro_call(ast, env)) { | |
49 | mac <- Env.get(env, ast[[1]]) | |
50 | ast <- fapply(mac, slice(ast, 2)) | |
51 | } | |
52 | ast | |
53 | } | |
54 | ||
55 | eval_ast <- function(ast, env) { | |
56 | if (.symbol_q(ast)) { | |
57 | Env.get(env, ast) | |
58 | } else if (.list_q(ast)) { | |
59 | new.listl(lapply(ast, function(a) EVAL(a, env))) | |
60 | } else if (.vector_q(ast)) { | |
61 | new.vectorl(lapply(ast, function(a) EVAL(a, env))) | |
36737ae5 JM |
62 | } else if (.hash_map_q(ast)) { |
63 | lst <- list() | |
64 | for(k in ls(ast)) { | |
65 | lst[[length(lst)+1]] = k | |
66 | lst[[length(lst)+1]] = EVAL(ast[[k]], env) | |
67 | } | |
68 | new.hash_mapl(lst) | |
8128c69a JM |
69 | } else { |
70 | ast | |
71 | } | |
72 | } | |
73 | ||
74 | EVAL <- function(ast, env) { | |
75 | repeat { | |
76 | ||
77 | #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") | |
78 | if (!.list_q(ast)) { | |
79 | return(eval_ast(ast, env)) | |
80 | } | |
81 | ||
82 | # apply list | |
83 | ast <- macroexpand(ast, env) | |
d5b81cc0 | 84 | if (!.list_q(ast)) return(eval_ast(ast, env)) |
8128c69a JM |
85 | |
86 | switch(paste("l",length(ast),sep=""), | |
87 | l0={ return(ast) }, | |
88 | l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, | |
89 | l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, | |
90 | { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) | |
91 | if (length(a0) > 1) a0sym <- "__<*fn*>__" | |
92 | else a0sym <- as.character(a0) | |
93 | if (a0sym == "def!") { | |
94 | res <- EVAL(a2, env) | |
95 | return(Env.set(env, a1, res)) | |
96 | } else if (a0sym == "let*") { | |
97 | let_env <- new.Env(env) | |
98 | for(i in seq(1,length(a1),2)) { | |
99 | Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) | |
100 | } | |
101 | ast <- a2 | |
102 | env <- let_env | |
103 | } else if (a0sym == "quote") { | |
104 | return(a1) | |
105 | } else if (a0sym == "quasiquote") { | |
106 | ast <- quasiquote(a1) | |
107 | } else if (a0sym == "defmacro!") { | |
108 | func <- EVAL(a2, env) | |
109 | func$ismacro = TRUE | |
110 | return(Env.set(env, a1, func)) | |
111 | } else if (a0sym == "macroexpand") { | |
112 | return(macroexpand(a1, env)) | |
113 | } else if (a0sym == "try*") { | |
114 | edata <- new.env() | |
115 | tryCatch({ | |
116 | return(EVAL(a1, env)) | |
117 | }, error=function(err) { | |
118 | edata$exc <- get_error(err) | |
119 | }) | |
120 | if ((!is.null(a2)) && a2[[1]] == "catch*") { | |
121 | return(EVAL(a2[[3]], new.Env(env, | |
122 | new.list(a2[[2]]), | |
123 | new.list(edata$exc)))) | |
124 | } else { | |
125 | throw(err) | |
126 | } | |
127 | } else if (a0sym == "do") { | |
128 | eval_ast(slice(ast,2,length(ast)-1), env) | |
129 | ast <- ast[[length(ast)]] | |
130 | } else if (a0sym == "if") { | |
131 | cond <- EVAL(a1, env) | |
132 | if (.nil_q(cond) || identical(cond, FALSE)) { | |
133 | if (length(ast) < 4) return(nil) | |
134 | ast <- ast[[4]] | |
135 | } else { | |
136 | ast <- a2 | |
137 | } | |
138 | } else if (a0sym == "fn*") { | |
139 | return(malfunc(EVAL, a2, env, a1)) | |
140 | } else { | |
141 | el <- eval_ast(ast, env) | |
142 | f <- el[[1]] | |
143 | if (class(f) == "MalFunc") { | |
144 | ast <- f$ast | |
145 | env <- f$gen_env(slice(el,2)) | |
146 | } else { | |
147 | return(do.call(f,slice(el,2))) | |
148 | } | |
149 | } | |
150 | ||
151 | } | |
152 | } | |
153 | ||
154 | ||
155 | PRINT <- function(exp) { | |
156 | return(.pr_str(exp, TRUE)) | |
157 | } | |
158 | ||
159 | # repl loop | |
160 | repl_env <- new.Env() | |
161 | rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) | |
162 | ||
163 | # core.r: defined using R | |
164 | for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } | |
165 | Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) | |
f947d503 | 166 | Env.set(repl_env, "*ARGV*", new.list()) |
8128c69a JM |
167 | |
168 | # core.mal: defined using the language itself | |
169 | . <- rep("(def! not (fn* (a) (if a false true)))") | |
170 | . <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") | |
171 | . <- 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)))))))") | |
172 | . <- 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))))))))") | |
173 | ||
174 | ||
f947d503 JM |
175 | args <- commandArgs(trailingOnly = TRUE) |
176 | if (length(args) > 0) { | |
8a16f953 | 177 | Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) |
9b3362e8 JM |
178 | tryCatch({ |
179 | . <- rep(concat("(load-file \"", args[[1]], "\")")) | |
180 | }, error=function(err) { | |
181 | cat("Error: ", get_error(err),"\n", sep="") | |
182 | }) | |
f947d503 JM |
183 | quit(save="no", status=0) |
184 | } | |
8128c69a JM |
185 | |
186 | repeat { | |
187 | line <- readline("user> ") | |
188 | if (is.null(line)) { cat("\n"); break } | |
189 | tryCatch({ | |
190 | cat(rep(line),"\n", sep="") | |
191 | }, error=function(err) { | |
192 | cat("Error: ", get_error(err),"\n", sep="") | |
193 | }) | |
194 | # R debug/fatal with tracebacks: | |
195 | #cat(rep(line),"\n", sep="") | |
196 | } |