apply.c (15956B)
1 /* 10dec07abu 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 x = prog(cdr(foo)); 31 } 32 else { 33 int cnt = n; 34 int next = Env.next; 35 cell *arg = Env.arg; 36 cell c[Env.next = n]; 37 38 Env.arg = c; 39 for (i = f.cnt-1; --n >= 0; ++i) 40 Push(c[n], cf? car(data(p[i])) : data(p[i])); 41 x = prog(cdr(foo)); 42 if (cnt) 43 drop(c[cnt-1]); 44 Env.arg = arg, Env.next = next; 45 } 46 while (--f.cnt >= 0) 47 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 48 Env.bind = f.link; 49 return x; 50 } 51 if (val(foo) == val(Meth)) { 52 any expr, o, x; 53 54 o = cf? car(data(p[0])) : data(p[0]); 55 NeedSymb(ex,o); 56 TheKey = foo, TheCls = Nil; 57 if (expr = method(o)) { 58 int i; 59 methFrame m; 60 struct { // bindFrame 61 struct bindFrame *link; 62 int i, cnt; 63 struct {any sym; any val;} bnd[length(x = car(expr))+3]; 64 } f; 65 66 m.link = Env.meth; 67 m.key = TheKey; 68 m.cls = TheCls; 69 f.link = Env.bind, Env.bind = (bindFrame*)&f; 70 f.i = 0; 71 f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 72 --n, ++p; 73 while (isCell(x)) { 74 f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 75 val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); 76 ++f.cnt, x = cdr(x); 77 } 78 if (isNil(x)) { 79 f.bnd[f.cnt].sym = This; 80 f.bnd[f.cnt++].val = val(This); 81 val(This) = o; 82 Env.meth = &m; 83 x = prog(cdr(expr)); 84 } 85 else if (x != At) { 86 f.bnd[f.cnt].sym = x, f.bnd[f.cnt++].val = val(x), val(x) = Nil; 87 f.bnd[f.cnt].sym = This; 88 f.bnd[f.cnt++].val = val(This); 89 val(This) = o; 90 Env.meth = &m; 91 x = prog(cdr(expr)); 92 } 93 else { 94 int cnt = n; 95 int next = Env.next; 96 cell *arg = Env.arg; 97 cell c[Env.next = n]; 98 99 Env.arg = c; 100 for (i = f.cnt-1; --n >= 0; ++i) 101 Push(c[n], cf? car(data(p[i])) : data(p[i])); 102 f.bnd[f.cnt].sym = This; 103 f.bnd[f.cnt++].val = val(This); 104 val(This) = o; 105 Env.meth = &m; 106 x = prog(cdr(expr)); 107 if (cnt) 108 drop(c[cnt-1]); 109 Env.arg = arg, Env.next = next; 110 } 111 while (--f.cnt >= 0) 112 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 113 Env.bind = f.link; 114 Env.meth = Env.meth->link; 115 return x; 116 } 117 err(ex, o, "Bad object"); 118 } 119 if (isNil(val(foo)) || foo == val(foo)) 120 undefined(foo,ex); 121 foo = val(foo); 122 } 123 if (--n < 0) 124 cdr(ApplyBody) = Nil; 125 else { 126 any x = ApplyArgs; 127 val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 128 while (--n >= 0) { 129 if (!isCell(cdr(x))) 130 cdr(x) = cons(cons(consSym(Nil,0), car(x)), Nil); 131 x = cdr(x); 132 val(caar(x)) = cf? car(data(p[n])) : data(p[n]); 133 } 134 cdr(ApplyBody) = car(x); 135 } 136 return evSubr(foo, ApplyBody); 137 } 138 139 // (apply 'fun 'lst ['any ..]) -> any 140 any doApply(any ex) { 141 any x, y; 142 int i, n; 143 cell foo; 144 145 x = cdr(ex), Push(foo, EVAL(car(x))); 146 x = cdr(x), y = EVAL(car(x)); 147 { 148 cell c[(n = length(cdr(x))) + length(y)]; 149 150 while (isCell(y)) 151 Push(c[n], car(y)), y = cdr(y), ++n; 152 for (i = 0; isCell(x = cdr(x)); ++i) 153 Push(c[i], EVAL(car(x))); 154 x = apply(ex, data(foo), NO, n, c); 155 } 156 drop(foo); 157 return x; 158 } 159 160 // (pass 'fun ['any ..]) -> any 161 any doPass(any ex) { 162 any x; 163 int n, i; 164 cell foo, c[length(cdr(x = cdr(ex))) + (Env.next>0? Env.next : 0)]; 165 166 Push(foo, EVAL(car(x))); 167 for (n = 0; isCell(x = cdr(x)); ++n) 168 Push(c[n], EVAL(car(x))); 169 for (i = Env.next; --i >= 0; ++n) 170 Push(c[n], data(Env.arg[i])); 171 x = apply(ex, data(foo), NO, n, c); 172 drop(foo); 173 return x; 174 } 175 176 // (maps 'fun 'sym ['lst ..]) -> any 177 any doMaps(any ex) { 178 any x, y; 179 int i, n; 180 cell foo, sym, val, c[length(cdr(x = cdr(ex)))]; 181 182 Push(foo, EVAL(car(x))); 183 x = cdr(x), Push(sym, EVAL(car(x))); 184 NeedSymb(ex, data(sym)); 185 for (n = 1; isCell(x = cdr(x)); ++n) 186 Push(c[n], EVAL(car(x))); 187 data(c[0]) = &val; 188 for (y = tail(data(sym)); isCell(y); y = car(y)) { 189 data(val) = cdr(y); 190 x = apply(ex, data(foo), YES, n, c); 191 for (i = 1; i < n; ++i) 192 data(c[i]) = cdr(data(c[i])); 193 } 194 drop(foo); 195 return x; 196 } 197 198 // (map 'fun 'lst ..) -> lst 199 any doMap(any ex) { 200 any x = cdr(ex); 201 cell foo; 202 203 Push(foo, EVAL(car(x))); 204 if (isCell(x = cdr(x))) { 205 int i, n = 0; 206 cell c[length(x)]; 207 208 do 209 Push(c[n], EVAL(car(x))), ++n; 210 while (isCell(x = cdr(x))); 211 while (isCell(data(c[0]))) { 212 x = apply(ex, data(foo), NO, n, c); 213 for (i = 0; i < n; ++i) 214 data(c[i]) = cdr(data(c[i])); 215 } 216 } 217 drop(foo); 218 return x; 219 } 220 221 // (mapc 'fun 'lst ..) -> any 222 any doMapc(any ex) { 223 any x = cdr(ex); 224 cell foo; 225 226 Push(foo, EVAL(car(x))); 227 if (isCell(x = cdr(x))) { 228 int i, n = 0; 229 cell c[length(x)]; 230 231 do 232 Push(c[n], EVAL(car(x))), ++n; 233 while (isCell(x = cdr(x))); 234 while (isCell(data(c[0]))) { 235 x = apply(ex, data(foo), YES, n, c); 236 for (i = 0; i < n; ++i) 237 data(c[i]) = cdr(data(c[i])); 238 } 239 } 240 drop(foo); 241 return x; 242 } 243 244 // (maplist 'fun 'lst ..) -> lst 245 any doMaplist(any ex) { 246 any x = cdr(ex); 247 cell res, foo; 248 249 Push(res, Nil); 250 Push(foo, EVAL(car(x))); 251 if (isCell(x = cdr(x))) { 252 int i, n = 0; 253 cell c[length(x)]; 254 255 do 256 Push(c[n], EVAL(car(x))), ++n; 257 while (isCell(x = cdr(x))); 258 if (!isCell(data(c[0]))) 259 return Pop(res); 260 data(res) = x = cons(apply(ex, data(foo), NO, n, c), Nil); 261 while (isCell(data(c[0]) = cdr(data(c[0])))) { 262 for (i = 1; i < n; ++i) 263 data(c[i]) = cdr(data(c[i])); 264 cdr(x) = cons(apply(ex, data(foo), NO, n, c), Nil); 265 x = cdr(x); 266 } 267 } 268 return Pop(res); 269 } 270 271 // (mapcar 'fun 'lst ..) -> lst 272 any doMapcar(any ex) { 273 any x = cdr(ex); 274 cell res, foo; 275 276 Push(res, Nil); 277 Push(foo, EVAL(car(x))); 278 if (isCell(x = cdr(x))) { 279 int i, n = 0; 280 cell c[length(x)]; 281 282 do 283 Push(c[n], EVAL(car(x))), ++n; 284 while (isCell(x = cdr(x))); 285 if (!isCell(data(c[0]))) 286 return Pop(res); 287 data(res) = x = cons(apply(ex, data(foo), YES, n, c), Nil); 288 while (isCell(data(c[0]) = cdr(data(c[0])))) { 289 for (i = 1; i < n; ++i) 290 data(c[i]) = cdr(data(c[i])); 291 cdr(x) = cons(apply(ex, data(foo), YES, n, c), Nil); 292 x = cdr(x); 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 // (seek 'fun 'lst ..) -> lst 400 any doSeek(any ex) { 401 any x = cdr(ex); 402 cell foo; 403 404 Push(foo, EVAL(car(x))); 405 if (isCell(x = cdr(x))) { 406 int i, n = 0; 407 cell c[length(x)]; 408 409 do 410 Push(c[n], EVAL(car(x))), ++n; 411 while (isCell(x = cdr(x))); 412 while (isCell(data(c[0]))) { 413 if (!isNil(apply(ex, data(foo), NO, n, c))) { 414 drop(foo); 415 return data(c[0]); 416 } 417 for (i = 0; i < n; ++i) 418 data(c[i]) = cdr(data(c[i])); 419 } 420 } 421 drop(foo); 422 return Nil; 423 } 424 425 // (find 'fun 'lst ..) -> any 426 any doFind(any ex) { 427 any x = cdr(ex); 428 cell foo; 429 430 Push(foo, EVAL(car(x))); 431 if (isCell(x = cdr(x))) { 432 int i, n = 0; 433 cell c[length(x)]; 434 435 do 436 Push(c[n], EVAL(car(x))), ++n; 437 while (isCell(x = cdr(x))); 438 while (isCell(data(c[0]))) { 439 if (!isNil(apply(ex, data(foo), YES, n, c))) { 440 drop(foo); 441 return car(data(c[0])); 442 } 443 for (i = 0; i < n; ++i) 444 data(c[i]) = cdr(data(c[i])); 445 } 446 } 447 drop(foo); 448 return Nil; 449 } 450 451 // (pick 'fun 'lst ..) -> any 452 any doPick(any ex) { 453 any x = cdr(ex); 454 cell foo; 455 456 Push(foo, EVAL(car(x))); 457 if (isCell(x = cdr(x))) { 458 int i, n = 0; 459 cell c[length(x)]; 460 461 do 462 Push(c[n], EVAL(car(x))), ++n; 463 while (isCell(x = cdr(x))); 464 while (isCell(data(c[0]))) { 465 if (!isNil(x = apply(ex, data(foo), YES, n, c))) { 466 drop(foo); 467 return x; 468 } 469 for (i = 0; i < n; ++i) 470 data(c[i]) = cdr(data(c[i])); 471 } 472 } 473 drop(foo); 474 return Nil; 475 } 476 477 // (cnt 'fun 'lst ..) -> num 478 any doCnt(any ex) { 479 any x = cdr(ex); 480 int res; 481 cell foo; 482 483 res = 0; 484 Push(foo, EVAL(car(x))); 485 if (isCell(x = cdr(x))) { 486 int i, n = 0; 487 cell c[length(x)]; 488 489 do 490 Push(c[n], EVAL(car(x))), ++n; 491 while (isCell(x = cdr(x))); 492 while (isCell(data(c[0]))) { 493 if (!isNil(apply(ex, data(foo), YES, n, c))) 494 ++res; 495 for (i = 0; i < n; ++i) 496 data(c[i]) = cdr(data(c[i])); 497 } 498 } 499 drop(foo); 500 return box(res); 501 } 502 503 // (sum 'fun 'lst ..) -> num 504 any doSum(any ex) { 505 any x = cdr(ex); 506 int res; 507 cell foo; 508 509 res = 0; 510 Push(foo, EVAL(car(x))); 511 if (isCell(x = cdr(x))) { 512 int i, n = 0; 513 cell c[length(x)]; 514 515 do 516 Push(c[n], EVAL(car(x))), ++n; 517 while (isCell(x = cdr(x))); 518 while (isCell(data(c[0]))) { 519 if (isNum(x = apply(ex, data(foo), YES, n, c))) 520 res += unBox(x); 521 for (i = 0; i < n; ++i) 522 data(c[i]) = cdr(data(c[i])); 523 } 524 } 525 drop(foo); 526 return box(res); 527 } 528 529 // (maxi 'fun 'lst ..) -> any 530 any doMaxi(any ex) { 531 any x = cdr(ex); 532 cell res, val, foo; 533 534 Push(res, Nil); 535 Push(val, Nil); 536 Push(foo, EVAL(car(x))); 537 if (isCell(x = cdr(x))) { 538 int i, n = 0; 539 cell c[length(x)]; 540 541 do 542 Push(c[n], EVAL(car(x))), ++n; 543 while (isCell(x = cdr(x))); 544 while (isCell(data(c[0]))) { 545 if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) > 0) 546 data(res) = car(data(c[0])), data(val) = x; 547 for (i = 0; i < n; ++i) 548 data(c[i]) = cdr(data(c[i])); 549 } 550 } 551 return Pop(res); 552 } 553 554 // (mini 'fun 'lst ..) -> any 555 any doMini(any ex) { 556 any x = cdr(ex); 557 cell res, val, foo; 558 559 Push(res, Nil); 560 Push(val, T); 561 Push(foo, EVAL(car(x))); 562 if (isCell(x = cdr(x))) { 563 int i, n = 0; 564 cell c[length(x)]; 565 566 do 567 Push(c[n], EVAL(car(x))), ++n; 568 while (isCell(x = cdr(x))); 569 while (isCell(data(c[0]))) { 570 if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) < 0) 571 data(res) = car(data(c[0])), data(val) = x; 572 for (i = 0; i < n; ++i) 573 data(c[i]) = cdr(data(c[i])); 574 } 575 } 576 return Pop(res); 577 } 578 579 static void fish(any ex, any foo, any x, cell *r) { 580 if (!isNil(apply(ex, foo, NO, 1, (cell*)&x))) 581 data(*r) = cons(x, data(*r)); 582 else if (isCell(x)) { 583 if (!isNil(cdr(x))) 584 fish(ex, foo, cdr(x), r); 585 fish(ex, foo, car(x), r); 586 } 587 } 588 589 // (fish 'fun 'any) -> lst 590 any doFish(any ex) { 591 any x = cdr(ex); 592 cell res, foo, c1; 593 594 Push(res, Nil); 595 Push(foo, EVAL(car(x))); 596 x = cdr(x), Push(c1, EVAL(car(x))); 597 fish(ex, data(foo), data(c1), &res); 598 return Pop(res); 599 } 600 601 // (by 'fun1 'fun2 'lst ..) -> lst 602 any doBy(any ex) { 603 any x = cdr(ex); 604 cell res, foo1, foo2; 605 606 Push(res, Nil); 607 Push(foo1, EVAL(car(x))), x = cdr(x), Push(foo2, 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 if (!isCell(data(c[0]))) 616 return Pop(res); 617 data(res) = x = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 618 while (isCell(data(c[0]) = cdr(data(c[0])))) { 619 for (i = 1; i < n; ++i) 620 data(c[i]) = cdr(data(c[i])); 621 cdr(x) = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); 622 x = cdr(x); 623 } 624 data(res) = apply(ex, data(foo2), NO, 1, &res); 625 for (x = data(res); isCell(x); x = cdr(x)) 626 car(x) = cdar(x); 627 } 628 return Pop(res); 629 }