R: add step8_macros and step9_try.

r/Makefile

@@ -1,3 +1,19 @@
+TESTS =
+
+SOURCES_BASE = readline.r types.r reader.r printer.r
+SOURCES_LISP = env.r core.r step9_try.r
+SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
+
+all: libs
+
+.PHONY: stats tests $(TESTS)
+
+stats: $(SOURCES)
+	@wc $^
+stats-lisp: $(SOURCES_LISP)
+	@wc $^
+
+
 .PHONY:
 libs: lib/rdyncall
 

r/core.r

@@ -23,8 +23,7 @@ println <- function(...) {
 # Sequence functions
 cons <- function(a,b) {
     new_lst <- append(list(a), b)
-    class(new_lst) <- "List"
-    new_lst
+    new.listl(new_lst)
 }
 
 do_concat <- function(...) {
@@ -32,17 +31,40 @@ do_concat <- function(...) {
     for(l in list(...)) {
         new_lst <- append(new_lst, l)
     }
-    class(new_lst) <- "List"
-    new_lst
+    new.listl(new_lst)
+}
+
+do_apply <- function(f, ...) {
+    p <- list(...)
+    args <- list()
+    if (length(p) > 1) {
+        for(l in slice(p, 1, length(p)-1)) {
+            args[[length(args)+1]] <- l
+        }
+    }
+    args <- append(args, p[[length(p)]])
+    fapply(f, args)
+}
+
+map <- function(f, seq) {
+    new.listl(lapply(seq, function(el) fapply(f, el)))
 }
 
 core_ns <- list(
     "="=function(a,b) .equal_q(a,b),
+    "throw"=function(err) throw(err),
+    "nil?"=.nil_q,
+    "true?"=.true_q,
+    "false?"=.false_q,
+    "symbol?"=.symbol_q,
+    "symbol"=new.symbol,
+    "symbol?"=.symbol_q,
 
     "pr-str"=pr_str,
     "str"=str,
     "prn"=prn,
     "println"=println,
+    "readline"=readline,
     "read-string"=function(str) read_str(str),
     "slurp"=function(path) readChar(path, file.info(path)$size),
     "<"=function(a,b) a<b,
@@ -54,11 +76,19 @@ core_ns <- list(
     "*"=function(a,b) a*b,
     "/"=function(a,b) a/b,
 
-    "list"=function(...) new.list(...),
+    "list"=new.list,
     "list?"=function(a) .list_q(a),
+    "vector"=new.vector,
+    "vector?"=function(a) .vector_q(a),
     "empty?"=function(a) .sequential_q(a) && length(a) == 0,
     "count"=function(a) length(a),
 
+    "sequential?"=.sequential_q,
     "cons"=cons,
-    "concat"=do_concat
+    "concat"=do_concat,
+    "nth"=function(a,b) if (length(a) < b+1) nil else a[[b+1]],
+    "first"=function(a) if (length(a) < 1) nil else a[[1]], 
+    "rest"=function(a) new.listl(slice(a,2)),
+    "apply"=do_apply,
+    "map"=map
 )

r/reader.r

@@ -38,8 +38,10 @@ re_match <- function(re, str) { length(grep(re, c(str))) > 0 }
 
 read_atom <- function(rdr) {
     token <- Reader.next(rdr)
-    if (re_match("^-?[0-9][0-9.]*$", token)) {
-        as.numeric(token)
+    if (re_match("^-?[0-9]+$", token)) {
+        as.integer(token)
+    } else if (re_match("^-?[0-9][0-9.]*$", token)) {
+        as.double(token)
     } else if (substr(token,1,1) == "\"") {
         gsub("\\\\n", "\\n",
              gsub("\\\\\"", "\"",

r/readline.r

@@ -7,7 +7,7 @@ rllib <- dynfind(c("readline"))
 rl <- .dynsym(rllib,"readline")
 
 readline <- function(prompt) {
-    res <- .dyncall(rl, "Z)p", "user> ")
+    res <- .dyncall(rl, "Z)p", prompt)
     if (is.nullptr(res)) {
         return(NULL)
     } else {

r/step5_tco.r

@@ -53,13 +53,13 @@ EVAL <- function(ast, env) {
     } else if (a0sym == "if") {
         cond <- EVAL(a1, env)
         if (.nil_q(cond) || identical(cond, FALSE)) {
-            if (length(ast) < 4) return(NULL)
+            if (length(ast) < 4) return(nil)
             ast <- ast[[4]]
         } else {
             ast <- a2
         }
     } else if (a0sym == "fn*") {
-        return(malfunc(a2, env, a1))
+        return(malfunc(EVAL, a2, env, a1))
     } else {
         el <- eval_ast(ast, env)
         f <- el[[1]]

r/step6_file.r

@@ -53,13 +53,13 @@ EVAL <- function(ast, env) {
     } else if (a0sym == "if") {
         cond <- EVAL(a1, env)
         if (.nil_q(cond) || identical(cond, FALSE)) {
-            if (length(ast) < 4) return(NULL)
+            if (length(ast) < 4) return(nil)
             ast <- ast[[4]]
         } else {
             ast <- a2
         }
     } else if (a0sym == "fn*") {
-        return(malfunc(a2, env, a1))
+        return(malfunc(EVAL, a2, env, a1))
     } else {
         el <- eval_ast(ast, env)
         f <- el[[1]]

r/step7_quote.r

@@ -82,13 +82,13 @@ EVAL <- function(ast, env) {
     } else if (a0sym == "if") {
         cond <- EVAL(a1, env)
         if (.nil_q(cond) || identical(cond, FALSE)) {
-            if (length(ast) < 4) return(NULL)
+            if (length(ast) < 4) return(nil)
             ast <- ast[[4]]
         } else {
             ast <- a2
         }
     } else if (a0sym == "fn*") {
-        return(malfunc(a2, env, a1))
+        return(malfunc(EVAL, a2, env, a1))
     } else {
         el <- eval_ast(ast, env)
         f <- el[[1]]

r/step8_macros.r

@@ -0,0 +1,165 @@
+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)))
+    }
+}
+
+is_macro_call <- function(ast, env) {
+    if(.list_q(ast) &&
+      .symbol_q(ast[[1]]) &&
+      (!.nil_q(Env.find(env, ast[[1]])))) {
+        exp <- Env.get(env, ast[[1]])
+        return(.malfunc_q(exp) && exp$ismacro)
+    }
+    FALSE
+}
+
+macroexpand <- function(ast, env) {
+    while(is_macro_call(ast, env)) {
+        mac <- Env.get(env, ast[[1]])
+        ast <- fapply(mac, slice(ast, 2))
+    }
+    ast
+}
+
+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
+    ast <- macroexpand(ast, env)
+    if (!.list_q(ast)) return(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 (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 == "defmacro!") {
+        func <- EVAL(a2, env)
+        func$ismacro = TRUE
+        return(Env.set(env, a1, func))
+    } else if (a0sym == "macroexpand") {
+        return(macroexpand(a1, 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(nil)
+            ast <- ast[[4]]
+        } else {
+            ast <- a2
+        }
+    } else if (a0sym == "fn*") {
+        return(malfunc(EVAL, 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) \")\")))))")
+. <- 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)))))))")
+. <- 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))))))))")
+
+
+
+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="")
+}

