apply.c (17445B)
1 /* 03feb11abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include "pico.h" 6 7 any apply(any ex, any foo, bool cf, int n, cell *p) { 8 while (!isNum(foo)) { 9 if (isCell(foo)) { 10 int i; 11 any x = car(foo); 12 struct { // bindFrame 13 struct bindFrame *link; 14 int i, cnt; 15 struct {any sym; any val;} bnd[length(x)+2]; 16 } f; 17 18 f.link = Env.bind, Env.bind = (bindFrame*)&f; 19 f.i = 0; 20 f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 21 while (isCell(x)) { 22 f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 23 val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); 24 ++f.cnt, x = cdr(x); 25 } 26 if (isNil(x)) 27 x = prog(cdr(foo)); 28 else if (x != At) { 29 f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; 30 while (--n >= 0) 31 val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x)); 32 ++f.cnt; 33 x = prog(cdr(foo)); 34 } 35 else { 36 int cnt = n; 37 int next = Env.next; 38 cell *arg = Env.arg; 39 cell c[Env.next = n]; 40 41 Env.arg = c; 42 for (i = f.cnt-1; --n >= 0; ++i) 43 Push(c[n], cf? car(data(p[i])) : data(p[i])); 44 x = prog(cdr(foo)); 45 if (cnt) 46 drop(c[cnt-1]); 47 Env.arg = arg, Env.next = next; 48 } 49 while (--f.cnt >= 0) 50 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 51 Env.bind = f.link; 52 return x; 53 } 54 if (val(foo) == val(Meth)) { 55 any expr, o, x; 56 57 o = cf? car(data(p[0])) : data(p[0]); 58 NeedSym(ex,o); 59 Fetch(ex,o); 60 TheCls = NULL, TheKey = foo; 61 if (expr = method(o)) { 62 int i; 63 any cls = Env.cls, key = Env.key; 64 struct { // bindFrame 65 struct bindFrame *link; 66 int i, cnt; 67 struct {any sym; any val;} bnd[length(x = car(expr))+3]; 68 } f; 69 70 Env.cls = TheCls, Env.key = TheKey; 71 f.link = Env.bind, Env.bind = (bindFrame*)&f; 72 f.i = 0; 73 f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 74 --n, ++p; 75 while (isCell(x)) { 76 f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 77 val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); 78 ++f.cnt, x = cdr(x); 79 } 80 if (isNil(x)) { 81 f.bnd[f.cnt].sym = This; 82 f.bnd[f.cnt++].val = val(This); 83 val(This) = o; 84 x = prog(cdr(expr)); 85 } 86 else if (x != At) { 87 f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; 88 while (--n >= 0) 89 val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x)); 90 ++f.cnt; 91 f.bnd[f.cnt].sym = This; 92 f.bnd[f.cnt++].val = val(This); 93 val(This) = o; 94 x = prog(cdr(expr)); 95 } 96 else { 97 int cnt = n; 98 int next = Env.next; 99 cell *arg = Env.arg; 100 cell c[Env.next = n]; 101 102 Env.arg = c; 103 for (i = f.cnt-1; --n >= 0; ++i) 104 Push(c[n], cf? car(data(p[i])) : data(p[i])); 105 f.bnd[f.cnt].sym = This; 106 f.bnd[f.cnt++].val = val(This); 107 val(This) = o; 108 x = prog(cdr(expr)); 109 if (cnt) 110 drop(c[cnt-1]); 111 Env.arg = arg, Env.next = next; 112 } 113 while (--f.cnt >= 0) 114 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 115 Env.bind = f.link; 116 Env.cls = cls, Env.key = key; 117 return x; 118 } 119 err(ex, o, "Bad object"); 120 } 121 if (isNil(val(foo)) || foo == val(foo)) 122 undefined(foo,ex); 123 foo = val(foo); 124 } 125 if (--n < 0) 126 cdr(ApplyBody) = Nil; 127 else { 128 any x = ApplyArgs; 129 val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 130 while (--n >= 0) { 131 if (!isCell(cdr(x))) 132 cdr(x) = cons(cons(consSym(Nil,Nil), car(x)), Nil); 133 x = cdr(x); 134 val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 135 } 136 cdr(ApplyBody) = car(x); 137 } 138 return evSubr(foo, ApplyBody); 139 } 140 141 // (apply 'fun 'lst ['any ..]) -> any 142 any doApply(any ex) { 143 any x, y; 144 int i, n; 145 cell foo; 146 147 x = cdr(ex), Push(foo, EVAL(car(x))); 148 x = cdr(x), y = EVAL(car(x)); 149 { 150 cell c[(n = length(cdr(x))) + length(y)]; 151 152 while (isCell(y)) 153 Push(c[n], car(y)), y = cdr(y), ++n; 154 for (i = 0; isCell(x = cdr(x)); ++i) 155 Push(c[i], EVAL(car(x))); 156 x = apply(ex, data(foo), NO, n, c); 157 } 158 drop(foo); 159 return x; 160 } 161 162 // (pass 'fun ['any ..]) -> any 163 any doPass(any ex) { 164 any x; 165 int n, i; 166 cell foo, c[length(cdr(x = cdr(ex))) + (Env.next>0? Env.next : 0)]; 167 168 Push(foo, EVAL(car(x))); 169 for (n = 0; isCell(x = cdr(x)); ++n) 170 Push(c[n], EVAL(car(x))); 171 for (i = Env.next; --i >= 0; ++n) 172 Push(c[n], data(Env.arg[i])); 173 x = apply(ex, data(foo), NO, n, c); 174 drop(foo); 175 return x; 176 } 177 178 // (maps 'fun 'sym ['lst ..]) -> any 179 any doMaps(any ex) { 180 any x; 181 int i, n; 182 cell foo, c[length(cdr(x = cdr(ex)))]; 183 184 Push(foo, EVAL(car(x))); 185 x = cdr(x), Push(c[0], EVAL(car(x))); 186 NeedSym(ex, data(c[0])); 187 for (n = 1; isCell(x = cdr(x)); ++n) 188 Push(c[n], EVAL(car(x))); 189 Fetch(ex, data(c[0])); 190 data(c[0]) = tail1(data(c[0])); 191 while (isCell(data(c[0]))) { 192 x = apply(ex, data(foo), YES, n, c); 193 for (i = 0; i < n; ++i) 194 data(c[i]) = cdr(data(c[i])); 195 } 196 drop(foo); 197 return x; 198 } 199 200 // (map 'fun 'lst ..) -> lst 201 any doMap(any ex) { 202 any x = cdr(ex); 203 cell foo; 204 205 Push(foo, EVAL(car(x))); 206 if (isCell(x = cdr(x))) { 207 int i, n = 0; 208 cell c[length(x)]; 209 210 do 211 Push(c[n], EVAL(car(x))), ++n; 212 while (isCell(x = cdr(x))); 213 while (isCell(data(c[0]))) { 214 x = apply(ex, data(foo), NO, n, c); 215 for (i = 0; i < n; ++i) 216 data(c[i]) = cdr(data(c[i])); 217 } 218 } 219 drop(foo); 220 return x; 221 } 222 223 // (mapc 'fun 'lst ..) -> any 224 any doMapc(any ex) { 225 any x = cdr(ex); 226 cell foo; 227 228 Push(foo, EVAL(car(x))); 229 if (isCell(x = cdr(x))) { 230 int i, n = 0; 231 cell c[length(x)]; 232 233 do 234 Push(c[n], EVAL(car(x))), ++n; 235 while (isCell(x = cdr(x))); 236 while (isCell(data(c[0]))) { 237 x = apply(ex, data(foo), YES, n, c); 238 for (i = 0; i < n; ++i) 239 data(c[i]) = cdr(data(c[i])); 240 } 241 } 242 drop(foo); 243 return x; 244 } 245 246 // (maplist 'fun 'lst ..) -> lst 247 any doMaplist(any ex) { 248 any x = cdr(ex); 249 cell res, foo; 250 251 Push(res, Nil); 252 Push(foo, EVAL(car(x))); 253 if (isCell(x = cdr(x))) { 254 int i, n = 0; 255 cell c[length(x)]; 256 257 do 258 Push(c[n], EVAL(car(x))), ++n; 259 while (isCell(x = cdr(x))); 260 if (!isCell(data(c[0]))) 261 return Pop(res); 262 data(res) = x = cons(apply(ex, data(foo), NO, n, c), Nil); 263 while (isCell(data(c[0]) = cdr(data(c[0])))) { 264 for (i = 1; i < n; ++i) 265 data(c[i]) = cdr(data(c[i])); 266 x = cdr(x) = cons(apply(ex, data(foo), NO, n, c), Nil); 267 } 268 } 269 return Pop(res); 270 } 271 272 // (mapcar 'fun 'lst ..) -> lst 273 any doMapcar(any ex) { 274 any x = cdr(ex); 275 cell res, foo; 276 277 Push(res, Nil); 278 Push(foo, EVAL(car(x))); 279 if (isCell(x = cdr(x))) { 280 int i, n = 0; 281 cell c[length(x)]; 282 283 do 284 Push(c[n], EVAL(car(x))), ++n; 285 while (isCell(x = cdr(x))); 286 if (!isCell(data(c[0]))) 287 return Pop(res); 288 data(res) = x = cons(apply(ex, data(foo), YES, n, c), Nil); 289 while (isCell(data(c[0]) = cdr(data(c[0])))) { 290 for (i = 1; i < n; ++i) 291 data(c[i]) = cdr(data(c[i])); 292 x = cdr(x) = cons(apply(ex, data(foo), YES, n, c), Nil); 293 } 294 } 295 return Pop(res); 296 } 297 298 // (mapcon 'fun 'lst ..) -> lst 299 any doMapcon(any ex) { 300 any x = cdr(ex); 301 cell res, foo; 302 303 Push(res, Nil); 304 Push(foo, EVAL(car(x))); 305 if (isCell(x = cdr(x))) { 306 int i, n = 0; 307 cell c[length(x)]; 308 309 do 310 Push(c[n], EVAL(car(x))), ++n; 311 while (isCell(x = cdr(x))); 312 if (!isCell(data(c[0]))) 313 return Pop(res); 314 while (!isCell(x = apply(ex, data(foo), NO, n, c))) { 315 if (!isCell(data(c[0]) = cdr(data(c[0])))) 316 return Pop(res); 317 for (i = 1; i < n; ++i) 318 data(c[i]) = cdr(data(c[i])); 319 } 320 data(res) = x; 321 while (isCell(data(c[0]) = cdr(data(c[0])))) { 322 for (i = 1; i < n; ++i) 323 data(c[i]) = cdr(data(c[i])); 324 while (isCell(cdr(x))) 325 x = cdr(x); 326 cdr(x) = apply(ex, data(foo), NO, n, c); 327 } 328 } 329 return Pop(res); 330 } 331 332 // (mapcan 'fun 'lst ..) -> lst 333 any doMapcan(any ex) { 334 any x = cdr(ex); 335 cell res, foo; 336 337 Push(res, Nil); 338 Push(foo, EVAL(car(x))); 339 if (isCell(x = cdr(x))) { 340 int i, n = 0; 341 cell c[length(x)]; 342 343 do 344 Push(c[n], EVAL(car(x))), ++n; 345 while (isCell(x = cdr(x))); 346 if (!isCell(data(c[0]))) 347 return Pop(res); 348 while (!isCell(x = apply(ex, data(foo), YES, n, c))) { 349 if (!isCell(data(c[0]) = cdr(data(c[0])))) 350 return Pop(res); 351 for (i = 1; i < n; ++i) 352 data(c[i]) = cdr(data(c[i])); 353 } 354 data(res) = x; 355 while (isCell(data(c[0]) = cdr(data(c[0])))) { 356 for (i = 1; i < n; ++i) 357 data(c[i]) = cdr(data(c[i])); 358 while (isCell(cdr(x))) 359 x = cdr(x); 360 cdr(x) = apply(ex, data(foo), YES, n, c); 361 } 362 } 363 return Pop(res); 364 } 365 366 // (filter 'fun 'lst ..) -> lst 367 any doFilter(any ex) { 368 any x = cdr(ex); 369 cell res, foo; 370 371 Push(res, Nil); 372 Push(foo, EVAL(car(x))); 373 if (isCell(x = cdr(x))) { 374 int i, n = 0; 375 cell c[length(x)]; 376 377 do 378 Push(c[n], EVAL(car(x))), ++n; 379 while (isCell(x = cdr(x))); 380 if (!isCell(data(c[0]))) 381 return Pop(res); 382 while (isNil(apply(ex, data(foo), YES, n, c))) { 383 if (!isCell(data(c[0]) = cdr(data(c[0])))) 384 return Pop(res); 385 for (i = 1; i < n; ++i) 386 data(c[i]) = cdr(data(c[i])); 387 } 388 data(res) = x = cons(car(data(c[0])), Nil); 389 while (isCell(data(c[0]) = cdr(data(c[0])))) { 390 for (i = 1; i < n; ++i) 391 data(c[i]) = cdr(data(c[i])); 392 if (!isNil(apply(ex, data(foo), YES, n, c))) 393 x = cdr(x) = cons(car(data(c[0])), Nil); 394 } 395 } 396 return Pop(res); 397 } 398 399 // (extract 'fun 'lst ..) -> lst 400 any doExtract(any ex) { 401 any x = cdr(ex); 402 any y; 403 cell res, foo; 404 405 Push(res, Nil); 406 Push(foo, EVAL(car(x))); 407 if (isCell(x = cdr(x))) { 408 int i, n = 0; 409 cell c[length(x)]; 410 411 do 412 Push(c[n], EVAL(car(x))), ++n; 413 while (isCell(x = cdr(x))); 414 if (!isCell(data(c[0]))) 415 return Pop(res); 416 while (isNil(y = apply(ex, data(foo), YES, n, c))) { 417 if (!isCell(data(c[0]) = cdr(data(c[0])))) 418 return Pop(res); 419 for (i = 1; i < n; ++i) 420 data(c[i]) = cdr(data(c[i])); 421 } 422 data(res) = x = cons(y, Nil); 423 while (isCell(data(c[0]) = cdr(data(c[0])))) { 424 for (i = 1; i < n; ++i) 425 data(c[i]) = cdr(data(c[i])); 426 if (!isNil(y = apply(ex, data(foo), YES, n, c))) 427 x = cdr(x) = cons(y, Nil); 428 } 429 } 430 return Pop(res); 431 } 432 433 // (seek 'fun 'lst ..) -> lst 434 any doSeek(any ex) { 435 any x = cdr(ex); 436 cell foo; 437 438 Push(foo, EVAL(car(x))); 439 if (isCell(x = cdr(x))) { 440 int i, n = 0; 441 cell c[length(x)]; 442 443 do 444 Push(c[n], EVAL(car(x))), ++n; 445 while (isCell(x = cdr(x))); 446 while (isCell(data(c[0]))) { 447 if (!isNil(apply(ex, data(foo), NO, n, c))) { 448 drop(foo); 449 return data(c[0]); 450 } 451 for (i = 0; i < n; ++i) 452 data(c[i]) = cdr(data(c[i])); 453 } 454 } 455 drop(foo); 456 return Nil; 457 } 458 459 // (find 'fun 'lst ..) -> any 460 any doFind(any ex) { 461 any x = cdr(ex); 462 cell foo; 463 464 Push(foo, EVAL(car(x))); 465 if (isCell(x = cdr(x))) { 466 int i, n = 0; 467 cell c[length(x)]; 468 469 do 470 Push(c[n], EVAL(car(x))), ++n; 471 while (isCell(x = cdr(x))); 472 while (isCell(data(c[0]))) { 473 if (!isNil(apply(ex, data(foo), YES, n, c))) { 474 drop(foo); 475 return car(data(c[0])); 476 } 477 for (i = 0; i < n; ++i) 478 data(c[i]) = cdr(data(c[i])); 479 } 480 } 481 drop(foo); 482 return Nil; 483 } 484 485 // (pick 'fun 'lst ..) -> any 486 any doPick(any ex) { 487 any x = cdr(ex); 488 cell foo; 489 490 Push(foo, EVAL(car(x))); 491 if (isCell(x = cdr(x))) { 492 int i, n = 0; 493 cell c[length(x)]; 494 495 do 496 Push(c[n], EVAL(car(x))), ++n; 497 while (isCell(x = cdr(x))); 498 while (isCell(data(c[0]))) { 499 if (!isNil(x = apply(ex, data(foo), YES, n, c))) { 500 drop(foo); 501 return x; 502 } 503 for (i = 0; i < n; ++i) 504 data(c[i]) = cdr(data(c[i])); 505 } 506 } 507 drop(foo); 508 return Nil; 509 } 510 511 // (cnt 'fun 'lst ..) -> cnt 512 any doCnt(any ex) { 513 any x = cdr(ex); 514 int res; 515 cell foo; 516 517 res = 0; 518 Push(foo, EVAL(car(x))); 519 if (isCell(x = cdr(x))) { 520 int i, n = 0; 521 cell c[length(x)]; 522 523 do 524 Push(c[n], EVAL(car(x))), ++n; 525 while (isCell(x = cdr(x))); 526 while (isCell(data(c[0]))) { 527 if (!isNil(apply(ex, data(foo), YES, n, c))) 528 res += 2; 529 for (i = 0; i < n; ++i) 530 data(c[i]) = cdr(data(c[i])); 531 } 532 } 533 drop(foo); 534 return box(res); 535 } 536 537 // (sum 'fun 'lst ..) -> num 538 any doSum(any ex) { 539 any x = cdr(ex); 540 cell res, foo, c1; 541 542 Push(res, box(0)); 543 Push(foo, EVAL(car(x))); 544 if (isCell(x = cdr(x))) { 545 int i, n = 0; 546 cell c[length(x)]; 547 548 do 549 Push(c[n], EVAL(car(x))), ++n; 550 while (isCell(x = cdr(x))); 551 while (isCell(data(c[0]))) { 552 if (isNum(data(c1) = apply(ex, data(foo), YES, n, c))) { 553 Save(c1); 554 if (isNeg(data(res))) { 555 if (isNeg(data(c1))) 556 bigAdd(data(res),data(c1)); 557 else 558 bigSub(data(res),data(c1)); 559 if (!IsZero(data(res))) 560 neg(data(res)); 561 } 562 else if (isNeg(data(c1))) 563 bigSub(data(res),data(c1)); 564 else 565 bigAdd(data(res),data(c1)); 566 drop(c1); 567 } 568 for (i = 0; i < n; ++i) 569 data(c[i]) = cdr(data(c[i])); 570 } 571 } 572 return Pop(res); 573 } 574 575 // (maxi 'fun 'lst ..) -> any 576 any doMaxi(any ex) { 577 any x = cdr(ex); 578 cell res, val, foo; 579 580 Push(res, Nil); 581 Push(val, Nil); 582 Push(foo, EVAL(car(x))); 583 if (isCell(x = cdr(x))) { 584 int i, n = 0; 585 cell c[length(x)]; 586 587 do 588 Push(c[n], EVAL(car(x))), ++n; 589 while (isCell(x = cdr(x))); 590 while (isCell(data(c[0]))) { 591 if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) > 0) 592 data(res) = car(data(c[0])), data(val) = x; 593 for (i = 0; i < n; ++i) 594 data(c[i]) = cdr(data(c[i])); 595 } 596 } 597 return Pop(res); 598 } 599 600 // (mini 'fun 'lst ..) -> any 601 any doMini(any ex) { 602 any x = cdr(ex); 603 cell res, val, foo; 604 605 Push(res, Nil); 606 Push(val, T); 607 Push(foo, EVAL(car(x))); 608 if (isCell(x = cdr(x))) { 609 int i, n = 0; 610 cell c[length(x)]; 611 612 do 613 Push(c[n], EVAL(car(x))), ++n; 614 while (isCell(x = cdr(x))); 615 while (isCell(data(c[0]))) { 616 if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) < 0) 617 data(res) = car(data(c[0])), data(val) = x; 618 for (i = 0; i < n; ++i) 619 data(c[i]) = cdr(data(c[i])); 620 } 621 } 622 return Pop(res); 623 } 624 625 static void fish(any ex, any foo, any x, cell *r) { 626 if (!isNil(apply(ex, foo, NO, 1, (cell*)&x))) 627 data(*r) = cons(x, data(*r)); 628 else if (isCell(x)) { 629 if (!isNil(cdr(x))) 630 fish(ex, foo, cdr(x), r); 631 fish(ex, foo, car(x), r); 632 } 633 } 634 635 // (fish 'fun 'any) -> lst 636 any doFish(any ex) { 637 any x = cdr(ex); 638 cell res, foo, c1; 639 640 Push(res, Nil); 641 Push(foo, EVAL(car(x))); 642 x = cdr(x), Push(c1, EVAL(car(x))); 643 fish(ex, data(foo), data(c1), &res); 644 return Pop(res); 645 } 646 647 // (by 'fun1 'fun2 'lst ..) -> lst 648 any doBy(any ex) { 649 any x = cdr(ex); 650 cell res, foo1, foo2; 651 652 Push(res, Nil); 653 Push(foo1, EVAL(car(x))), x = cdr(x), Push(foo2, EVAL(car(x))); 654 if (isCell(x = cdr(x))) { 655 int i, n = 0; 656 cell c[length(x)]; 657 658 do 659 Push(c[n], EVAL(car(x))), ++n; 660 while (isCell(x = cdr(x))); 661 if (!isCell(data(c[0]))) 662 return Pop(res); 663 data(res) = x = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 664 while (isCell(data(c[0]) = cdr(data(c[0])))) { 665 for (i = 1; i < n; ++i) 666 data(c[i]) = cdr(data(c[i])); 667 x = cdr(x) = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 668 } 669 data(res) = apply(ex, data(foo2), NO, 1, &res); 670 for (x = data(res); isCell(x); x = cdr(x)) 671 car(x) = cdar(x); 672 } 673 return Pop(res); 674 }