r/types.r

   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 # Functions
 108
 109 malfunc <- function(eval, ast, env, params) {
 110     gen_env <- function(args) new.Env(env, params, args)
 111     structure(list(eval=eval,
 112                    ast=ast,
 113                    env=env,
 114                    params=params,
 115                    gen_env=gen_env,
 116                    ismacro=FALSE), class="MalFunc")
 117 }
 118 .malfunc_q <- function(obj) "MalFunc" == class(obj)
 119
 120 fapply <- function(mf, args) {
 121     if (class(mf) == "MalFunc") {
 122         ast <- mf$ast
 123         env <- mf$gen_env(args)
 124         mf$eval(ast, env)
 125     } else {
 126         #print(args)
 127         do.call(mf,args)
 128     }
 129 }
 130
 131 # Lists
 132 new.list <- function(...) new.listl(list(...))
 133 new.listl <- function(lst) { class(lst) <- "List"; lst }
 134 .list_q <- function(obj) "List" == class(obj)
 135
 136 # Vectors
 137 new.vector <- function(...) new.vectorl(list(...))
 138 new.vectorl <- function(lst) { class(lst) <- "Vector"; lst }
 139 .vector_q <- function(obj) "Vector" == class(obj)
 140
 141 # Hash Maps
 142 new.hash_map <- function(...) new.hash_mapl(list(...))
 143 new.hash_mapl <- function(lst) {
 144     .assoc(new.env(), lst)
 145 }
 146 .assoc <- function(src_hm, lst) {
 147     hm <- .clone(src_hm)
 148     if (length(lst) > 0) {
 149         for(i in seq(1,length(lst),2)) {
 150             hm[[lst[[i]]]] <- lst[[i+1]]
 151         }
 152     }
 153     class(hm) <- "HashMap"
 154     hm
 155 }
 156 .dissoc <- function(src_hm, lst) {
 157     hm <- .clone(src_hm)
 158     if (length(lst) > 0) {
 159         for(k in lst) {
 160             remove(list=c(k), envir=hm)
 161         }
 162     }
 163     ls(hm)
 164     class(hm) <- "HashMap"
 165     hm
 166 }
 167 .hash_map_q <- function(obj) "HashMap" == class(obj)
 168
 169 # Atoms
 170 new.atom <- function(val) {
 171     atm <- new.env()
 172     class(atm) <- "Atom"
 173     atm$val <- .clone(val)
 174     atm
 175 }
 176 .atom_q <- function(obj) "Atom" == class(obj)