r/step9_try.r

@@ -0,0 +1,179 @@
+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)))
+    }
+}
+
+is_macro_call <- function(ast, env) {
+    if(.list_q(ast) &&
+      .symbol_q(ast[[1]]) &&
+      (!.nil_q(Env.find(env, ast[[1]])))) {
+        exp <- Env.get(env, ast[[1]])
+        return(.malfunc_q(exp) && exp$ismacro)
+    }
+    FALSE
+}
+
+macroexpand <- function(ast, env) {
+    while(is_macro_call(ast, env)) {
+        mac <- Env.get(env, ast[[1]])
+        ast <- fapply(mac, slice(ast, 2))
+    }
+    ast
+}
+
+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
+    ast <- macroexpand(ast, env)
+    if (!.list_q(ast)) return(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 (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 == "defmacro!") {
+        func <- EVAL(a2, env)
+        func$ismacro = TRUE
+        return(Env.set(env, a1, func))
+    } else if (a0sym == "macroexpand") {
+        return(macroexpand(a1, env))
+    } else if (a0sym == "try*") {
+        edata <- new.env()
+        tryCatch({
+            return(EVAL(a1, env))
+        }, error=function(err) {
+            edata$exc <- get_error(err)
+        })
+        if ((!is.null(a2)) && a2[[1]] == "catch*") {
+            return(EVAL(a2[[3]], new.Env(env,
+                                         new.list(a2[[2]]),
+                                         new.list(edata$exc))))
+        } else {
+            throw(err)
+        }
+    } 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(nil)
+            ast <- ast[[4]]
+        } else {
+            ast <- a2
+        }
+    } else if (a0sym == "fn*") {
+        return(malfunc(EVAL, 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) \")\")))))")
+. <- 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)))))))")
+. <- 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))))))))")
+
+
+
+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="")
+}

