R: add hash-map and metadata support.

r/core.r

@@ -6,20 +6,35 @@ if(!exists("..printer..")) source("printer.r")
 
 # String functions
 
-pr_str <- function(...) .pr_list(..., print_readably=TRUE, join=" ")
+pr_str <- function(...)
+    .pr_list(list(...), print_readably=TRUE, join=" ")
 
-str <- function(...) .pr_list(..., print_readably=FALSE, join="")
+str <- function(...)
+    .pr_list(list(...), print_readably=FALSE, join="")
 
 prn <- function(...) {
-    cat(.pr_list(..., print_readably=TRUE, join=" ")); cat("\n")
+    cat(.pr_list(list(...), print_readably=TRUE, join=" "))
+    cat("\n")
     nil
 }
 
 println <- function(...) {
-    cat(.pr_list(..., print_readably=FALSE, join=" ")); cat("\n")
+    cat(.pr_list(list(...), print_readably=FALSE, join=" "))
+    cat("\n")
     nil
 }
 
+# Hash Map functions
+do_get <- function(hm,k) {
+    if (class(hm) == "nil") return(nil)
+    v <- hm[[k]]
+    if (is.null(v)) nil else v
+}
+contains_q <-function(hm,k) {
+    if (class(hm) == "nil") return(FALSE)
+    if (is.null(hm[[k]])) FALSE else TRUE
+}
+
 # Sequence functions
 cons <- function(a,b) {
     new_lst <- append(list(a), b)
@@ -50,6 +65,18 @@ map <- function(f, seq) {
     new.listl(lapply(seq, function(el) fapply(f, el)))
 }
 
+# Metadata functions
+with_meta <- function(obj, m) {
+    new_obj <- .clone(obj)
+    attr(new_obj, "meta") <- m
+    new_obj
+}
+
+meta <- function(obj) {
+    m <- attr(obj, "meta")
+    if (is.null(m)) nil else m
+}
+
 core_ns <- list(
     "="=function(a,b) .equal_q(a,b),
     "throw"=function(err) throw(err),
@@ -80,8 +107,14 @@ core_ns <- 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),
+    "hash-map"=new.hash_map,
+    "map?"=function(a) .hash_map_q(a),
+    "assoc"=function(hm,...) .assoc(hm,list(...)),
+    "dissoc"=function(hm,...) .dissoc(hm,list(...)),
+    "get"=do_get,
+    "contains?"=contains_q,
+    "keys"=function(hm) new.listl(ls(hm)),
+    "vals"=function(hm) new.listl(lapply(ls(hm), function(x) hm[[x]])),
 
     "sequential?"=.sequential_q,
     "cons"=cons,
@@ -89,6 +122,11 @@ core_ns <- list(
     "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)),
+    "empty?"=function(a) .sequential_q(a) && length(a) == 0,
+    "count"=function(a) length(a),
     "apply"=do_apply,
-    "map"=map
+    "map"=map,
+
+    "with-meta"=with_meta,
+    "meta"=meta
 )

r/printer.r

@@ -2,8 +2,8 @@
 
 if(!exists("..types..")) source("types.r")
 
-.pr_list <- function(..., print_readably=TRUE, join="") {
-    concatl(lapply(list(...),
+.pr_list <- function(lst, print_readably=TRUE, join="") {
+    concatl(lapply(lst,
                    function(e) .pr_str(e, print_readably)), sep=join)
 }
 
@@ -11,14 +11,20 @@ if(!exists("..types..")) source("types.r")
     pr <- print_readably
     switch(class(exp),
         "List"={
-            data <- paste(lapply(exp, function(e) .pr_str(e, pr)),
-                          sep="", collapse=" ")
-            paste("(", data, ")", sep="", collapse="")
+            paste("(", .pr_list(exp, pr, " "), ")", sep="", collapse="")
         },
         "Vector"={
-            data <- paste(lapply(exp, function(e) .pr_str(e, pr)),
-                          sep=" ", collapse=" ")
-            paste("[", data, "]", sep="", collapse="")
+            paste("[", .pr_list(exp, pr, " "), "]", sep="", collapse="")
+        },
+        "HashMap"={
+            hlst <- list()
+            if (length(exp) > 0) {
+                for(k in ls(exp)) {
+                    hlst[[length(hlst)+1]] <- k
+                    hlst[[length(hlst)+1]] <- exp[[k]]
+                }
+            }
+            paste("{", .pr_list(hlst, pr, " "), "}", sep="", collapse="")
         },
         "character"={
             if (print_readably) {

r/reader.r

@@ -89,6 +89,13 @@ read_form <- function(rdr) {
     } else if (token == "~@") {
         . <- Reader.next(rdr);
         new.list(new.symbol("splice-unquote"), read_form(rdr))
+    } else if (token == "^") {
+        . <- Reader.next(rdr)
+        m <- read_form(rdr)
+        new.list(new.symbol("with-meta"), read_form(rdr), m)
+    } else if (token == "@") {
+        . <- Reader.next(rdr);
+        new.list(new.symbol("deref"), read_form(rdr))
     } else if (token == ")") {
         throw("unexpected ')'")
     } else if (token == "(") {
@@ -97,6 +104,10 @@ read_form <- function(rdr) {
         throw("unexpected ']'")
     } else if (token == "[") {
         new.vectorl(read_seq(rdr, "[", "]"))
+    } else if (token == "}") {
+        throw("unexpected '}'")
+    } else if (token == "{") {
+        new.hash_mapl(read_seq(rdr, "{", "}"))
     } else {
         read_atom(rdr)
     }

r/step2_eval.r

@@ -14,6 +14,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/step3_env.r

@@ -15,6 +15,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }
@@ -29,9 +36,9 @@ EVAL <- function(ast, env) {
     # apply list
     switch(paste("l",length(ast),sep=""),
            l0={ return(ast) },
-           l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL },
+           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]] })
+              { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] })
     a0sym <- as.character(a0)
     if (a0sym == "def!") {
         res <- EVAL(ast[[3]], env)

r/step4_if_fn_do.r

@@ -16,6 +16,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }
@@ -30,9 +37,9 @@ EVAL <- function(ast, env) {
     # apply list
     switch(paste("l",length(ast),sep=""),
            l0={ return(ast) },
-           l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL },
+           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]] })
+              { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] })
     if (length(a0) > 1) a0sym <- "__<*fn*>__"
     else                a0sym <- as.character(a0)
     if (a0sym == "def!") {

r/step5_tco.r

@@ -16,6 +16,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/step6_file.r

@@ -16,6 +16,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/step7_quote.r

@@ -41,6 +41,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/step8_macros.r

@@ -59,6 +59,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/step9_try.r

@@ -59,6 +59,13 @@ eval_ast <- function(ast, env) {
         new.listl(lapply(ast, function(a) EVAL(a, env)))
     } else if (.vector_q(ast)) {
         new.vectorl(lapply(ast, function(a) EVAL(a, env)))
+    } else if (.hash_map_q(ast)) {
+        lst <- list()
+        for(k in ls(ast)) {
+            lst[[length(lst)+1]] = k
+            lst[[length(lst)+1]] = EVAL(ast[[k]], env)
+        }
+        new.hash_mapl(lst)
     } else {
         ast
     }

r/types.r

@@ -45,6 +45,17 @@ slice <- function(seq, start=1, end=-1) {
     })
 }
 
