kglibraries.c (26010B)
1 /* 2 ** kglibraries.c 3 ** Libraries features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <stdlib.h> 8 #include <stdbool.h> 9 #include <stdint.h> 10 #include <string.h> 11 12 #include "kstate.h" 13 #include "kobject.h" 14 #include "klibrary.h" 15 #include "kapplicative.h" 16 #include "koperative.h" 17 #include "kcontinuation.h" 18 #include "kerror.h" 19 #include "kpair.h" 20 #include "kenvironment.h" 21 #include "kkeyword.h" 22 23 #include "kghelpers.h" 24 #include "kglibraries.h" 25 26 /* Continuations */ 27 static void do_register_library(klisp_State *K); 28 static void do_provide_library(klisp_State *K); 29 30 31 /* ?.? library? */ 32 /* uses typep */ 33 34 /* Helper for make-library */ 35 static inline void unmark_symbol_list(klisp_State *K, TValue ls) 36 { 37 UNUSED(K); 38 for(; ttispair(ls) && kis_symbol_marked(kcar(ls)); ls = kcdr(ls)) 39 kunmark_symbol(kcar(ls)); 40 } 41 42 /* ?.? make-library */ 43 static void make_library(klisp_State *K) 44 { 45 bind_1p(K, K->next_value, obj); 46 47 int32_t pairs; 48 /* list can't be cyclical */ 49 check_list(K, false, obj, &pairs, NULL); 50 /* 51 ** - check the type (also check symbols aren't repeated) 52 ** - copy the symbols in an immutable list 53 ** - put the values in a new empty env 54 */ 55 TValue dummy = kcons(K, KNIL, KNIL); 56 krooted_tvs_push(K, dummy); 57 TValue lp = dummy; 58 TValue tail = obj; 59 /* use a table environment for libraries */ 60 TValue env = kmake_table_environment(K, KNIL); 61 krooted_tvs_push(K, env); 62 63 for (int32_t i = 0; i < pairs; ++i, tail = kcdr(tail)) { 64 TValue p = kcar(tail); 65 if (!ttispair(p) || !ttissymbol(kcar(p))) { 66 unmark_symbol_list(K, kcdr(dummy)); 67 klispE_throw_simple_with_irritants(K, "Bad type in bindings", 68 1, tail); 69 return; 70 } 71 72 TValue sym = kcar(p); 73 TValue val = kcdr(p); 74 if (kis_symbol_marked(sym)) { 75 unmark_symbol_list(K, kcdr(dummy)); 76 klispE_throw_simple_with_irritants(K, "Repeated symbol in " 77 "bindings", 1, sym); 78 return; 79 } 80 kmark_symbol(sym); 81 82 TValue np = kimm_cons(K, sym, KNIL); 83 kset_cdr_unsafe(K, lp, np); 84 lp = np; 85 kadd_binding(K, env, sym, val); 86 } 87 88 unmark_symbol_list(K, kcdr(dummy)); 89 TValue new_lib = kmake_library(K, env, kcdr(dummy)); 90 krooted_tvs_pop(K); krooted_tvs_pop(K); 91 kapply_cc(K, new_lib); 92 } 93 94 /* ?.? get-library-export-list */ 95 static void get_library_export_list(klisp_State *K) 96 { 97 bind_1tp(K, K->next_value, "library", ttislibrary, lib); 98 /* return mutable list (following the Kernel report) */ 99 /* XXX could use unchecked_copy_list if available */ 100 TValue copy = check_copy_list(K, klibrary_exp_list(lib), true, NULL, NULL); 101 kapply_cc(K, copy); 102 } 103 104 /* ?.? get-library-environment */ 105 static void get_library_environment(klisp_State *K) 106 { 107 bind_1tp(K, K->next_value, "library", ttislibrary, lib); 108 kapply_cc(K, kmake_environment(K, klibrary_env(lib))); 109 } 110 111 /* Helpers for working with library names */ 112 static bool valid_name_partp(TValue obj) 113 { 114 return ttissymbol(obj) || (keintegerp(obj) && !knegativep(obj)); 115 } 116 117 static void check_library_name(klisp_State *K, TValue name) 118 { 119 if (ttisnil(name)) { 120 klispE_throw_simple(K, "Empty library name"); 121 return; 122 } 123 check_typed_list(K, valid_name_partp, false, name, NULL, NULL); 124 } 125 126 static TValue libraries_registry_assoc(klisp_State *K, TValue name, TValue *lastp) 127 { 128 TValue last = KNIL; 129 TValue res = KNIL; 130 for (TValue ls = G(K)->libraries_registry; !ttisnil(ls); last = ls, 131 ls = kcdr(ls)) { 132 if (equal2p(K, kcar(kcar(ls)), name)) { 133 res = kcar(ls); 134 break; 135 } 136 } 137 if (lastp != NULL) *lastp = last; 138 return res; 139 } 140 141 /* ?.? $registered-library? */ 142 static void Sregistered_libraryP(klisp_State *K) 143 { 144 bind_1p(K, K->next_value, name); 145 check_library_name(K, name); 146 TValue entry = libraries_registry_assoc(K, name, NULL); 147 kapply_cc(K, ttisnil(entry)? KFALSE : KTRUE); 148 } 149 150 /* ?.? $get-registered-library */ 151 static void Sget_registered_library(klisp_State *K) 152 { 153 bind_1p(K, K->next_value, name); 154 check_library_name(K, name); 155 TValue entry = libraries_registry_assoc(K, name, NULL); 156 if (ttisnil(entry)) { 157 klispE_throw_simple_with_irritants(K, "Unregistered library name", 158 1, name); 159 return; 160 } 161 kapply_cc(K, kcdr(entry)); 162 } 163 164 static void do_register_library(klisp_State *K) 165 { 166 /* 167 ** xparams[0]: name 168 */ 169 TValue obj = K->next_value; 170 if (!ttislibrary(obj)) { 171 klispE_throw_simple_with_irritants(K, "not a library", 1, obj); 172 return; 173 } 174 TValue name = K->next_xparams[0]; 175 TValue entry = libraries_registry_assoc(K, name, NULL); 176 if (!ttisnil(entry)) { 177 klispE_throw_simple_with_irritants(K, "library name already registered", 178 1, name); 179 return; 180 } 181 TValue np = kcons(K, name, obj); 182 krooted_tvs_push(K, np); 183 np = kcons(K, np, G(K)->libraries_registry); 184 G(K)->libraries_registry = np; 185 krooted_tvs_pop(K); 186 kapply_cc(K, KINERT); 187 } 188 189 /* ?.? $register-library! */ 190 static void Sregister_libraryB(klisp_State *K) 191 { 192 bind_2p(K, K->next_value, name, library); 193 check_library_name(K, name); 194 /* copy the name to avoid mutation */ 195 /* XXX could use unchecked_copy_list if available */ 196 name = check_copy_list(K, name, false, NULL, NULL); 197 krooted_tvs_push(K, name); 198 TValue cont = kmake_continuation(K, kget_cc(K), do_register_library, 199 1, name); 200 krooted_tvs_pop(K); 201 kset_cc(K, cont); 202 ktail_eval(K, library, K->next_env); 203 } 204 205 /* ?.? $unregister-library! */ 206 static void Sunregister_libraryB(klisp_State *K) 207 { 208 bind_1p(K, K->next_value, name); 209 check_library_name(K, name); 210 TValue last; 211 TValue entry = libraries_registry_assoc(K, name, &last); 212 if (ttisnil(entry)) { 213 klispE_throw_simple_with_irritants(K, "library name not registered", 214 1, name); 215 return; 216 } 217 if (ttisnil(last)) { /* it's in the first pair */ 218 G(K)->libraries_registry = kcdr(G(K)->libraries_registry); 219 } else { 220 kset_cdr(last, kcdr(kcdr(last))); 221 } 222 kapply_cc(K, KINERT); 223 } 224 225 /* Helpers for provide-library */ 226 static void unmark_export_list(klisp_State *K, TValue exports, TValue last) 227 { 228 /* exports shouldn't have the leading keyword */ 229 UNUSED(K); 230 for (; !tv_equal(exports, last); exports = kcdr(exports)) { 231 TValue first = kcar(exports); 232 if (ttissymbol(first)) 233 kunmark_symbol(first); 234 else 235 kunmark_symbol(kcar(kcdr(kcdr(first)))); 236 } 237 } 238 239 static void check_export_list(klisp_State *K, TValue exports) 240 { 241 int32_t pairs; 242 check_list(K, false, exports, &pairs, NULL); 243 if (ttisnil(exports) || !ttiskeyword(kcar(exports)) || 244 kkeyword_cstr_cmp(kcar(exports), "export") != 0) { 245 246 klispE_throw_simple_with_irritants(K, "missing #:export keyword", 247 1, exports); 248 return; 249 } 250 /* empty export list are allowed (but still need #:export) */ 251 --pairs; 252 exports = kcdr(exports); 253 /* check that all entries are either a unique symbol or 254 a rename form: (#:rename int-s ext-s) with unique ext-s */ 255 for (TValue tail = exports; pairs > 0; --pairs, tail = kcdr(tail)) { 256 TValue clause = kcar(tail); 257 TValue symbol; 258 if (ttissymbol(clause)) { 259 symbol = clause; 260 } else { 261 int32_t pairs; 262 /* this use of marks doesn't interfere with symbols */ 263 check_list(K, false, clause, &pairs, NULL); 264 if (pairs != 3 || 265 kkeyword_cstr_cmp(kcar(clause), "rename") != 0) { 266 267 unmark_export_list(K, exports, tail); 268 klispE_throw_simple_with_irritants(K, "Bad export clause " 269 "syntax", 1, clause); 270 return; 271 } else if (!ttissymbol(kcar(kcdr(clause))) || 272 !ttissymbol(kcar(kcdr(kcdr(clause))))) { 273 unmark_export_list(K, exports, tail); 274 klispE_throw_simple_with_irritants(K, "Non symbol in #:rename " 275 "export clause", 1, clause); 276 return; 277 } else { 278 symbol = kcar(kcdr(kcdr(clause))); 279 } 280 } 281 282 if (kis_symbol_marked(symbol)) { 283 unmark_export_list(K, exports, tail); 284 klispE_throw_simple_with_irritants(K, "repeated symbol in export " 285 "list", 1, symbol); 286 return; 287 } 288 kmark_symbol(symbol); 289 } 290 unmark_export_list(K, exports, KNIL); 291 } 292 293 static void do_provide_library(klisp_State *K) 294 { 295 /* 296 ** xparams[0]: name 297 ** xparams[1]: inames 298 ** xparams[2]: enames 299 ** xparams[3]: env 300 */ 301 TValue name = K->next_xparams[0]; 302 303 if (!ttisnil(libraries_registry_assoc(K, name, NULL))) { 304 klispE_throw_simple_with_irritants(K, "library name already registered", 305 1, name); 306 return; 307 } 308 309 TValue inames = K->next_xparams[1]; 310 TValue enames = K->next_xparams[2]; 311 TValue env = K->next_xparams[3]; 312 313 TValue new_env = kmake_table_environment(K, KNIL); 314 krooted_tvs_push(K, new_env); 315 316 for (; !ttisnil(inames); inames = kcdr(inames), enames = kcdr(enames)) { 317 TValue iname = kcar(inames); 318 if (!kbinds(K, env, iname)) { 319 klispE_throw_simple_with_irritants(K, "unbound exported symbol in " 320 "library", 1, iname); 321 return; 322 } 323 kadd_binding(K, new_env, kcar(enames), kget_binding(K, env, iname)); 324 } 325 326 enames = K->next_xparams[2]; 327 TValue library = kmake_library(K, new_env, enames); 328 krooted_tvs_pop(K); /* new_env */ 329 krooted_tvs_push(K, library); 330 331 TValue np = kcons(K, name, library); 332 krooted_tvs_pop(K); /* library */ 333 krooted_tvs_push(K, np); 334 np = kcons(K, np, G(K)->libraries_registry); 335 G(K)->libraries_registry = np; 336 krooted_tvs_pop(K); 337 kapply_cc(K, KINERT); 338 } 339 340 /* ?.? $provide-library! */ 341 static void Sprovide_libraryB(klisp_State *K) 342 { 343 bind_al2p(K, K->next_value, name, exports, body); 344 check_library_name(K, name); 345 name = check_copy_list(K, name, false, NULL, NULL); 346 krooted_tvs_push(K, name); 347 check_export_list(K, exports); 348 TValue inames = kimm_cons(K, KNIL, KNIL); 349 TValue ilast = inames; 350 krooted_vars_push(K, &inames); 351 TValue enames = kimm_cons(K, KNIL, KNIL); 352 TValue elast = enames; 353 krooted_vars_push(K, &enames); 354 355 for (exports = kcdr(exports); !ttisnil(exports); exports = kcdr(exports)) { 356 TValue clause = kcar(exports); 357 TValue isym, esym; 358 if (ttissymbol(clause)) { 359 isym = esym = clause; 360 } else { 361 isym = kcar(kcdr(clause)); 362 esym = kcar(kcdr(kcdr(clause))); 363 } 364 TValue np = kimm_cons(K, isym, KNIL); 365 kset_cdr_unsafe(K, ilast, np); 366 ilast = np; 367 np = kimm_cons(K, esym, KNIL); 368 kset_cdr_unsafe(K, elast, np); 369 elast = np; 370 } 371 inames = kcdr(inames); 372 enames = kcdr(enames); 373 374 check_list(K, false, body, NULL, NULL); 375 376 body = copy_es_immutable_h(K, body, false); 377 krooted_tvs_push(K, body); 378 379 if (!ttisnil(libraries_registry_assoc(K, name, NULL))) { 380 klispE_throw_simple_with_irritants(K, "library name already registered", 381 1, name); 382 return; 383 } 384 /* TODO add some continuation protection/additional checks */ 385 /* TODO add cyclical definition handling */ 386 // do cont 387 388 /* use a child of the dynamic environment to do evaluations */ 389 TValue env = kmake_table_environment(K, K->next_env); 390 krooted_tvs_push(K, env); 391 392 kset_cc(K, kmake_continuation(K, kget_cc(K), do_provide_library, 393 4, name, inames, enames, env)); 394 395 if (!ttisnil(body) && !ttisnil(kcdr(body))) { 396 TValue cont = kmake_continuation(K, kget_cc(K), do_seq, 2, 397 kcdr(body), env); 398 kset_cc(K, cont); 399 #if KTRACK_SI 400 /* put the source info of the list including the element 401 that we are about to evaluate */ 402 kset_source_info(K, cont, ktry_get_si(K, body)); 403 #endif 404 } 405 406 krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K); 407 krooted_vars_pop(K); krooted_vars_pop(K); 408 409 if (ttisnil(body)) { 410 kapply_cc(K, KINERT); 411 } else { 412 ktail_eval(K, kcar(body), env); 413 } 414 } 415 416 /* Helpers from $import-library! */ 417 418 /* This takes a keyword import clause */ 419 static void check_distinct_symbols(klisp_State *K, TValue clause) 420 { 421 /* probably no need to use a table environment for this */ 422 TValue env = kmake_empty_environment(K); 423 krooted_tvs_push(K, env); 424 bool pairp = kkeyword_cstr_cmp(kcar(clause), "rename") == 0; 425 for (TValue ls = kcdr(kcdr(clause)); !ttisnil(ls); ls = kcdr(ls)) { 426 TValue s = kcar(ls); 427 TValue s2 = s; 428 if (pairp) { 429 if (!ttispair(s) || !ttispair(kcdr(s)) || 430 !ttisnil(kcdr(kcdr(s)))) { 431 432 klispE_throw_simple_with_irritants(K, "bad syntax in #:rename " 433 "import clause", 1, clause); 434 return; 435 } 436 s2 = kcar(s); 437 /* s is the one that is checked for repeats */ 438 s = kcar(kcdr(s)); 439 } 440 if (!ttissymbol(s) || !ttissymbol(s2)) { 441 klispE_throw_simple_with_irritants( 442 K, "Not a symbol in import clause", 1, ttissymbol(s)? s2 : s); 443 return; 444 } else if (kbinds(K, env, s)) { 445 klispE_throw_simple_with_irritants(K, "Repeated symbol in import " 446 "clause", 1, s); 447 return; 448 } 449 kadd_binding(K, env, s, KINERT); 450 } 451 krooted_tvs_pop(K); 452 } 453 454 static void check_import_list(klisp_State *K, TValue imports) 455 { 456 /* will use a stack for accumulating clauses */ 457 TValue stack = KNIL; 458 krooted_vars_push(K, &stack); 459 check_list(K, false, imports, NULL, NULL); 460 461 while(!ttisnil(stack) || !ttisnil(imports)) { 462 TValue clause; 463 if (ttisnil(stack)) { 464 clause = kcar(imports); 465 while (ttispair(clause) && ttiskeyword(kcar(clause))) { 466 stack = kcons(K, clause, stack); 467 clause = kcar(kcdr(clause)); 468 } 469 check_library_name(K, clause); 470 } else { 471 /* this is always a keyword clause */ 472 clause = kcar(stack); 473 stack = kcdr(stack); 474 int32_t pairs; 475 check_list(K, false, clause, &pairs, NULL); 476 if (pairs < 3) { 477 klispE_throw_simple_with_irritants(K, "bad syntax in import " 478 "clause", 1, clause); 479 return; 480 } 481 TValue keyw = kcar(clause); 482 483 if (kkeyword_cstr_cmp(keyw, "only") == 0 || 484 kkeyword_cstr_cmp(keyw, "except") == 0 || 485 kkeyword_cstr_cmp(keyw, "rename") == 0) { 486 487 check_distinct_symbols(K, clause); 488 } else if (kkeyword_cstr_cmp(keyw, "prefix") == 0) { 489 if (pairs != 3) { 490 klispE_throw_simple_with_irritants(K, "import clause is too " 491 "short", 1, clause); 492 return; 493 } else if (!ttissymbol(kcar(kcdr(kcdr(clause))))) { 494 klispE_throw_simple_with_irritants( 495 K, "Non symbol in #:prefix import clause", 1, clause); 496 return; 497 } 498 } else { 499 klispE_throw_simple_with_irritants(K, "unknown keyword in " 500 "import clause", 1, clause); 501 return; 502 } 503 } 504 if (ttisnil(stack)) 505 imports = kcdr(imports); 506 } 507 krooted_vars_pop(K); 508 } 509 510 static void check_symbols_in_bindings(klisp_State *K, TValue ls, TValue env) 511 { 512 for (; !ttisnil(ls); ls = kcdr(ls)) { 513 TValue s = kcar(ls); 514 if (ttispair(s)) s = kcar(s); 515 516 if (!kbinds(K, env, s)) { 517 klispE_throw_simple_with_irritants( 518 K, "Unknown symbol in import clause", 1, s); 519 return; 520 } 521 } 522 } 523 524 static TValue extract_import_bindings(klisp_State *K, TValue imports) 525 { 526 TValue ret_ls = kcons(K, KNIL, KNIL); 527 TValue lp = ret_ls; 528 krooted_tvs_push(K, ret_ls); 529 TValue np = KNIL; 530 krooted_vars_push(K, &np); 531 /* will use a stack for accumulating clauses */ 532 TValue stack = KNIL; 533 krooted_vars_push(K, &stack); 534 TValue menv = KINERT; 535 TValue mls = KINERT; 536 krooted_vars_push(K, &menv); 537 krooted_vars_push(K, &mls); 538 539 while(!ttisnil(stack) || !ttisnil(imports)) { 540 TValue clause; 541 if (ttisnil(stack)) { 542 /* clause can't be nil */ 543 clause = kcar(imports); 544 while (ttiskeyword(kcar(clause))) { 545 stack = kcons(K, clause, stack); 546 clause = kcar(kcdr(clause)); 547 } 548 TValue entry = libraries_registry_assoc(K, clause, NULL); 549 if (ttisnil(entry)) { 550 klispE_throw_simple_with_irritants(K, "library name not " 551 "registered", 1, clause); 552 return KINERT; 553 } 554 menv = klibrary_env(kcdr(entry)); 555 mls = klibrary_exp_list(kcdr(entry)); 556 557 klisp_assert(ttispair(clause) && !ttiskeyword(kcar(clause))); 558 } else { 559 clause = kcar(stack); 560 stack = kcdr(stack); 561 } 562 563 if (ttiskeyword(kcar(clause))) { 564 TValue keyw = kcar(clause); 565 566 TValue rest = kcdr(kcdr(clause)); 567 if (kkeyword_cstr_cmp(keyw, "only") == 0) { 568 check_symbols_in_bindings(K, rest, menv); 569 mls = rest; 570 } else if (kkeyword_cstr_cmp(keyw, "except") == 0) { 571 check_symbols_in_bindings(K, rest, menv); 572 TValue env = kmake_empty_environment(K); 573 krooted_tvs_push(K, env); 574 for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls)) 575 kadd_binding(K, env, kcar(ls), KINERT); 576 /* filter */ 577 TValue nmls = kcons(K, KNIL, KNIL); 578 TValue nmls_lp = nmls; 579 krooted_tvs_push(K, nmls); 580 for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) { 581 TValue s = kcar(ls); 582 if (!kbinds(K, env, s)) { 583 np = kcons(K, s, KNIL); 584 kset_cdr(nmls_lp, np); 585 nmls_lp = np; 586 } 587 } 588 mls = kcdr(nmls); 589 krooted_tvs_pop(K); krooted_tvs_pop(K); 590 } else if (kkeyword_cstr_cmp(keyw, "prefix") == 0) { 591 TValue pre = kcar(rest); 592 TValue obj = KNIL; 593 krooted_vars_push(K, &obj); 594 TValue nmls = kcons(K, KNIL, KNIL); 595 TValue nmls_lp = nmls; 596 krooted_tvs_push(K, nmls); 597 TValue nmenv = kmake_empty_environment(K); 598 krooted_tvs_push(K, nmenv); 599 for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) { 600 TValue s = kcar(ls); 601 obj = kstring_new_s(K, ksymbol_size(pre) + 602 ksymbol_size(s)); 603 memcpy(kstring_buf(obj), ksymbol_buf(pre), 604 ksymbol_size(pre)); 605 memcpy(kstring_buf(obj) + ksymbol_size(pre), 606 ksymbol_buf(s), ksymbol_size(s)); 607 /* TODO attach si */ 608 obj = ksymbol_new_str(K, obj, KNIL); 609 np = kcons(K, obj, KNIL); 610 kset_cdr(nmls_lp, np); 611 nmls_lp = np; 612 613 kadd_binding(K, nmenv, obj, kget_binding(K, menv, s)); 614 } 615 mls = kcdr(nmls); 616 menv = nmenv; 617 krooted_vars_pop(K); 618 krooted_tvs_pop(K); krooted_tvs_pop(K); 619 } else if (kkeyword_cstr_cmp(keyw, "rename") == 0) { 620 check_distinct_symbols(K, clause); 621 /* env is for renamed symbols info */ 622 TValue env = kmake_empty_environment(K); 623 krooted_tvs_push(K, env); 624 625 /* remember all renamed symbols info first */ 626 for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls)) { 627 TValue p = kcar(ls); 628 kadd_binding(K, env, kcar(p), kcar(kcdr(p))); 629 } 630 631 /* now we can construct the list and env */ 632 TValue nmls = kcons(K, KNIL, KNIL); 633 TValue nmls_lp = nmls; 634 krooted_tvs_push(K, nmls); 635 TValue nmenv = kmake_empty_environment(K); 636 krooted_tvs_push(K, nmenv); 637 638 639 /* add all renamed symbols first */ 640 for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) { 641 TValue si = kcar(ls); 642 TValue se; 643 if (kbinds(K, env, si)) /* renamed binding */ 644 se = kget_binding(K, env, si); 645 else se = si; 646 647 /* check that symbol wasn't already defined 648 (can happen if a binding is renamed to another binding 649 of the same library and that other binding isn't itself 650 renamed) */ 651 if (kbinds(K, nmenv, se)) { 652 klispE_throw_simple_with_irritants( 653 K, "imported a symbol twice in #:rename clause", 654 1, se); 655 return KINERT; 656 } 657 658 np = kcons(K, se, KNIL); 659 kset_cdr(nmls_lp, np); 660 nmls_lp = np; 661 662 kadd_binding(K, nmenv, se, kget_binding(K, menv, si)); 663 } 664 665 mls = kcdr(nmls); 666 menv = nmenv; 667 krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K); 668 } 669 } 670 671 if (ttisnil(stack)) { 672 /* move to next import clause */ 673 for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) { 674 TValue s = kcar(ls); 675 np = kcons(K, s, kget_binding(K, menv, s)); 676 np = kcons(K, np, KNIL); 677 kset_cdr(lp, np); 678 lp = np; 679 } 680 imports = kcdr(imports); 681 } 682 } 683 krooted_vars_pop(K); krooted_vars_pop(K); 684 krooted_vars_pop(K); krooted_vars_pop(K); 685 krooted_tvs_pop(K); 686 return kcdr(ret_ls); 687 } 688 689 /* ?.? $import-library! */ 690 static void Simport_libraryB(klisp_State *K) 691 { 692 TValue imports = K->next_value; 693 TValue denv = K->next_env; 694 695 check_import_list(K, imports); 696 /* list of (name . value) pairs */ 697 TValue bindings = extract_import_bindings(K, imports); 698 krooted_tvs_push(K, bindings); 699 700 TValue env = kmake_table_environment(K, KNIL); 701 krooted_tvs_push(K, env); 702 TValue tail; 703 for (tail = bindings; !ttisnil(tail); tail = kcdr(tail)) { 704 TValue s = kcar(kcar(tail)); 705 TValue v = kcdr(kcar(tail)); 706 if (kbinds(K, env, s)) { 707 TValue v2 = kget_binding(K, env, s); 708 if (!eq2p(K, v, v2)) { 709 klispE_throw_simple_with_irritants( 710 K, "imported a symbol twice with un-eq? values", 711 3, s, v, v2); 712 return; 713 } 714 } else { 715 kadd_binding(K, env, s, v); 716 } 717 } 718 719 for (tail = bindings; !ttisnil(tail); tail = kcdr(tail)) { 720 TValue s = kcar(kcar(tail)); 721 TValue v = kcdr(kcar(tail)); 722 kadd_binding(K, denv, s, v); 723 } 724 krooted_tvs_pop(K); krooted_tvs_pop(K); 725 kapply_cc(K, KINERT); 726 } 727 728 /* init ground */ 729 void kinit_libraries_ground_env(klisp_State *K) 730 { 731 TValue ground_env = G(K)->ground_env; 732 TValue symbol, value; 733 734 add_applicative(K, ground_env, "library?", typep, 2, symbol, 735 i2tv(K_TLIBRARY)); 736 add_applicative(K, ground_env, "make-library", make_library, 0); 737 add_applicative(K, ground_env, "get-library-export-list", 738 get_library_export_list, 0); 739 add_applicative(K, ground_env, "get-library-environment", 740 get_library_environment, 0); 741 742 add_operative(K, ground_env, "$registered-library?", Sregistered_libraryP, 743 0); 744 add_operative(K, ground_env, "$get-registered-library", 745 Sget_registered_library, 0); 746 add_operative(K, ground_env, "$register-library!", Sregister_libraryB, 747 0); 748 add_operative(K, ground_env, "$unregister-library!", Sunregister_libraryB, 749 0); 750 751 add_operative(K, ground_env, "$provide-library!", Sprovide_libraryB, 0); 752 add_operative(K, ground_env, "$import-library!", Simport_libraryB, 0); 753 } 754 755 /* XXX lock? */ 756 /* init continuation names */ 757 void kinit_libraries_cont_names(klisp_State *K) 758 { 759 Table *t = tv2table(G(K)->cont_name_table); 760 761 add_cont_name(K, t, do_register_library, "register-library"); 762 add_cont_name(K, t, do_provide_library, "provide-library"); 763 }