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 > length(seq)) 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     {
  44         a == b
  45     })
  46 }
  47
  48 .clone <- function(obj) {
  49     if (.hash_map_q(obj)) {
  50         new_obj <- new.env()
  51         for(k in ls(obj, all.names=TRUE)) new_obj[[k]] = obj[[k]]
  52         class(new_obj) <- "HashMap"
  53     } else {
  54         new_obj <- obj
  55     }
  56     new_obj
  57 }
  58
  59 # Errors/exceptions
  60 thrown_error = new.env()
  61 thrown_error$val = NULL
  62 throw <- function(obj) {
  63     thrown_error$val = obj
  64     stop("<mal_exception>")
  65 }
  66 get_error <- function(e) {
  67     estr <- e$message
  68     if (estr == "<mal_exception>") {
  69         err <- thrown_error$val
  70         thrown_error$val <- NULL
  71         err
  72     } else {
  73         estr
  74     }
  75 }
  76
  77 # Scalars
  78 nil <- structure("malnil", class="nil")
  79 .nil_q <- function(obj) "nil" == class(obj)
  80 .true_q <- function(obj) "logical" == class(obj) && obj == TRUE
  81 .false_q <- function(obj) "logical" == class(obj) && obj == FALSE
  82 new.symbol <- function(name) structure(name, class="Symbol")
  83 .symbol_q <- function(obj) "Symbol" == class(obj)
  84
  85 # Functions
  86
  87 malfunc <- function(eval, ast, env, params) {
  88     gen_env <- function(args) new.Env(env, params, args)
  89     structure(list(eval=eval,
  90                    ast=ast,
  91                    env=env,
  92                    params=params,
  93                    gen_env=gen_env,
  94                    ismacro=TRUE), class="MalFunc")
  95 }
  96 .malfunc_q <- function(obj) "MalFunc" == class(obj)
  97
  98 fapply <- function(mf, args) {
  99     if (class(mf) == "MalFunc") {
 100         ast <- mf$ast
 101         env <- mf$gen_env(args)
 102         mf$eval(ast, env)
 103     } else {
 104         #print(args)
 105         do.call(mf,args)
 106     }
 107 }
 108
 109 # Lists
 110 new.list <- function(...) new.listl(list(...))
 111 new.listl <- function(lst) { class(lst) <- "List"; lst }
 112 .list_q <- function(obj) "List" == class(obj)
 113
 114 # Vectors
 115 new.vector <- function(...) new.vectorl(list(...))
 116 new.vectorl <- function(lst) { class(lst) <- "Vector"; lst }
 117 .vector_q <- function(obj) "Vector" == class(obj)
 118
 119 # Hash Maps
 120 new.hash_map <- function(...) new.hash_mapl(list(...))
 121 new.hash_mapl <- function(lst) {
 122     .assoc(new.env(), lst)
 123 }
 124 .assoc <- function(src_hm, lst) {
 125     hm <- .clone(src_hm)
 126     if (length(lst) > 0) {
 127         for(i in seq(1,length(lst),2)) {
 128             hm[[lst[[i]]]] <- lst[[i+1]]
 129         }
 130     }
 131     class(hm) <- "HashMap"
 132     hm
 133 }
 134 .dissoc <- function(src_hm, lst) {
 135     hm <- .clone(src_hm)
 136     if (length(lst) > 0) {
 137         for(k in lst) {
 138             remove(list=c(k), envir=hm)
 139         }
 140     }
 141     ls(hm)
 142     class(hm) <- "HashMap"
 143     hm
 144 }
 145 .hash_map_q <- function(obj) "HashMap" == class(obj)