kgenv_mut.c (10093B)
1 /* 2 ** kgenv_mut.c 3 ** Environment mutation features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <assert.h> 8 #include <stdio.h> 9 #include <stdlib.h> 10 #include <stdbool.h> 11 #include <stdint.h> 12 13 #include "kstate.h" 14 #include "kobject.h" 15 #include "kpair.h" 16 #include "kenvironment.h" 17 #include "kcontinuation.h" 18 #include "ksymbol.h" 19 #include "kerror.h" 20 21 #include "kghelpers.h" 22 #include "kgenv_mut.h" 23 24 /* Continuations */ 25 void do_match(klisp_State *K); 26 void do_set_eval_obj(klisp_State *K); 27 void do_import(klisp_State *K); 28 29 /* 4.9.1 $define! */ 30 void SdefineB(klisp_State *K) 31 { 32 TValue *xparams = K->next_xparams; 33 TValue ptree = K->next_value; 34 TValue denv = K->next_env; 35 klisp_assert(ttisenvironment(K->next_env)); 36 /* 37 ** xparams[0] = define symbol 38 */ 39 bind_2p(K, ptree, dptree, expr); 40 41 TValue def_sym = xparams[0]; 42 43 dptree = check_copy_ptree(K, dptree, KIGNORE); 44 45 krooted_tvs_push(K, dptree); 46 47 TValue new_cont = kmake_continuation(K, kget_cc(K), 48 do_match, 3, dptree, denv, 49 def_sym); 50 kset_cc(K, new_cont); 51 krooted_tvs_pop(K); 52 ktail_eval(K, expr, denv); 53 } 54 55 /* helper */ 56 void do_match(klisp_State *K) 57 { 58 TValue *xparams = K->next_xparams; 59 TValue obj = K->next_value; 60 klisp_assert(ttisnil(K->next_env)); 61 /* 62 ** xparams[0]: ptree 63 ** xparams[1]: dynamic environment 64 ** xparams[2]: combiner symbol 65 */ 66 TValue ptree = xparams[0]; 67 TValue env = xparams[1]; 68 69 match(K, env, ptree, obj); 70 kapply_cc(K, KINERT); 71 } 72 73 /* 6.8.1 $set! */ 74 void SsetB(klisp_State *K) 75 { 76 TValue *xparams = K->next_xparams; 77 TValue ptree = K->next_value; 78 TValue denv = K->next_env; 79 klisp_assert(ttisenvironment(K->next_env)); 80 UNUSED(denv); 81 82 TValue sname = xparams[0]; 83 84 bind_3p(K, ptree, env_exp, raw_formals, eval_exp); 85 86 TValue formals = check_copy_ptree(K, raw_formals, KIGNORE); 87 krooted_tvs_push(K, formals); 88 89 TValue new_cont = 90 kmake_continuation(K, kget_cc(K), do_set_eval_obj, 4, 91 sname, formals, eval_exp, denv); 92 kset_cc(K, new_cont); 93 94 krooted_tvs_pop(K); 95 ktail_eval(K, env_exp, denv); 96 } 97 98 /* Helpers for $set! */ 99 void do_set_eval_obj(klisp_State *K) 100 { 101 TValue *xparams = K->next_xparams; 102 TValue obj = K->next_value; 103 klisp_assert(ttisnil(K->next_env)); 104 /* 105 ** xparams[0]: name as symbol 106 ** xparams[1]: ptree 107 ** xparams[2]: expression to be eval'ed 108 ** xparams[3]: dynamic environment 109 */ 110 TValue sname = xparams[0]; 111 TValue formals = xparams[1]; 112 TValue eval_exp = xparams[2]; 113 TValue denv = xparams[3]; 114 115 if (!ttisenvironment(obj)) { 116 klispE_throw_simple(K, "bad type from first " 117 "operand evaluation (expected environment)"); 118 return; 119 } else { 120 TValue env = obj; 121 122 TValue new_cont = 123 kmake_continuation(K, kget_cc(K), do_match, 3, 124 formals, env, sname); 125 kset_cc(K, new_cont); 126 ktail_eval(K, eval_exp, denv); 127 } 128 } 129 130 /* Helpers for $provide! & $import! */ 131 132 static inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls) 133 { 134 UNUSED(K); 135 while(ttispair(ls) && kis_marked(ls)) { 136 TValue first = kcar(ls); 137 if (ttissymbol(first)) 138 kunmark_symbol(first); 139 kunmark(ls); 140 ls = kcdr(ls); 141 } 142 } 143 144 /* 145 ** Check that obj is a finite list of symbols with no duplicates and 146 ** returns a copy of the list (cf. check_copy_ptree) 147 */ 148 /* GC: Assumes obj is rooted */ 149 TValue check_copy_symbol_list(klisp_State *K, TValue obj) 150 { 151 TValue tail = obj; 152 bool type_errorp = false; 153 bool repeated_errorp = false; 154 TValue slist = kcons(K, KNIL, KNIL); 155 krooted_vars_push(K, &slist); 156 TValue last_pair = slist; 157 158 while(ttispair(tail) && !kis_marked(tail)) { 159 /* even if there is a type error continue checking the structure */ 160 TValue first = kcar(tail); 161 if (ttissymbol(first)) { 162 repeated_errorp |= kis_symbol_marked(first); 163 kmark_symbol(first); 164 } else { 165 type_errorp = true; 166 } 167 kmark(tail); 168 169 TValue new_pair = kcons(K, first, KNIL); 170 kset_cdr(last_pair, new_pair); 171 last_pair = new_pair; 172 173 tail = kcdr(tail); 174 } 175 unmark_maybe_symbol_list(K, obj); 176 177 if (!ttisnil(tail)) { 178 klispE_throw_simple(K, "expected finite list"); 179 return KNIL; 180 } else if (type_errorp) { 181 klispE_throw_simple(K, "bad operand type (expected list of " 182 "symbols)"); 183 return KNIL; 184 } else if (repeated_errorp) { 185 klispE_throw_simple(K, "repeated symbols"); 186 } 187 krooted_vars_pop(K); 188 return kcdr(slist); 189 } 190 191 void do_import(klisp_State *K) 192 { 193 TValue *xparams = K->next_xparams; 194 TValue obj = K->next_value; 195 klisp_assert(ttisnil(K->next_env)); 196 /* 197 ** xparams[0]: name as symbol 198 ** xparams[1]: symbols 199 ** xparams[2]: dynamic environment 200 */ 201 TValue sname = xparams[0]; 202 TValue symbols = xparams[1]; 203 TValue denv = xparams[2]; 204 205 if (!ttisenvironment(obj)) { 206 klispE_throw_simple(K, "bad type from first " 207 "operand evaluation (expected environment)"); 208 return; 209 } else { 210 TValue env = obj; 211 TValue new_cont = 212 kmake_continuation(K, kget_cc(K), do_match, 3, 213 symbols, denv, sname); 214 kset_cc(K, new_cont); 215 ktail_eval(K, kcons(K, G(K)->list_app, symbols), env); 216 } 217 } 218 219 /* 6.8.2 $provide! */ 220 void SprovideB(klisp_State *K) 221 { 222 TValue *xparams = K->next_xparams; 223 TValue ptree = K->next_value; 224 TValue denv = K->next_env; 225 klisp_assert(ttisenvironment(K->next_env)); 226 /* 227 ** xparams[0]: name as symbol 228 */ 229 TValue sname = xparams[0]; 230 231 bind_al1p(K, ptree, symbols, body); 232 233 symbols = check_copy_symbol_list(K, symbols); 234 krooted_tvs_push(K, symbols); 235 body = check_copy_list(K, body, false, NULL, NULL); 236 krooted_tvs_push(K, body); 237 238 TValue new_env = kmake_environment(K, denv); 239 /* this will copy the bindings from new_env to denv */ 240 krooted_tvs_push(K, new_env); 241 TValue import_cont = 242 kmake_continuation(K, kget_cc(K), do_import, 3, 243 sname, symbols, denv); 244 kset_cc(K, import_cont); /* this implicitly roots import_cont */ 245 /* this will ignore the last value and pass the env to the 246 above continuation */ 247 TValue ret_exp_cont = 248 kmake_continuation(K, import_cont, do_return_value, 249 1, new_env); 250 kset_cc(K, ret_exp_cont); /* this implicitly roots ret_exp_cont */ 251 252 if (ttisnil(body)) { 253 krooted_tvs_pop(K); 254 krooted_tvs_pop(K); 255 krooted_tvs_pop(K); 256 kapply_cc(K, KINERT); 257 } else { 258 /* this is needed because seq continuation doesn't check for 259 nil sequence */ 260 TValue tail = kcdr(body); 261 if (ttispair(tail)) { 262 TValue new_cont = kmake_continuation(K, kget_cc(K), 263 do_seq, 2, tail, new_env); 264 kset_cc(K, new_cont); 265 #if KTRACK_SI 266 /* put the source info of the list including the element 267 that we are about to evaluate */ 268 kset_source_info(K, new_cont, ktry_get_si(K, body)); 269 #endif 270 } 271 krooted_tvs_pop(K); 272 krooted_tvs_pop(K); 273 krooted_tvs_pop(K); 274 ktail_eval(K, kcar(body), new_env); 275 } 276 } 277 278 /* 6.8.3 $import! */ 279 void SimportB(klisp_State *K) 280 { 281 TValue *xparams = K->next_xparams; 282 TValue ptree = K->next_value; 283 TValue denv = K->next_env; 284 klisp_assert(ttisenvironment(K->next_env)); 285 /* ASK John: The report says that symbols can have repeated symbols 286 and even be cyclical (cf $provide!) however this doesn't work 287 in the derivation (that uses $set! and so needs a ptree, which are 288 acyclical and with no repeated symbols). 289 Here I follow $provide! and don't allow repeated symbols or cyclical 290 lists, NOTE: is this restriction is to be lifted the code to copy the 291 list should guarantee to contruct an acyclical list or do_import be 292 changed to work with cyclical lists (at the moment it uses do_match 293 that expects a ptree (although it works with repeated symbols provided 294 they all have the same value, it loops indefinitely with cyclical ptree) 295 */ 296 /* 297 ** xparams[0]: name as symbol 298 */ 299 TValue sname = xparams[0]; 300 301 bind_al1p(K, ptree, env_expr, symbols); 302 303 symbols = check_copy_symbol_list(K, symbols); 304 305 /* REFACTOR/ASK John: another way for this kind of operative would be 306 to first eval the env expression and only then check the type 307 of the symbol list (other operatives that could use this model to 308 avoid copying are $set!, $define! & $binds?) */ 309 310 krooted_tvs_push(K, symbols); 311 TValue new_cont = 312 kmake_continuation(K, kget_cc(K), do_import, 3, 313 sname, symbols, denv); 314 kset_cc(K, new_cont); 315 krooted_tvs_pop(K); 316 ktail_eval(K, env_expr, denv); 317 } 318 319 /* init ground */ 320 void kinit_env_mut_ground_env(klisp_State *K) 321 { 322 TValue ground_env = G(K)->ground_env; 323 TValue symbol, value; 324 325 /* 4.9.1 $define! */ 326 add_operative(K, ground_env, "$define!", SdefineB, 1, symbol); 327 /* 6.8.1 $set! */ 328 add_operative(K, ground_env, "$set!", SsetB, 1, symbol); 329 /* 6.8.2 $provide! */ 330 add_operative(K, ground_env, "$provide!", SprovideB, 1, symbol); 331 /* 6.8.3 $import! */ 332 add_operative(K, ground_env, "$import!", SimportB, 1, symbol); 333 } 334 335 /* XXX lock? */ 336 /* init continuation names */ 337 void kinit_env_mut_cont_names(klisp_State *K) 338 { 339 Table *t = tv2table(G(K)->cont_name_table); 340 341 add_cont_name(K, t, do_match, "match-ptree"); 342 add_cont_name(K, t, do_set_eval_obj, "set-eval-obj"); 343 add_cont_name(K, t, do_import, "import-bindings"); 344 } 345