flow.c (39679B)
1 /* 31jul13abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include "pico.h" 6 7 static void redefMsg(any x, any y) { 8 outFile *oSave = OutFile; 9 void (*putSave)(int) = Env.put; 10 11 OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; 12 outString("# "); 13 print(x); 14 if (y) 15 space(), print(y); 16 outString(" redefined\n"); 17 Env.put = putSave, OutFile = oSave; 18 } 19 20 static void putSrc(any s, any k) { 21 if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) { 22 any x, y; 23 cell c1; 24 25 Push(c1, boxCnt(InFile->src)); 26 data(c1) = cons(data(c1), mkStr(InFile->name)); 27 x = get(s, Dbg); 28 if (!k) { 29 if (isNil(x)) 30 put(s, Dbg, cons(data(c1), Nil)); 31 else 32 car(x) = data(c1); 33 } 34 else if (isNil(x)) 35 put(s, Dbg, cons(Nil, cons(data(c1), Nil))); 36 else { 37 for (y = cdr(x); isCell(y); y = cdr(y)) 38 if (caar(y) == k) { 39 cdar(y) = data(c1); 40 drop(c1); 41 return; 42 } 43 cdr(x) = cons(cons(k, data(c1)), cdr(x)); 44 } 45 drop(c1); 46 } 47 } 48 49 static void redefine(any ex, any s, any x) { 50 NeedSym(ex,s); 51 CheckVar(ex,s); 52 if (!isNil(val(s)) && s != val(s) && !equal(x,val(s))) 53 redefMsg(s, NULL); 54 val(s) = x; 55 putSrc(s, NULL); 56 } 57 58 // (quote . any) -> any 59 any doQuote(any x) {return cdr(x);} 60 61 // (as 'any1 . any2) -> any2 | NIL 62 any doAs(any x) { 63 x = cdr(x); 64 if (isNil(EVAL(car(x)))) 65 return Nil; 66 return cdr(x); 67 } 68 69 // (lit 'any) -> any 70 any doLit(any x) { 71 x = cadr(x); 72 if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x))) 73 return x; 74 return cons(Quote, x); 75 } 76 77 // (eval 'any ['cnt ['lst]]) -> any 78 any doEval(any x) { 79 any y; 80 cell c1; 81 bindFrame *p; 82 83 x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x); 84 if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) 85 data(c1) = EVAL(data(c1)); 86 else { 87 int cnt, n, i, j; 88 struct { // bindFrame 89 struct bindFrame *link; 90 int i, cnt; 91 struct {any sym; any val;} bnd[length(x)]; 92 } f; 93 94 x = cdr(x), x = EVAL(car(x)); 95 j = cnt = (int)unBox(y); 96 n = f.i = f.cnt = 0; 97 do { 98 ++n; 99 if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { 100 for (i = 0; i < p->cnt; ++i) { 101 y = val(p->bnd[i].sym); 102 val(p->bnd[i].sym) = p->bnd[i].val; 103 p->bnd[i].val = y; 104 } 105 if (p->cnt && p->bnd[0].sym == At && !--j) 106 break; 107 } 108 } while (p = p->link); 109 while (isCell(x)) { 110 for (p = Env.bind, j = n; ; p = p->link) { 111 if (p->i < 0) 112 for (i = 0; i < p->cnt; ++i) { 113 if (p->bnd[i].sym == car(x)) { 114 f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 115 val(car(x)) = p->bnd[i].val; 116 ++f.cnt; 117 goto next; 118 } 119 } 120 if (!--j) 121 break; 122 } 123 next: x = cdr(x); 124 } 125 f.link = Env.bind, Env.bind = (bindFrame*)&f; 126 data(c1) = EVAL(data(c1)); 127 while (--f.cnt >= 0) 128 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 129 Env.bind = f.link; 130 do { 131 for (p = Env.bind, i = n; --i; p = p->link); 132 if (p->i < 0 && (p->i += cnt) == 0) 133 for (i = p->cnt; --i >= 0;) { 134 y = val(p->bnd[i].sym); 135 val(p->bnd[i].sym) = p->bnd[i].val; 136 p->bnd[i].val = y; 137 } 138 } while (--n); 139 } 140 return Pop(c1); 141 } 142 143 // (run 'any ['cnt ['lst]]) -> any 144 any doRun(any x) { 145 any y; 146 cell c1; 147 bindFrame *p; 148 149 x = cdr(x), data(c1) = EVAL(car(x)), x = cdr(x); 150 if (!isNum(data(c1))) { 151 Save(c1); 152 if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) 153 data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1)); 154 else { 155 int cnt, n, i, j; 156 struct { // bindFrame 157 struct bindFrame *link; 158 int i, cnt; 159 struct {any sym; any val;} bnd[length(x)]; 160 } f; 161 162 x = cdr(x), x = EVAL(car(x)); 163 j = cnt = (int)unBox(y); 164 n = f.i = f.cnt = 0; 165 do { 166 ++n; 167 if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { 168 for (i = 0; i < p->cnt; ++i) { 169 y = val(p->bnd[i].sym); 170 val(p->bnd[i].sym) = p->bnd[i].val; 171 p->bnd[i].val = y; 172 } 173 if (p->cnt && p->bnd[0].sym == At && !--j) 174 break; 175 } 176 } while (p = p->link); 177 while (isCell(x)) { 178 for (p = Env.bind, j = n; ; p = p->link) { 179 if (p->i < 0) 180 for (i = 0; i < p->cnt; ++i) { 181 if (p->bnd[i].sym == car(x)) { 182 f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); 183 val(car(x)) = p->bnd[i].val; 184 ++f.cnt; 185 goto next; 186 } 187 } 188 if (!--j) 189 break; 190 } 191 next: x = cdr(x); 192 } 193 f.link = Env.bind, Env.bind = (bindFrame*)&f; 194 data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1)); 195 while (--f.cnt >= 0) 196 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 197 Env.bind = f.link; 198 do { 199 for (p = Env.bind, i = n; --i; p = p->link); 200 if (p->i < 0 && (p->i += cnt) == 0) 201 for (i = p->cnt; --i >= 0;) { 202 y = val(p->bnd[i].sym); 203 val(p->bnd[i].sym) = p->bnd[i].val; 204 p->bnd[i].val = y; 205 } 206 } while (--n); 207 } 208 drop(c1); 209 } 210 return data(c1); 211 } 212 213 // (def 'sym 'any) -> sym 214 // (def 'sym 'sym 'any) -> sym 215 any doDef(any ex) { 216 any x, y; 217 cell c1, c2, c3; 218 219 x = cdr(ex), Push(c1, EVAL(car(x))); 220 NeedSym(ex,data(c1)); 221 x = cdr(x), Push(c2, EVAL(car(x))); 222 if (!isCell(cdr(x))) { 223 CheckVar(ex,data(c1)); 224 Touch(ex,data(c1)); 225 if (!isNil(y = val(data(c1))) && y != data(c1) && !equal(data(c2), y)) 226 redefMsg(data(c1), NULL); 227 val(data(c1)) = data(c2); 228 putSrc(data(c1), NULL); 229 } 230 else { 231 x = cdr(x), Push(c3, EVAL(car(x))); 232 if (!isNil(data(c2))) 233 Touch(ex,data(c1)); 234 if (!isNil(y = get(data(c1), data(c2))) && !equal(data(c3), y)) 235 redefMsg(data(c1), data(c2)); 236 put(data(c1), data(c2), data(c3)); 237 putSrc(data(c1), data(c2)); 238 } 239 return Pop(c1); 240 } 241 242 // (de sym . any) -> sym 243 any doDe(any ex) { 244 redefine(ex, cadr(ex), cddr(ex)); 245 return cadr(ex); 246 } 247 248 // (dm sym . fun|cls2) -> sym 249 // (dm (sym . cls) . fun|cls2) -> sym 250 // (dm (sym sym2 [. cls]) . fun|cls2) -> sym 251 any doDm(any ex) { 252 any x, y, msg, cls; 253 254 x = cdr(ex); 255 if (!isCell(car(x))) 256 msg = car(x), cls = val(Class); 257 else { 258 msg = caar(x); 259 cls = !isCell(cdar(x))? cdar(x) : 260 get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x)); 261 } 262 if (msg != T) 263 redefine(ex, msg, val(Meth)); 264 if (isSym(cdr(x))) { 265 y = val(cdr(x)); 266 for (;;) { 267 if (!isCell(y) || !isCell(car(y))) 268 err(ex, msg, "Bad message"); 269 if (caar(y) == msg) { 270 x = car(y); 271 break; 272 } 273 y = cdr(y); 274 } 275 } 276 for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y)) 277 if (caar(y) == msg) { 278 if (!equal(cdr(x), cdar(y))) 279 redefMsg(msg, cls); 280 cdar(y) = cdr(x); 281 putSrc(cls, msg); 282 return msg; 283 } 284 if (!isCell(car(x))) 285 val(cls) = cons(x, val(cls)); 286 else 287 val(cls) = cons(cons(msg, cdr(x)), val(cls)); 288 putSrc(cls, msg); 289 return msg; 290 } 291 292 /* Evaluate method invocation */ 293 static any evMethod(any o, any expr, any x) { 294 any y = car(expr); 295 any cls = TheCls, key = TheKey; 296 struct { // bindFrame 297 struct bindFrame *link; 298 int i, cnt; 299 struct {any sym; any val;} bnd[length(y)+3]; 300 } f; 301 302 f.link = Env.bind, Env.bind = (bindFrame*)&f; 303 f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2; 304 f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); 305 while (isCell(y)) { 306 f.bnd[f.cnt].sym = car(y); 307 f.bnd[f.cnt].val = EVAL(car(x)); 308 ++f.cnt, x = cdr(x), y = cdr(y); 309 } 310 if (isNil(y)) { 311 do { 312 x = val(f.bnd[--f.i].sym); 313 val(f.bnd[f.i].sym) = f.bnd[f.i].val; 314 f.bnd[f.i].val = x; 315 } while (f.i); 316 f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 317 y = cls, cls = Env.cls; Env.cls = y; 318 y = key, key = Env.key; Env.key = y; 319 x = prog(cdr(expr)); 320 } 321 else if (y != At) { 322 f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; 323 do { 324 x = val(f.bnd[--f.i].sym); 325 val(f.bnd[f.i].sym) = f.bnd[f.i].val; 326 f.bnd[f.i].val = x; 327 } while (f.i); 328 f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 329 y = cls, cls = Env.cls; Env.cls = y; 330 y = key, key = Env.key; Env.key = y; 331 x = prog(cdr(expr)); 332 } 333 else { 334 int n, cnt; 335 cell *arg; 336 cell c[n = cnt = length(x)]; 337 338 while (--n >= 0) 339 Push(c[n], EVAL(car(x))), x = cdr(x); 340 do { 341 x = val(f.bnd[--f.i].sym); 342 val(f.bnd[f.i].sym) = f.bnd[f.i].val; 343 f.bnd[f.i].val = x; 344 } while (f.i); 345 n = Env.next, Env.next = cnt; 346 arg = Env.arg, Env.arg = c; 347 f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; 348 y = cls, cls = Env.cls; Env.cls = y; 349 y = key, key = Env.key; Env.key = y; 350 x = prog(cdr(expr)); 351 if (cnt) 352 drop(c[cnt-1]); 353 Env.arg = arg, Env.next = n; 354 } 355 while (--f.cnt >= 0) 356 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 357 Env.bind = f.link; 358 Env.cls = cls, Env.key = key; 359 return x; 360 } 361 362 any method(any x) { 363 any y, z; 364 365 if (isCell(y = val(x))) { 366 while (isCell(z = car(y))) { 367 if (car(z) == TheKey) 368 return cdr(z); 369 if (!isCell(y = cdr(y))) 370 return NULL; 371 } 372 do 373 if (x = method(car(TheCls = y))) 374 return x; 375 while (isCell(y = cdr(y))); 376 } 377 return NULL; 378 } 379 380 // (box 'any) -> sym 381 any doBox(any x) { 382 x = cdr(x); 383 return consSym(EVAL(car(x)), Nil); 384 } 385 386 // (new ['flg|num] ['typ ['any ..]]) -> obj 387 any doNew(any ex) { 388 any x, y, *h; 389 cell c1, c2; 390 391 x = cdr(ex); 392 if (isCell(y = EVAL(car(x)))) 393 Push(c1, consSym(y,Nil)); 394 else { 395 if (isNil(y)) 396 data(c1) = consSym(Nil,Nil); 397 else { 398 y = newId(ex, isNum(y)? (int)unDig(y)/2 : 1); 399 if (data(c1) = findHash(y, h = Extern + ehash(y))) 400 tail(data(c1)) = y; 401 else 402 *h = cons(data(c1) = consSym(Nil,y), *h); 403 mkExt(data(c1)); 404 } 405 Save(c1); 406 x = cdr(x), val(data(c1)) = EVAL(car(x)); 407 } 408 TheKey = T, TheCls = NULL; 409 if (y = method(data(c1))) 410 evMethod(data(c1), y, cdr(x)); 411 else { 412 Push(c2, Nil); 413 while (isCell(x = cdr(x))) { 414 data(c2) = EVAL(car(x)), x = cdr(x); 415 put(data(c1), data(c2), EVAL(car(x))); 416 } 417 } 418 return Pop(c1); 419 } 420 421 // (type 'any) -> lst 422 any doType(any ex) { 423 any x, y, z; 424 425 x = cdr(ex), x = EVAL(car(x)); 426 if (isSym(x)) { 427 Fetch(ex,x); 428 z = x = val(x); 429 while (isCell(x)) { 430 if (!isCell(car(x))) { 431 y = x; 432 while (isSym(car(x))) { 433 if (!isCell(x = cdr(x))) 434 return isNil(x)? y : Nil; 435 if (z == x) 436 return Nil; 437 } 438 return Nil; 439 } 440 if (z == (x = cdr(x))) 441 return Nil; 442 } 443 } 444 return Nil; 445 } 446 447 static bool isa(any cls, any x) { 448 any z; 449 450 z = x = val(x); 451 while (isCell(x)) { 452 if (!isCell(car(x))) { 453 while (isSym(car(x))) { 454 if (isExt(car(x))) 455 return NO; 456 if (cls == car(x) || isa(cls, car(x))) 457 return YES; 458 if (!isCell(x = cdr(x)) || z == x) 459 return NO; 460 } 461 return NO; 462 } 463 if (z == (x = cdr(x))) 464 return NO; 465 } 466 return NO; 467 } 468 469 // (isa 'cls|typ 'any) -> obj | NIL 470 any doIsa(any ex) { 471 any x; 472 cell c1; 473 474 x = cdr(ex), Push(c1, EVAL(car(x))); 475 x = cdr(x), x = EVAL(car(x)); 476 if (isSym(x)) { 477 Fetch(ex,x); 478 drop(c1); 479 if (isSym(data(c1))) 480 return isa(data(c1), x)? x : Nil; 481 while (isCell(data(c1))) { 482 if (!isa(car(data(c1)), x)) 483 return Nil; 484 data(c1) = cdr(data(c1)); 485 } 486 return x; 487 } 488 drop(c1); 489 return Nil; 490 } 491 492 // (method 'msg 'obj) -> fun 493 any doMethod(any ex) { 494 any x; 495 cell c1; 496 497 x = cdr(ex), Push(c1, EVAL(car(x))); 498 NeedSym(ex,data(c1)); 499 x = cdr(x), x = EVAL(car(x)); 500 NeedSym(ex,x); 501 Fetch(ex,x); 502 TheKey = Pop(c1); 503 return method(x)? : Nil; 504 } 505 506 // (meth 'obj ['any ..]) -> any 507 any doMeth(any ex) { 508 any x, y; 509 cell c1; 510 511 x = cdr(ex), Push(c1, EVAL(car(x))); 512 NeedSym(ex,data(c1)); 513 Fetch(ex,data(c1)); 514 for (TheKey = car(ex); ; TheKey = val(TheKey)) { 515 if (!isSym(TheKey)) 516 err(ex, TheKey, "Bad message"); 517 if (isNum(val(TheKey))) { 518 TheCls = NULL; 519 if (y = method(data(c1))) { 520 x = evMethod(data(c1), y, cdr(x)); 521 drop(c1); 522 return x; 523 } 524 err(ex, TheKey, "Bad message"); 525 } 526 } 527 } 528 529 // (send 'msg 'obj ['any ..]) -> any 530 any doSend(any ex) { 531 any x, y; 532 cell c1, c2; 533 534 x = cdr(ex), Push(c1, EVAL(car(x))); 535 NeedSym(ex,data(c1)); 536 x = cdr(x), Push(c2, EVAL(car(x))); 537 NeedSym(ex,data(c2)); 538 Fetch(ex,data(c2)); 539 TheKey = data(c1), TheCls = NULL; 540 if (y = method(data(c2))) { 541 x = evMethod(data(c2), y, cdr(x)); 542 drop(c1); 543 return x; 544 } 545 err(ex, TheKey, "Bad message"); 546 } 547 548 // (try 'msg 'obj ['any ..]) -> any 549 any doTry(any ex) { 550 any x, y; 551 cell c1, c2; 552 553 x = cdr(ex), Push(c1, EVAL(car(x))); 554 NeedSym(ex,data(c1)); 555 x = cdr(x), Push(c2, EVAL(car(x))); 556 if (isSym(data(c2))) { 557 if (isExt(data(c2))) { 558 if (!isLife(data(c2))) 559 return Nil; 560 db(ex,data(c2),1); 561 } 562 TheKey = data(c1), TheCls = NULL; 563 if (y = method(data(c2))) { 564 x = evMethod(data(c2), y, cdr(x)); 565 drop(c1); 566 return x; 567 } 568 } 569 drop(c1); 570 return Nil; 571 } 572 573 // (super ['any ..]) -> any 574 any doSuper(any ex) { 575 any x, y, cls, key; 576 577 TheKey = Env.key; 578 x = val(Env.cls? car(Env.cls) : val(This)); 579 while (isCell(car(x))) 580 x = cdr(x); 581 while (isCell(x)) { 582 if (y = method(car(TheCls = x))) { 583 cls = Env.cls, Env.cls = TheCls; 584 key = Env.key, Env.key = TheKey; 585 x = evExpr(y, cdr(ex)); 586 Env.key = key, Env.cls = cls; 587 return x; 588 } 589 x = cdr(x); 590 } 591 err(ex, TheKey, "Bad super"); 592 } 593 594 static any extra(any x) { 595 any y; 596 597 for (x = val(x); isCell(car(x)); x = cdr(x)); 598 while (isCell(x)) { 599 if (x == Env.cls || !(y = extra(car(x)))) { 600 while (isCell(x = cdr(x))) 601 if (y = method(car(TheCls = x))) 602 return y; 603 return NULL; 604 } 605 if (y && num(y) != 1) 606 return y; 607 x = cdr(x); 608 } 609 return (any)1; 610 } 611 612 // (extra ['any ..]) -> any 613 any doExtra(any ex) { 614 any x, y, cls, key; 615 616 TheKey = Env.key; 617 if ((y = extra(val(This))) && num(y) != 1) { 618 cls = Env.cls, Env.cls = TheCls; 619 key = Env.key, Env.key = TheKey; 620 x = evExpr(y, cdr(ex)); 621 Env.key = key, Env.cls = cls; 622 return x; 623 } 624 err(ex, TheKey, "Bad extra"); 625 } 626 627 // (with 'sym . prg) -> any 628 any doWith(any ex) { 629 any x; 630 bindFrame f; 631 632 x = cdr(ex); 633 if (isNil(x = EVAL(car(x)))) 634 return Nil; 635 NeedSym(ex,x); 636 Bind(This,f), val(This) = x; 637 x = prog(cddr(ex)); 638 Unbind(f); 639 return x; 640 } 641 642 // (bind 'sym|lst . prg) -> any 643 any doBind(any ex) { 644 any x, y; 645 646 x = cdr(ex); 647 if (isNum(y = EVAL(car(x)))) 648 argError(ex, y); 649 if (isNil(y)) 650 return prog(cdr(x)); 651 if (isSym(y)) { 652 bindFrame f; 653 654 Bind(y,f); 655 x = prog(cdr(x)); 656 Unbind(f); 657 return x; 658 } 659 { 660 struct { // bindFrame 661 struct bindFrame *link; 662 int i, cnt; 663 struct {any sym; any val;} bnd[length(y)]; 664 } f; 665 666 f.link = Env.bind, Env.bind = (bindFrame*)&f; 667 f.i = f.cnt = 0; 668 do { 669 if (isNum(car(y))) 670 argError(ex, car(y)); 671 if (isSym(car(y))) { 672 f.bnd[f.cnt].sym = car(y); 673 f.bnd[f.cnt].val = val(car(y)); 674 } 675 else { 676 f.bnd[f.cnt].sym = caar(y); 677 f.bnd[f.cnt].val = val(caar(y)); 678 val(caar(y)) = cdar(y); 679 } 680 ++f.cnt; 681 } while (isCell(y = cdr(y))); 682 x = prog(cdr(x)); 683 while (--f.cnt >= 0) 684 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 685 Env.bind = f.link; 686 return x; 687 } 688 } 689 690 // (job 'lst . prg) -> any 691 any doJob(any ex) { 692 any x = cdr(ex); 693 any y = EVAL(car(x)); 694 cell c1; 695 struct { // bindFrame 696 struct bindFrame *link; 697 int i, cnt; 698 struct {any sym; any val;} bnd[length(y)]; 699 } f; 700 701 Push(c1,y); 702 f.link = Env.bind, Env.bind = (bindFrame*)&f; 703 f.i = f.cnt = 0; 704 while (isCell(y)) { 705 f.bnd[f.cnt].sym = caar(y); 706 f.bnd[f.cnt].val = val(caar(y)); 707 val(caar(y)) = cdar(y); 708 ++f.cnt, y = cdr(y); 709 } 710 x = prog(cdr(x)); 711 for (f.cnt = 0, y = Pop(c1); isCell(y); ++f.cnt, y = cdr(y)) { 712 cdar(y) = val(caar(y)); 713 val(caar(y)) = f.bnd[f.cnt].val; 714 } 715 Env.bind = f.link; 716 return x; 717 } 718 719 // (let sym 'any . prg) -> any 720 // (let (sym 'any ..) . prg) -> any 721 any doLet(any x) { 722 any y; 723 724 x = cdr(x); 725 if (isSym(y = car(x))) { 726 bindFrame f; 727 728 x = cdr(x), Bind(y,f), val(y) = EVAL(car(x)); 729 x = prog(cdr(x)); 730 Unbind(f); 731 } 732 else { 733 struct { // bindFrame 734 struct bindFrame *link; 735 int i, cnt; 736 struct {any sym; any val;} bnd[(length(y)+1)/2]; 737 } f; 738 739 f.link = Env.bind, Env.bind = (bindFrame*)&f; 740 f.i = f.cnt = 0; 741 do { 742 f.bnd[f.cnt].sym = car(y); 743 f.bnd[f.cnt].val = val(car(y)); 744 ++f.cnt; 745 val(car(y)) = EVAL(cadr(y)); 746 } while (isCell(y = cddr(y))); 747 x = prog(cdr(x)); 748 while (--f.cnt >= 0) 749 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 750 Env.bind = f.link; 751 } 752 return x; 753 } 754 755 // (let? sym 'any . prg) -> any 756 any doLetQ(any x) { 757 any y, z; 758 bindFrame f; 759 760 x = cdr(x), y = car(x), x = cdr(x); 761 if (isNil(z = EVAL(car(x)))) 762 return Nil; 763 Bind(y,f), val(y) = z; 764 x = prog(cdr(x)); 765 Unbind(f); 766 return x; 767 } 768 769 // (use sym . prg) -> any 770 // (use (sym ..) . prg) -> any 771 any doUse(any x) { 772 any y; 773 774 x = cdr(x); 775 if (isSym(y = car(x))) { 776 bindFrame f; 777 778 Bind(y,f); 779 x = prog(cdr(x)); 780 Unbind(f); 781 } 782 else { 783 struct { // bindFrame 784 struct bindFrame *link; 785 int i, cnt; 786 struct {any sym; any val;} bnd[length(y)]; 787 } f; 788 789 f.link = Env.bind, Env.bind = (bindFrame*)&f; 790 f.i = f.cnt = 0; 791 do { 792 f.bnd[f.cnt].sym = car(y); 793 f.bnd[f.cnt].val = val(car(y)); 794 ++f.cnt; 795 } while (isCell(y = cdr(y))); 796 x = prog(cdr(x)); 797 while (--f.cnt >= 0) 798 val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; 799 Env.bind = f.link; 800 } 801 return x; 802 } 803 804 // (and 'any ..) -> any 805 any doAnd(any x) { 806 any a; 807 808 x = cdr(x); 809 do { 810 if (isNil(a = EVAL(car(x)))) 811 return Nil; 812 val(At) = a; 813 } while (isCell(x = cdr(x))); 814 return a; 815 } 816 817 // (or 'any ..) -> any 818 any doOr(any x) { 819 any a; 820 821 x = cdr(x); 822 do 823 if (!isNil(a = EVAL(car(x)))) 824 return val(At) = a; 825 while (isCell(x = cdr(x))); 826 return Nil; 827 } 828 829 // (nand 'any ..) -> flg 830 any doNand(any x) { 831 any a; 832 833 x = cdr(x); 834 do { 835 if (isNil(a = EVAL(car(x)))) 836 return T; 837 val(At) = a; 838 } while (isCell(x = cdr(x))); 839 return Nil; 840 } 841 842 // (nor 'any ..) -> flg 843 any doNor(any x) { 844 any a; 845 846 x = cdr(x); 847 do 848 if (!isNil(a = EVAL(car(x)))) { 849 val(At) = a; 850 return Nil; 851 } 852 while (isCell(x = cdr(x))); 853 return T; 854 } 855 856 // (xor 'any 'any) -> flg 857 any doXor(any x) { 858 bool f; 859 860 x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x); 861 return f ^ isNil(EVAL(car(x)))? T : Nil; 862 } 863 864 // (bool 'any) -> flg 865 any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;} 866 867 // (not 'any) -> flg 868 any doNot(any x) { 869 any a; 870 871 if (isNil(a = EVAL(cadr(x)))) 872 return T; 873 val(At) = a; 874 return Nil; 875 } 876 877 // (nil . prg) -> NIL 878 any doNil(any x) { 879 while (isCell(x = cdr(x))) 880 if (isCell(car(x))) 881 evList(car(x)); 882 return Nil; 883 } 884 885 // (t . prg) -> T 886 any doT(any x) { 887 while (isCell(x = cdr(x))) 888 if (isCell(car(x))) 889 evList(car(x)); 890 return T; 891 } 892 893 // (prog . prg) -> any 894 any doProg(any x) {return prog(cdr(x));} 895 896 // (prog1 'any1 . prg) -> any1 897 any doProg1(any x) { 898 cell c1; 899 900 x = cdr(x), Push(c1, val(At) = EVAL(car(x))); 901 while (isCell(x = cdr(x))) 902 if (isCell(car(x))) 903 evList(car(x)); 904 return Pop(c1); 905 } 906 907 // (prog2 'any1 'any2 . prg) -> any2 908 any doProg2(any x) { 909 cell c1; 910 911 x = cdr(x), EVAL(car(x)); 912 x = cdr(x), Push(c1, val(At) = EVAL(car(x))); 913 while (isCell(x = cdr(x))) 914 if (isCell(car(x))) 915 evList(car(x)); 916 return Pop(c1); 917 } 918 919 // (if 'any1 'any2 . prg) -> any 920 any doIf(any x) { 921 any a; 922 923 x = cdr(x); 924 if (isNil(a = EVAL(car(x)))) 925 return prog(cddr(x)); 926 val(At) = a; 927 x = cdr(x); 928 return EVAL(car(x)); 929 } 930 931 // (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any 932 any doIf2(any x) { 933 any a; 934 935 x = cdr(x); 936 if (isNil(a = EVAL(car(x)))) { 937 x = cdr(x); 938 if (isNil(a = EVAL(car(x)))) 939 return prog(cddddr(x)); 940 val(At) = a; 941 x = cdddr(x); 942 return EVAL(car(x)); 943 } 944 val(At) = a; 945 x = cdr(x); 946 if (isNil(a = EVAL(car(x)))) { 947 x = cddr(x); 948 return EVAL(car(x)); 949 } 950 val(At) = a; 951 x = cdr(x); 952 return EVAL(car(x)); 953 } 954 955 // (ifn 'any1 'any2 . prg) -> any 956 any doIfn(any x) { 957 any a; 958 959 x = cdr(x); 960 if (!isNil(a = EVAL(car(x)))) { 961 val(At) = a; 962 return prog(cddr(x)); 963 } 964 x = cdr(x); 965 return EVAL(car(x)); 966 } 967 968 // (when 'any . prg) -> any 969 any doWhen(any x) { 970 any a; 971 972 x = cdr(x); 973 if (isNil(a = EVAL(car(x)))) 974 return Nil; 975 val(At) = a; 976 return prog(cdr(x)); 977 } 978 979 // (unless 'any . prg) -> any 980 any doUnless(any x) { 981 any a; 982 983 x = cdr(x); 984 if (!isNil(a = EVAL(car(x)))) { 985 val(At) = a; 986 return Nil; 987 } 988 return prog(cdr(x)); 989 } 990 991 // (cond ('any1 . prg1) ('any2 . prg2) ..) -> any 992 any doCond(any x) { 993 any a; 994 995 while (isCell(x = cdr(x))) { 996 if (!isNil(a = EVAL(caar(x)))) { 997 val(At) = a; 998 return prog(cdar(x)); 999 } 1000 } 1001 return Nil; 1002 } 1003 1004 // (nond ('any1 . prg1) ('any2 . prg2) ..) -> any 1005 any doNond(any x) { 1006 any a; 1007 1008 while (isCell(x = cdr(x))) { 1009 if (isNil(a = EVAL(caar(x)))) 1010 return prog(cdar(x)); 1011 val(At) = a; 1012 } 1013 return Nil; 1014 } 1015 1016 // (case 'any (any1 . prg1) (any2 . prg2) ..) -> any 1017 any doCase(any x) { 1018 any y, z; 1019 1020 x = cdr(x), val(At) = EVAL(car(x)); 1021 while (isCell(x = cdr(x))) { 1022 y = car(x), z = car(y); 1023 if (z == T || equal(val(At), z)) 1024 return prog(cdr(y)); 1025 if (isCell(z)) { 1026 do 1027 if (equal(val(At), car(z))) 1028 return prog(cdr(y)); 1029 while (isCell(z = cdr(z))); 1030 } 1031 } 1032 return Nil; 1033 } 1034 1035 // (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any 1036 any doCasq(any x) { 1037 any y, z; 1038 1039 x = cdr(x), val(At) = EVAL(car(x)); 1040 while (isCell(x = cdr(x))) { 1041 y = car(x), z = car(y); 1042 if (z == T || z == val(At)) 1043 return prog(cdr(y)); 1044 if (isCell(z)) { 1045 do 1046 if (car(z) == val(At)) 1047 return prog(cdr(y)); 1048 while (isCell(z = cdr(z))); 1049 } 1050 } 1051 return Nil; 1052 } 1053 1054 // (state 'var (sym|lst exe [. prg]) ..) -> any 1055 any doState(any ex) { 1056 any x, y, a; 1057 cell c1; 1058 1059 x = cdr(ex); 1060 Push(c1, EVAL(car(x))); 1061 NeedVar(ex,data(c1)); 1062 CheckVar(ex,data(c1)); 1063 while (isCell(x = cdr(x))) { 1064 y = car(x); 1065 if (car(y) == T || memq(val(data(c1)), car(y))) { 1066 y = cdr(y); 1067 if (!isNil(a = EVAL(car(y)))) { 1068 val(At) = val(data(c1)) = a; 1069 drop(c1); 1070 return prog(cdr(y)); 1071 } 1072 } 1073 } 1074 drop(c1); 1075 return Nil; 1076 } 1077 1078 // (while 'any . prg) -> any 1079 any doWhile(any x) { 1080 any cond, a; 1081 cell c1; 1082 1083 cond = car(x = cdr(x)), x = cdr(x); 1084 Push(c1, Nil); 1085 while (!isNil(a = EVAL(cond))) { 1086 val(At) = a; 1087 data(c1) = prog(x); 1088 } 1089 return Pop(c1); 1090 } 1091 1092 // (until 'any . prg) -> any 1093 any doUntil(any x) { 1094 any cond, a; 1095 cell c1; 1096 1097 cond = car(x = cdr(x)), x = cdr(x); 1098 Push(c1, Nil); 1099 while (isNil(a = EVAL(cond))) 1100 data(c1) = prog(x); 1101 val(At) = a; 1102 return Pop(c1); 1103 } 1104 1105 // (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1106 any doLoop(any ex) { 1107 any x, y, a; 1108 1109 for (;;) { 1110 x = cdr(ex); 1111 do { 1112 if (isCell(y = car(x))) { 1113 if (isNil(car(y))) { 1114 y = cdr(y); 1115 if (isNil(a = EVAL(car(y)))) 1116 return prog(cdr(y)); 1117 val(At) = a; 1118 } 1119 else if (car(y) == T) { 1120 y = cdr(y); 1121 if (!isNil(a = EVAL(car(y)))) { 1122 val(At) = a; 1123 return prog(cdr(y)); 1124 } 1125 } 1126 else 1127 evList(y); 1128 } 1129 } while (isCell(x = cdr(x))); 1130 } 1131 } 1132 1133 // (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1134 any doDo(any x) { 1135 any y, z, a; 1136 cell c1; 1137 1138 x = cdr(x); 1139 if (isNil(data(c1) = EVAL(car(x)))) 1140 return Nil; 1141 Save(c1); 1142 if (isNum(data(c1))) { 1143 if (isNeg(data(c1))) { 1144 drop(c1); 1145 return Nil; 1146 } 1147 data(c1) = bigCopy(data(c1)); 1148 } 1149 x = cdr(x), z = Nil; 1150 for (;;) { 1151 if (isNum(data(c1))) { 1152 if (IsZero(data(c1))) { 1153 drop(c1); 1154 return z; 1155 } 1156 digSub1(data(c1)); 1157 } 1158 y = x; 1159 do { 1160 if (!isNum(z = car(y))) { 1161 if (isSym(z)) 1162 z = val(z); 1163 else if (isNil(car(z))) { 1164 z = cdr(z); 1165 if (isNil(a = EVAL(car(z)))) { 1166 drop(c1); 1167 return prog(cdr(z)); 1168 } 1169 val(At) = a; 1170 z = Nil; 1171 } 1172 else if (car(z) == T) { 1173 z = cdr(z); 1174 if (!isNil(a = EVAL(car(z)))) { 1175 val(At) = a; 1176 drop(c1); 1177 return prog(cdr(z)); 1178 } 1179 z = Nil; 1180 } 1181 else 1182 z = evList(z); 1183 } 1184 } while (isCell(y = cdr(y))); 1185 } 1186 } 1187 1188 // (at '(cnt1 . cnt2|NIL) . prg) -> any 1189 any doAt(any ex) { 1190 any x; 1191 1192 x = cdr(ex), x = EVAL(car(x)); 1193 NeedPair(ex,x); 1194 if (isNil(cdr(x))) 1195 return Nil; 1196 NeedCnt(ex,car(x)); 1197 NeedCnt(ex,cdr(x)); 1198 if (num(setDig(car(x), unDig(car(x))+2)) < unDig(cdr(x))) 1199 return Nil; 1200 setDig(car(x), 0); 1201 return prog(cddr(ex)); 1202 } 1203 1204 // (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1205 // (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1206 // (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 1207 any doFor(any x) { 1208 any y, body, cond, a; 1209 cell c1; 1210 struct { // bindFrame 1211 struct bindFrame *link; 1212 int i, cnt; 1213 struct {any sym; any val;} bnd[2]; 1214 } f; 1215 1216 f.link = Env.bind, Env.bind = (bindFrame*)&f; 1217 f.i = 0; 1218 if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) { 1219 if (!isCell(y)) { 1220 f.cnt = 1; 1221 f.bnd[0].sym = y; 1222 f.bnd[0].val = val(y); 1223 } 1224 else { 1225 f.cnt = 2; 1226 f.bnd[0].sym = cdr(y); 1227 f.bnd[0].val = val(cdr(y)); 1228 f.bnd[1].sym = car(y); 1229 f.bnd[1].val = val(car(y)); 1230 val(f.bnd[1].sym) = Zero; 1231 } 1232 y = Nil; 1233 x = cdr(x), Push(c1, EVAL(car(x))); 1234 if (isNum(data(c1))) 1235 val(f.bnd[0].sym) = Zero; 1236 body = x = cdr(x); 1237 for (;;) { 1238 if (isNum(data(c1))) { 1239 val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym)); 1240 digAdd(val(f.bnd[0].sym), 2); 1241 if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0) 1242 break; 1243 } 1244 else { 1245 if (!isCell(data(c1))) 1246 break; 1247 val(f.bnd[0].sym) = car(data(c1)); 1248 if (!isCell(data(c1) = cdr(data(c1)))) 1249 data(c1) = Nil; 1250 } 1251 if (f.cnt == 2) { 1252 val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); 1253 digAdd(val(f.bnd[1].sym), 2); 1254 } 1255 do { 1256 if (!isNum(y = car(x))) { 1257 if (isSym(y)) 1258 y = val(y); 1259 else if (isNil(car(y))) { 1260 y = cdr(y); 1261 if (isNil(a = EVAL(car(y)))) { 1262 y = prog(cdr(y)); 1263 goto for1; 1264 } 1265 val(At) = a; 1266 y = Nil; 1267 } 1268 else if (car(y) == T) { 1269 y = cdr(y); 1270 if (!isNil(a = EVAL(car(y)))) { 1271 val(At) = a; 1272 y = prog(cdr(y)); 1273 goto for1; 1274 } 1275 y = Nil; 1276 } 1277 else 1278 y = evList(y); 1279 } 1280 } while (isCell(x = cdr(x))); 1281 x = body; 1282 } 1283 for1: 1284 drop(c1); 1285 if (f.cnt == 2) 1286 val(f.bnd[1].sym) = f.bnd[1].val; 1287 val(f.bnd[0].sym) = f.bnd[0].val; 1288 Env.bind = f.link; 1289 return y; 1290 } 1291 if (!isCell(car(y))) { 1292 f.cnt = 1; 1293 f.bnd[0].sym = car(y); 1294 f.bnd[0].val = val(car(y)); 1295 } 1296 else { 1297 f.cnt = 2; 1298 f.bnd[0].sym = cdar(y); 1299 f.bnd[0].val = val(cdar(y)); 1300 f.bnd[1].sym = caar(y); 1301 f.bnd[1].val = val(caar(y)); 1302 val(f.bnd[1].sym) = Zero; 1303 } 1304 y = cdr(y); 1305 val(f.bnd[0].sym) = EVAL(car(y)); 1306 y = cdr(y), cond = car(y), y = cdr(y); 1307 Push(c1,Nil); 1308 body = x = cdr(x); 1309 for (;;) { 1310 if (f.cnt == 2) { 1311 val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); 1312 digAdd(val(f.bnd[1].sym), 2); 1313 } 1314 if (isNil(a = EVAL(cond))) 1315 break; 1316 val(At) = a; 1317 do { 1318 if (!isNum(data(c1) = car(x))) { 1319 if (isSym(data(c1))) 1320 data(c1) = val(data(c1)); 1321 else if (isNil(car(data(c1)))) { 1322 data(c1) = cdr(data(c1)); 1323 if (isNil(a = EVAL(car(data(c1))))) { 1324 data(c1) = prog(cdr(data(c1))); 1325 goto for2; 1326 } 1327 val(At) = a; 1328 data(c1) = Nil; 1329 } 1330 else if (car(data(c1)) == T) { 1331 data(c1) = cdr(data(c1)); 1332 if (!isNil(a = EVAL(car(data(c1))))) { 1333 val(At) = a; 1334 data(c1) = prog(cdr(data(c1))); 1335 goto for2; 1336 } 1337 data(c1) = Nil; 1338 } 1339 else 1340 data(c1) = evList(data(c1)); 1341 } 1342 } while (isCell(x = cdr(x))); 1343 if (isCell(y)) 1344 val(f.bnd[0].sym) = prog(y); 1345 x = body; 1346 } 1347 for2: 1348 if (f.cnt == 2) 1349 val(f.bnd[1].sym) = f.bnd[1].val; 1350 val(f.bnd[0].sym) = f.bnd[0].val; 1351 Env.bind = f.link; 1352 return Pop(c1); 1353 } 1354 1355 // (catch 'any . prg) -> any 1356 any doCatch(any x) { 1357 any y; 1358 catchFrame f; 1359 1360 x = cdr(x), f.tag = EVAL(car(x)), f.fin = Zero; 1361 f.link = CatchPtr, CatchPtr = &f; 1362 f.env = Env; 1363 y = setjmp(f.rst)? Thrown : prog(cdr(x)); 1364 CatchPtr = f.link; 1365 return y; 1366 } 1367 1368 // (throw 'sym 'any) 1369 any doThrow(any ex) { 1370 any x, tag; 1371 catchFrame *p; 1372 1373 x = cdr(ex), tag = EVAL(car(x)); 1374 x = cdr(x), Thrown = EVAL(car(x)); 1375 for (p = CatchPtr; p; p = p->link) 1376 if (p->tag == T || tag == p->tag) { 1377 unwind(p); 1378 longjmp(p->rst, 1); 1379 } 1380 err(ex, tag, "Tag not found"); 1381 } 1382 1383 // (finally exe . prg) -> any 1384 any doFinally(any x) { 1385 catchFrame f; 1386 cell c1; 1387 1388 x = cdr(x), f.tag = NULL, f.fin = car(x); 1389 f.link = CatchPtr, CatchPtr = &f; 1390 f.env = Env; 1391 Push(c1, prog(cdr(x))); 1392 EVAL(f.fin); 1393 CatchPtr = f.link; 1394 return Pop(c1); 1395 } 1396 1397 static outFrame Out; 1398 static struct { // bindFrame 1399 struct bindFrame *link; 1400 int i, cnt; 1401 struct {any sym; any val;} bnd[3]; // for 'Up', 'Run' and 'At' 1402 } Brk; 1403 1404 any brkLoad(any x) { 1405 if (!Break && isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) { 1406 Break = YES; 1407 Brk.cnt = 3; 1408 Brk.bnd[0].sym = Up, Brk.bnd[0].val = val(Up), val(Up) = x; 1409 Brk.bnd[1].sym = Run, Brk.bnd[1].val = val(Run), val(Run) = Nil; 1410 Brk.bnd[2].sym = At, Brk.bnd[2].val = val(At); 1411 Brk.link = Env.bind, Env.bind = (bindFrame*)&Brk; 1412 Out.pid = 0, Out.fd = STDOUT_FILENO, pushOutFiles(&Out); 1413 print(x), newline(); 1414 load(NULL, '!', Nil); 1415 popOutFiles(); 1416 val(At) = Brk.bnd[2].val; 1417 val(Run) = Brk.bnd[1].val; 1418 x = val(Up), val(Up) = Brk.bnd[0].val; 1419 Env.bind = Brk.link; 1420 Break = NO; 1421 } 1422 return x; 1423 } 1424 1425 // (! . exe) -> any 1426 any doBreak(any x) { 1427 x = cdr(x); 1428 if (!isNil(val(Dbg))) 1429 x = brkLoad(x); 1430 return EVAL(x); 1431 } 1432 1433 // (e . prg) -> any 1434 any doE(any ex) { 1435 any x; 1436 inFrame *in; 1437 cell c1, at, key; 1438 1439 if (!Break) 1440 err(ex, NULL, "No Break"); 1441 Push(c1,val(Dbg)), val(Dbg) = Nil; 1442 Push(at, val(At)), val(At) = Brk.bnd[2].val; 1443 Push(key, val(Run)), val(Run) = Brk.bnd[1].val; 1444 in = Env.inFrames, popInFiles(); 1445 popOutFiles(); 1446 x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up)); 1447 pushOutFiles(&Out); 1448 pushInFiles(in); 1449 val(Run) = data(key); 1450 val(At) = data(at); 1451 val(Dbg) = Pop(c1); 1452 return x; 1453 } 1454 1455 static void traceIndent(int i, any x, char *s) { 1456 if (i > 64) 1457 i = 64; 1458 while (--i >= 0) 1459 Env.put(' '); 1460 if (isSym(x)) 1461 print(x); 1462 else 1463 print(car(x)), space(), print(cdr(x)), space(), print(val(This)); 1464 outString(s); 1465 } 1466 1467 // ($ sym|lst lst . prg) -> any 1468 any doTrace(any x) { 1469 any foo, body; 1470 outFile *oSave; 1471 void (*putSave)(int); 1472 cell c1; 1473 1474 x = cdr(x); 1475 if (isNil(val(Dbg))) 1476 return prog(cddr(x)); 1477 oSave = OutFile, putSave = Env.put; 1478 OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; 1479 foo = car(x); 1480 x = cdr(x), body = cdr(x); 1481 traceIndent(++Env.trace, foo, " :"); 1482 for (x = car(x); isCell(x); x = cdr(x)) 1483 space(), print(val(car(x))); 1484 if (!isNil(x)) { 1485 if (x != At) 1486 space(), print(val(x)); 1487 else { 1488 int i = Env.next; 1489 1490 while (--i >= 0) 1491 space(), print(data(Env.arg[i])); 1492 } 1493 } 1494 newline(); 1495 Env.put = putSave, OutFile = oSave; 1496 Push(c1, prog(body)); 1497 OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; 1498 traceIndent(Env.trace--, foo, " = "), print(data(c1)); 1499 newline(); 1500 Env.put = putSave, OutFile = oSave; 1501 return Pop(c1); 1502 } 1503 1504 // (call 'any ..) -> flg 1505 any doCall(any ex) { 1506 pid_t pid; 1507 any x, y; 1508 int res, i, ac = length(x = cdr(ex)); 1509 char *av[ac+1]; 1510 1511 if (ac == 0) 1512 return Nil; 1513 av[0] = alloc(NULL, pathSize(y = evSym(x))), pathString(y, av[0]); 1514 for (i = 1; isCell(x = cdr(x)); ++i) 1515 av[i] = alloc(NULL, bufSize(y = evSym(x))), bufString(y, av[i]); 1516 av[ac] = NULL; 1517 flushAll(); 1518 if ((pid = fork()) == 0) { 1519 setpgid(0,0); 1520 execvp(av[0], av); 1521 execError(av[0]); 1522 } 1523 i = 0; do 1524 free(av[i]); 1525 while (++i < ac); 1526 if (pid < 0) 1527 err(ex, NULL, "fork"); 1528 setpgid(pid,0); 1529 if (Termio) 1530 tcsetpgrp(0,pid); 1531 for (;;) { 1532 while (waitpid(pid, &res, WUNTRACED) < 0) { 1533 if (errno != EINTR) 1534 err(ex, NULL, "wait pid"); 1535 if (*Signal) 1536 sighandler(ex); 1537 } 1538 if (Termio) 1539 tcsetpgrp(0,getpgrp()); 1540 if (!WIFSTOPPED(res)) 1541 return res == 0? T : Nil; 1542 load(NULL, '+', Nil); 1543 if (Termio) 1544 tcsetpgrp(0,pid); 1545 kill(pid, SIGCONT); 1546 } 1547 } 1548 1549 // (tick (cnt1 . cnt2) . prg) -> any 1550 any doTick(any ex) { 1551 any x; 1552 clock_t n1, n2, save1, save2; 1553 struct tms tim; 1554 static clock_t ticks1, ticks2; 1555 1556 save1 = ticks1, save2 = ticks2; 1557 times(&tim), n1 = tim.tms_utime, n2 = tim.tms_stime; 1558 x = prog(cddr(ex)); 1559 times(&tim); 1560 n1 = (tim.tms_utime - n1) - (ticks1 - save1); 1561 n2 = (tim.tms_stime - n2) - (ticks2 - save2); 1562 setDig(caadr(ex), unDig(caadr(ex)) + 2*n1); 1563 setDig(cdadr(ex), unDig(cdadr(ex)) + 2*n2); 1564 ticks1 += n1, ticks2 += n2; 1565 return x; 1566 } 1567 1568 // (ipid) -> pid | NIL 1569 any doIpid(any ex __attribute__((unused))) { 1570 if (Env.inFrames && Env.inFrames->pid > 1) 1571 return boxCnt((long)Env.inFrames->pid); 1572 return Nil; 1573 } 1574 1575 // (opid) -> pid | NIL 1576 any doOpid(any ex __attribute__((unused))) { 1577 if (Env.outFrames && Env.outFrames->pid > 1) 1578 return boxCnt((long)Env.outFrames->pid); 1579 return Nil; 1580 } 1581 1582 // (kill 'pid ['cnt]) -> flg 1583 any doKill(any ex) { 1584 pid_t pid; 1585 1586 pid = (pid_t)evCnt(ex,cdr(ex)); 1587 return kill(pid, isCell(cddr(ex))? (int)evCnt(ex,cddr(ex)) : SIGTERM)? Nil : T; 1588 } 1589 1590 static void allocChildren(void) { 1591 int i; 1592 1593 Child = alloc(Child, (Children + 8) * sizeof(child)); 1594 for (i = 0; i < 8; ++i) 1595 Child[Children++].pid = 0; 1596 } 1597 1598 pid_t forkLisp(any ex) { 1599 pid_t n; 1600 int i, hear[2], tell[2]; 1601 static int mic[2]; 1602 1603 flushAll(); 1604 if (!Spkr) { 1605 if (pipe(mic) < 0) 1606 pipeError(ex, "open"); 1607 closeOnExec(ex, mic[0]), closeOnExec(ex, mic[1]); 1608 Spkr = mic[0]; 1609 } 1610 if (pipe(hear) < 0 || pipe(tell) < 0) 1611 pipeError(ex, "open"); 1612 closeOnExec(ex, hear[0]), closeOnExec(ex, hear[1]); 1613 closeOnExec(ex, tell[0]), closeOnExec(ex, tell[1]); 1614 for (i = 0; i < Children; ++i) 1615 if (!Child[i].pid) 1616 break; 1617 if ((n = fork()) < 0) 1618 err(ex, NULL, "fork"); 1619 if (n == 0) { 1620 void *p; 1621 1622 Slot = i; 1623 Spkr = 0; 1624 Mic = mic[1]; 1625 close(hear[1]), close(tell[0]), close(mic[0]); 1626 if (Hear) 1627 close(Hear), closeInFile(Hear), closeOutFile(Hear); 1628 initInFile(Hear = hear[0], NULL); 1629 if (Tell) 1630 close(Tell); 1631 Tell = tell[1]; 1632 for (i = 0; i < Children; ++i) 1633 if (Child[i].pid) 1634 close(Child[i].hear), close(Child[i].tell), free(Child[i].buf); 1635 Children = 0, free(Child), Child = NULL; 1636 for (p = Env.inFrames; p; p = ((inFrame*)p)->link) 1637 ((inFrame*)p)->pid = 0; 1638 for (p = Env.outFrames; p; p = ((outFrame*)p)->link) 1639 ((outFrame*)p)->pid = 0; 1640 for (p = CatchPtr; p; p = ((catchFrame*)p)->link) 1641 ((catchFrame*)p)->fin = Zero; 1642 free(Termio), Termio = NULL; 1643 if (Repl) 1644 ++Repl; 1645 val(PPid) = val(Pid); 1646 val(Pid) = boxCnt(getpid()); 1647 run(val(Fork)); 1648 val(Fork) = Nil; 1649 return 0; 1650 } 1651 if (i == Children) 1652 allocChildren(); 1653 close(hear[0]), close(tell[1]); 1654 Child[i].pid = n; 1655 Child[i].hear = tell[0]; 1656 nonblocking(Child[i].tell = hear[1]); 1657 Child[i].ofs = Child[i].cnt = 0; 1658 Child[i].buf = NULL; 1659 return n; 1660 } 1661 1662 // (fork) -> pid | NIL 1663 any doFork(any ex) { 1664 int n; 1665 1666 return (n = forkLisp(ex))? boxCnt(n) : Nil; 1667 } 1668 1669 // (bye 'cnt|NIL) 1670 any doBye(any ex) { 1671 any x = EVAL(cadr(ex)); 1672 1673 bye(isNil(x)? 0 : xCnt(ex,x)); 1674 }