r/step8_macros.r

   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)))
  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)
  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)) { return(eval_ast(ast, env)) }
  79     if (length(ast) == 0) { return(ast) }
  80
  81     # apply list
  82     ast <- macroexpand(ast, env)
  83     if (!.list_q(ast)) return(eval_ast(ast, env))
  84
  85     switch(paste("l",length(ast),sep=""),
  86            l0={ return(ast) },
  87            l1={ a0 <- ast[[1]]; a1 <- NULL;     a2 <- NULL },
  88            l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL },
  89               { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] })
  90     if (length(a0) > 1) a0sym <- "__<*fn*>__"
  91     else                a0sym <- as.character(a0)
  92     if (a0sym == "def!") {
  93         res <- EVAL(a2, env)
  94         return(Env.set(env, a1, res))
  95     } else if (a0sym == "let*") {
  96         let_env <- new.Env(env)
  97         for(i in seq(1,length(a1),2)) {
  98             Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env))
  99         }
 100         ast <- a2
 101         env <- let_env
 102     } else if (a0sym == "quote") {
 103         return(a1)
 104     } else if (a0sym == "quasiquote") {
 105         ast <- quasiquote(a1)
 106     } else if (a0sym == "defmacro!") {
 107         func <- EVAL(a2, env)
 108         func$ismacro = TRUE
 109         return(Env.set(env, a1, func))
 110     } else if (a0sym == "macroexpand") {
 111         return(macroexpand(a1, env))
 112     } else if (a0sym == "do") {
 113         eval_ast(slice(ast,2,length(ast)-1), env)
 114         ast <- ast[[length(ast)]]
 115     } else if (a0sym == "if") {
 116         cond <- EVAL(a1, env)
 117         if (.nil_q(cond) || identical(cond, FALSE)) {
 118             if (length(ast) < 4) return(nil)
 119             ast <- ast[[4]]
 120         } else {
 121             ast <- a2
 122         }
 123     } else if (a0sym == "fn*") {
 124         return(malfunc(EVAL, a2, env, a1))
 125     } else {
 126         el <- eval_ast(ast, env)
 127         f <- el[[1]]
 128         if (class(f) == "MalFunc") {
 129             ast <- f$ast
 130             env <- f$gen_env(slice(el,2))
 131         } else {
 132             return(do.call(f,slice(el,2)))
 133         }
 134     }
 135
 136     }
 137 }
 138
 139 # print
 140 PRINT <- function(exp) {
 141     return(.pr_str(exp, TRUE))
 142 }
 143
 144 # repl loop
 145 repl_env <- new.Env()
 146 rep <- function(str) return(PRINT(EVAL(READ(str), repl_env)))
 147
 148 # core.r: defined using R
 149 for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) }
 150 Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env))
 151 Env.set(repl_env, "*ARGV*", new.list())
 152
 153 # core.mal: defined using the language itself
 154 . <- rep("(def! not (fn* (a) (if a false true)))")
 155 . <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 156 . <- 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)))))))")
 157 . <- 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))))))))")
 158
 159
 160 args <- commandArgs(trailingOnly = TRUE)
 161 if (length(args) > 0) {
 162     Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2)))
 163     . <- rep(concat("(load-file \"", args[[1]], "\")"))
 164     quit(save="no", status=0)
 165 }
 166
 167 repeat {
 168     line <- readline("user> ")
 169     if (is.null(line)) { cat("\n"); break }
 170     tryCatch({
 171         cat(rep(line),"\n", sep="")
 172     }, error=function(err) {
 173         cat("Error: ", get_error(err),"\n", sep="")
 174     })
 175     # R debug/fatal with tracebacks:
 176     #cat(rep(line),"\n", sep="")
 177 }