kgpairs_lists.c (42493B)
1 /* 2 ** kgpairs_lists.c 3 ** Pairs and lists 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 "kstring.h" 17 #include "kcontinuation.h" 18 #include "kenvironment.h" 19 #include "ksymbol.h" 20 #include "kerror.h" 21 22 #include "kghelpers.h" 23 #include "kgpairs_lists.h" 24 25 /* Continuations */ 26 void do_memberp(klisp_State *K); 27 void do_assoc(klisp_State *K); 28 void do_filter(klisp_State *K); 29 30 void do_reduce(klisp_State *K); 31 void do_reduce_prec(klisp_State *K); 32 void do_reduce_postc(klisp_State *K); 33 void do_reduce_combine(klisp_State *K); 34 void do_reduce_cycle(klisp_State *K); 35 36 /* 4.6.1 pair? */ 37 /* uses typep */ 38 39 /* 4.6.2 null? */ 40 /* uses typep */ 41 42 /* 4.6.3 cons */ 43 void cons(klisp_State *K) 44 { 45 TValue *xparams = K->next_xparams; 46 TValue ptree = K->next_value; 47 TValue denv = K->next_env; 48 klisp_assert(ttisenvironment(K->next_env)); 49 UNUSED(denv); 50 UNUSED(xparams); 51 bind_2p(K, ptree, car, cdr); 52 53 TValue new_pair = kcons(K, car, cdr); 54 kapply_cc(K, new_pair); 55 } 56 57 /* 5.2.1 list */ 58 /* defined in kghelpers.h (for use in kstate) */ 59 60 /* 5.2.2 list* */ 61 void listS(klisp_State *K) 62 { 63 TValue *xparams = K->next_xparams; 64 TValue ptree = K->next_value; 65 TValue denv = K->next_env; 66 klisp_assert(ttisenvironment(K->next_env)); 67 /* TODO: 68 OPTIMIZE: if this call is a result of a call to eval, we could get away 69 with just setting the kcdr of the next to last pair to the car of 70 the last pair, because the list of operands is fresh. Also the type 71 check wouldn't be necessary. This optimization technique could be 72 used in lots of places to avoid checks and the like. */ 73 UNUSED(xparams); 74 UNUSED(denv); 75 76 if (ttisnil(ptree)) { 77 klispE_throw_simple(K, "empty argument list"); 78 return; 79 } 80 TValue res_obj = kcons(K, KNIL, KNIL); 81 krooted_vars_push(K, &res_obj); 82 TValue last_pair = res_obj; 83 TValue tail = ptree; 84 85 /* First copy the list, but remembering the next to last pair */ 86 while(ttispair(tail) && !kis_marked(tail)) { 87 kmark(tail); 88 /* we save the next_to last pair in the cdr to 89 allow the change into an improper list later */ 90 TValue new_pair = kcons(K, kcar(tail), last_pair); 91 kset_cdr(last_pair, new_pair); 92 last_pair = new_pair; 93 tail = kcdr(tail); 94 } 95 unmark_list(K, ptree); 96 97 if (ttisnil(tail)) { 98 /* Now eliminate the last pair to get the correct improper list. 99 This avoids an if in the above loop. It's inside the if because 100 we need at least one pair for this to work. */ 101 TValue next_to_last_pair = kcdr(last_pair); 102 kset_cdr(next_to_last_pair, kcar(last_pair)); 103 krooted_vars_pop(K); 104 kapply_cc(K, kcdr(res_obj)); 105 } else if (ttispair(tail)) { /* cyclic argument list */ 106 klispE_throw_simple(K, "cyclic argument list"); 107 return; 108 } else { 109 klispE_throw_simple(K, "argument list is improper"); 110 return; 111 } 112 } 113 114 /* Helper macros to construct xparams[1] for c[ad]{1,4}r */ 115 #define C_AD_R_PARAM(len_, br_) \ 116 (i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_))))) 117 #define C_AD_R_LEN(len_) ((len_) << 4) 118 #define C_AD_R_BRANCH(br_) \ 119 ((br_ & 0x0001? 0x1 : 0) | \ 120 (br_ & 0x0010? 0x2 : 0) | \ 121 (br_ & 0x0100? 0x4 : 0) | \ 122 (br_ & 0x1000? 0x8 : 0)) 123 124 /* 5.4.1 car, cdr */ 125 /* 5.4.2 caar, cadr, ... cddddr */ 126 void c_ad_r(klisp_State *K) 127 { 128 TValue *xparams = K->next_xparams; 129 TValue ptree = K->next_value; 130 TValue denv = K->next_env; 131 klisp_assert(ttisenvironment(K->next_env)); 132 133 UNUSED(denv); 134 135 /* 136 ** xparams[0]: name as symbol 137 ** xparams[1]: an int with the less significant 2 nibbles 138 ** standing for the count and the branch selection. 139 ** The high nibble is the count: that is the number of 140 ** 'a's and 'd's in the name, for example: 141 ** 0x1? for car and cdr. 142 ** 0x2? for caar, cadr, cdar and cddr. 143 ** The low nibble is the branch selection, a 0 bit means 144 ** car, a 1 bit means cdr, the first bit to be applied 145 ** is bit 0 so: caar=0x20, cadr=0x21, cdar:0x22, cddr 0x23 146 */ 147 148 int p = ivalue(xparams[1]); 149 int count = (p >> 4) & 0xf; 150 int branches = p & 0xf; 151 152 bind_1p(K, ptree, obj); 153 154 while(count) { 155 if (!ttispair(obj)) { 156 klispE_throw_simple(K, "non pair found while traversing"); 157 return; 158 } 159 obj = ((branches & 1) == 0)? kcar(obj) : kcdr(obj); 160 branches >>= 1; 161 --count; 162 } 163 kapply_cc(K, obj); 164 } 165 166 /* 5.4.? make-list */ 167 void make_list(klisp_State *K) 168 { 169 TValue *xparams = K->next_xparams; 170 TValue ptree = K->next_value; 171 TValue denv = K->next_env; 172 klisp_assert(ttisenvironment(K->next_env)); 173 174 UNUSED(xparams); 175 UNUSED(denv); 176 177 bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill); 178 179 if (!get_opt_tpar(K, fill, "any", anytype)) 180 fill = KINERT; 181 182 if (knegativep(tv_s)) { 183 klispE_throw_simple(K, "negative list length"); 184 return; 185 } else if (!ttisfixint(tv_s)) { 186 klispE_throw_simple(K, "list length is too big"); 187 return; 188 } 189 TValue tail = KNIL; 190 int i = ivalue(tv_s); 191 krooted_vars_push(K, &tail); 192 while(i-- > 0) { 193 tail = kcons(K, fill, tail); 194 } 195 krooted_vars_pop(K); 196 197 kapply_cc(K, tail); 198 } 199 200 /* 5.4.? list-copy */ 201 void list_copy(klisp_State *K) 202 { 203 TValue *xparams = K->next_xparams; 204 TValue ptree = K->next_value; 205 TValue denv = K->next_env; 206 klisp_assert(ttisenvironment(K->next_env)); 207 208 UNUSED(xparams); 209 UNUSED(denv); 210 211 bind_1p(K, ptree, ls); 212 TValue copy = check_copy_list(K, ls, true, NULL, NULL); 213 kapply_cc(K, copy); 214 } 215 216 /* 5.4.? reverse */ 217 void reverse(klisp_State *K) 218 { 219 TValue *xparams = K->next_xparams; 220 TValue ptree = K->next_value; 221 TValue denv = K->next_env; 222 klisp_assert(ttisenvironment(K->next_env)); 223 224 UNUSED(xparams); 225 UNUSED(denv); 226 227 bind_1p(K, ptree, ls); 228 TValue tail = ls; 229 TValue res = KNIL; 230 krooted_vars_push(K, &res); 231 while(ttispair(tail) && !kis_marked(tail)) { 232 kmark(tail); 233 res = kcons(K, kcar(tail), res); 234 tail = kcdr(tail); 235 } 236 unmark_list(K, ls); 237 krooted_vars_pop(K); 238 239 if (ttispair(tail)) { 240 klispE_throw_simple(K, "expected acyclic list"); 241 } else if (!ttisnil(tail)) { 242 klispE_throw_simple(K, "expected list"); 243 } else { 244 kapply_cc(K, res); 245 } 246 } 247 248 /* 5.7.1 get-list-metrics */ 249 void get_list_metrics(klisp_State *K) 250 { 251 TValue *xparams = K->next_xparams; 252 TValue ptree = K->next_value; 253 TValue denv = K->next_env; 254 klisp_assert(ttisenvironment(K->next_env)); 255 UNUSED(xparams); 256 UNUSED(denv); 257 258 bind_1p(K, ptree, obj); 259 260 int32_t pairs, nils, apairs, cpairs; 261 get_list_metrics_aux(K, obj, &pairs, &nils, &apairs, &cpairs); 262 263 TValue res = klist(K, 4, i2tv(pairs), i2tv(nils), 264 i2tv(apairs), i2tv(cpairs)); 265 kapply_cc(K, res); 266 } 267 268 /* 5.7.2 list-tail */ 269 void list_tail(klisp_State *K) 270 { 271 TValue *xparams = K->next_xparams; 272 TValue ptree = K->next_value; 273 TValue denv = K->next_env; 274 klisp_assert(ttisenvironment(K->next_env)); 275 /* ASK John: can the object be a cyclic list? the wording of the report 276 seems to indicate that can't be the case, but it makes sense here 277 (cf $encycle!) to allow cyclic lists, so that's what I do */ 278 UNUSED(xparams); 279 UNUSED(denv); 280 bind_2tp(K, ptree, "any", anytype, obj, 281 "exact integer", keintegerp, tk); 282 283 if (knegativep(tk)) { 284 klispE_throw_simple(K, "negative index"); 285 return; 286 } 287 288 int32_t k = (ttisfixint(tk))? ivalue(tk) 289 : ksmallest_index(K, obj, tk); 290 291 while(k) { 292 if (!ttispair(obj)) { 293 klispE_throw_simple(K, "non pair found while traversing " 294 "object"); 295 return; 296 } 297 obj = kcdr(obj); 298 --k; 299 } 300 kapply_cc(K, obj); 301 } 302 303 /* 6.3.1 length */ 304 void length(klisp_State *K) 305 { 306 TValue *xparams = K->next_xparams; 307 TValue ptree = K->next_value; 308 TValue denv = K->next_env; 309 klisp_assert(ttisenvironment(K->next_env)); 310 UNUSED(xparams); 311 UNUSED(denv); 312 313 bind_1p(K, ptree, obj); 314 315 TValue tail = obj; 316 int pairs = 0; 317 while(ttispair(tail) && !kis_marked(tail)) { 318 kmark(tail); 319 tail = kcdr(tail); 320 ++pairs; 321 } 322 unmark_list(K, obj); 323 324 TValue res = ttispair(tail)? KEPINF : i2tv(pairs); 325 kapply_cc(K, res); 326 } 327 328 /* 6.3.2 list-ref */ 329 void list_ref(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 /* ASK John: can the object be an improper list? the wording of the report 336 seems to indicate that can't be the case, but it makes sense 337 (cf list-tail) For now we allow it. */ 338 UNUSED(denv); 339 UNUSED(xparams); 340 341 bind_2tp(K, ptree, "any", anytype, obj, 342 "exact integer", keintegerp, tk); 343 344 if (knegativep(tk)) { 345 klispE_throw_simple(K, "negative index"); 346 return; 347 } 348 349 int32_t k = (ttisfixint(tk))? ivalue(tk) 350 : ksmallest_index(K, obj, tk); 351 352 while(k) { 353 if (!ttispair(obj)) { 354 klispE_throw_simple(K, "non pair found while traversing " 355 "object"); 356 return; 357 } 358 obj = kcdr(obj); 359 --k; 360 } 361 if (!ttispair(obj)) { 362 klispE_throw_simple(K, "non pair found while traversing " 363 "object"); 364 return; 365 } 366 TValue res = kcar(obj); 367 kapply_cc(K, res); 368 } 369 370 /* Helper for append */ 371 372 /* Check that ls is an acyclic list, copy it and return both the list 373 (as the ret value) and the last_pair. If obj is nil, *last_pair remains 374 unmodified (this avoids having to check ttisnil before calling this) */ 375 376 /* GC: Assumes obj is rooted */ 377 TValue append_check_copy_list(klisp_State *K, char *name, TValue obj, 378 TValue *last_pair_ptr) 379 { 380 /* return early if nil to avoid setting *last_pair_ptr */ 381 if (ttisnil(obj)) 382 return obj; 383 384 TValue copy = kcons(K, KNIL, KNIL); 385 krooted_vars_push(K, ©); 386 TValue last_pair = copy; 387 TValue tail = obj; 388 389 while(ttispair(tail) && !kis_marked(tail)) { 390 kmark(tail); 391 TValue new_pair = kcons(K, kcar(tail), KNIL); 392 kset_cdr(last_pair, new_pair); 393 last_pair = new_pair; 394 tail = kcdr(tail); 395 } 396 unmark_list(K, obj); 397 398 if (ttispair(tail)) { 399 klispE_throw_simple(K, "expected acyclic list"); 400 return KINERT; 401 } else if (!ttisnil(tail)) { 402 klispE_throw_simple(K, "expected list"); 403 return KINERT; 404 } 405 *last_pair_ptr = last_pair; 406 krooted_vars_pop(K); 407 return (kcdr(copy)); 408 } 409 410 /* 6.3.3 append */ 411 void append(klisp_State *K) 412 { 413 TValue *xparams = K->next_xparams; 414 TValue ptree = K->next_value; 415 TValue denv = K->next_env; 416 klisp_assert(ttisenvironment(K->next_env)); 417 UNUSED(xparams); 418 UNUSED(denv); 419 420 int32_t pairs, cpairs; 421 check_list(K, true, ptree, &pairs, &cpairs); 422 int32_t apairs = pairs - cpairs; 423 424 TValue res_list = kcons(K, KNIL, KNIL); 425 krooted_vars_push(K, &res_list); 426 TValue last_pair = res_list; 427 TValue lss = ptree; 428 TValue last_apair; 429 430 while (apairs != 0 || cpairs != 0) { 431 if (apairs == 0) { 432 /* this is the first run of the loop (if there is no acyclic part) 433 or the second run of the loop (the cyclic part), 434 must remember the last acyclic pair to encycle! the result */ 435 last_apair = last_pair; 436 pairs = cpairs; 437 } else { 438 /* this is the first (maybe only) run of the loop 439 (the acyclic part) */ 440 pairs = apairs; 441 } 442 443 while (pairs--) { 444 TValue first = kcar(lss); 445 lss = kcdr(lss); 446 TValue next_list; 447 TValue new_last_pair = last_pair; /* this helps if first is nil */ 448 /* don't check or copy last list */ 449 if (ttisnil(lss)) { 450 /* here, new_last_pair is bogus, but it isn't necessary 451 anymore so don't set it */ 452 next_list = first; 453 } else { 454 next_list = append_check_copy_list(K, "append", first, 455 &new_last_pair); 456 } 457 kset_cdr(last_pair, next_list); 458 last_pair = new_last_pair; 459 } 460 461 if (apairs != 0) { 462 /* acyclic part done */ 463 apairs = 0; 464 } else { 465 /* cyclic part done */ 466 cpairs = 0; 467 TValue first_cpair = kcdr(last_apair); 468 TValue last_cpair = last_pair; 469 /* this works even if there is no cycle to be formed 470 (kcdr(last_apair) == ()) */ 471 kset_cdr(last_cpair, first_cpair); /* encycle! */ 472 } 473 } 474 krooted_vars_pop(K); 475 kapply_cc(K, kcdr(res_list)); 476 } 477 478 /* 6.3.4 list-neighbors */ 479 void list_neighbors(klisp_State *K) 480 { 481 TValue *xparams = K->next_xparams; 482 TValue ptree = K->next_value; 483 TValue denv = K->next_env; 484 klisp_assert(ttisenvironment(K->next_env)); 485 UNUSED(xparams); 486 UNUSED(denv); 487 488 bind_1p(K, ptree, ls); 489 490 int32_t pairs, cpairs; 491 check_list(K, true, ls, &pairs, &cpairs); 492 493 TValue tail = ls; 494 int32_t count = cpairs? pairs - cpairs : pairs - 1; 495 TValue neighbors = kcons(K, KNIL, KNIL); 496 krooted_vars_push(K, &neighbors); 497 TValue last_pair = neighbors; 498 TValue last_apair = last_pair; /* set after first loop */ 499 bool doing_cycle = false; 500 501 while(count > 0 || !doing_cycle) { 502 while(count-- > 0) { /* can be -1 if ls is nil */ 503 TValue first = kcar(tail); 504 tail = kcdr(tail); /* tail advances one place per iter */ 505 TValue new_car = klist(K, 2, first, kcar(tail)); 506 krooted_tvs_push(K, new_car); 507 TValue new_pair = kcons(K, new_car, KNIL); 508 krooted_tvs_pop(K); 509 kset_cdr(last_pair, new_pair); 510 last_pair = new_pair; 511 } 512 513 if (doing_cycle) { 514 TValue first_cpair = kcdr(last_apair); 515 kset_cdr(last_pair, first_cpair); 516 } else { /* this is done even if cpairs is 0 to terminate the loop */ 517 doing_cycle = true; 518 /* must remember first cycle pair to reconstruct the cycle, 519 we can save the last outside of the cycle and then check 520 its cdr */ 521 last_apair = last_pair; 522 count = cpairs; /* this contains the sublist that has the last 523 and first element of the cycle */ 524 /* this will loop once more */ 525 } 526 } 527 krooted_vars_pop(K); 528 kapply_cc(K, kcdr(neighbors)); 529 } 530 531 /* Helpers for filter */ 532 533 /* For acyclic input lists: Return the filtered list */ 534 void do_ret_cdr(klisp_State *K) 535 { 536 TValue *xparams = K->next_xparams; 537 TValue obj = K->next_value; 538 klisp_assert(ttisnil(K->next_env)); 539 /* 540 ** xparams[0]: (dummy . complete-ls) 541 */ 542 UNUSED(obj); 543 /* copy the list to avoid problems with continuations 544 captured from within the dynamic extent to filter 545 and later mutation of the result */ 546 /* XXX: the check isn't necessary really, but there is 547 no list_copy (and if there was it would take apairs and 548 cpairs, which we don't have here */ 549 TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL); 550 kapply_cc(K, copy); 551 } 552 553 /* For cyclic input list: If the result cycle is non empty, 554 close it and return filtered list */ 555 void do_filter_encycle(klisp_State *K) 556 { 557 TValue *xparams = K->next_xparams; 558 TValue obj = K->next_value; 559 klisp_assert(ttisnil(K->next_env)); 560 /* 561 ** xparams[0]: (dummy . complete-ls) 562 ** xparams[1]: last non-cycle pair 563 */ 564 /* obj: (rem-ls . last-pair) */ 565 TValue last_pair = kcdr(obj); 566 TValue last_non_cycle_pair = xparams[1]; 567 568 if (tv_equal(last_pair, last_non_cycle_pair)) { 569 /* no cycle in result, this isn't strictly necessary 570 but just in case */ 571 kset_cdr(last_non_cycle_pair, KNIL); 572 } else { 573 /* There are pairs in the cycle, so close it */ 574 TValue first_cycle_pair = kcdr(last_non_cycle_pair); 575 TValue last_cycle_pair = last_pair; 576 kset_cdr(last_cycle_pair, first_cycle_pair); 577 } 578 579 /* copy the list to avoid problems with continuations 580 captured from within the dynamic extent to filter 581 and later mutation of the result */ 582 /* XXX: the check isn't necessary really, but there is 583 no list_copy (and if there was it would take apairs and 584 cpairs, which we don't have here */ 585 TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL); 586 kapply_cc(K, copy); 587 } 588 589 void do_filter(klisp_State *K) 590 { 591 TValue *xparams = K->next_xparams; 592 TValue obj = K->next_value; 593 klisp_assert(ttisnil(K->next_env)); 594 /* 595 ** xparams[0]: app 596 ** xparams[1]: (last-exp . rem-ls) 597 ** xparams[2]: acc 598 ** xparams[3]: rem-apairs (+1?) 599 ** xparams[4]: rem-cpairs (+1?) 600 ** xparams[5]: acc-apairs 601 ** xparams[6]: acc-cpairs 602 */ 603 TValue app = xparams[0]; 604 TValue ls = xparams[1]; 605 TValue last_exp = kcar(ls); 606 ls = kcdr(ls); 607 TValue acc = xparams[2]; 608 int32_t apairs = ivalue(xparams[3]); 609 int32_t cpairs = ivalue(xparams[4]); 610 int32_t acc_apairs = ivalue(xparams[5]); 611 int32_t acc_cpairs = ivalue(xparams[6]); 612 613 bool last_acyclicp; 614 615 if (apairs > 0) { 616 last_acyclicp = true; 617 --apairs; 618 } else { 619 last_acyclicp = false; 620 --cpairs; 621 } 622 623 if (!ttisboolean(obj)) { 624 klispE_throw_simple(K, "expected boolean result"); 625 return; 626 } 627 628 if (kis_true(obj)) { 629 acc = kcons(K, last_exp, acc); 630 if (last_acyclicp) 631 ++acc_apairs; 632 else 633 ++acc_cpairs; 634 } 635 636 krooted_tvs_push(K, acc); /* push it in case an object was added above */ 637 638 if (apairs > 0 || cpairs > 0) { 639 /* there is still some work to do */ 640 TValue new_env = kmake_empty_environment(K); 641 krooted_tvs_push(K, new_env); 642 /* have to unwrap the applicative to avoid extra evaluation of first */ 643 TValue new_expr = klist(K, 2, kunwrap(app), kcar(ls), KNIL); 644 krooted_tvs_push(K, new_expr); 645 TValue new_cont = 646 kmake_continuation(K, kget_cc(K), do_filter, 7, app, 647 ls, acc, i2tv(apairs), i2tv(cpairs), 648 i2tv(acc_apairs), i2tv(acc_cpairs)); 649 krooted_tvs_pop(K); /* acc, new_env & new_expr */ 650 krooted_tvs_pop(K); 651 krooted_tvs_pop(K); 652 653 kset_cc(K, new_cont); /* this will avoid GC */ 654 ktail_eval(K, new_expr, new_env); 655 } else { 656 /* reverse-copy the list and encycle if necessary */ 657 /* GC: acc is already rooted */ 658 TValue res = reverse_copy_and_encycle(K, acc, acc_apairs + acc_cpairs, 659 acc_cpairs); 660 krooted_tvs_pop(K); 661 kapply_cc(K, res); 662 } 663 } 664 665 /* 6.3.5 filter */ 666 void filter(klisp_State *K) 667 { 668 TValue *xparams = K->next_xparams; 669 TValue ptree = K->next_value; 670 TValue denv = K->next_env; 671 klisp_assert(ttisenvironment(K->next_env)); 672 UNUSED(xparams); 673 UNUSED(denv); 674 bind_2tp(K, ptree, "applicative", ttisapplicative, app, 675 "any", anytype, ls); 676 677 if (ttisnil(ls)) { 678 kapply_cc(K, KNIL); 679 } 680 681 /* copy the list to ignore changes made by the applicative */ 682 int32_t pairs, cpairs; 683 check_list(K, true, ls, &pairs, &cpairs); 684 ls = check_copy_list(K, ls, false, &pairs, &cpairs); 685 int apairs = pairs - cpairs; 686 687 krooted_tvs_push(K, ls); 688 TValue dummy_ls = kcons(K, KINERT, ls); 689 krooted_tvs_pop(K); 690 krooted_tvs_push(K, dummy_ls); 691 TValue new_cont = 692 kmake_continuation(K, kget_cc(K), do_filter, 7, app, 693 dummy_ls, KNIL, i2tv(apairs+1), i2tv(cpairs), i2tv(0), i2tv(0)); 694 /* pass apairs + 1 to allow do_filter to tell whether the last evaluation was from 695 the acyclic or cyclic part */ 696 krooted_tvs_pop(K); 697 kset_cc(K, new_cont); 698 /* this will be a nop, and will continue with do_filter */ 699 kapply_cc(K, KFALSE); 700 } 701 702 /* 6.3.6 assoc */ 703 /* helper if third optional argument is used */ 704 void do_assoc(klisp_State *K) 705 { 706 TValue *xparams = K->next_xparams; 707 TValue obj = K->next_value; 708 klisp_assert(ttisnil(K->next_env)); 709 /* 710 ** xparams[0]: pred 711 ** xparams[1]: obj to be compared 712 ** xparams[2]: last-pair + rem ls 713 ** xparams[3]: rem pairs 714 */ 715 716 TValue pred = xparams[0]; 717 TValue cmp_obj = xparams[1]; 718 TValue ls = xparams[2]; 719 int32_t pairs = ivalue(xparams[3]); 720 721 if (!ttisboolean(obj)) { 722 klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj); 723 return; 724 } else if (kis_true(obj) || pairs == 0) { 725 TValue res = kis_true(obj)? kcar(ls) : KNIL; 726 kapply_cc(K, res); 727 } else { 728 /* object not YET found */ 729 TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4, pred, 730 cmp_obj, kcdr(ls), i2tv(pairs-1)); 731 /* not necessary but may save a continuation in some cases */ 732 kset_bool_check_cont(cont); 733 kset_cc(K, cont); 734 TValue exp = kcons(K, kcar(kcar(kcdr(ls))), KNIL); 735 krooted_vars_push(K, &exp); 736 exp = kcons(K, cmp_obj, exp); 737 exp = kcons(K, pred, exp); 738 /* TEMP for now use an empty environment for dynamic env */ 739 TValue env = kmake_empty_environment(K); 740 krooted_vars_pop(K); 741 ktail_eval(K, exp, env); 742 } 743 } 744 745 void assoc(klisp_State *K) 746 { 747 TValue *xparams = K->next_xparams; 748 TValue ptree = K->next_value; 749 TValue denv = K->next_env; 750 klisp_assert(ttisenvironment(K->next_env)); 751 UNUSED(xparams); 752 UNUSED(denv); 753 754 bind_al2p(K, ptree, obj, ls, maybe_pred); 755 bool predp = get_opt_tpar(K, maybe_pred, "applicative", ttisapplicative); 756 /* first pass, check structure */ 757 int32_t pairs; 758 check_typed_list(K, kpairp, true, ls, &pairs, NULL); 759 760 TValue res; 761 if (predp) { 762 /* we'll need use continuations, copy list first to 763 avoid troubles with mutation */ 764 ls = check_copy_list(K, ls, false, NULL, NULL); 765 krooted_vars_push(K, &ls); 766 ls = kcons(K, KINERT, ls); /* add dummy obj to stand as last 767 compared obj */ 768 TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4, 769 maybe_pred, obj, ls, i2tv(pairs)); 770 krooted_vars_pop(K); 771 kset_cc(K, cont); 772 /* pass false to have it keep looking (in the whole list) */ 773 res = KFALSE; 774 } else { 775 /* use equal?, no continuation needed */ 776 TValue tail = ls; 777 res = KNIL; 778 while(pairs--) { 779 TValue first = kcar(tail); 780 if (equal2p(K, kcar(first), obj)) { 781 res = first; 782 break; 783 } 784 tail = kcdr(tail); 785 } 786 } 787 kapply_cc(K, res); 788 } 789 790 /* 6.3.7 member? */ 791 /* helper if third optional argument is used */ 792 void do_memberp(klisp_State *K) 793 { 794 TValue *xparams = K->next_xparams; 795 TValue obj = K->next_value; 796 klisp_assert(ttisnil(K->next_env)); 797 /* 798 ** xparams[0]: pred 799 ** xparams[1]: obj to be compared 800 ** xparams[2]: rem ls 801 ** xparams[3]: rem pairs 802 */ 803 804 TValue pred = xparams[0]; 805 TValue cmp_obj = xparams[1]; 806 TValue ls = xparams[2]; 807 int32_t pairs = ivalue(xparams[3]); 808 809 if (!ttisboolean(obj)) { 810 klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj); 811 return; 812 } else if (kis_true(obj) || pairs == 0) { 813 /* object found if obj is true and not found if obj is false */ 814 kapply_cc(K, obj); 815 } else { 816 /* object not YET found */ 817 TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4, pred, 818 cmp_obj, kcdr(ls), i2tv(pairs-1)); 819 /* not necessary but may save a continuation in some cases */ 820 kset_bool_check_cont(cont); 821 kset_cc(K, cont); 822 TValue exp = kcons(K, kcar(ls), KNIL); 823 krooted_vars_push(K, &exp); 824 exp = kcons(K, cmp_obj, exp); 825 exp = kcons(K, pred, exp); 826 /* TEMP for now use an empty environment for dynamic env */ 827 TValue env = kmake_empty_environment(K); 828 krooted_vars_pop(K); 829 ktail_eval(K, exp, env); 830 } 831 } 832 833 void memberp(klisp_State *K) 834 { 835 TValue *xparams = K->next_xparams; 836 TValue ptree = K->next_value; 837 TValue denv = K->next_env; 838 klisp_assert(ttisenvironment(K->next_env)); 839 UNUSED(xparams); 840 UNUSED(denv); 841 842 bind_al2p(K, ptree, obj, ls, maybe_pred); 843 bool predp = get_opt_tpar(K, maybe_pred, "applicative", ttisapplicative); 844 845 /* first pass, check structure */ 846 int32_t pairs; 847 if (predp) { /* copy if a custom predicate is used */ 848 ls = check_copy_list(K, ls, false, &pairs, NULL); 849 } else { 850 check_list(K, true, ls, &pairs, NULL); 851 } 852 853 TValue res; 854 if (predp) { 855 /* we'll need use continuations */ 856 krooted_tvs_push(K, ls); 857 TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4, 858 maybe_pred, obj, ls, i2tv(pairs)); 859 krooted_tvs_pop(K); 860 kset_cc(K, cont); 861 /* pass false to have it keep looking (in the whole list) */ 862 res = KFALSE; 863 } else { 864 /* if using equal? we need no continuation, we can 865 do it all here */ 866 TValue tail = ls; 867 res = KFALSE; 868 while(pairs--) { 869 TValue first = kcar(tail); 870 if (equal2p(K, first, obj)) { 871 res = KTRUE; 872 break; 873 } 874 tail = kcdr(tail); 875 } 876 } 877 kapply_cc(K, res); 878 } 879 880 /* 6.3.8 finite-list? */ 881 /* NOTE: can't use ftypep because the predicate marks pairs too */ 882 void finite_listp(klisp_State *K) 883 { 884 TValue *xparams = K->next_xparams; 885 TValue ptree = K->next_value; 886 TValue denv = K->next_env; 887 klisp_assert(ttisenvironment(K->next_env)); 888 UNUSED(xparams); 889 UNUSED(denv); 890 int32_t pairs; 891 check_list(K, true, ptree, &pairs, NULL); 892 893 TValue res = KTRUE; 894 TValue tail = ptree; 895 while(pairs--) { 896 TValue first = kcar(tail); 897 tail = kcdr(tail); 898 TValue itail = first; 899 while(ttispair(itail) && !kis_marked(itail)) { 900 kmark(itail); 901 itail = kcdr(itail); 902 } 903 unmark_list(K, first); 904 905 if (!ttisnil(itail)) { 906 res = KFALSE; 907 break; 908 } 909 } 910 kapply_cc(K, res); 911 } 912 913 /* 6.3.9 countable-list? */ 914 /* NOTE: can't use ftypep because the predicate marks pairs too */ 915 void countable_listp(klisp_State *K) 916 { 917 TValue *xparams = K->next_xparams; 918 TValue ptree = K->next_value; 919 TValue denv = K->next_env; 920 klisp_assert(ttisenvironment(K->next_env)); 921 UNUSED(xparams); 922 UNUSED(denv); 923 int32_t pairs; 924 check_list(K, true, ptree, &pairs, NULL); 925 926 TValue res = KTRUE; 927 TValue tail = ptree; 928 while(pairs--) { 929 TValue first = kcar(tail); 930 tail = kcdr(tail); 931 TValue itail = first; 932 while(ttispair(itail) && !kis_marked(itail)) { 933 kmark(itail); 934 itail = kcdr(itail); 935 } 936 unmark_list(K, first); 937 938 if (!ttisnil(itail) && !ttispair(itail)) { 939 res = KFALSE; 940 break; 941 } 942 } 943 kapply_cc(K, res); 944 } 945 946 /* Helpers for reduce */ 947 948 void do_reduce_prec(klisp_State *K) 949 { 950 TValue *xparams = K->next_xparams; 951 TValue obj = K->next_value; 952 klisp_assert(ttisnil(K->next_env)); 953 /* 954 ** xparams[0]: first-pair 955 ** xparams[1]: (old-obj . rem-ls) 956 ** xparams[2]: cpairs 957 ** xparams[3]: prec 958 ** xparams[4]: denv 959 */ 960 961 TValue first_pair = xparams[0]; 962 TValue last_pair = xparams[1]; 963 TValue ls = kcdr(last_pair); 964 int32_t cpairs = ivalue(xparams[2]); 965 TValue prec = xparams[3]; 966 TValue denv = xparams[4]; 967 968 /* save the last result of precycle */ 969 kset_car(last_pair, obj); 970 971 if (cpairs == 0) { 972 /* pass the first element to the do_reduce_inc continuation */ 973 kapply_cc(K, kcar(first_pair)); 974 } else { 975 TValue expr = klist(K, 2, kunwrap(prec), kcar(ls)); 976 krooted_tvs_push(K, expr); 977 TValue new_cont = 978 kmake_continuation(K, kget_cc(K), do_reduce_prec, 979 5, first_pair, ls, i2tv(cpairs-1), prec, denv); 980 kset_cc(K, new_cont); 981 krooted_tvs_pop(K); 982 ktail_eval(K, expr, denv); 983 } 984 } 985 986 void do_reduce_postc(klisp_State *K) 987 { 988 TValue *xparams = K->next_xparams; 989 TValue obj = K->next_value; 990 klisp_assert(ttisnil(K->next_env)); 991 /* 992 ** xparams[0]: postc 993 ** xparams[1]: denv 994 */ 995 TValue postc = xparams[0]; 996 TValue denv = xparams[1]; 997 998 TValue expr = klist(K, 2, kunwrap(postc), obj); 999 ktail_eval(K, expr, denv); 1000 } 1001 1002 /* This could be avoided by contructing a list and calling 1003 do_reduce, but the order would be backwards if the cycle 1004 is processed after the acyclic part */ 1005 void do_reduce_combine(klisp_State *K) 1006 { 1007 TValue *xparams = K->next_xparams; 1008 TValue obj = K->next_value; 1009 klisp_assert(ttisnil(K->next_env)); 1010 /* 1011 ** xparams[0]: acyclic result 1012 ** xparams[1]: bin 1013 ** xparams[2]: denv 1014 */ 1015 1016 TValue acyclic_res = xparams[0]; 1017 TValue bin = xparams[1]; 1018 TValue denv = xparams[2]; 1019 1020 /* obj: cyclic_res */ 1021 TValue cyclic_res = obj; 1022 TValue expr = klist(K, 3, kunwrap(bin), acyclic_res, 1023 cyclic_res); 1024 ktail_eval(K, expr, denv); 1025 } 1026 1027 void do_reduce_cycle(klisp_State *K) 1028 { 1029 TValue *xparams = K->next_xparams; 1030 TValue obj = K->next_value; 1031 klisp_assert(ttisnil(K->next_env)); 1032 /* 1033 ** xparams[0]: first-cpair 1034 ** xparams[1]: cpairs 1035 ** xparams[2]: acyclic binary applicative 1036 ** xparams[3]: prec applicative 1037 ** xparams[4]: inc applicative 1038 ** xparams[5]: postc applicative 1039 ** xparams[6]: denv 1040 ** xparams[7]: has-acyclic-part? 1041 */ 1042 1043 TValue ls = xparams[0]; 1044 int32_t cpairs = ivalue(xparams[1]); 1045 TValue bin = xparams[2]; 1046 TValue prec = xparams[3]; 1047 TValue inc = xparams[4]; 1048 TValue postc = xparams[5]; 1049 TValue denv = xparams[6]; 1050 bool has_acyclic_partp = bvalue(xparams[7]); 1051 1052 /* 1053 ** Schedule actions in reverse order 1054 */ 1055 1056 if (has_acyclic_partp) { 1057 TValue acyclic_obj = obj; 1058 TValue combine_cont = 1059 kmake_continuation(K, kget_cc(K), do_reduce_combine, 1060 3, acyclic_obj, bin, denv); 1061 kset_cc(K, combine_cont); /* implitly rooted */ 1062 } /* if there is no acyclic part, just let the result pass through */ 1063 1064 TValue post_cont = 1065 kmake_continuation(K, kget_cc(K), do_reduce_postc, 1066 2, postc, denv); 1067 kset_cc(K, post_cont); /* implitly rooted */ 1068 1069 /* pass one less so that pre_cont can pass the first argument 1070 to the continuation */ 1071 TValue in_cont = 1072 kmake_continuation(K, kget_cc(K), do_reduce, 1073 4, kcdr(ls), i2tv(cpairs - 1), inc, denv); 1074 kset_cc(K, in_cont); 1075 1076 /* add dummy to allow passing inert to pre_cont */ 1077 TValue dummy = kcons(K, KINERT, ls); 1078 krooted_tvs_push(K, dummy); 1079 /* pass ls as the first pair to be passed to the do_reduce 1080 continuation */ 1081 TValue pre_cont = 1082 kmake_continuation(K, kget_cc(K), do_reduce_prec, 1083 5, ls, dummy, i2tv(cpairs), prec, denv); 1084 kset_cc(K, pre_cont); 1085 krooted_tvs_pop(K); 1086 /* this will overwrite dummy, but that's ok */ 1087 kapply_cc(K, KINERT); 1088 } 1089 1090 /* NOTE: This is used from both do_reduce_cycle and reduce */ 1091 void do_reduce(klisp_State *K) 1092 { 1093 TValue *xparams = K->next_xparams; 1094 TValue obj = K->next_value; 1095 klisp_assert(ttisnil(K->next_env)); 1096 /* 1097 ** xparams[0]: remaining list 1098 ** xparams[1]: remaining pairs 1099 ** xparams[2]: binary applicative (either bin or inc) 1100 ** xparams[3]: denv 1101 */ 1102 1103 TValue ls = xparams[0]; 1104 int32_t pairs = ivalue(xparams[1]); 1105 TValue bin = xparams[2]; 1106 TValue denv = xparams[3]; 1107 1108 if (pairs == 0) { 1109 /* NOTE: this continuation could have been avoided (made a 1110 tail context) but since it isn't a requirement having 1111 this will help with error signaling and backtraces */ 1112 kapply_cc(K, obj); 1113 } else { 1114 TValue next = kcar(ls); 1115 TValue expr = klist(K, 3, kunwrap(bin), obj, next); 1116 krooted_tvs_push(K, expr); 1117 1118 TValue new_cont = 1119 kmake_continuation(K, kget_cc(K), do_reduce, 4, 1120 kcdr(ls), i2tv(pairs-1), bin, denv); 1121 kset_cc(K, new_cont); 1122 krooted_tvs_pop(K); 1123 /* use the dynamic environment of the call to reduce */ 1124 ktail_eval(K, expr, denv); 1125 } 1126 } 1127 1128 /* 6.3.10 reduce */ 1129 /* ASK John: There should probably be a clarification to reduce comparing 1130 with fold like in Haskell, r6rs and srfi-1 (all of which have the 1131 mentioned in the report, left/right distintion). 1132 srfi-1 also defines reduce-left/reduce-right that work as in 1133 kernel. The difference is the use or not of the id value if the list 1134 is not null */ 1135 void reduce(klisp_State *K) 1136 { 1137 TValue *xparams = K->next_xparams; 1138 TValue ptree = K->next_value; 1139 TValue denv = K->next_env; 1140 klisp_assert(ttisenvironment(K->next_env)); 1141 UNUSED(xparams); 1142 1143 bind_al3tp(K, ptree, "any", anytype, ls, "applicative", 1144 ttisapplicative, bin, "any", anytype, id, rest); 1145 1146 TValue prec, inc, postc; 1147 bool extended_form = !ttisnil(rest); 1148 1149 if (extended_form) { 1150 /* the variables are an artifact of the way bind_3tp macro works, 1151 XXX: this will also send wrong error msgs (bad number of arg) */ 1152 bind_3tp(K, rest, 1153 "applicative", ttisapplicative, prec_h, 1154 "applicative", ttisapplicative, inc_h, 1155 "applicative", ttisapplicative, postc_h); 1156 prec = prec_h; 1157 inc = inc_h; 1158 postc = postc_h; 1159 } else { 1160 /* dummy init */ 1161 prec = inc = postc = KINERT; 1162 } 1163 1164 /* the easy case first */ 1165 if (ttisnil(ls)) { 1166 kapply_cc(K, id); 1167 } 1168 1169 /* TODO all of these in one procedure */ 1170 int32_t pairs, cpairs; 1171 /* force copy to be able to do all precycles and replace 1172 the corresponding objs in ls */ 1173 ls = check_copy_list(K, ls, true, &pairs, &cpairs); 1174 int32_t apairs = pairs - cpairs; 1175 TValue first_cycle_pair = ls; 1176 int32_t dapairs = apairs; 1177 /* REFACTOR: add an extra return value to check_copy_list to output 1178 the last pair of the list */ 1179 while(dapairs--) 1180 first_cycle_pair = kcdr(first_cycle_pair); 1181 1182 TValue res; 1183 1184 if (cpairs != 0) { 1185 if (!extended_form) { 1186 klispE_throw_simple(K, "no cyclic handling applicatives"); 1187 return; 1188 } 1189 /* make cycle reducing cont */ 1190 TValue cyc_cont = 1191 kmake_continuation(K, kget_cc(K), do_reduce_cycle, 8, 1192 first_cycle_pair, i2tv(cpairs), bin, prec, 1193 inc, postc, denv, b2tv(apairs != 0)); 1194 kset_cc(K, cyc_cont); 1195 } 1196 1197 if (apairs == 0) { 1198 /* this will be ignore by cyc_cont */ 1199 res = KINERT; 1200 } else { 1201 /* this will pass the parent continuation either 1202 a list of (rem-ls result) if there is a cycle or 1203 result if there is no cycle, this should be a list 1204 and not a regular pair to allow the above case of 1205 a one element list to signal no acyclic part */ 1206 TValue acyc_cont = 1207 kmake_continuation(K, kget_cc(K), do_reduce, 4, 1208 kcdr(ls), i2tv(apairs-1), bin, denv); 1209 kset_cc(K, acyc_cont); 1210 res = kcar(ls); 1211 } 1212 kapply_cc(K, res); 1213 } 1214 1215 /* init ground */ 1216 void kinit_pairs_lists_ground_env(klisp_State *K) 1217 { 1218 TValue ground_env = G(K)->ground_env; 1219 TValue symbol, value; 1220 1221 /* 4.6.1 pair? */ 1222 add_applicative(K, ground_env, "pair?", typep, 2, symbol, 1223 i2tv(K_TPAIR)); 1224 /* 4.6.2 null? */ 1225 add_applicative(K, ground_env, "null?", typep, 2, symbol, 1226 i2tv(K_TNIL)); 1227 /* 4.6.3 cons */ 1228 add_applicative(K, ground_env, "cons", cons, 0); 1229 /* 5.2.1 list */ 1230 add_applicative(K, ground_env, "list", list, 0); 1231 /* 5.2.2 list* */ 1232 add_applicative(K, ground_env, "list*", listS, 0); 1233 /* 5.4.1 car, cdr */ 1234 add_applicative(K, ground_env, "car", c_ad_r, 2, symbol, 1235 C_AD_R_PARAM(1, 0x0000)); 1236 add_applicative(K, ground_env, "cdr", c_ad_r, 2, symbol, 1237 C_AD_R_PARAM(1, 0x0001)); 1238 /* 5.4.2 caar, cadr, ... cddddr */ 1239 add_applicative(K, ground_env, "caar", c_ad_r, 2, symbol, 1240 C_AD_R_PARAM(2, 0x0000)); 1241 add_applicative(K, ground_env, "cadr", c_ad_r, 2, symbol, 1242 C_AD_R_PARAM(2, 0x0001)); 1243 add_applicative(K, ground_env, "cdar", c_ad_r, 2, symbol, 1244 C_AD_R_PARAM(2, 0x0010)); 1245 add_applicative(K, ground_env, "cddr", c_ad_r, 2, symbol, 1246 C_AD_R_PARAM(2, 0x0011)); 1247 add_applicative(K, ground_env, "caaar", c_ad_r, 2, symbol, 1248 C_AD_R_PARAM(3, 0x0000)); 1249 add_applicative(K, ground_env, "caadr", c_ad_r, 2, symbol, 1250 C_AD_R_PARAM(3, 0x0001)); 1251 add_applicative(K, ground_env, "cadar", c_ad_r, 2, symbol, 1252 C_AD_R_PARAM(3, 0x0010)); 1253 add_applicative(K, ground_env, "caddr", c_ad_r, 2, symbol, 1254 C_AD_R_PARAM(3, 0x0011)); 1255 add_applicative(K, ground_env, "cdaar", c_ad_r, 2, symbol, 1256 C_AD_R_PARAM(3, 0x0100)); 1257 add_applicative(K, ground_env, "cdadr", c_ad_r, 2, symbol, 1258 C_AD_R_PARAM(3, 0x0101)); 1259 add_applicative(K, ground_env, "cddar", c_ad_r, 2, symbol, 1260 C_AD_R_PARAM(3, 0x0110)); 1261 add_applicative(K, ground_env, "cdddr", c_ad_r, 2, symbol, 1262 C_AD_R_PARAM(3, 0x0111)); 1263 add_applicative(K, ground_env, "caaaar", c_ad_r, 2, symbol, 1264 C_AD_R_PARAM(4, 0x0000)); 1265 add_applicative(K, ground_env, "caaadr", c_ad_r, 2, symbol, 1266 C_AD_R_PARAM(4, 0x0001)); 1267 add_applicative(K, ground_env, "caadar", c_ad_r, 2, symbol, 1268 C_AD_R_PARAM(4, 0x0010)); 1269 add_applicative(K, ground_env, "caaddr", c_ad_r, 2, symbol, 1270 C_AD_R_PARAM(4, 0x0011)); 1271 add_applicative(K, ground_env, "cadaar", c_ad_r, 2, symbol, 1272 C_AD_R_PARAM(4, 0x0100)); 1273 add_applicative(K, ground_env, "cadadr", c_ad_r, 2, symbol, 1274 C_AD_R_PARAM(4, 0x0101)); 1275 add_applicative(K, ground_env, "caddar", c_ad_r, 2, symbol, 1276 C_AD_R_PARAM(4, 0x0110)); 1277 add_applicative(K, ground_env, "cadddr", c_ad_r, 2, symbol, 1278 C_AD_R_PARAM(4, 0x0111)); 1279 add_applicative(K, ground_env, "cdaaar", c_ad_r, 2, symbol, 1280 C_AD_R_PARAM(4, 0x1000)); 1281 add_applicative(K, ground_env, "cdaadr", c_ad_r, 2, symbol, 1282 C_AD_R_PARAM(4, 0x1001)); 1283 add_applicative(K, ground_env, "cdadar", c_ad_r, 2, symbol, 1284 C_AD_R_PARAM(4, 0x1010)); 1285 add_applicative(K, ground_env, "cdaddr", c_ad_r, 2, symbol, 1286 C_AD_R_PARAM(4, 0x1011)); 1287 add_applicative(K, ground_env, "cddaar", c_ad_r, 2, symbol, 1288 C_AD_R_PARAM(4, 0x1100)); 1289 add_applicative(K, ground_env, "cddadr", c_ad_r, 2, symbol, 1290 C_AD_R_PARAM(4, 0x1101)); 1291 add_applicative(K, ground_env, "cdddar", c_ad_r, 2, symbol, 1292 C_AD_R_PARAM(4, 0x1110)); 1293 add_applicative(K, ground_env, "cddddr", c_ad_r, 2, symbol, 1294 C_AD_R_PARAM(4, 0x1111)); 1295 /* 5.?.? make-list */ 1296 add_applicative(K, ground_env, "make-list", make_list, 0); 1297 /* 5.?.? list-copy */ 1298 add_applicative(K, ground_env, "list-copy", list_copy, 0); 1299 /* 5.?.? reverse */ 1300 add_applicative(K, ground_env, "reverse", reverse, 0); 1301 /* 5.7.1 get-list-metrics */ 1302 add_applicative(K, ground_env, "get-list-metrics", get_list_metrics, 0); 1303 /* 5.7.2 list-tail */ 1304 add_applicative(K, ground_env, "list-tail", list_tail, 0); 1305 /* 6.3.1 length */ 1306 add_applicative(K, ground_env, "length", length, 0); 1307 /* 6.3.2 list-ref */ 1308 add_applicative(K, ground_env, "list-ref", list_ref, 0); 1309 /* 6.3.3 append */ 1310 add_applicative(K, ground_env, "append", append, 0); 1311 /* 6.3.4 list-neighbors */ 1312 add_applicative(K, ground_env, "list-neighbors", list_neighbors, 0); 1313 /* 6.3.5 filter */ 1314 add_applicative(K, ground_env, "filter", filter, 0); 1315 /* 6.3.6 assoc */ 1316 add_applicative(K, ground_env, "assoc", assoc, 0); 1317 /* 6.3.7 member? */ 1318 add_applicative(K, ground_env, "member?", memberp, 0); 1319 /* 6.3.8 finite-list? */ 1320 add_applicative(K, ground_env, "finite-list?", finite_listp, 0); 1321 /* 6.3.9 countable-list? */ 1322 add_applicative(K, ground_env, "countable-list?", countable_listp, 0); 1323 /* 6.3.10 reduce */ 1324 add_applicative(K, ground_env, "reduce", reduce, 0); 1325 } 1326 1327 /* XXX lock? */ 1328 /* init continuation names */ 1329 void kinit_pairs_lists_cont_names(klisp_State *K) 1330 { 1331 Table *t = tv2table(G(K)->cont_name_table); 1332 1333 add_cont_name(K, t, do_memberp, "member?-search"); 1334 add_cont_name(K, t, do_assoc, "assoc-search"); 1335 1336 add_cont_name(K, t, do_filter, "filter"); 1337 1338 add_cont_name(K, t, do_reduce, "reduce-acyclic-part"); 1339 add_cont_name(K, t, do_reduce_prec, "reduce-precycle"); 1340 add_cont_name(K, t, do_reduce_combine, "reduce-combine"); 1341 add_cont_name(K, t, do_reduce_postc, "reduce-postcycle"); 1342 add_cont_name(K, t, do_reduce_cycle, "reduce-cyclic-part"); 1343 }