Commit | Line | Data |
---|---|---|
4d1456b9 JM |
1 | ..types.. <- TRUE |
2 | ||
01feedfe JM |
3 | if(!exists("..env..")) source("env.r") |
4 | ||
4d1456b9 | 5 | # General type related functions |
01feedfe JM |
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) | |
f947d503 | 11 | if (start > end) lst <- list() else lst <- seq[start:end] |
01feedfe JM |
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 | }, | |
4be8abdf JM |
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 | }, | |
01feedfe JM |
52 | { |
53 | a == b | |
54 | }) | |
4d1456b9 JM |
55 | } |
56 | ||
36737ae5 JM |
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 | ||
4d1456b9 JM |
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 | ||
01feedfe JM |
86 | # Scalars |
87 | nil <- structure("malnil", class="nil") | |
88 | .nil_q <- function(obj) "nil" == class(obj) | |
8128c69a JM |
89 | .true_q <- function(obj) "logical" == class(obj) && obj == TRUE |
90 | .false_q <- function(obj) "logical" == class(obj) && obj == FALSE | |
defa41f3 JM |
91 | .string_q <- function(obj) { |
92 | "character" == class(obj) && | |
93 | !("\u029e" == substr(obj,1,1) || | |
94 | "<U+029E>" == substring(obj,1,8)) | |
95 | } | |
b8ee29b2 | 96 | |
defa41f3 | 97 | new.symbol <- function(name) structure(name, class="Symbol") |
c30efef4 | 98 | .symbol_q <- function(obj) "Symbol" == class(obj) |
defa41f3 | 99 | |
b8ee29b2 JM |
100 | new.keyword <- function(name) concat("\u029e", name) |
101 | .keyword_q <- function(obj) { | |
dbac60df JM |
102 | "character" == class(obj) && |
103 | ("\u029e" == substr(obj,1,1) || | |
104 | "<U+029E>" == substring(obj,1,8)) | |
b8ee29b2 | 105 | } |
01feedfe | 106 | |
677cfe0c DM |
107 | .number_q <- function(obj) "numeric" == class(obj) || "integer" == class(obj) |
108 | ||
01feedfe JM |
109 | # Functions |
110 | ||
8128c69a | 111 | malfunc <- function(eval, ast, env, params) { |
01feedfe | 112 | gen_env <- function(args) new.Env(env, params, args) |
8128c69a JM |
113 | structure(list(eval=eval, |
114 | ast=ast, | |
01feedfe JM |
115 | env=env, |
116 | params=params, | |
8128c69a | 117 | gen_env=gen_env, |
f947d503 | 118 | ismacro=FALSE), class="MalFunc") |
8128c69a JM |
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 | } | |
01feedfe JM |
131 | } |
132 | ||
677cfe0c DM |
133 | .fn_q <- function(obj) "function" == class(obj) || (.malfunc_q(obj) && !obj$ismacro) |
134 | .macro_q <- function(obj) .malfunc_q(obj) && obj$ismacro | |
135 | ||
4d1456b9 | 136 | # Lists |
36737ae5 JM |
137 | new.list <- function(...) new.listl(list(...)) |
138 | new.listl <- function(lst) { class(lst) <- "List"; lst } | |
4d1456b9 JM |
139 | .list_q <- function(obj) "List" == class(obj) |
140 | ||
141 | # Vectors | |
36737ae5 JM |
142 | new.vector <- function(...) new.vectorl(list(...)) |
143 | new.vectorl <- function(lst) { class(lst) <- "Vector"; lst } | |
4d1456b9 JM |
144 | .vector_q <- function(obj) "Vector" == class(obj) |
145 | ||
36737ae5 JM |
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) | |
f947d503 JM |
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) |