kgenvironments.c (23925B)
1 /* 2 ** kgenvironments.c 3 ** Environments 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 #include "kport.h" /* for eval_string */ 21 #include "kread.h" /* for eval_string */ 22 23 #include "kghelpers.h" 24 #include "kgenvironments.h" 25 26 /* Continuations */ 27 void do_let(klisp_State *K); 28 void do_let_redirect(klisp_State *K); 29 void do_bindsp(klisp_State *K); 30 void do_remote_eval(klisp_State *K); 31 void do_b_to_env(klisp_State *K); 32 void do_eval_string(klisp_State *K); 33 34 /* 4.8.1 environment? */ 35 /* uses typep */ 36 37 /* 4.8.2 ignore? */ 38 /* uses typep */ 39 40 /* 4.8.3 eval */ 41 void eval(klisp_State *K) 42 { 43 TValue *xparams = K->next_xparams; 44 TValue ptree = K->next_value; 45 TValue denv = K->next_env; 46 klisp_assert(ttisenvironment(K->next_env)); 47 UNUSED(denv); 48 UNUSED(xparams); 49 50 bind_2tp(K, ptree, "any", anytype, expr, 51 "environment", ttisenvironment, env); 52 /* TODO: track source code info */ 53 ktail_eval(K, expr, env); 54 } 55 56 /* 4.8.4 make-environment */ 57 void make_environment(klisp_State *K) 58 { 59 TValue *xparams = K->next_xparams; 60 TValue ptree = K->next_value; 61 TValue denv = K->next_env; 62 klisp_assert(ttisenvironment(K->next_env)); 63 UNUSED(denv); 64 UNUSED(xparams); 65 66 TValue new_env; 67 if (ttisnil(ptree)) { 68 new_env = kmake_empty_environment(K); 69 kapply_cc(K, new_env); 70 } else if (ttispair(ptree) && ttisnil(kcdr(ptree))) { 71 /* special common case of one parent, don't keep a list */ 72 TValue parent = kcar(ptree); 73 if (ttisenvironment(parent)) { 74 new_env = kmake_environment(K, parent); 75 kapply_cc(K, new_env); 76 } else { 77 klispE_throw_simple(K, "not an environment in " 78 "parent list"); 79 return; 80 } 81 } else { 82 /* this is the general case, copy the list but without the 83 cycle if there is any */ 84 TValue parents = check_copy_env_list(K, ptree); 85 krooted_tvs_push(K, parents); 86 new_env = kmake_environment(K, parents); 87 krooted_tvs_pop(K); 88 kapply_cc(K, new_env); 89 } 90 } 91 92 /* Helpers for all the let family */ 93 94 /* 95 ** The split-let-bindings function has two cases: 96 ** the 'lets' with a star ($let* and $letrec) allow repeated symbols 97 ** in different bidings (each binding is a different ptree whereas 98 ** in $let, $letrec, $let-redirect and $let-safe, all the bindings 99 ** are collected in a single ptree). 100 ** In both cases the value returned is a list of cars of bindings and 101 ** exprs is modified to point to a list of cadrs of bindings. 102 ** The ptrees are copied as by copy-es-immutable (as with $vau & $lambda) 103 ** If bindings is not finite (or not a list) an error is signaled. 104 */ 105 106 /* GC: assume bindings is rooted */ 107 TValue split_check_let_bindings(klisp_State *K, TValue bindings, 108 TValue *exprs, bool starp) 109 { 110 TValue cars = kcons(K, KNIL, KNIL); 111 krooted_vars_push(K, &cars); 112 TValue last_car_pair = cars; 113 TValue cadrs = kcons(K, KNIL, KNIL); 114 krooted_vars_push(K, &cadrs); 115 TValue last_cadr_pair = cadrs; 116 117 TValue tail = bindings; 118 119 while(ttispair(tail) && !kis_marked(tail)) { 120 kmark(tail); 121 TValue first = kcar(tail); 122 if (!ttispair(first) || !ttispair(kcdr(first)) || 123 !ttisnil(kcddr(first))) { 124 unmark_list(K, bindings); 125 klispE_throw_simple(K, "bad structure in bindings"); 126 return KNIL; 127 } 128 129 TValue new_car = kcons(K, kcar(first), KNIL); 130 kset_cdr(last_car_pair, new_car); 131 last_car_pair = new_car; 132 TValue new_cadr = kcons(K, kcadr(first), KNIL); 133 kset_cdr(last_cadr_pair, new_cadr); 134 last_cadr_pair = new_cadr; 135 136 tail = kcdr(tail); 137 } 138 139 unmark_list(K, bindings); 140 141 if (!ttispair(tail) && !ttisnil(tail)) { 142 klispE_throw_simple(K, "expected list"); 143 return KNIL; 144 } else if(ttispair(tail)) { 145 klispE_throw_simple(K, "expected finite list"); 146 return KNIL; 147 } else { 148 TValue res; 149 if (starp) { 150 /* all bindings are consider individual ptrees in these 'let's, 151 replace each ptree with its copy (after checking of course) */ 152 tail = kcdr(cars); 153 while(!ttisnil(tail)) { 154 TValue first = kcar(tail); 155 TValue copy = check_copy_ptree(K, first, KIGNORE); 156 kset_car(tail, copy); 157 tail = kcdr(tail); 158 } 159 res = kcdr(cars); 160 } else { 161 /* all bindings are consider one ptree in these 'let's */ 162 res = check_copy_ptree(K, kcdr(cars), KIGNORE); 163 } 164 *exprs = kcdr(cadrs); 165 krooted_vars_pop(K); 166 krooted_vars_pop(K); 167 return res; 168 } 169 } 170 171 /* 172 ** Continuation function for all the let family 173 ** it expects the result of the last evaluation to be matched to 174 ** this-ptree 175 */ 176 void do_let(klisp_State *K) 177 { 178 TValue *xparams = K->next_xparams; 179 TValue obj = K->next_value; 180 klisp_assert(ttisnil(K->next_env)); 181 /* 182 ** xparams[0]: symbol name 183 ** xparams[1]: this ptree 184 ** xparams[2]: remaining bindings 185 ** xparams[3]: remaining exprs 186 ** xparams[4]: match environment 187 ** xparams[5]: rec/not rec flag 188 ** xparams[6]: body 189 */ 190 TValue sname = xparams[0]; 191 TValue ptree = xparams[1]; 192 TValue bindings = xparams[2]; 193 TValue exprs = xparams[3]; 194 TValue env = xparams[4]; 195 bool recp = bvalue(xparams[5]); 196 TValue body = xparams[6]; 197 198 match(K, env, ptree, obj); 199 200 if (ttisnil(bindings)) { 201 if (ttisnil(body)) { 202 kapply_cc(K, KINERT); 203 } else { 204 /* this is needed because seq continuation doesn't check for 205 nil sequence */ 206 TValue tail = kcdr(body); 207 if (ttispair(tail)) { 208 TValue new_cont = kmake_continuation(K, kget_cc(K), 209 do_seq, 2, tail, env); 210 kset_cc(K, new_cont); 211 #if KTRACK_SI 212 /* put the source info of the list including the element 213 that we are about to evaluate */ 214 kset_source_info(K, new_cont, ktry_get_si(K, body)); 215 #endif 216 } 217 ktail_eval(K, kcar(body), env); 218 } 219 } else { 220 TValue new_env = kmake_environment(K, env); 221 krooted_tvs_push(K, new_env); 222 TValue new_cont = 223 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 224 kcar(bindings), kcdr(bindings), kcdr(exprs), 225 new_env, b2tv(recp), body); 226 krooted_tvs_pop(K); 227 kset_cc(K, new_cont); 228 ktail_eval(K, kcar(exprs), recp? new_env : env); 229 } 230 } 231 232 /* 5.10.1 $let */ 233 /* REFACTOR: reuse code in other members of the $let family */ 234 void Slet(klisp_State *K) 235 { 236 TValue *xparams = K->next_xparams; 237 TValue ptree = K->next_value; 238 TValue denv = K->next_env; 239 klisp_assert(ttisenvironment(K->next_env)); 240 /* 241 ** xparams[0]: symbol name 242 */ 243 TValue sname = xparams[0]; 244 bind_al1p(K, ptree, bindings, body); 245 246 TValue exprs; 247 TValue bptree = split_check_let_bindings(K, bindings, &exprs, false); 248 krooted_tvs_push(K, bptree); 249 krooted_tvs_push(K, exprs); 250 251 check_list(K, true, body, NULL, NULL); 252 body = copy_es_immutable_h(K, body, false); 253 krooted_tvs_push(K, body); 254 255 TValue new_env = kmake_environment(K, denv); 256 krooted_tvs_push(K, new_env); 257 TValue new_cont = 258 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 259 bptree, KNIL, KNIL, new_env, b2tv(false), body); 260 kset_cc(K, new_cont); 261 262 TValue expr = kcons(K, G(K)->list_app, exprs); 263 264 krooted_tvs_pop(K); 265 krooted_tvs_pop(K); 266 krooted_tvs_pop(K); 267 krooted_tvs_pop(K); 268 269 ktail_eval(K, expr, denv); 270 } 271 272 /* Helper for $binds? */ 273 void do_bindsp(klisp_State *K) 274 { 275 TValue *xparams = K->next_xparams; 276 TValue obj = K->next_value; 277 klisp_assert(ttisnil(K->next_env)); 278 /* 279 ** xparams[0]: symbol list (may contain cycles) 280 ** xparams[1]: symbol list count 281 */ 282 TValue symbols = xparams[0]; 283 int32_t count = ivalue(xparams[1]); 284 285 if (!ttisenvironment(obj)) { 286 klispE_throw_simple(K, "expected environment as first argument"); 287 return; 288 } 289 TValue env = obj; 290 TValue res = KTRUE; 291 292 while(count--) { 293 TValue first = kcar(symbols); 294 symbols = kcdr(symbols); 295 296 if (!kbinds(K, env, first)) { 297 res = KFALSE; 298 break; 299 } 300 } 301 302 kapply_cc(K, res); 303 } 304 305 /* 6.7.1 $binds? */ 306 void Sbindsp(klisp_State *K) 307 { 308 TValue *xparams = K->next_xparams; 309 TValue ptree = K->next_value; 310 TValue denv = K->next_env; 311 klisp_assert(ttisenvironment(K->next_env)); 312 UNUSED(xparams); 313 bind_al1p(K, ptree, env_expr, symbols); 314 315 /* REFACTOR replace with single function check_copy_typed_list */ 316 int32_t count; 317 check_typed_list(K, ksymbolp, true, symbols, &count, NULL); 318 symbols = check_copy_list(K, symbols, false, NULL, NULL); 319 320 krooted_tvs_push(K, symbols); 321 TValue new_cont = kmake_continuation(K, kget_cc(K), do_bindsp, 322 2, symbols, i2tv(count)); 323 krooted_tvs_pop(K); 324 kset_cc(K, new_cont); 325 ktail_eval(K, env_expr, denv); 326 } 327 328 /* 6.7.2 get-current-environment */ 329 void get_current_environment(klisp_State *K) 330 { 331 TValue *xparams = K->next_xparams; 332 TValue ptree = K->next_value; 333 TValue denv = K->next_env; 334 klisp_assert(ttisenvironment(K->next_env)); 335 UNUSED(xparams); 336 check_0p(K, ptree); 337 kapply_cc(K, denv); 338 } 339 340 /* 6.7.3 make-kernel-standard-environment */ 341 void make_kernel_standard_environment(klisp_State *K) 342 { 343 TValue *xparams = K->next_xparams; 344 TValue ptree = K->next_value; 345 TValue denv = K->next_env; 346 klisp_assert(ttisenvironment(K->next_env)); 347 UNUSED(xparams); 348 UNUSED(denv); 349 check_0p(K, ptree); 350 351 /* std environments have hashtable for bindings */ 352 TValue new_env = kmake_table_environment(K, G(K)->ground_env); 353 // TValue new_env = kmake_environment(K, G(K)->ground_env); 354 kapply_cc(K, new_env); 355 } 356 357 /* 6.7.4 $let* */ 358 void SletS(klisp_State *K) 359 { 360 TValue *xparams = K->next_xparams; 361 TValue ptree = K->next_value; 362 TValue denv = K->next_env; 363 klisp_assert(ttisenvironment(K->next_env)); 364 /* 365 ** xparams[0]: symbol name 366 */ 367 TValue sname = xparams[0]; 368 bind_al1p(K, ptree, bindings, body); 369 370 TValue exprs; 371 TValue bptree = split_check_let_bindings(K, bindings, &exprs, true); 372 krooted_tvs_push(K, exprs); 373 krooted_tvs_push(K, bptree); 374 check_list(K, true, body, NULL, NULL); 375 body = copy_es_immutable_h(K, body, false); 376 krooted_tvs_push(K, body); 377 378 TValue new_env = kmake_environment(K, denv); 379 krooted_tvs_push(K, new_env); 380 381 if (ttisnil(bptree)) { 382 /* same as $let */ 383 TValue new_cont = 384 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 385 bptree, KNIL, KNIL, new_env, b2tv(false), body); 386 kset_cc(K, new_cont); 387 388 TValue expr = kcons(K, G(K)->list_app, exprs); 389 krooted_tvs_pop(K); 390 krooted_tvs_pop(K); 391 krooted_tvs_pop(K); 392 krooted_tvs_pop(K); 393 ktail_eval(K, expr, denv); 394 } else { 395 TValue new_cont = 396 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 397 kcar(bptree), kcdr(bptree), kcdr(exprs), 398 new_env, b2tv(false), body); 399 kset_cc(K, new_cont); 400 401 krooted_tvs_pop(K); 402 krooted_tvs_pop(K); 403 krooted_tvs_pop(K); 404 krooted_tvs_pop(K); 405 ktail_eval(K, kcar(exprs), denv); 406 } 407 } 408 409 /* 6.7.5 $letrec */ 410 void Sletrec(klisp_State *K) 411 { 412 TValue *xparams = K->next_xparams; 413 TValue ptree = K->next_value; 414 TValue denv = K->next_env; 415 klisp_assert(ttisenvironment(K->next_env)); 416 /* 417 ** xparams[0]: symbol name 418 */ 419 TValue sname = xparams[0]; 420 bind_al1p(K, ptree, bindings, body); 421 422 TValue exprs; 423 TValue bptree = split_check_let_bindings(K, bindings, &exprs, false); 424 krooted_tvs_push(K, exprs); 425 krooted_tvs_push(K, bptree); 426 427 check_list(K, true, body, NULL, NULL); 428 body = copy_es_immutable_h(K, body, false); 429 krooted_tvs_push(K, body); 430 431 TValue new_env = kmake_environment(K, denv); 432 krooted_tvs_push(K, new_env); 433 434 TValue new_cont = 435 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 436 bptree, KNIL, KNIL, new_env, b2tv(true), body); 437 kset_cc(K, new_cont); 438 439 TValue expr = kcons(K, G(K)->list_app, exprs); 440 441 krooted_tvs_pop(K); 442 krooted_tvs_pop(K); 443 krooted_tvs_pop(K); 444 krooted_tvs_pop(K); 445 446 ktail_eval(K, expr, new_env); 447 } 448 449 /* 6.7.6 $letrec* */ 450 void SletrecS(klisp_State *K) 451 { 452 TValue *xparams = K->next_xparams; 453 TValue ptree = K->next_value; 454 TValue denv = K->next_env; 455 klisp_assert(ttisenvironment(K->next_env)); 456 /* 457 ** xparams[0]: symbol name 458 */ 459 TValue sname = xparams[0]; 460 bind_al1p(K, ptree, bindings, body); 461 462 TValue exprs; 463 TValue bptree = split_check_let_bindings(K, bindings, &exprs, true); 464 krooted_tvs_push(K, exprs); 465 krooted_tvs_push(K, bptree); 466 check_list(K, true, body, NULL, NULL); 467 body = copy_es_immutable_h(K, body, false); 468 krooted_tvs_push(K, body); 469 470 TValue new_env = kmake_environment(K, denv); 471 krooted_tvs_push(K, new_env); 472 473 if (ttisnil(bptree)) { 474 /* same as $letrec */ 475 TValue new_cont = 476 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 477 bptree, KNIL, KNIL, new_env, b2tv(true), body); 478 kset_cc(K, new_cont); 479 480 TValue expr = kcons(K, G(K)->list_app, exprs); 481 482 krooted_tvs_pop(K); 483 krooted_tvs_pop(K); 484 krooted_tvs_pop(K); 485 krooted_tvs_pop(K); 486 ktail_eval(K, expr, new_env); 487 } else { 488 TValue new_cont = 489 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 490 kcar(bptree), kcdr(bptree), kcdr(exprs), 491 new_env, b2tv(true), body); 492 kset_cc(K, new_cont); 493 494 krooted_tvs_pop(K); 495 krooted_tvs_pop(K); 496 krooted_tvs_pop(K); 497 krooted_tvs_pop(K); 498 ktail_eval(K, kcar(exprs), new_env); 499 } 500 } 501 502 /* Helper for $let-redirect */ 503 void do_let_redirect(klisp_State *K) 504 { 505 TValue *xparams = K->next_xparams; 506 TValue obj = K->next_value; 507 klisp_assert(ttisnil(K->next_env)); 508 /* 509 ** xparams[0]: symbol name 510 ** xparams[1]: ptree 511 ** xparams[2]: list expr to be eval'ed 512 ** xparams[3]: denv 513 ** xparams[4]: body 514 */ 515 TValue sname = xparams[0]; 516 TValue bptree = xparams[1]; 517 TValue lexpr = xparams[2]; 518 TValue denv = xparams[3]; 519 TValue body = xparams[4]; 520 521 if (!ttisenvironment(obj)) { 522 klispE_throw_simple(K, "expected environment"); 523 return; 524 } 525 TValue new_env = kmake_environment(K, obj); 526 krooted_tvs_push(K, new_env); 527 TValue new_cont = 528 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 529 bptree, KNIL, KNIL, new_env, b2tv(false), body); 530 kset_cc(K, new_cont); 531 532 krooted_tvs_pop(K); 533 ktail_eval(K, lexpr, denv); 534 } 535 536 /* 6.7.7 $let-redirect */ 537 void Slet_redirect(klisp_State *K) 538 { 539 TValue *xparams = K->next_xparams; 540 TValue ptree = K->next_value; 541 TValue denv = K->next_env; 542 klisp_assert(ttisenvironment(K->next_env)); 543 /* 544 ** xparams[0]: symbol name 545 */ 546 TValue sname = xparams[0]; 547 bind_al2p(K, ptree, env_exp, bindings, body); 548 549 TValue exprs; 550 TValue bptree = split_check_let_bindings(K, bindings, &exprs, false); 551 krooted_tvs_push(K, exprs); 552 krooted_tvs_push(K, bptree); 553 554 check_list(K, true, body, NULL, NULL); 555 body = copy_es_immutable_h(K, body, false); 556 krooted_tvs_push(K, body); 557 558 TValue eexpr = kcons(K, G(K)->list_app, exprs); 559 krooted_tvs_push(K, eexpr); 560 561 TValue new_cont = 562 kmake_continuation(K, kget_cc(K), do_let_redirect, 5, sname, 563 bptree, eexpr, denv, body); 564 kset_cc(K, new_cont); 565 566 krooted_tvs_pop(K); 567 krooted_tvs_pop(K); 568 krooted_tvs_pop(K); 569 krooted_tvs_pop(K); 570 571 ktail_eval(K, env_exp, denv); 572 } 573 574 /* 6.7.8 $let-safe */ 575 void Slet_safe(klisp_State *K) 576 { 577 TValue *xparams = K->next_xparams; 578 TValue ptree = K->next_value; 579 TValue denv = K->next_env; 580 klisp_assert(ttisenvironment(K->next_env)); 581 /* 582 ** xparams[0]: symbol name 583 */ 584 TValue sname = xparams[0]; 585 bind_al1p(K, ptree, bindings, body); 586 587 TValue exprs; 588 TValue bptree = split_check_let_bindings(K, bindings, &exprs, false); 589 krooted_tvs_push(K, exprs); 590 krooted_tvs_push(K, bptree); 591 592 check_list(K, true, body, NULL, NULL); 593 594 body = copy_es_immutable_h(K, body, false); 595 krooted_tvs_push(K, body); 596 597 /* according to the definition of the report it should be a child 598 of a child of the ground environment, but since this is a fresh 599 environment, the semantics are the same */ 600 TValue new_env = kmake_environment(K, G(K)->ground_env); 601 krooted_tvs_push(K, new_env); 602 TValue new_cont = 603 kmake_continuation(K, kget_cc(K), do_let, 7, sname, 604 bptree, KNIL, KNIL, new_env, b2tv(false), body); 605 kset_cc(K, new_cont); 606 607 TValue expr = kcons(K, G(K)->list_app, exprs); 608 krooted_tvs_pop(K); 609 krooted_tvs_pop(K); 610 krooted_tvs_pop(K); 611 krooted_tvs_pop(K); 612 613 ktail_eval(K, expr, denv); 614 } 615 616 /* 6.7.9 $remote-eval */ 617 void Sremote_eval(klisp_State *K) 618 { 619 TValue *xparams = K->next_xparams; 620 TValue ptree = K->next_value; 621 TValue denv = K->next_env; 622 klisp_assert(ttisenvironment(K->next_env)); 623 UNUSED(xparams); 624 UNUSED(denv); 625 626 bind_2p(K, ptree, obj, env_exp); 627 628 TValue new_cont = kmake_continuation(K, kget_cc(K), 629 do_remote_eval, 1, obj); 630 kset_cc(K, new_cont); 631 632 ktail_eval(K, env_exp, denv); 633 } 634 635 /* Helper for $remote-eval */ 636 void do_remote_eval(klisp_State *K) 637 { 638 TValue *xparams = K->next_xparams; 639 TValue obj = K->next_value; 640 klisp_assert(ttisnil(K->next_env)); 641 if (!ttisenvironment(obj)) { 642 klispE_throw_simple(K, "bad type from second operand " 643 "evaluation (expected environment)"); 644 return; 645 } else { 646 TValue eval_exp = xparams[0]; 647 ktail_eval(K, eval_exp, obj); 648 } 649 } 650 651 /* Helper for $bindings->environment */ 652 void do_b_to_env(klisp_State *K) 653 { 654 TValue *xparams = K->next_xparams; 655 TValue obj = K->next_value; 656 klisp_assert(ttisnil(K->next_env)); 657 /* 658 ** xparams[0]: ptree 659 ** xparams[1]: created env 660 */ 661 TValue ptree = xparams[0]; 662 TValue env = xparams[1]; 663 664 match(K, env, ptree, obj); 665 kapply_cc(K, env); 666 } 667 668 /* 6.7.10 $bindings->environment */ 669 void Sbindings_to_environment(klisp_State *K) 670 { 671 TValue *xparams = K->next_xparams; 672 TValue ptree = K->next_value; 673 TValue denv = K->next_env; 674 klisp_assert(ttisenvironment(K->next_env)); 675 UNUSED(xparams); 676 TValue exprs; 677 TValue bptree = split_check_let_bindings(K, ptree, &exprs, false); 678 krooted_tvs_push(K, exprs); 679 krooted_tvs_push(K, bptree); 680 681 TValue new_env = kmake_environment(K, KNIL); 682 krooted_tvs_push(K, new_env); 683 684 TValue new_cont = kmake_continuation(K, kget_cc(K), 685 do_b_to_env, 2, bptree, new_env); 686 kset_cc(K, new_cont); 687 TValue expr = kcons(K, G(K)->list_app, exprs); 688 689 krooted_tvs_pop(K); 690 krooted_tvs_pop(K); 691 krooted_tvs_pop(K); 692 693 ktail_eval(K, expr, denv); 694 } 695 696 void do_eval_string(klisp_State *K) 697 { 698 TValue *xparams = K->next_xparams; 699 TValue obj = K->next_value; 700 klisp_assert(ttisnil(K->next_env)); 701 /* 702 ** xparams[0]: environment 703 */ 704 TValue env = xparams[0]; 705 ktail_eval(K, obj, env); 706 } 707 708 /* ?.? eval-string */ 709 void eval_string(klisp_State *K) 710 { 711 TValue *xparams = K->next_xparams; 712 TValue ptree = K->next_value; 713 TValue denv = K->next_env; 714 klisp_assert(ttisenvironment(K->next_env)); 715 UNUSED(xparams); 716 UNUSED(denv); 717 718 bind_2tp(K, ptree, "string", ttisstring, str, 719 "environment", ttisenvironment, env); 720 721 /* create a continuation for better stack traces 722 in case of error */ 723 TValue port = kmake_mport(K, str, false, false); 724 krooted_tvs_push(K, port); 725 TValue cont = kmake_continuation(K, kget_cc(K), do_eval_string, 1, env); 726 kset_cc(K, cont); 727 krooted_tvs_pop(K); 728 729 TValue obj = kread_from_port(K, port, true); /* read mutable pairs */ 730 if (ttiseof(obj)) { 731 klispE_throw_simple_with_irritants(K, "No object found in string", 1, 732 str); 733 return; 734 } 735 krooted_tvs_push(K, obj); 736 TValue second_obj = kread_from_port(K, port, true); 737 krooted_tvs_pop(K); 738 if (!ttiseof(second_obj)) { 739 klispE_throw_simple_with_irritants(K, "More than one object found " 740 "in string", 1, str); 741 return; 742 } 743 kapply_cc(K, obj); 744 } 745 746 /* init ground */ 747 void kinit_environments_ground_env(klisp_State *K) 748 { 749 TValue ground_env = G(K)->ground_env; 750 TValue symbol, value; 751 752 /* 4.8.1 environment? */ 753 add_applicative(K, ground_env, "environment?", typep, 2, symbol, 754 i2tv(K_TENVIRONMENT)); 755 /* 4.8.2 ignore? */ 756 add_applicative(K, ground_env, "ignore?", typep, 2, symbol, 757 i2tv(K_TIGNORE)); 758 /* 4.8.3 eval */ 759 add_applicative(K, ground_env, "eval", eval, 0); 760 /* 4.8.4 make-environment */ 761 add_applicative(K, ground_env, "make-environment", make_environment, 0); 762 /* 5.10.1 $let */ 763 add_operative(K, ground_env, "$let", Slet, 1, symbol); 764 /* 6.7.1 $binds? */ 765 add_operative(K, ground_env, "$binds?", Sbindsp, 0); 766 /* 6.7.2 get-current-environment */ 767 add_applicative(K, ground_env, "get-current-environment", 768 get_current_environment, 0); 769 /* 6.7.3 make-kernel-standard-environment */ 770 add_applicative(K, ground_env, "make-kernel-standard-environment", 771 make_kernel_standard_environment, 0); 772 /* 6.7.4 $let* */ 773 add_operative(K, ground_env, "$let*", SletS, 1, symbol); 774 /* 6.7.5 $letrec */ 775 add_operative(K, ground_env, "$letrec", Sletrec, 1, symbol); 776 /* 6.7.6 $letrec* */ 777 add_operative(K, ground_env, "$letrec*", SletrecS, 1, symbol); 778 /* 6.7.7 $let-redirect */ 779 add_operative(K, ground_env, "$let-redirect", Slet_redirect, 1, symbol); 780 /* 6.7.8 $let-safe */ 781 add_operative(K, ground_env, "$let-safe", Slet_safe, 1, symbol); 782 /* 6.7.9 $remote-eval */ 783 add_operative(K, ground_env, "$remote-eval", Sremote_eval, 0); 784 /* 6.7.10 $bindings->environment */ 785 add_operative(K, ground_env, "$bindings->environment", 786 Sbindings_to_environment, 1, symbol); 787 /* ?.? eval-string */ 788 add_applicative(K, ground_env, "eval-string", eval_string, 0); 789 } 790 791 /* XXX lock? */ 792 /* init continuation names */ 793 void kinit_environments_cont_names(klisp_State *K) 794 { 795 Table *t = tv2table(G(K)->cont_name_table); 796 797 add_cont_name(K, t, do_let, "eval-let"); 798 add_cont_name(K, t, do_let_redirect, "eval-let-redirect"); 799 add_cont_name(K, t, do_bindsp, "eval-$binds?-env"); 800 add_cont_name(K, t, do_remote_eval, "eval-remote-eval-env"); 801 add_cont_name(K, t, do_eval_string, "eval-string"); 802 add_cont_name(K, t, do_b_to_env, "bindings-to-env"); 803 }