r/types.r

@@ -66,17 +66,33 @@ get_error <- function(e) {
 # Scalars
 nil <- structure("malnil", class="nil")
 .nil_q <- function(obj) "nil" == class(obj)
+.true_q <- function(obj) "logical" == class(obj) && obj == TRUE
+.false_q <- function(obj) "logical" == class(obj) && obj == FALSE
 new.symbol <- function(name) structure(name, class="Symbol")
 .symbol_q <- function(obj) "Symbol" == class(obj)
 
 # Functions
 
-malfunc <- function(ast, env, params) {
+malfunc <- function(eval, ast, env, params) {
     gen_env <- function(args) new.Env(env, params, args)
-    structure(list(ast=ast,
+    structure(list(eval=eval,
+                   ast=ast,
                    env=env,
                    params=params,
-                   gen_env=gen_env), class="MalFunc")
+                   gen_env=gen_env,
+                   ismacro=TRUE), class="MalFunc")
+}
+.malfunc_q <- function(obj) "MalFunc" == class(obj)
+
+fapply <- function(mf, args) {
+    if (class(mf) == "MalFunc") {
+        ast <- mf$ast
+        env <- mf$gen_env(args)
+        mf$eval(ast, env)
+    } else {
+        #print(args)
+        do.call(mf,args)
+    }
 }
 
 # Lists

tests/step7_quote.mal

@@ -99,6 +99,15 @@
 ;;
 ;; -------- Optional Functionality --------
 
+;; Testing cons, concat, first, rest with vectors
+
+(cons [1] [2 3])
+;=>([1] 2 3)
+(cons 1 [2 3])
+;=>(1 2 3)
+(concat [1 2] (list 3 4) [5 6])
+;=>(1 2 3 4 5 6)
+
 ;; Testing unquote with vectors
 (def! a 8)
 ;=>8
@@ -114,3 +123,4 @@
 ;=>(1 1 "b" "d" 3)
 ;;; TODO: fix this
 ;;;;=>[1 1 "b" "d" 3]
+

tests/step8_macros.mal

@@ -114,14 +114,17 @@
 ;;
 ;; -------- Optional Functionality --------
 
-;; Testing cons, concat, first, rest with vectors
+;; Testing nth, first, rest with vectors
+
+(nth [] 0)
+;=>nil
+(nth [1] 0)
+;=>1
+(nth [1 2] 1)
+;=>2
+(nth [1 2] 2)
+;=>nil
 
-(cons [1] [2 3])
-;=>([1] 2 3)
-(cons 1 [2 3])
-;=>(1 2 3)
-(concat [1 2] (list 3 4) [5 6])
-;=>(1 2 3 4 5 6)
 (first [])
 ;=>nil
 (first [10])

tests/step9_try.mal

@@ -6,12 +6,12 @@
 ;=>nil
 
 ;;;TODO: fix so long lines don't trigger ANSI escape codes ;;;(try*
-;;;(try* (throw {"data" "foo"}) (catch* exc (do (prn "exc is:" exc) 7))) ;;;;
-;;;; "exc is:" {"data" "foo"} ;;;;=>7
+;;;(try* (throw ["data" "foo"]) (catch* exc (do (prn "exc is:" exc) 7))) ;;;;
+;;;; "exc is:" ["data" "foo"] ;;;;=>7
 ;;;;=>7
 
-(try* (throw {"data" "foo"}) (catch* exc (do (prn "err:" exc) 7)))
-; "err:" {"data" "foo"}
+(try* (throw ["data" "foo"]) (catch* exc (do (prn "err:" exc) 7)))
+; "err:" ["data" "foo"]
 ;=>7
 
 (try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7)))