kgcontrol.c (18867B)
1 /* 2 ** kgcontrol.c 3 ** Control 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 "kcontinuation.h" 17 #include "kerror.h" 18 19 #include "kghelpers.h" 20 #include "kgcontrol.h" 21 22 /* Continuations */ 23 void do_select_clause(klisp_State *K); 24 void do_cond(klisp_State *K); 25 void do_for_each(klisp_State *K); 26 void do_Swhen_Sunless(klisp_State *K); 27 28 /* 4.5.1 inert? */ 29 /* uses typep */ 30 31 /* 4.5.2 $if */ 32 33 /* ASK JOHN: both clauses should probably be copied (copy-es-immutable) */ 34 void Sif(klisp_State *K) 35 { 36 TValue *xparams = K->next_xparams; 37 TValue ptree = K->next_value; 38 TValue denv = K->next_env; 39 klisp_assert(ttisenvironment(K->next_env)); 40 UNUSED(denv); 41 UNUSED(xparams); 42 43 bind_3p(K, ptree, test, cons_c, alt_c); 44 45 TValue new_cont = 46 kmake_continuation(K, kget_cc(K), do_select_clause, 47 3, denv, cons_c, alt_c); 48 /* 49 ** Mark as a bool checking cont, not necessary but avoids a continuation 50 ** in the last evaluation in the common use of ($if ($or?/$and? ...) ...) 51 */ 52 kset_bool_check_cont(new_cont); 53 kset_cc(K, new_cont); 54 ktail_eval(K, test, denv); 55 } 56 57 void do_select_clause(klisp_State *K) 58 { 59 TValue *xparams = K->next_xparams; 60 TValue obj = K->next_value; 61 klisp_assert(ttisnil(K->next_env)); 62 /* 63 ** xparams[0]: dynamic env 64 ** xparams[1]: consequent clause 65 ** xparams[2]: alternative clause 66 */ 67 if (ttisboolean(obj)) { 68 TValue denv = xparams[0]; 69 TValue clause = bvalue(obj)? xparams[1] : xparams[2]; 70 ktail_eval(K, clause, denv); 71 } else { 72 klispE_throw_simple(K, "test is not a boolean"); 73 return; 74 } 75 } 76 77 /* 5.1.1 $sequence */ 78 void Ssequence(klisp_State *K) 79 { 80 TValue *xparams = K->next_xparams; 81 TValue ptree = K->next_value; 82 TValue denv = K->next_env; 83 klisp_assert(ttisenvironment(K->next_env)); 84 UNUSED(xparams); 85 86 if (ttisnil(ptree)) { 87 kapply_cc(K, KINERT); 88 } else { 89 /* the list of instructions is copied to avoid mutation */ 90 /* MAYBE: copy the evaluation structure, ASK John */ 91 TValue ls = check_copy_list(K, ptree, false, NULL, NULL); 92 /* this is needed because seq continuation doesn't check for 93 nil sequence */ 94 /* TODO this could be at least in an inlineable function to 95 allow used from $lambda, $vau, $let family, load, etc */ 96 TValue tail = kcdr(ls); 97 if (ttispair(tail)) { 98 krooted_tvs_push(K, ls); 99 TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, 100 tail, denv); 101 kset_cc(K, new_cont); 102 #if KTRACK_SI 103 /* put the source info of the list including the element 104 that we are about to evaluate */ 105 kset_source_info(K, new_cont, ktry_get_si(K, ls)); 106 #endif 107 krooted_tvs_pop(K); 108 } 109 ktail_eval(K, kcar(ls), denv); 110 } 111 } 112 113 114 /* Helpers for cond */ 115 116 /* 117 ** Check the clauses structure. 118 ** Each should be a list of at least 1 element. 119 ** Return both a copied list of tests (only list structure is copied) 120 ** and a copied list of bodies (only list structure is copied, see comment 121 ** on $sequence, cf. $let, $vau and $lambda) 122 ** Throw errors if any of the above mentioned checks fail. 123 */ 124 /* GC: assumes clauses is rooted, uses dummy 1 & 2 */ 125 TValue split_check_cond_clauses(klisp_State *K, TValue clauses, 126 TValue *bodies) 127 { 128 TValue cars = kcons(K, KNIL, KNIL); 129 krooted_vars_push(K, &cars); 130 TValue last_car_pair = cars; 131 132 TValue cdrs = kcons(K, KNIL, KNIL); 133 krooted_vars_push(K, &cdrs); 134 TValue last_cdr_pair = cdrs; 135 136 TValue tail = clauses; 137 int32_t count = 0; 138 139 while(ttispair(tail) && !kis_marked(tail)) { 140 ++count; 141 TValue first = kcar(tail); 142 if (!ttispair(first)) { 143 unmark_list(K, clauses); 144 klispE_throw_simple(K, "bad structure in clauses"); 145 return KNIL; 146 } 147 148 TValue new_car = kcons(K, kcar(first), KNIL); 149 kset_cdr(last_car_pair, new_car); 150 last_car_pair = new_car; 151 /* bodies have to be checked later */ 152 TValue new_cdr = kcons(K, kcdr(first), KNIL); 153 kset_cdr(last_cdr_pair, new_cdr); 154 last_cdr_pair = new_cdr; 155 156 kset_mark(tail, kcons(K, new_car, new_cdr)); 157 tail = kcdr(tail); 158 } 159 160 /* complete the cycles before unmarking */ 161 if (ttispair(tail)) { 162 TValue mark = kget_mark(tail); 163 kset_cdr(last_car_pair, kcar(mark)); 164 kset_cdr(last_cdr_pair, kcdr(mark)); 165 } 166 167 unmark_list(K, clauses); 168 169 if (!ttispair(tail) && !ttisnil(tail)) { 170 klispE_throw_simple(K, "expected list (clauses)"); 171 return KNIL; 172 } 173 174 /* 175 check all the bodies (should be lists), and 176 make a copy of the list structure. 177 couldn't be done before because this uses 178 marks, count is used because it may be a cyclic list 179 */ 180 tail = kcdr(cdrs); 181 while(count--) { 182 TValue first = kcar(tail); 183 TValue copy = check_copy_list(K, first, false, NULL, NULL); 184 kset_car(tail, copy); 185 tail = kcdr(tail); 186 } 187 188 *bodies = kcdr(cdrs); 189 krooted_vars_pop(K); 190 krooted_vars_pop(K); 191 return kcdr(cars); 192 } 193 194 /* Helper for the $cond continuation */ 195 void do_cond(klisp_State *K) 196 { 197 TValue *xparams = K->next_xparams; 198 TValue obj = K->next_value; 199 klisp_assert(ttisnil(K->next_env)); 200 /* 201 ** xparams[0]: the body corresponding to obj 202 ** xparams[1]: remaining tests 203 ** xparams[2]: remaining bodies 204 ** xparams[3]: dynamic environment 205 */ 206 TValue this_body = xparams[0]; 207 TValue tests = xparams[1]; 208 TValue bodies = xparams[2]; 209 TValue denv = xparams[3]; 210 211 if (!ttisboolean(obj)) { 212 klispE_throw_simple(K, "test evaluated to a non boolean value"); 213 return; 214 } else if (bvalue(obj)) { 215 if (ttisnil(this_body)) { 216 kapply_cc(K, KINERT); 217 } else { 218 TValue tail = kcdr(this_body); 219 if (ttispair(tail)) { 220 TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, 221 tail, denv); 222 kset_cc(K, new_cont); 223 #if KTRACK_SI 224 /* put the source info of the list including the element 225 that we are about to evaluate */ 226 kset_source_info(K, new_cont, ktry_get_si(K, this_body)); 227 #endif 228 } 229 ktail_eval(K, kcar(this_body), denv); 230 } 231 } else { 232 /* check next clause if there is any*/ 233 if (ttisnil(tests)) { 234 kapply_cc(K, KINERT); 235 } else { 236 TValue new_cont = 237 kmake_continuation(K, kget_cc(K), do_cond, 4, 238 kcar(bodies), kcdr(tests), kcdr(bodies), 239 denv); 240 /* 241 ** Mark as a bool checking cont, not necessary but avoids a 242 ** continuation in the last evaluation in the common use of 243 ** ($cond ... (($or?/$and? ...) ...) ...) 244 */ 245 kset_bool_check_cont(new_cont); 246 kset_cc(K, new_cont); 247 #if KTRACK_SI 248 /* put the source info of the list including the element 249 that we are about to evaluate */ 250 kset_source_info(K, new_cont, ktry_get_si(K, tests)); 251 #endif 252 ktail_eval(K, kcar(tests), denv); 253 } 254 } 255 } 256 257 /* 5.6.1 $cond */ 258 void Scond(klisp_State *K) 259 { 260 TValue *xparams = K->next_xparams; 261 TValue ptree = K->next_value; 262 TValue denv = K->next_env; 263 klisp_assert(ttisenvironment(K->next_env)); 264 (void) xparams; 265 266 TValue bodies; 267 TValue tests = split_check_cond_clauses(K, ptree, &bodies); 268 krooted_tvs_push(K, tests); 269 krooted_tvs_push(K, bodies); 270 271 TValue obj; 272 if (ttisnil(tests)) { 273 obj = KINERT; 274 } else { 275 /* pass a dummy body and a #f to the $cond continuation to 276 avoid code repetition here */ 277 TValue new_cont = 278 kmake_continuation(K, kget_cc(K), do_cond, 4, 279 KNIL, tests, bodies, denv); 280 /* there is no need to mark this continuation with bool check 281 because it is just a dummy, no evaluation happens in its 282 dynamic extent, no need for source info either */ 283 kset_cc(K, new_cont); 284 obj = KFALSE; 285 } 286 287 krooted_tvs_pop(K); 288 krooted_tvs_pop(K); 289 kapply_cc(K, obj); 290 } 291 292 /* Helper continuation for for-each */ 293 void do_for_each(klisp_State *K) 294 { 295 TValue *xparams = K->next_xparams; 296 TValue obj = K->next_value; 297 klisp_assert(ttisnil(K->next_env)); 298 /* 299 ** xparams[0]: app 300 ** xparams[1]: rem-ls 301 ** xparams[2]: n 302 ** xparams[3]: denv 303 */ 304 TValue app = xparams[0]; 305 TValue ls = xparams[1]; 306 int32_t n = ivalue(xparams[2]); 307 TValue denv = xparams[3]; 308 309 /* the resulting value is just ignored */ 310 UNUSED(obj); 311 312 if (n == 0) { 313 /* return inert as the final result to for-each */ 314 kapply_cc(K, KINERT); 315 } else { 316 /* copy the ptree to avoid problems with mutation */ 317 /* XXX: no check necessary, could just use copy_list if there 318 was such a procedure */ 319 TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL); 320 krooted_tvs_push(K, first_ptree); 321 ls = kcdr(ls); 322 n = n-1; 323 324 /* have to unwrap the applicative to avoid extra evaluation of first */ 325 TValue new_expr = kcons(K, kunwrap(app), first_ptree); 326 TValue new_cont = 327 kmake_continuation(K, kget_cc(K), do_for_each, 4, 328 app, ls, i2tv(n), denv); 329 krooted_tvs_pop(K); 330 kset_cc(K, new_cont); 331 ktail_eval(K, new_expr, denv); 332 } 333 } 334 335 /* 6.9.1 for-each */ 336 void for_each(klisp_State *K) 337 { 338 TValue *xparams = K->next_xparams; 339 TValue ptree = K->next_value; 340 TValue denv = K->next_env; 341 klisp_assert(ttisenvironment(K->next_env)); 342 (void) xparams; 343 344 bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss); 345 346 if (ttisnil(lss)) { 347 klispE_throw_simple(K, "no lists"); 348 return; 349 } 350 351 /* get the metrics of the ptree of each call to app and 352 of the result list */ 353 int32_t app_pairs, app_apairs, app_cpairs; 354 int32_t res_pairs, res_apairs, res_cpairs; 355 356 map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs, 357 &res_apairs, &res_cpairs); 358 app_pairs = app_apairs + app_cpairs; 359 UNUSED(app_pairs); 360 res_pairs = res_apairs + res_cpairs; 361 362 /* create the list of parameters to app */ 363 lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs, 364 res_apairs, res_cpairs); 365 366 krooted_tvs_push(K, lss); 367 368 /* schedule all elements at once, the cycle is just ignored, this 369 will also return #inert once done. */ 370 TValue new_cont = 371 kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss, 372 i2tv(res_pairs), denv); 373 kset_cc(K, new_cont); 374 krooted_tvs_pop(K); 375 /* this will be a nop */ 376 kapply_cc(K, KINERT); 377 } 378 379 /* 6.9.? string-for-each, vector-for-each, bytevector-for-each */ 380 void array_for_each(klisp_State *K) 381 { 382 TValue *xparams = K->next_xparams; 383 TValue ptree = K->next_value; 384 TValue denv = K->next_env; 385 klisp_assert(ttisenvironment(K->next_env)); 386 387 /* 388 ** xparams[1]: array->list fn (with type check and size ret) 389 */ 390 391 TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) = 392 pvalue(xparams[0]); 393 394 bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss); 395 396 /* check that lss is a non empty list, and copy it */ 397 if (ttisnil(lss)) { 398 klispE_throw_simple(K, "no arguments after applicative"); 399 return; 400 } 401 402 int32_t app_pairs, app_apairs, app_cpairs; 403 /* the copied list should be protected from gc, and will host 404 the lists resulting from the conversion */ 405 lss = check_copy_list(K, lss, true, &app_pairs, &app_cpairs); 406 app_apairs = app_pairs - app_cpairs; 407 krooted_tvs_push(K, lss); 408 409 /* check that all elements have the correct type and same size, 410 and convert them to lists */ 411 int32_t res_pairs; 412 TValue head = kcar(lss); 413 TValue tail = kcdr(lss); 414 TValue ls = array_to_list(K, head, &res_pairs); 415 kset_car(lss, ls); /* save the first */ 416 /* all array will produce acyclic lists */ 417 for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) { 418 head = kcar(tail); 419 int32_t pairs; 420 ls = array_to_list(K, head, &pairs); 421 /* in klisp all arrays should have the same length */ 422 if (pairs != res_pairs) { 423 klispE_throw_simple(K, "arguments of different length"); 424 return; 425 } 426 kset_car(tail, ls); 427 tail = kcdr(tail); 428 } 429 430 /* create the list of parameters to app */ 431 lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs, 432 res_pairs, 0); /* cycle pairs is always 0 */ 433 434 /* ASK John: the semantics when this is mixed with continuations, 435 isn't all that great..., but what are the expectations considering 436 there is no prescribed order? */ 437 438 krooted_tvs_pop(K); 439 krooted_tvs_push(K, lss); 440 441 /* schedule all elements at once, this will also return #inert once 442 done. */ 443 TValue new_cont = 444 kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss, 445 i2tv(res_pairs), denv); 446 kset_cc(K, new_cont); 447 krooted_tvs_pop(K); 448 /* this will be a nop */ 449 kapply_cc(K, KINERT); 450 } 451 452 /* Helper for $when and $unless */ 453 void do_Swhen_Sunless(klisp_State *K) 454 { 455 TValue *xparams = K->next_xparams; 456 TValue obj = K->next_value; 457 klisp_assert(ttisnil(K->next_env)); 458 459 /* 460 ** xparams[0]: bool condition 461 ** xparams[1]: body 462 ** xparams[2]: denv 463 ** xparams[3]: si for whole form 464 */ 465 bool cond = bvalue(xparams[0]); 466 TValue ls = xparams[1]; 467 TValue denv = xparams[2]; 468 #if KTRACK_SI 469 TValue si = xparams[3]; 470 #endif 471 472 if (!ttisboolean(obj)) { 473 klispE_throw_simple(K, "test is not a boolean"); 474 return; 475 } 476 477 if (bvalue(obj) == cond && !ttisnil(ls)) { 478 /* only contruct the #inert returning continuation if the 479 current continuation is not of the same type */ 480 if (!kis_inert_ret_cont(kget_cc(K))) { 481 TValue new_cont = 482 kmake_continuation(K, kget_cc(K), do_return_value, 1, KINERT); 483 /* mark it, so that it can be detected as inert throwing cont */ 484 kset_inert_ret_cont(new_cont); 485 kset_cc(K, new_cont); 486 #if KTRACK_SI 487 /* put the source info of the whole form */ 488 kset_source_info(K, new_cont, si); 489 #endif 490 } 491 /* this is needed because seq continuation doesn't check for 492 nil sequence */ 493 /* TODO this could be at least in an inlineable function to 494 allow used from $lambda, $vau, $let family, load, etc */ 495 TValue tail = kcdr(ls); 496 if (ttispair(tail)) { 497 krooted_tvs_push(K, ls); 498 TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, 499 tail, denv); 500 kset_cc(K, new_cont); 501 #if KTRACK_SI 502 /* put the source info of the list including the element 503 that we are about to evaluate */ 504 kset_source_info(K, new_cont, ktry_get_si(K, ls)); 505 #endif 506 krooted_tvs_pop(K); 507 } 508 ktail_eval(K, kcar(ls), denv); 509 } else { 510 /* either the test failed or the body was nil */ 511 kapply_cc(K, KINERT); 512 } 513 } 514 515 /* ASK JOHN: list is copied here (like in $sequence) */ 516 void Swhen_Sunless(klisp_State *K) 517 { 518 TValue *xparams = K->next_xparams; 519 TValue ptree = K->next_value; 520 TValue denv = K->next_env; 521 klisp_assert(ttisenvironment(K->next_env)); 522 523 bind_al1p(K, ptree, test, body); 524 525 /* 526 ** xparams[0]: bool condition 527 */ 528 TValue tv_cond = xparams[0]; 529 530 /* the list of instructions is copied to avoid mutation */ 531 /* MAYBE: copy the evaluation structure, ASK John */ 532 TValue ls = check_copy_list(K, body, false, NULL, NULL); 533 krooted_tvs_push(K, ls); 534 /* prepare the continuation that will check the test result 535 and do the evaluation */ 536 TValue si = K->next_si; /* this is the source info of the whole 537 $when/$unless form */ 538 TValue new_cont = kmake_continuation(K, kget_cc(K), do_Swhen_Sunless, 539 4, tv_cond, ls, denv, si); 540 krooted_tvs_pop(K); 541 /* 542 ** Mark as a bool checking cont, not necessary but avoids a continuation 543 ** in the last evaluation in the common use of 544 ** ($when/$unless ($or?/$and? ...) ...) 545 */ 546 kset_bool_check_cont(new_cont); 547 kset_cc(K, new_cont); 548 ktail_eval(K, test, denv); 549 } 550 551 /* init ground */ 552 void kinit_control_ground_env(klisp_State *K) 553 { 554 TValue ground_env = G(K)->ground_env; 555 TValue symbol, value; 556 557 /* 4.5.1 inert? */ 558 add_applicative(K, ground_env, "inert?", typep, 2, symbol, 559 i2tv(K_TINERT)); 560 /* 4.5.2 $if */ 561 add_operative(K, ground_env, "$if", Sif, 0); 562 /* 5.1.1 $sequence */ 563 add_operative(K, ground_env, "$sequence", Ssequence, 0); 564 /* 5.6.1 $cond */ 565 add_operative(K, ground_env, "$cond", Scond, 0); 566 /* 6.9.1 for-each */ 567 add_applicative(K, ground_env, "for-each", for_each, 0); 568 /* 6.9.? string-for-each, vector-for-each, bytevector-for-each */ 569 add_applicative(K, ground_env, "string-for-each", array_for_each, 1, 570 p2tv(string_to_list_h)); 571 add_applicative(K, ground_env, "vector-for-each", array_for_each, 1, 572 p2tv(vector_to_list_h)); 573 add_applicative(K, ground_env, "bytevector-for-each", array_for_each, 1, 574 p2tv(bytevector_to_list_h)); 575 /* ?.? */ 576 add_operative(K, ground_env, "$when", Swhen_Sunless, 1, 577 b2tv(true)); 578 add_operative(K, ground_env, "$unless", Swhen_Sunless, 1, 579 b2tv(false)); 580 } 581 582 /* XXX lock? */ 583 /* init continuation names */ 584 void kinit_control_cont_names(klisp_State *K) 585 { 586 Table *t = tv2table(G(K)->cont_name_table); 587 588 add_cont_name(K, t, do_select_clause, "select-clause"); 589 add_cont_name(K, t, do_Swhen_Sunless, "conditional-eval-sequence"); 590 591 add_cont_name(K, t, do_cond, "eval-cond-list"); 592 add_cont_name(K, t, do_for_each, "for-each"); 593 }