| 1 | ..types.. <- TRUE |
| 2 | |
| 3 | if(!exists("..env..")) source("env.r") |
| 4 | |
| 5 | # General type related functions |
| 6 | concat <- function(..., sep="") paste(..., collapse="", sep=sep) |
| 7 | concatl <- function(lst, sep="") paste(lst, collapse=sep, sep=sep) |
| 8 | |
| 9 | slice <- function(seq, start=1, end=-1) { |
| 10 | if (end == -1) end <- length(seq) |
| 11 | if (start > end) lst <- list() else lst <- seq[start:end] |
| 12 | switch(class(seq), |
| 13 | list={ new.listl(lst) }, |
| 14 | List={ new.listl(lst) }, |
| 15 | Vector={ new.vectorl(lst) }, |
| 16 | { throw("slice called on non-sequence") }) |
| 17 | } |
| 18 | |
| 19 | .sequential_q <- function(obj) .list_q(obj) || .vector_q(obj) |
| 20 | |
| 21 | .equal_q <- function(a,b) { |
| 22 | ota <- class(a); otb <- class(b) |
| 23 | if (!((ota == otb) || (.sequential_q(a) && .sequential_q(b)))) { |
| 24 | return(FALSE) |
| 25 | } |
| 26 | switch(ota, |
| 27 | "List"={ |
| 28 | if (length(a) != length(b)) return(FALSE) |
| 29 | if (length(a) == 0) return(TRUE) |
| 30 | for(i in seq(length(a))) { |
| 31 | if (!.equal_q(a[[i]],b[[i]])) return(FALSE) |
| 32 | } |
| 33 | TRUE |
| 34 | }, |
| 35 | "Vector"={ |
| 36 | if (length(a) != length(b)) return(FALSE) |
| 37 | if (length(a) == 0) return(TRUE) |
| 38 | for(i in seq(length(a))) { |
| 39 | if (!.equal_q(a[[i]],b[[i]])) return(FALSE) |
| 40 | } |
| 41 | TRUE |
| 42 | }, |
| 43 | "HashMap"={ |
| 44 | ks1 <- ls(a) |
| 45 | ks2 <- ls(b) |
| 46 | if (length(ks1) != length(ks2)) return(FALSE) |
| 47 | for(k in ks1) { |
| 48 | if (!.equal_q(a[[k]],b[[k]])) return(FALSE) |
| 49 | } |
| 50 | TRUE |
| 51 | }, |
| 52 | { |
| 53 | a == b |
| 54 | }) |
| 55 | } |
| 56 | |
| 57 | .clone <- function(obj) { |
| 58 | if (.hash_map_q(obj)) { |
| 59 | new_obj <- new.env() |
| 60 | for(k in ls(obj, all.names=TRUE)) new_obj[[k]] = obj[[k]] |
| 61 | class(new_obj) <- "HashMap" |
| 62 | } else { |
| 63 | new_obj <- obj |
| 64 | } |
| 65 | new_obj |
| 66 | } |
| 67 | |
| 68 | # Errors/exceptions |
| 69 | thrown_error = new.env() |
| 70 | thrown_error$val = NULL |
| 71 | throw <- function(obj) { |
| 72 | thrown_error$val = obj |
| 73 | stop("<mal_exception>") |
| 74 | } |
| 75 | get_error <- function(e) { |
| 76 | estr <- e$message |
| 77 | if (estr == "<mal_exception>") { |
| 78 | err <- thrown_error$val |
| 79 | thrown_error$val <- NULL |
| 80 | err |
| 81 | } else { |
| 82 | estr |
| 83 | } |
| 84 | } |
| 85 | |
| 86 | # Scalars |
| 87 | nil <- structure("malnil", class="nil") |
| 88 | .nil_q <- function(obj) "nil" == class(obj) |
| 89 | .true_q <- function(obj) "logical" == class(obj) && obj == TRUE |
| 90 | .false_q <- function(obj) "logical" == class(obj) && obj == FALSE |
| 91 | .string_q <- function(obj) { |
| 92 | "character" == class(obj) && |
| 93 | !("\u029e" == substr(obj,1,1) || |
| 94 | "<U+029E>" == substring(obj,1,8)) |
| 95 | } |
| 96 | |
| 97 | new.symbol <- function(name) structure(name, class="Symbol") |
| 98 | .symbol_q <- function(obj) "Symbol" == class(obj) |
| 99 | |
| 100 | new.keyword <- function(name) concat("\u029e", name) |
| 101 | .keyword_q <- function(obj) { |
| 102 | "character" == class(obj) && |
| 103 | ("\u029e" == substr(obj,1,1) || |
| 104 | "<U+029E>" == substring(obj,1,8)) |
| 105 | } |
| 106 | |
| 107 | .number_q <- function(obj) "numeric" == class(obj) || "integer" == class(obj) |
| 108 | |
| 109 | # Functions |
| 110 | |
| 111 | malfunc <- function(eval, ast, env, params) { |
| 112 | gen_env <- function(args) new.Env(env, params, args) |
| 113 | structure(list(eval=eval, |
| 114 | ast=ast, |
| 115 | env=env, |
| 116 | params=params, |
| 117 | gen_env=gen_env, |
| 118 | ismacro=FALSE), class="MalFunc") |
| 119 | } |
| 120 | .malfunc_q <- function(obj) "MalFunc" == class(obj) |
| 121 | |
| 122 | fapply <- function(mf, args) { |
| 123 | if (class(mf) == "MalFunc") { |
| 124 | ast <- mf$ast |
| 125 | env <- mf$gen_env(args) |
| 126 | mf$eval(ast, env) |
| 127 | } else { |
| 128 | #print(args) |
| 129 | do.call(mf,args) |
| 130 | } |
| 131 | } |
| 132 | |
| 133 | .fn_q <- function(obj) "function" == class(obj) || (.malfunc_q(obj) && !obj$ismacro) |
| 134 | .macro_q <- function(obj) .malfunc_q(obj) && obj$ismacro |
| 135 | |
| 136 | # Lists |
| 137 | new.list <- function(...) new.listl(list(...)) |
| 138 | new.listl <- function(lst) { class(lst) <- "List"; lst } |
| 139 | .list_q <- function(obj) "List" == class(obj) |
| 140 | |
| 141 | # Vectors |
| 142 | new.vector <- function(...) new.vectorl(list(...)) |
| 143 | new.vectorl <- function(lst) { class(lst) <- "Vector"; lst } |
| 144 | .vector_q <- function(obj) "Vector" == class(obj) |
| 145 | |
| 146 | # Hash Maps |
| 147 | new.hash_map <- function(...) new.hash_mapl(list(...)) |
| 148 | new.hash_mapl <- function(lst) { |
| 149 | .assoc(new.env(), lst) |
| 150 | } |
| 151 | .assoc <- function(src_hm, lst) { |
| 152 | hm <- .clone(src_hm) |
| 153 | if (length(lst) > 0) { |
| 154 | for(i in seq(1,length(lst),2)) { |
| 155 | hm[[lst[[i]]]] <- lst[[i+1]] |
| 156 | } |
| 157 | } |
| 158 | class(hm) <- "HashMap" |
| 159 | hm |
| 160 | } |
| 161 | .dissoc <- function(src_hm, lst) { |
| 162 | hm <- .clone(src_hm) |
| 163 | if (length(lst) > 0) { |
| 164 | for(k in lst) { |
| 165 | remove(list=c(k), envir=hm) |
| 166 | } |
| 167 | } |
| 168 | ls(hm) |
| 169 | class(hm) <- "HashMap" |
| 170 | hm |
| 171 | } |
| 172 | .hash_map_q <- function(obj) "HashMap" == class(obj) |
| 173 | |
| 174 | # Atoms |
| 175 | new.atom <- function(val) { |
| 176 | atm <- new.env() |
| 177 | class(atm) <- "Atom" |
| 178 | atm$val <- .clone(val) |
| 179 | atm |
| 180 | } |
| 181 | .atom_q <- function(obj) "Atom" == class(obj) |