+.clone <- function(obj) {
+    if (.hash_map_q(obj)) {
+        new_obj <- new.env()
+        for(k in ls(obj, all.names=TRUE)) new_obj[[k]] = obj[[k]]
+        class(new_obj) <- "HashMap"
+    } else {
+        new_obj <- obj
+    }
+    new_obj
+}
+
 # Errors/exceptions
 thrown_error = new.env()
 thrown_error$val = NULL
@@ -96,26 +107,39 @@ fapply <- function(mf, args) {
 }
 
 # Lists
-new.list <- function(...) {
-    lst <- list(...)
-    class(lst) <- "List"
-    lst
-}
-new.listl <- function(lst) {
-    class(lst) <- "List"
-    lst
-}
+new.list <- function(...) new.listl(list(...))
+new.listl <- function(lst) { class(lst) <- "List"; lst }
 .list_q <- function(obj) "List" == class(obj)
 
 # Vectors
-new.vector <- function(...) {
-    lst <- list(...)
-    class(lst) <- "Vector"
-    lst
-}
-new.vectorl <- function(lst) {
-    class(lst) <- "Vector"
-    lst
-}
+new.vector <- function(...) new.vectorl(list(...))
+new.vectorl <- function(lst) { class(lst) <- "Vector"; lst }
 .vector_q <- function(obj) "Vector" == class(obj)
 
+# Hash Maps
+new.hash_map <- function(...) new.hash_mapl(list(...))
+new.hash_mapl <- function(lst) {
+    .assoc(new.env(), lst)
+}
+.assoc <- function(src_hm, lst) {
+    hm <- .clone(src_hm)
+    if (length(lst) > 0) {
+        for(i in seq(1,length(lst),2)) {
+            hm[[lst[[i]]]] <- lst[[i+1]]
+        }
+    }
+    class(hm) <- "HashMap"
+    hm
+}
+.dissoc <- function(src_hm, lst) {
+    hm <- .clone(src_hm)
+    if (length(lst) > 0) {
+        for(k in lst) {
+            remove(list=c(k), envir=hm)
+        }
+    }
+    ls(hm)
+    class(hm) <- "HashMap"
+    hm
+}
+.hash_map_q <- function(obj) "HashMap" == class(obj)