kgcontinuations.c (9192B)
1 /* 2 ** kgcontinuations.c 3 ** Continuations 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 "kapplicative.h" 19 #include "koperative.h" 20 #include "ksymbol.h" 21 #include "kerror.h" 22 23 #include "kghelpers.h" 24 #include "kgcontinuations.h" 25 26 /* Continuations */ 27 void do_extended_cont(klisp_State *K); 28 29 /* 7.1.1 continuation? */ 30 /* uses typep */ 31 32 /* 7.2.2 call/cc */ 33 void call_cc(klisp_State *K) 34 { 35 TValue *xparams = K->next_xparams; 36 TValue ptree = K->next_value; 37 TValue denv = K->next_env; 38 klisp_assert(ttisenvironment(K->next_env)); 39 UNUSED(xparams); 40 bind_1tp(K, ptree, "combiner", ttiscombiner, comb); 41 42 TValue expr = klist(K, 2, comb, kget_cc(K)); 43 ktail_eval(K, expr, denv); 44 } 45 46 /* Helper for extend-continuation */ 47 void do_extended_cont(klisp_State *K) 48 { 49 TValue *xparams = K->next_xparams; 50 TValue obj = K->next_value; 51 klisp_assert(ttisnil(K->next_env)); 52 /* 53 ** xparams[0]: applicative 54 ** xparams[1]: environment 55 */ 56 TValue app = xparams[0]; 57 TValue underlying = kunwrap(app); 58 TValue env = xparams[1]; 59 60 TValue expr = kcons(K, underlying, obj); 61 ktail_eval(K, expr, env); 62 } 63 64 /* 7.2.3 extend-continuation */ 65 void extend_continuation(klisp_State *K) 66 { 67 TValue *xparams = K->next_xparams; 68 TValue ptree = K->next_value; 69 TValue denv = K->next_env; 70 klisp_assert(ttisenvironment(K->next_env)); 71 UNUSED(denv); 72 UNUSED(xparams); 73 74 bind_al2tp(K, ptree, 75 "continuation", ttiscontinuation, cont, 76 "applicative", ttisapplicative, app, 77 maybe_env); 78 79 TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))? 80 maybe_env : kmake_empty_environment(K); 81 82 krooted_tvs_push(K, env); 83 TValue new_cont = kmake_continuation(K, cont, 84 do_extended_cont, 2, app, env); 85 krooted_tvs_pop(K); 86 kapply_cc(K, new_cont); 87 } 88 89 /* 7.2.4 guard-continuation */ 90 void guard_continuation(klisp_State *K) 91 { 92 TValue *xparams = K->next_xparams; 93 TValue ptree = K->next_value; 94 TValue denv = K->next_env; 95 klisp_assert(ttisenvironment(K->next_env)); 96 UNUSED(xparams); 97 98 bind_3tp(K, ptree, "any", anytype, entry_guards, 99 "continuation", ttiscontinuation, cont, 100 "any", anytype, exit_guards); 101 102 entry_guards = check_copy_guards(K, "guard-continuation: entry guards", 103 entry_guards); 104 krooted_tvs_push(K, entry_guards); 105 106 exit_guards = check_copy_guards(K, "guard-continuation: exit guards", 107 exit_guards); 108 krooted_tvs_push(K, exit_guards); 109 110 TValue outer_cont = kmake_continuation(K, cont, do_pass_value, 111 2, entry_guards, denv); 112 krooted_tvs_push(K, outer_cont); 113 /* mark it as an outer continuation */ 114 kset_outer_cont(outer_cont); 115 TValue inner_cont = kmake_continuation(K, outer_cont, 116 do_pass_value, 2, exit_guards, denv); 117 /* mark it as an outer continuation */ 118 kset_inner_cont(inner_cont); 119 120 krooted_tvs_pop(K); 121 krooted_tvs_pop(K); 122 krooted_tvs_pop(K); 123 124 kapply_cc(K, inner_cont); 125 } 126 127 /* 7.2.5 continuation->applicative */ 128 void continuation_applicative(klisp_State *K) 129 { 130 TValue *xparams = K->next_xparams; 131 TValue ptree = K->next_value; 132 TValue denv = K->next_env; 133 klisp_assert(ttisenvironment(K->next_env)); 134 135 UNUSED(xparams); 136 UNUSED(denv); 137 138 bind_1tp(K, ptree, "continuation", 139 ttiscontinuation, cont); 140 TValue app = kmake_applicative(K, cont_app, 1, cont); 141 kapply_cc(K, app); 142 } 143 144 /* 7.2.6 root-continuation */ 145 static void do_root_exit(klisp_State *K) 146 { 147 TValue *xparams = K->next_xparams; 148 TValue obj = K->next_value; 149 klisp_assert(ttisnil(K->next_env)); 150 UNUSED(xparams); 151 152 /* TODO/REFACTOR move this to a end_loop function in kstate.c */ 153 /* Just save the value and end the loop */ 154 K->next_value = obj; 155 K->next_func = NULL; /* force the loop to terminate */ 156 return; 157 } 158 159 160 static void kinit_root_cont(klisp_State *K) 161 { 162 klisp_assert(ttisinert(G(K)->root_cont)); 163 G(K)->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0); 164 TValue str, tail, si; 165 #if KTRACK_SI 166 /* Add source info to the cont */ 167 str = kstring_new_b_imm(K, __FILE__); 168 tail = kcons(K, i2tv(__LINE__), i2tv(0)); 169 si = kcons(K, str, tail); 170 kset_source_info(K, G(K)->root_cont, si); 171 #endif 172 } 173 174 /* 7.2.7 error-continuation */ 175 /* done in kgerrors.c */ 176 177 /* 178 ** 7.3 Library features 179 */ 180 181 /* 7.3.1 apply-continuation */ 182 void apply_continuation(klisp_State *K) 183 { 184 TValue *xparams = K->next_xparams; 185 TValue ptree = K->next_value; 186 TValue denv = K->next_env; 187 klisp_assert(ttisenvironment(K->next_env)); 188 UNUSED(xparams); 189 UNUSED(denv); 190 191 bind_2tp(K, ptree, "continuation", ttiscontinuation, 192 cont, "any", anytype, obj); 193 194 /* kcall_cont is from kstate, it handles dynamic vars & 195 interceptions */ 196 kcall_cont(K, cont, obj); 197 } 198 199 /* 7.3.2 $let/cc */ 200 void Slet_cc(klisp_State *K) 201 { 202 TValue *xparams = K->next_xparams; 203 TValue ptree = K->next_value; 204 TValue denv = K->next_env; 205 klisp_assert(ttisenvironment(K->next_env)); 206 UNUSED(xparams); 207 /* from the report: #ignore is not ok, only symbol */ 208 bind_al1tp(K, ptree, "symbol", ttissymbol, sym, objs); 209 210 if (ttisnil(objs)) { 211 /* we don't even bother creating the environment */ 212 kapply_cc(K, KINERT); 213 } else { 214 TValue new_env = kmake_environment(K, denv); 215 216 /* add binding may allocate, protect env, 217 keep in stack until continuation is allocated */ 218 krooted_tvs_push(K, new_env); 219 kadd_binding(K, new_env, sym, kget_cc(K)); 220 221 /* the list of instructions is copied to avoid mutation */ 222 /* MAYBE: copy the evaluation structure, ASK John */ 223 TValue ls = check_copy_list(K, objs, false, NULL, NULL); 224 krooted_tvs_push(K, ls); 225 226 /* this is needed because seq continuation doesn't check for 227 nil sequence */ 228 TValue tail = kcdr(ls); 229 if (ttispair(tail)) { 230 TValue new_cont = kmake_continuation(K, kget_cc(K), 231 do_seq, 2, tail, new_env); 232 kset_cc(K, new_cont); 233 } 234 235 krooted_tvs_pop(K); 236 krooted_tvs_pop(K); 237 238 ktail_eval(K, kcar(ls), new_env); 239 } 240 } 241 242 /* 7.3.3 guard-dynamic-extent */ 243 /* in kghelpers */ 244 245 /* 7.3.4 exit */ 246 /* Unlike in the report, in klisp this takes an optional argument 247 to be passed to the root continuation (defaults to #inert) */ 248 void kgexit(klisp_State *K) 249 { 250 TValue *xparams = K->next_xparams; 251 TValue ptree = K->next_value; 252 TValue denv = K->next_env; 253 klisp_assert(ttisenvironment(K->next_env)); 254 UNUSED(denv); 255 UNUSED(xparams); 256 257 TValue obj = ptree; 258 if (!get_opt_tpar(K, obj, "any", anytype)) 259 obj = KINERT; 260 261 /* guards and dynamic variables are handled in kcall_cont() */ 262 kcall_cont(K, G(K)->root_cont, obj); 263 } 264 265 /* init ground */ 266 void kinit_continuations_ground_env(klisp_State *K) 267 { 268 TValue ground_env = G(K)->ground_env; 269 TValue symbol, value; 270 271 /* 7.1.1 continuation? */ 272 add_applicative(K, ground_env, "continuation?", typep, 2, symbol, 273 i2tv(K_TCONTINUATION)); 274 /* 7.2.2 call/cc */ 275 add_applicative(K, ground_env, "call/cc", call_cc, 0); 276 /* 7.2.3 extend-continuation */ 277 add_applicative(K, ground_env, "extend-continuation", extend_continuation, 278 0); 279 /* 7.2.4 guard-continuation */ 280 add_applicative(K, ground_env, "guard-continuation", guard_continuation, 281 0); 282 /* 7.2.5 continuation->applicative */ 283 add_applicative(K, ground_env, "continuation->applicative", 284 continuation_applicative, 0); 285 /* 7.2.6 root-continuation */ 286 kinit_root_cont(K); 287 add_value(K, ground_env, "root-continuation", G(K)->root_cont); 288 289 /* 7.2.7 error-continuation */ 290 /* done in kgerrors.c */ 291 292 /* 7.3.1 apply-continuation */ 293 add_applicative(K, ground_env, "apply-continuation", apply_continuation, 294 0); 295 /* 7.3.2 $let/cc */ 296 add_operative(K, ground_env, "$let/cc", Slet_cc, 297 0); 298 /* 7.3.3 guard-dynamic-extent */ 299 add_applicative(K, ground_env, "guard-dynamic-extent", 300 guard_dynamic_extent, 0); 301 /* 7.3.4 exit */ 302 add_applicative(K, ground_env, "exit", kgexit, 303 0); 304 } 305 306 /* XXX lock? */ 307 /* init continuation names */ 308 void kinit_continuations_cont_names(klisp_State *K) 309 { 310 Table *t = tv2table(G(K)->cont_name_table); 311 312 add_cont_name(K, t, do_extended_cont, "extended-cont"); 313 add_cont_name(K, t, do_root_exit, "exit"); 314 /* this is defined in kcontinuation.c */ 315 add_cont_name(K, t, do_interception, "do-interception"); 316 }