flow.l (86086B)
1 # 31jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 (code 'redefMsgEC) 5 push (OutFile) # Save output channel 6 ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) 7 push (PutB) # Save 'put' 8 ld (PutB) putStdoutB # Set new 9 push C # Save optional class 10 ld C HashBlank # Print comment 11 call outStringC 12 call printE # Print sym 13 pop E # Class? 14 null E 15 if nz # Yes 16 call space 17 call printE_E # Print class 18 end 19 ld C Redefined # Print message 20 call outStringC 21 pop (PutB) # Restore 'put' 22 pop (OutFile) # and output channel 23 ret 24 25 (code 'putSrcEC_E) 26 cmp (Dbg) Nil # Debug? 27 if ne # Yes 28 sym (E TAIL) # External symbol? 29 if z # No 30 ld A (InFile) # Current InFile 31 null A # Any? 32 if nz # Yes 33 null (A VI) # Filename? 34 if nz # Yes 35 push X 36 push E # <S I> sym 37 push C # <S> key 38 ld C Dbg 39 call getEC_E # Get '*Dbg' properties 40 ld X E # into X 41 ld E ((InFile) VI) # Get filename 42 call mkStrE_E # Make string 43 ld A ((InFile) V) # Get 'src' 44 shl A 4 # Make short number 45 or A CNT 46 push E 47 call consE_E # (<src> . "filename") 48 ld (E) A 49 pop (E CDR) 50 ld A (S) # Get key 51 null A # Any? 52 if z # No 53 cmp X Nil # '*Dbg' properties? 54 if eq # No 55 push E 56 call consE_E # Make list 57 pop (E) 58 ld (E CDR) Nil 59 ld A (S I) # Put initial '*Dbg' properties 60 ld C Dbg 61 call putACE 62 else 63 ld (X) E # Set first '*Dbg' property 64 end 65 else 66 cmp X Nil # '*Dbg' properties? 67 if eq # No 68 call consE_C # Make list 69 ld (C) E 70 ld (C CDR) Nil 71 call consC_E # Empty first property 72 ld (E) Nil 73 ld (E CDR) C 74 ld A (S I) # Put initial '*Dbg' properties 75 ld C Dbg 76 call putACE 77 else 78 ld C (X CDR) # Search secondary properties 79 do 80 atom C # Any? 81 if nz # No 82 call consE_C 83 ld (C) (S) # Get key 84 ld (C CDR) E # Cons with value 85 call consC_A # Insert into list 86 ld (A) C 87 ld (A CDR) (X CDR) 88 ld (X CDR) A 89 break T 90 end 91 cmp ((C)) (S) # Found key? 92 if eq # Yes 93 ld ((C) CDR) E # Store value 94 break T 95 end 96 ld C (C CDR) 97 loop 98 end 99 end 100 pop C 101 pop E 102 pop X 103 end 104 end 105 end 106 end 107 ret 108 109 (code 'redefineCE 0) 110 ld A (E) # Current value 111 cmp A Nil # NIL? 112 if ne # NO 113 cmp A E # Auto-symbol? 114 if ne # No 115 push C # Save definition 116 push E # and sym 117 ld E C # Value 118 call equalAE_F # Changing? 119 if ne # Yes 120 ld E (S) # Get sym 121 ld C 0 # No class 122 call redefMsgEC 123 end 124 pop E # Retrieve sym 125 pop C # and definition 126 end 127 end 128 ld (E) C # Set definition 129 ld C 0 # No key 130 call putSrcEC_E # Put source information 131 ret 132 133 # (quote . any) -> any 134 (code 'doQuote 2) 135 ld E (E CDR) # Get CDR 136 ret 137 138 # (as 'any1 . any2) -> any2 | NIL 139 (code 'doAs 2) 140 ld E (E CDR) 141 push E # Save args 142 ld E (E) # Eval condition 143 eval 144 pop A # Retrieve args 145 cmp E Nil # Result NIL? 146 ldnz E (A CDR) # No: Return 'any2' 147 ret 148 149 # (lit 'any) -> any 150 (code 'doLit 2) 151 ld E (E CDR) # Get arg 152 ld E (E) # Eval it 153 eval 154 num E # Number? 155 if z # No 156 cmp E Nil # NIL? 157 if ne # No 158 cmp E TSym # T? 159 if ne # No 160 atom E # Pair? 161 jnz 10 # No 162 num (E) # CAR number? 163 if z # No 164 10 ld A E 165 call consE_E # Cons with 'quote' 166 ld (E) Quote 167 ld (E CDR) A 168 end 169 end 170 end 171 end 172 ret 173 174 # (eval 'any ['cnt ['lst]]) -> any 175 (code 'doEval 2) 176 push X 177 ld X (E CDR) # Args 178 ld E (X) # Eval first 179 eval 180 num E # 'any' is number? 181 if z # No 182 link 183 push E # <L I> 'any' 184 link 185 ld X (X CDR) # X on rest 186 atom X # Any? 187 if nz # No 188 10 sym E # Symbolic? 189 if nz # Yes 190 ld E (E) # Get value 191 else 192 call evListE_E # Else evaluate expression 193 end 194 drop 195 pop X 196 ret 197 end 198 null (EnvBind) # Bindings? 199 jz 10 # No 200 ld E (X) # Eval 'cnt' 201 eval 202 shr E 4 # Normalize 203 push E # <L -I> 'cnt' 204 push 0 # <L -II> 'n' 205 ld E ((X CDR)) # Last argument 206 eval # Exclusion list 'lst' in E 207 push Y 208 ld C (L -I) # Get 'cnt' 209 ld Y (EnvBind) # and bindings 210 do 211 ld A (Y) # End of bindings in A 212 inc (L -II) # Increment 'n' 213 sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' 214 if c # First pass 215 add Y I 216 do 217 ld X (Y) # Next symbol 218 xchg (X) (Y I) # Exchange symbol value with saved value 219 add Y II 220 cmp Y A # More? 221 until eq # No 222 cmp X At # Lambda frame? 223 if eq # Yes 224 dec C # Decrement local 'cnt' 225 break z # Done 226 end 227 end 228 ld Y (A I) # Bind link 229 null Y # More bindings? 230 until z # No 231 atom E # Exclusion list? 232 if nz # No 233 ld E (L I) # Get 'any' 234 eval # Evaluate it 235 else 236 push (EnvBind) # Build bind frame 237 link 238 do 239 ld X (E) # Next excluded symbol 240 push (X) # Save in bind frame 241 push X 242 ld C (L -II) # Get 'n' 243 ld Y (EnvBind) # Bindings 244 do 245 ld A (Y) # End of bindings in A 246 add Y I 247 do 248 cmp X (Y) # Found excluded symbol? 249 if eq # Yes 250 ld (X) (Y I) # Bind to found value 251 jmp 20 252 end 253 add Y II 254 cmp Y A # More? 255 until eq # No 256 dec C # Traversed 'n' frames? 257 while nz # No 258 ld Y (A I) # Bind link 259 null Y # More bindings? 260 until z # No 261 20 ld E (E CDR) 262 atom E # Exclusion list? 263 until nz # No 264 ld E ((L) I) # Get 'any' 265 link 266 ld (EnvBind) L # Close bind frame 267 push 0 # Init env swap 268 eval # Evaluate 'any' 269 add S I # Drop env swap 270 pop L # Get link 271 do # Unbind excluded symbols 272 pop X # Next symbol 273 pop (X) # Restore value 274 cmp S L # More? 275 until eq # No 276 pop L # Restore link 277 pop (EnvBind) # Restore bind link 278 end 279 ld C (L -II) # Get 'n' 280 do 281 ld A C # in A 282 ld Y (EnvBind) # Bindings 283 do 284 dec A # 'n-1' times 285 while nz 286 ld Y ((Y) I) # Follow link 287 loop 288 add (Y -I) (L -I) # Increment 'eswp' by 'cnt' 289 if z # Last pass 290 lea A ((Y) -II) # Last binding in A 291 do 292 xchg ((A)) (A I) # Exchange next symbol value with saved value 293 sub A II 294 cmp A Y # More? 295 until lt # No 296 end 297 dec C # Decrement 'n' 298 until z # Done 299 pop Y 300 drop 301 end 302 pop X 303 ret 304 305 # (run 'any ['cnt ['lst]]) -> any 306 (code 'doRun 2) 307 push X 308 ld X (E CDR) # Args 309 ld E (X) # Eval first 310 eval 311 num E # 'any' is number? 312 if z # No 313 link 314 push E # <L I> 'any' 315 link 316 ld X (X CDR) # X on rest 317 atom X # Any? 318 if nz # No 319 10 sym E # Symbolic? 320 if nz # Yes 321 ld E (E) # Get value 322 else 323 call runE_E # Execute 324 end 325 drop 326 pop X 327 ret 328 end 329 null (EnvBind) # Bindings? 330 jz 10 # No 331 ld E (X) # Eval 'cnt' 332 eval 333 shr E 4 # Normalize 334 push E # <L -I> 'cnt' 335 push 0 # <L -II> 'n' 336 ld E ((X CDR)) # Last argument 337 eval # Exclusion list 'lst' in E 338 push Y 339 ld C (L -I) # Get 'cnt' 340 ld Y (EnvBind) # and bindings 341 do 342 ld A (Y) # End of bindings in A 343 inc (L -II) # Increment 'n' 344 sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' 345 if c # First pass 346 add Y I 347 do 348 ld X (Y) # Next symbol 349 xchg (X) (Y I) # Exchange symbol value with saved value 350 add Y II 351 cmp Y A # More? 352 until eq # No 353 cmp X At # Lambda frame? 354 if eq # Yes 355 dec C # Decrement local 'cnt' 356 break z # Done 357 end 358 end 359 ld Y (A I) # Bind link 360 null Y # More bindings? 361 until z # No 362 atom E # Exclusion list? 363 if nz # No 364 ld E (L I) # Run 'any' 365 sym E # Symbolic? 366 if nz # Yes 367 ld E (E) # Get value 368 else 369 call runE_E # Execute 370 end 371 else 372 push (EnvBind) # Build bind frame 373 link 374 do 375 ld X (E) # Next excluded symbol 376 push (X) # Save in bind frame 377 push X 378 ld C (L -II) # Get 'n' 379 ld Y (EnvBind) # Bindings 380 do 381 ld A (Y) # End of bindings in A 382 add Y I 383 do 384 cmp X (Y) # Found excluded symbol? 385 if eq # Yes 386 ld (X) (Y I) # Bind to found value 387 jmp 20 388 end 389 add Y II 390 cmp Y A # More? 391 until eq # No 392 dec C # Traversed 'n' frames? 393 while nz # No 394 ld Y (A I) # Bind link 395 null Y # More bindings? 396 until z # No 397 20 ld E (E CDR) 398 atom E # Exclusion list? 399 until nz # No 400 ld E ((L) I) # Get 'any' 401 link 402 ld (EnvBind) L # Close bind frame 403 push 0 # Init env swap 404 sym E # 'any' symbolic? 405 if nz # Yes 406 ld E (E) # Get value 407 else 408 call runE_E # Execute 409 end 410 add S I # Drop env swap 411 pop L # Get link 412 do # Unbind excluded symbols 413 pop X # Next symbol 414 pop (X) # Restore value 415 cmp S L # More? 416 until eq # No 417 pop L # Restore link 418 pop (EnvBind) # Restore bind link 419 end 420 ld C (L -II) # Get 'n' 421 do 422 ld A C # in A 423 ld Y (EnvBind) # Bindings 424 do 425 dec A # 'n-1' times 426 while nz 427 ld Y ((Y) I) # Follow link 428 loop 429 add (Y -I) (L -I) # Increment 'eswp' by 'cnt' 430 if z # Last pass 431 lea A ((Y) -II) # Last binding in A 432 do 433 xchg ((A)) (A I) # Exchange next symbol value with saved value 434 sub A II 435 cmp A Y # More? 436 until lt # No 437 end 438 dec C # Decrement 'n' 439 until z # Done 440 pop Y 441 drop 442 end 443 pop X 444 ret 445 446 # (def 'sym 'any) -> sym 447 # (def 'sym 'sym 'any) -> sym 448 (code 'doDef 2) 449 push X 450 push Y 451 ld X E 452 ld Y (E CDR) # Y on args 453 ld E (Y) # Eval first 454 eval 455 num E # Need symbol 456 jnz symErrEX 457 sym E 458 jz symErrEX 459 link 460 push E # <L II/III> First symbol 461 ld Y (Y CDR) # Next arg 462 ld E (Y) 463 eval+ # Eval next arg 464 push E # <L I/II> Second arg 465 link 466 ld Y (Y CDR) # Third arg? 467 atom Y 468 if nz # No 469 ld E (L II) # First symbol 470 call checkVarEX # Check 471 sym (E TAIL) # External symbol? 472 if nz # Yes 473 call dbTouchEX # Touch it 474 end 475 ld A (E) # Current value 476 cmp A Nil # NIL? 477 if ne # NO 478 cmp A E # Auto-symbol? 479 if ne # No 480 ld E (L I) # New value 481 call equalAE_F # Changing? 482 if ne # Yes 483 ld E (L II) # Get symbol 484 ld C 0 # No class 485 call redefMsgEC 486 end 487 ld E (L II) # Get symbol again 488 end 489 end 490 ld (E) (L I) # Set symbol to new value 491 ld C 0 # No key 492 call putSrcEC_E # Put source information 493 else 494 ld E (Y) 495 eval # Eval next arg 496 tuck E # <L I> Third arg 497 link 498 ld E (L III) # First symbol 499 ld C (L II) # Second arg 500 sym (E TAIL) # External symbol? 501 if nz # Yes 502 cmp C Nil # Volatile property? 503 if ne # No 504 call dbTouchEX # Touch it 505 end 506 end 507 call getEC_E # Current property value 508 cmp E Nil # NIL? 509 if ne # NO 510 ld A (L I) # New value 511 call equalAE_F # Changing? 512 if ne # Yes 513 ld E (L III) # First symbol 514 ld C (L II) # Property key 515 call redefMsgEC 516 end 517 end 518 ld A (L III) # Symbol 519 ld C (L II) # Key 520 ld E (L I) # Value 521 call putACE # Put propery 522 ld E (L III) # Symbol 523 ld C (L II) # Key 524 call putSrcEC_E # Put source information 525 end 526 drop # Return first symbol 527 pop Y 528 pop X 529 ret 530 531 # (de sym . any) -> sym 532 (code 'doDe 2) 533 push X 534 ld X (E CDR) # Args 535 ld E (X) # Symbol in E 536 ld C (X CDR) # Body in C 537 call needSymEX 538 call redefineCE # Redefine 539 pop X 540 ret 541 542 # (dm sym . fun|cls2) -> sym 543 # (dm (sym . cls) . fun|cls2) -> sym 544 # (dm (sym sym2 [. cls]) . fun|cls2) -> sym 545 (code 'doDm 2) 546 push X 547 push Y 548 ld X E 549 ld Y (E CDR) # Y on args 550 ld E (Y) # Get first 551 atom E # First form? 552 if nz # Yes 553 ld C (Class) # Get 'cls' from Class 554 else 555 ld C (E CDR) 556 atom C # Second form? 557 if z # No 558 ld E (C CDR) # 'cls'? 559 cmp E Nil 560 if eq # No 561 ld E (Class) # Default to Class 562 end 563 ld C (C) # 'sym' 564 call getEC_E # Get instance object 565 ld C E # into C 566 ld E (Y) # Get first again 567 end 568 ld E (E) # msg 569 end 570 cmp E TSym # 'msg' is T? 571 if ne # No 572 push C # Save class 573 ld C (Meth) # Get 'meth' code pointer 574 call needSymEX 575 call redefineCE # Redefine 576 pop C 577 end 578 ld A (Y CDR) # Explicit inheritance? 579 num A 580 if z # No 581 sym A 582 if nz # Yes 583 ld A (A) # Get cls2's value 584 do 585 atom A # More method definitions? 586 jnz msgErrAX # No 587 atom (A) 588 jnz msgErrAX 589 cmp E ((A)) # Found 'msg'? 590 if eq # Yes 591 ld Y (A) # Get method entry 592 break T 593 end 594 ld A (A CDR) 595 loop 596 end 597 end 598 ld X (C) # Get cls's value 599 do 600 atom X # More method definitions? 601 while z # Yes 602 atom (X) 603 while z 604 cmp E ((X)) # Found 'msg'? 605 if eq # Yes 606 push E # Save 'msg' 607 ld E ((X) CDR) # Old body 608 ld A (Y CDR) # New body 609 call equalAE_F # Changing? 610 if ne # Yes 611 ld E (S) # Get 'msg' 612 push C # Save 'cls' 613 call redefMsgEC 614 pop C 615 end 616 pop E 617 ld ((X) CDR) (Y CDR) # Set new body 618 jmp 90 619 end 620 ld X (X CDR) 621 loop 622 atom (Y) # First form or explict inheritance? 623 if nz # Yes 624 call cons_A # Cons into methods 625 ld (A) Y 626 ld (A CDR) (C) 627 else 628 call cons_A # Cons 'msg' 629 ld (A) E 630 ld (A CDR) (Y CDR) # With method body 631 push A 632 call consA_A # Cons into methods 633 pop (A) 634 ld (A CDR) (C) 635 end 636 ld (C) A 637 90 xchg C E # 'msg' <-> 'cls' 638 call putSrcEC_E # Put source information 639 ld E C # Return 'msg' 640 pop Y 641 pop X 642 ret 643 644 # Apply METH in C to X, with object A 645 (code 'evMethodACEXYZ_E 0) 646 cmp S (StkLimit) # Stack check 647 jlt stkErr 648 push Z # <(L) IV> 'cls' 649 push Y # <(L) III> 'key' 650 ld Y (C) # Parameter list in Y 651 ld Z (C CDR) # Body in Z 652 push E # Save 'exe' 653 push (EnvBind) # Build bind frame 654 link 655 push (At) # Bind At 656 push At 657 push A # Bind object in A 658 push This # to 'This' 659 do 660 atom Y # More evaluating parameters? 661 while z # Yes 662 ld E (X) # Get next argument 663 ld X (X CDR) 664 eval+ # Evaluate and save 665 push E 666 push (Y) # Save symbol 667 ld Y (Y CDR) 668 loop 669 cmp Y Nil # NIL-terminated parameter list? 670 if eq # Yes: Bind parameter symbols 671 ld Y S # Y on bindings 672 do 673 ld X (Y) # Symbol in X 674 add Y I 675 ld A (X) # Old value in A 676 ld (X) (Y) # Set new value 677 ld (Y) A # Save old value 678 add Y I 679 cmp Y L # End? 680 until eq # Yes 681 link 682 ld (EnvBind) L # Close bind frame 683 push 0 # Init env swap 684 xchg (EnvCls) ((L) IV) # 'cls' 685 xchg (EnvKey) ((L) III) # 'key' 686 prog Z # Run body 687 add S I # Drop env swap 688 pop L # Get link 689 do # Unbind symbols 690 pop X # Next symbol 691 pop (X) # Restore value 692 cmp S L # More? 693 until eq # No 694 pop L # Restore link 695 pop (EnvBind) # Restore bind link 696 add S I # Drop 'exe' 697 pop (EnvKey) # 'key' 698 pop (EnvCls) # and 'cls' 699 ret 700 end 701 # Non-NIL parameter 702 cmp Y At # '@'? 703 if ne # No 704 push (Y) # Save last parameter's old value 705 push Y # and the last parameter 706 ld (Y) X # Set to unevaluated argument list 707 lea Y (S II) # Y on evaluated bindings 708 do 709 ld X (Y) # Symbol in X 710 add Y I 711 ld A (X) # Old value in A 712 ld (X) (Y) # Set new value 713 ld (Y) A # Save old value 714 add Y I 715 cmp Y L # End? 716 until eq # Yes 717 link 718 ld (EnvBind) L # Close bind frame 719 push 0 # Init env swap 720 xchg (EnvCls) ((L) IV) # 'cls' 721 xchg (EnvKey) ((L) III) # 'key' 722 prog Z # Run body 723 add S I # Drop env swap 724 pop L # Get link 725 do # Unbind symbols 726 pop X # Next symbol 727 pop (X) # Restore value 728 cmp S L # More? 729 until eq # No 730 pop L # Restore link 731 pop (EnvBind) # Restore bind link 732 add S I # Drop 'exe' 733 pop (EnvKey) # 'key' 734 pop (EnvCls) # and 'cls' 735 ret 736 end 737 # Evaluated argument list 738 link # Close bind frame 739 ld Y L # Y on frame 740 push 0 # Init env swap 741 push (EnvNext) # Save current 'next' 742 push (EnvArgs) # and varArgs base 743 atom X # Any args? 744 if nz # No 745 ld (EnvArgs) 0 746 ld (EnvNext) 0 747 else 748 link # Build varArgs frame 749 do 750 ld E (X) # Get next argument 751 eval+ # Evaluate and save 752 push E 753 ld X (X CDR) 754 atom X # More args? 755 until nz # No 756 ld (EnvArgs) S # Set new varArgs base 757 ld (EnvNext) L # Set new 'next' 758 link # Close varArgs frame 759 end 760 ld (EnvBind) Y # Close bind frame 761 xchg (EnvCls) ((Y) IV) # 'cls' 762 xchg (EnvKey) ((Y) III) # 'key' 763 ld C (Y) # End of bindings in C 764 add Y I 765 do 766 ld X (Y) # Symbol in X 767 add Y I 768 ld A (X) # Old value in A 769 ld (X) (Y) # Set new value 770 ld (Y) A # Save old value 771 add Y I 772 cmp Y C # End? 773 until eq # Yes 774 prog Z # Run body 775 null (EnvArgs) # VarArgs? 776 if nz # Yes 777 drop # Drop varArgs 778 end 779 pop (EnvArgs) # Restore varArgs base 780 pop (EnvNext) # and 'next' 781 add S I # Drop env swap 782 pop L # Get link 783 do # Unbind symbols 784 pop X # Next symbol 785 pop (X) # Restore value 786 cmp S L # More? 787 until eq # No 788 pop L # Restore link 789 pop (EnvBind) # Restore bind link 790 add S I # Drop 'exe' 791 pop (EnvKey) # 'key' 792 pop (EnvCls) # and 'cls' 793 ret 794 795 (code 'methodEY_FCYZ 0) 796 ld A (E) # Get class definition (methods and superclasses) 797 atom A # Any? 798 if z # Yes 799 do 800 ld C (A) # First item 801 atom C # Method definition? 802 while z # Yes 803 cmp Y (C) # Found method definition? 804 if eq # Yes 805 ld C (C CDR) # Return method 806 ret # 'z' 807 end 808 ld A (A CDR) # Next item 809 atom A # Any? 810 jnz ret # Return 'nz' 811 loop 812 do 813 ld Z A # Set class list 814 ld E (A) # Class symbol 815 push A 816 cmp S (StkLimit) # Stack check 817 jlt stkErr 818 call methodEY_FCYZ # Found method definition? 819 pop A 820 jeq ret # 'z' 821 ld A (A CDR) # Next superclass 822 atom A # Any? 823 until nz # No 824 end 825 ret # 'nz' 826 827 # (box 'any) -> sym 828 (code 'doBox 2) 829 ld E ((E CDR)) # Get arg 830 eval # Eval it 831 call consE_A # New symbol 832 ld (A) ZERO # anonymous 833 or A SYM 834 ld (A) E # Set value 835 ld E A 836 ret 837 838 # (new ['flg|num] ['typ ['any ..]]) -> obj 839 (code 'doNew 2) 840 push X 841 push Y 842 push Z 843 ld Z E # Save 'exe' in Z 844 ld Y (E CDR) # Y on args 845 ld E (Y) # Eval first 846 eval 847 atom E # 'typ' list? 848 if z # Yes 849 call consE_A # New object 850 ld (A) ZERO # anonymous 851 or A SYM # Make symbol 852 ld (A) E # Set 'typ' 853 link 854 push A # <L II> 'obj' 855 push Nil # <L I> Safe 856 link 857 else 858 cmp E Nil # 'flg'? 859 if eq # NIL 860 call cons_E # New object 861 ld (E) ZERO # anonymous 862 or E SYM # Make symbol 863 ld (E) Nil # Init to 'NIL' 864 else # External object 865 cnt E # File number? 866 ldz E ONE # Default to '1' 867 shr E 4 # Normalize 868 call newIdEX_X # Allocate new external name 869 call externX_E # Intern external symbol 870 ld A (E TAIL) # Get name again 871 shl A 1 872 setc # Set "dirty" 873 rcr A 1 874 ld (E TAIL) A # Set name 875 end 876 link 877 push E # <L II> 'obj' 878 push Nil # <L I> Safe 879 link 880 ld Y (Y CDR) # Next arg 881 ld E (Y) 882 eval # Eval 'typ' 883 ld A (L II) # Object in A 884 ld (A) E # Set value in 'obj' 885 end 886 push Z # <S> 'exe' 887 ld X (Y CDR) # Keep args in X 888 ld E A # Object 889 ld Y TSym # Search for initial method 890 ld Z 0 # No classes 891 call methodEY_FCYZ # Found? 892 if eq # Yes 893 ld A (L II) # Get 'obj' 894 ld E (S) # and 'exe' 895 call evMethodACEXYZ_E 896 else 897 do 898 atom X # More args? 899 while z # Yes 900 ld E (X) # Eval next key 901 eval 902 ld (L I) E # Save it 903 ld X (X CDR) 904 ld E (X) # Eval next value 905 eval 906 ld A (L II) # 'obj' 907 ld C (L I) # Key 908 call putACE # Put property 909 ld X (X CDR) 910 loop 911 end 912 ld E (L II) # Return 'obj' 913 drop 914 pop Z 915 pop Y 916 pop X 917 ret 918 919 # (type 'any) -> lst 920 (code 'doType 2) 921 push X 922 ld X E 923 ld E ((E CDR)) # E on arg 924 eval # Eval it 925 num E # Symbol? 926 if z 927 sym E 928 if nz # Yes 929 sym (E TAIL) # External symbol? 930 if nz # Yes 931 call dbFetchEX # Fetch it 932 end 933 pop X 934 ld E (E) # Get value 935 ld C E # Keep in C 936 do 937 atom E # Class definitions? 938 jnz retNil # No 939 atom (E) # Class? 940 if nz # Yes 941 ld A E 942 do 943 num (A) # Symbol? 944 jnz retNil # No 945 ld A (A CDR) # Next class 946 atom A # Any? 947 if nz # No 948 cmp A Nil # End of classes? 949 jnz retNil # No 950 ret # Return E 951 end 952 cmp C A # Circular? 953 jeq retNil # Yes 954 loop 955 end 956 ld E (E CDR) # Next definition 957 cmp C E # Circular? 958 jeq retNil # Yes 959 loop 960 end 961 end 962 pop X 963 ld E Nil # Return NIL 964 ret 965 966 # (isa 'cls|typ 'any) -> obj | NIL 967 (code 'doIsa 2) 968 push X 969 push Y 970 ld X E 971 ld Y (E CDR) # Y on args 972 ld E (Y) # Eval first 973 eval 974 link 975 push E # <L I> 'cls|typ' 976 link 977 ld Y (Y CDR) # Next arg 978 ld E (Y) 979 eval # Eval 'any' 980 num E # Symbol? 981 if z 982 sym E 983 if nz # Yes 984 sym (E TAIL) # External symbol? 985 if nz # Yes 986 call dbFetchEX # Fetch it 987 end 988 ld C (L I) # Get 'cls|typ' 989 atom C # 'cls'? 990 if nz # Yes 991 call isaCE_F # Check 992 ldnz E Nil # Return NIL if no match 993 else 994 ld Y C # Get 'typ' in Y 995 do 996 ld C (Y) # Next class 997 call isaCE_F # Check 998 if nz 999 ld E Nil # Return NIL if no match 1000 break T 1001 end 1002 ld Y (Y CDR) # More? 1003 atom Y 1004 until nz # No 1005 end 1006 drop 1007 pop Y 1008 pop X 1009 ret 1010 end 1011 end 1012 ld E Nil # Return NIL 1013 drop 1014 pop Y 1015 pop X 1016 ret 1017 1018 : isaCE_F # A, X 1019 ld X (E) # Get value 1020 ld A X # Keep in A 1021 do 1022 atom X # Atomic value? 1023 jnz ret # Return NO 1024 atom (X) # Next item atomic? 1025 if nz # Yes 1026 do 1027 num (X) # Numeric? 1028 jnz ret # Return NO 1029 sym ((X) TAIL) # External? 1030 jnz ret # Return NO 1031 cmp C (X) # Match? 1032 jeq ret # Return YES 1033 push A # Save list head 1034 push E # object 1035 push X # and list 1036 ld E (X) # Recurse 1037 cmp S (StkLimit) # Stack check 1038 jlt stkErr 1039 call isaCE_F # Match? 1040 pop X 1041 pop E 1042 pop A 1043 jeq ret # Return YES 1044 ld X (X CDR) # Next class 1045 atom X # Any? 1046 jnz ret # Return NO 1047 cmp A X # Circular? 1048 jeq retnz # Return NO 1049 atom (X) # Next item a list? 1050 jz retnz # Return NO 1051 loop 1052 end 1053 ld X (X CDR) # Next item 1054 cmp A X # Circular? 1055 jeq retnz # Yes 1056 loop 1057 1058 # (method 'msg 'obj) -> fun 1059 (code 'doMethod 2) 1060 push X 1061 push Y 1062 push Z 1063 ld X E 1064 ld Y (E CDR) # Y on args 1065 ld E (Y) # Eval first 1066 eval # Eval it 1067 num E # Need symbol 1068 jnz symErrEX 1069 sym E 1070 jz symErrEX 1071 link 1072 push E # <L I> 'msg' 1073 link 1074 ld E ((Y CDR)) # Second 1075 eval # 'obj' 1076 num E # Need symbol 1077 jnz symErrEX 1078 sym E 1079 jz symErrEX 1080 sym (E TAIL) # External symbol? 1081 if nz # Yes 1082 call dbFetchEX # Fetch it 1083 end 1084 ld Y (L I) # 'msg' 1085 call methodEY_FCYZ # Found? 1086 ld E C # Yes 1087 ldnz E Nil # No 1088 drop 1089 pop Z 1090 pop Y 1091 pop X 1092 ret 1093 1094 # (meth 'obj ['any ..]) -> any 1095 (code 'doMeth 2) 1096 push X 1097 push Y 1098 push Z 1099 link 1100 push C # <L II> Message symbol 1101 link 1102 ld X E 1103 ld Y (E CDR) # Y on args 1104 ld E (Y) # Eval 'obj' 1105 eval 1106 num E # Need symbol 1107 jnz symErrEX 1108 sym E 1109 jz symErrEX 1110 tuck E # <L I> 'obj' 1111 link 1112 sym (E TAIL) # External symbol? 1113 if nz # Yes 1114 call dbFetchEX # Fetch it 1115 end 1116 push (Y CDR) # Save args 1117 ld Y (L II) # Get message 1118 num Y # Need symbol 1119 jnz msgErrYX 1120 ld Z 0 # No classes 1121 call methodEY_FCYZ # Found? 1122 jne msgErrYX # No 1123 ld A (L I) # Get 'obj' 1124 ld E X # 'exe' 1125 pop X # and args 1126 call evMethodACEXYZ_E 1127 drop 1128 pop Z 1129 pop Y 1130 pop X 1131 ret 1132 1133 # (send 'msg 'obj ['any ..]) -> any 1134 (code 'doSend 2) 1135 push X 1136 push Y 1137 push Z 1138 ld X E 1139 ld Y (E CDR) # Y on args 1140 ld E (Y) # Eval 'msg' 1141 eval 1142 num E # Need symbol 1143 jnz symErrEX 1144 sym E 1145 jz symErrEX 1146 link 1147 push E # <L II> 'msg' 1148 ld Y (Y CDR) # Next arg 1149 ld E (Y) 1150 eval+ # Eval 'obj' 1151 push E # <L I> 'obj' 1152 link 1153 num E # Need symbol 1154 jnz symErrEX 1155 sym E 1156 jz symErrEX 1157 sym (E TAIL) # External symbol? 1158 if nz # Yes 1159 call dbFetchEX # Fetch it 1160 end 1161 push (Y CDR) # Save args 1162 ld Y (L II) # Get 'msg' 1163 ld Z 0 # No classes 1164 call methodEY_FCYZ # Found? 1165 jne msgErrYX # No 1166 ld A (L I) # Get 'obj' 1167 ld E X # 'exe' 1168 pop X # and args 1169 call evMethodACEXYZ_E 1170 drop 1171 pop Z 1172 pop Y 1173 pop X 1174 ret 1175 1176 # (try 'msg 'obj ['any ..]) -> any 1177 (code 'doTry 2) 1178 push X 1179 push Y 1180 push Z 1181 ld X E 1182 ld Y (E CDR) # Y on args 1183 ld E (Y) # Eval 'msg' 1184 eval 1185 num E # Need symbol 1186 jnz symErrEX 1187 sym E 1188 jz symErrEX 1189 link 1190 push E # <L II> 'msg' 1191 ld Y (Y CDR) # Next arg 1192 ld E (Y) 1193 eval+ # Eval 1194 push E # <L I> 'obj' 1195 link 1196 num E # Symbol? 1197 jnz 90 1198 sym E 1199 jz 90 # No 1200 sym (E TAIL) # External symbol? 1201 if nz # Yes 1202 call isLifeE_F # Alive? 1203 jnz 90 # No 1204 call dbFetchEX # Fetch it 1205 end 1206 push (Y CDR) # Save args 1207 ld Y (L II) # Get 'msg' 1208 ld Z 0 # No classes 1209 call methodEY_FCYZ # Found? 1210 if eq # Yes 1211 ld A (L I) # Get 'obj' 1212 ld E X # 'exe' 1213 ld X (S) # and args 1214 call evMethodACEXYZ_E 1215 else 1216 90 ld E Nil 1217 end 1218 drop 1219 pop Z 1220 pop Y 1221 pop X 1222 ret 1223 1224 # (super ['any ..]) -> any 1225 (code 'doSuper 2) 1226 push X 1227 push Y 1228 push Z 1229 push E # Save expression 1230 ld X (EnvCls) # 'cls' 1231 ld Y (EnvKey) # 'key' 1232 null X # Any? 1233 ldnz X (X) # Yes: First class 1234 ldz X (This) # No: 'This' 1235 ld X (X) # Get class definition 1236 do 1237 atom (X) # Method? 1238 while z # Yes 1239 ld X (X CDR) # Skip 1240 loop 1241 do 1242 atom X # Classes? 1243 while z # Yes 1244 ld E (X) # First class 1245 ld Z X # 'cls' 1246 call methodEY_FCYZ # Found? 1247 if eq # Yes 1248 pop E # Get expression 1249 push (EnvCls) # 'cls' 1250 push (EnvKey) # 'key' 1251 ld (EnvCls) Z # Set new 1252 ld (EnvKey) Y 1253 call evExprCE_E # Evaluate expression 1254 pop (EnvKey) 1255 pop (EnvCls) 1256 pop Z 1257 pop Y 1258 pop X 1259 ret 1260 end 1261 ld X (X CDR) 1262 loop 1263 ld E Y # 'key' 1264 pop X # Expression 1265 ld Y SuperErr 1266 jmp errEXYZ 1267 1268 # (extra ['any ..]) -> any 1269 (code 'doExtra 2) 1270 push X 1271 push Y 1272 push Z 1273 push E # Save expression 1274 ld Y (EnvKey) # Get 'key' 1275 ld X (This) # Current object 1276 call extraXY_FCYZ # Locate extra method 1277 if eq 1278 pop E # Get expression 1279 push (EnvCls) # 'cls' 1280 push (EnvKey) # 'key' 1281 ld (EnvCls) Z # Set new 1282 ld (EnvKey) Y 1283 call evExprCE_E # Evaluate expression 1284 pop (EnvKey) 1285 pop (EnvCls) 1286 pop Z 1287 pop Y 1288 pop X 1289 ret 1290 end 1291 ld E Y # 'key' 1292 pop X # Expression 1293 ld Y ExtraErr 1294 jmp errEXYZ 1295 1296 (code 'extraXY_FCYZ 0) 1297 ld X (X) # Get class definition 1298 do 1299 atom (X) # Method? 1300 while z # Yes 1301 ld X (X CDR) # Skip 1302 loop 1303 do 1304 atom X # Classes? 1305 while z # Yes 1306 cmp X (EnvCls) # Hit current 'cls' list? 1307 if eq # Yes 1308 10 do 1309 ld X (X CDR) # Locate method in extra classes 1310 atom X # Any? 1311 while z # No: Return 'gt' 1312 ld E (X) # Superclass 1313 ld Z X # 'cls' 1314 call methodEY_FCYZ # Found? 1315 until eq # Return 'eq' 1316 ret 1317 end 1318 push X 1319 ld X (X) # Recurse on superclass 1320 cmp S (StkLimit) # Stack check 1321 jlt stkErr 1322 call extraXY_FCYZ # Found? 1323 pop X 1324 jeq ret # Yes 1325 jgt 10 # Else try extra classes 1326 ld X (X CDR) # Try next in 'cls' list 1327 loop 1328 setc # Return 'lt' 1329 ret 1330 1331 # (with 'sym . prg) -> any 1332 (code 'doWith 2) 1333 push X 1334 ld X (E CDR) # Args 1335 ld E (X) # Eval first 1336 eval 1337 cmp E Nil # Non-NIL? 1338 if ne # Yes 1339 num E # Need symbol 1340 jnz symErrEX 1341 sym E 1342 jz symErrEX 1343 push (EnvBind) # Build bind frame 1344 link 1345 push (This) # Save old 'This' 1346 push This # and 'sym' 1347 link 1348 ld (EnvBind) L # Close bind frame 1349 push 0 # Init env swap 1350 ld (This) E # Set new 1351 ld X (X CDR) # Run 'prg' 1352 prog X 1353 add S III # Drop 'eswp' + link + 'This' 1354 pop (This) # Restore value 1355 pop L # Restore link 1356 pop (EnvBind) # Restore bind link 1357 end 1358 pop X 1359 ret 1360 1361 # (bind 'sym|lst . prg) -> any 1362 (code 'doBind 2) 1363 push X 1364 ld X (E CDR) # Args 1365 ld E (X) # Eval first 1366 eval 1367 num E # Need sym|lst 1368 jnz argErrEX 1369 ld X (X CDR) # X on 'prg' 1370 cmp E Nil # No bindings? 1371 if eq # Yes 1372 prog X # Run 'prg' 1373 pop X 1374 ret 1375 end 1376 push (EnvBind) # Build bind frame 1377 link 1378 sym E # Single symbol? 1379 if nz # Yes 1380 push (E) # Save value 1381 push E # and 'sym' 1382 link 1383 ld (EnvBind) L # Close bind frame 1384 push 0 # Init env swap 1385 prog X # Run 'prg' 1386 add S I # Drop env swap 1387 pop L # Get link 1388 pop X # Unbind symbol 1389 pop (X) # Restore value 1390 pop L # Restore link 1391 pop (EnvBind) # Restore bind link 1392 pop X 1393 ret 1394 end 1395 do 1396 ld A (E) # Next item 1397 num A # Need symbol or pair 1398 jnz argErrAX 1399 ld C (A) # Get VAL or CAR 1400 sym A # Symbol? 1401 if nz # Yes 1402 push C # Save value 1403 push A # and 'sym' 1404 else 1405 push (C) # Save value 1406 push C # and 'sym' 1407 ld (C) (A CDR) # Set new value 1408 end 1409 ld E (E CDR) # More items? 1410 atom E 1411 until nz # No 1412 link 1413 ld (EnvBind) L # Close bind frame 1414 push 0 # Init env swap 1415 prog X # Run 'prg' 1416 add S I # Drop env swap 1417 pop L # Get link 1418 do # Unbind symbols 1419 pop X # Next symbol 1420 pop (X) # Restore value 1421 cmp S L # More? 1422 until eq # No 1423 pop L # Restore link 1424 pop (EnvBind) # Restore bind link 1425 pop X 1426 ret 1427 1428 # (job 'lst . prg) -> any 1429 (code 'doJob 2) 1430 push X 1431 ld X (E CDR) # Args 1432 ld E (X) # Eval first 1433 eval 1434 cmp E Nil # Empty env 'lst'? 1435 if ne # No 1436 push (EnvBind) # Build bind frame 1437 link 1438 ld A E # Get 'lst' 1439 do 1440 ld C (A) # Next cell 1441 push ((C)) # Save value 1442 push (C) # and sym 1443 ld ((C)) (C CDR) # Set new value 1444 ld A (A CDR) 1445 atom A # More cells? 1446 until nz # No 1447 link 1448 ld (EnvBind) L # Close bind frame 1449 push 0 # Init env swap 1450 end 1451 link 1452 push E # <L I> 'lst' 1453 link 1454 ld X (X CDR) # X on 'prg' 1455 prog X # Run 'prg' 1456 add S I # Drop link 1457 pop C # Retrieve 'lst' 1458 pop L # Unlink 1459 cmp C Nil # Empty env 'lst'? 1460 if ne # No 1461 add S I # Drop env swap 1462 lea X ((L) -II) # X on bindings 1463 do # Unbind symbols 1464 ld A (X) # Next symbol 1465 ld ((C) CDR) (A) # Store value in env 1466 ld (A) (X I) # Restore value 1467 ld C (C CDR) 1468 sub X II # Reverse stacked order 1469 cmp X L # More? 1470 until lt # No 1471 drop # Restore link 1472 pop (EnvBind) # Restore bind link 1473 end 1474 pop X 1475 ret 1476 1477 # (let sym 'any . prg) -> any 1478 # (let (sym 'any ..) . prg) -> any 1479 (code 'doLet 2) 1480 push X 1481 push Y 1482 ld X (E CDR) # Args 1483 ld Y (X) # First arg 1484 ld X (X CDR) 1485 push (EnvBind) # Build bind frame 1486 link 1487 sym Y # Single symbol? 1488 if nz # Yes 1489 push (Y) # Save old value 1490 push Y # and 'sym' 1491 link 1492 ld (EnvBind) L # Close bind frame 1493 push 0 # Init env swap 1494 ld E (X) # Eval 'any' 1495 eval 1496 ld (Y) E # Set new value 1497 ld X (X CDR) # Run 'prg' 1498 prog X 1499 add S I # Drop env swap 1500 pop L # Get link 1501 pop X # Unbind symbol 1502 pop (X) # Restore value 1503 pop L # Restore link 1504 pop (EnvBind) # Restore bind link 1505 pop Y 1506 pop X 1507 ret 1508 end 1509 do 1510 ld A (Y) # Next sym 1511 push (A) # Save old value 1512 push A # and sym 1513 link 1514 ld (EnvBind) L # Close bind frame 1515 push 0 # Init env swap 1516 ld E ((Y CDR)) # Eval 'any' 1517 eval 1518 ld ((Y)) E # Set new value 1519 ld Y ((Y CDR) CDR) # More symbols? 1520 atom Y 1521 while z # Yes 1522 pop A # Drop env swap 1523 pop L # and link 1524 loop 1525 prog X # Run 'prg' 1526 add S I # Drop env swap 1527 pop L # Get link 1528 do # Unbind symbols 1529 pop X # Next symbol 1530 pop (X) # Restore value 1531 cmp S L # More? 1532 until eq # No 1533 pop L # Restore link 1534 pop (EnvBind) # Restore bind link 1535 pop Y 1536 pop X 1537 ret 1538 1539 # (let? sym 'any . prg) -> any 1540 (code 'doLetQ 2) 1541 push X 1542 push Y 1543 ld X (E CDR) # Args 1544 ld Y (X) # Get 'sym' 1545 ld X (X CDR) 1546 ld E (X) # Eval 'any' 1547 eval 1548 cmp E Nil # NIL? 1549 if ne # No 1550 push (EnvBind) # Build bind frame 1551 link 1552 push (Y) # Save old value 1553 push Y # and 'sym' 1554 link 1555 ld (EnvBind) L # Close bind frame 1556 push 0 # Init env swap 1557 ld (Y) E # Set new value 1558 ld X (X CDR) # Run 'prg' 1559 prog X 1560 add S I # Drop env swap 1561 pop L # Get link 1562 pop X # Unbind symbol 1563 pop (X) # Restore value 1564 pop L # Restore link 1565 pop (EnvBind) # Restore bind link 1566 end 1567 pop Y 1568 pop X 1569 ret 1570 1571 # (use sym . prg) -> any 1572 # (use (sym ..) . prg) -> any 1573 (code 'doUse 2) 1574 push X 1575 push Y 1576 ld X (E CDR) # Args 1577 ld Y (X) # First arg 1578 ld X (X CDR) 1579 push (EnvBind) # Build bind frame 1580 link 1581 sym Y # Single symbol? 1582 if nz # Yes 1583 push (Y) # Save old value 1584 push Y # and 'sym' 1585 link 1586 ld (EnvBind) L # Close bind frame 1587 push 0 # Init env swap 1588 prog X # Run 'prg' 1589 add S I # Drop env swap 1590 pop L # Get link 1591 pop X # Unbind symbol 1592 pop (X) # Restore value 1593 pop L # Restore link 1594 pop (EnvBind) # Restore bind link 1595 pop Y 1596 pop X 1597 ret 1598 end 1599 do 1600 ld A (Y) # Next sym 1601 push (A) # Save old value 1602 push A # and sym 1603 ld Y (Y CDR) # More symbols? 1604 atom Y 1605 until nz # No 1606 link 1607 ld (EnvBind) L # Close bind frame 1608 push 0 # Init env swap 1609 prog X # Run 'prg' 1610 add S I # Drop env swap 1611 pop L # Get link 1612 do # Unbind symbols 1613 pop X # Next symbol 1614 pop (X) # Restore value 1615 cmp S L # More? 1616 until eq # No 1617 pop L # Restore link 1618 pop (EnvBind) # Restore bind link 1619 pop Y 1620 pop X 1621 ret 1622 1623 # (and 'any ..) -> any 1624 (code 'doAnd 2) 1625 push X 1626 ld X (E CDR) # Args 1627 do 1628 ld E (X) # Eval next 1629 eval 1630 cmp E Nil # NIL? 1631 while ne # No 1632 ld (At) E 1633 ld X (X CDR) # X on rest 1634 atom X # Done? 1635 until nz # Yes 1636 pop X 1637 ret 1638 1639 # (or 'any ..) -> any 1640 (code 'doOr 2) 1641 push X 1642 ld X (E CDR) # Args 1643 do 1644 ld E (X) # Eval next 1645 eval 1646 cmp E Nil # NIL? 1647 if ne # No 1648 ld (At) E 1649 pop X 1650 ret 1651 end 1652 ld X (X CDR) # X on rest 1653 atom X # Done? 1654 until nz # Yes 1655 pop X 1656 ret 1657 1658 # (nand 'any ..) -> flg 1659 (code 'doNand 2) 1660 push X 1661 ld X (E CDR) # Args 1662 do 1663 ld E (X) # Eval next 1664 eval 1665 cmp E Nil # NIL? 1666 if eq # Yes 1667 ld E TSym # Return T 1668 pop X 1669 ret 1670 end 1671 ld (At) E 1672 ld X (X CDR) # X on rest 1673 atom X # Done? 1674 until nz # Yes 1675 ld E Nil # Return NIL 1676 pop X 1677 ret 1678 1679 # (nor 'any ..) -> flg 1680 (code 'doNor 2) 1681 push X 1682 ld X (E CDR) # Args 1683 do 1684 ld E (X) # Eval next 1685 eval 1686 cmp E Nil # NIL? 1687 if ne # No 1688 ld (At) E 1689 ld E Nil # Return NIL 1690 pop X 1691 ret 1692 end 1693 ld X (X CDR) # X on rest 1694 atom X # Done? 1695 until nz # Yes 1696 ld E TSym # Return T 1697 pop X 1698 ret 1699 1700 # (xor 'any 'any) -> flg 1701 (code 'doXor 2) 1702 ld E (E CDR) 1703 push (E CDR) # Push rest 1704 ld E (E) # Eval first 1705 eval 1706 cmp E Nil # NIL? 1707 if eq # Yes 1708 pop E # Get rest 1709 ld E (E) # Eval second 1710 eval 1711 cmp E Nil # NIL again? 1712 ldnz E TSym # No 1713 ret 1714 end 1715 pop E # Get rest 1716 ld E (E) # Eval second 1717 eval 1718 cmp E Nil # NIL? 1719 ld E Nil 1720 ldz E TSym # Yes 1721 ret 1722 1723 # (bool 'any) -> flg 1724 (code 'doBool 2) 1725 ld E ((E CDR)) # Get arg 1726 eval # Eval it 1727 cmp E Nil # NIL? 1728 ldnz E TSym # No 1729 ret 1730 1731 # (not 'any) -> flg 1732 (code 'doNot 2) 1733 ld E ((E CDR)) # Get arg 1734 eval # Eval it 1735 cmp E Nil # NIL? 1736 jeq retT # Yes 1737 ld (At) E 1738 ld E Nil 1739 ret 1740 1741 # (nil . prg) -> NIL 1742 (code 'doNil 2) 1743 push X 1744 ld X (E CDR) # Get 'prg' 1745 exec X # Execute it 1746 ld E Nil # Return NIL 1747 pop X 1748 ret 1749 1750 # (t . prg) -> T 1751 (code 'doT 2) 1752 push X 1753 ld X (E CDR) # Get 'prg' 1754 exec X # Execute it 1755 ld E TSym # Return T 1756 pop X 1757 ret 1758 1759 # (prog . prg) -> any 1760 (code 'doProg 2) 1761 push X 1762 ld X (E CDR) # Get 'prg' 1763 prog X # Run it 1764 pop X 1765 ret 1766 1767 # (prog1 'any1 . prg) -> any1 1768 (code 'doProg1 2) 1769 push X 1770 ld X (E CDR) # Args 1771 ld E (X) # Eval first 1772 eval 1773 ld (At) E 1774 link 1775 push E # <L I> Result 1776 link 1777 ld X (X CDR) # Get 'prg' 1778 exec X # Execute it 1779 ld E (L I) # Get result 1780 drop 1781 pop X 1782 ret 1783 1784 # (prog2 'any1 'any2 . prg) -> any2 1785 (code 'doProg2 2) 1786 push X 1787 ld X (E CDR) # Args 1788 ld E (X) # Eval first 1789 eval 1790 ld X (X CDR) # Eval second 1791 ld E (X) 1792 eval 1793 ld (At) E 1794 link 1795 push E # <L I> Result 1796 link 1797 ld X (X CDR) # Get 'prg' 1798 exec X # Execute it 1799 ld E (L I) # Get result 1800 drop 1801 pop X 1802 ret 1803 1804 # (if 'any1 'any2 . prg) -> any 1805 (code 'doIf 2) 1806 ld E (E CDR) 1807 push (E CDR) # Push rest 1808 ld E (E) # Eval condition 1809 eval 1810 cmp E Nil 1811 if ne # Non-NIL 1812 ld (At) E 1813 pop E # Get rest 1814 ld E (E) # Consequent 1815 eval/ret 1816 end 1817 xchg X (S) # Get rest in X 1818 ld X (X CDR) # Else 1819 prog X 1820 pop X 1821 ret 1822 1823 # (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any 1824 (code 'doIf2 2) 1825 ld E (E CDR) 1826 push (E CDR) # Push rest 1827 ld E (E) # Eval first condition 'any1' 1828 eval 1829 cmp E Nil 1830 if eq # NIL 1831 xchg X (S) # Get rest in X 1832 ld E (X) # Eval second condition 'any2' 1833 eval 1834 cmp E Nil 1835 if eq # Also NIL 1836 ld X ((((X CDR) CDR) CDR) CDR) # Run 'prg' 1837 prog X 1838 pop X 1839 ret 1840 end 1841 ld (At) E 1842 ld X (((X CDR) CDR) CDR) # Eval 'any5' 1843 ld E (X) 1844 pop X 1845 eval/ret 1846 end 1847 ld (At) E # 'any1' is non-Nil 1848 xchg X (S) # Get rest in X 1849 ld E (X) # Eval second condition 'any2' 1850 eval 1851 cmp E Nil 1852 if eq # NIL 1853 ld X ((X CDR) CDR) # Eval 'any4' 1854 ld E (X) 1855 pop X 1856 eval/ret 1857 end 1858 ld (At) E # Both are non-Nil 1859 ld X (X CDR) # Eval 'any3' 1860 ld E (X) 1861 pop X 1862 eval/ret 1863 1864 # (ifn 'any1 'any2 . prg) -> any 1865 (code 'doIfn 2) 1866 ld E (E CDR) 1867 push (E CDR) # Push body 1868 ld E (E) # Eval condition 1869 eval 1870 cmp E Nil 1871 if eq # NIL 1872 pop E # Get rest 1873 ld E (E) # Consequent 1874 eval/ret 1875 end 1876 ld (At) E 1877 xchg X (S) # Get rest in X 1878 ld X (X CDR) # Else 1879 prog X 1880 pop X 1881 ret 1882 1883 # (when 'any . prg) -> any 1884 (code 'doWhen 2) 1885 ld E (E CDR) 1886 push (E CDR) # Push body 1887 ld E (E) # Get condition 1888 eval # Eval condition 1889 cmp E Nil 1890 if eq # NIL 1891 add S I # Drop rest 1892 ret 1893 end 1894 ld (At) E 1895 xchg X (S) # Run body 1896 prog X 1897 pop X 1898 ret 1899 1900 # (unless 'any . prg) -> any 1901 (code 'doUnless 2) 1902 ld E (E CDR) 1903 push (E CDR) # Push body 1904 ld E (E) # Get condition 1905 eval # Eval condition 1906 cmp E Nil 1907 if ne # NIL 1908 ld (At) E 1909 add S I # Drop rest 1910 ld E Nil # Return NIL 1911 ret 1912 end 1913 xchg X (S) # Run body 1914 prog X 1915 pop X 1916 ret 1917 1918 # (cond ('any1 . prg1) ('any2 . prg2) ..) -> any 1919 (code 'doCond 2) 1920 push X 1921 ld X E # Clauses in X 1922 do 1923 ld X (X CDR) # Next clause 1924 atom X # Any? 1925 while z # Yes 1926 ld E ((X)) # Eval CAR 1927 eval 1928 cmp E Nil 1929 if ne # Non-NIL 1930 ld (At) E 1931 ld X ((X) CDR) # Run body 1932 prog X 1933 pop X 1934 ret 1935 end 1936 loop 1937 ld E Nil # Return NIL 1938 pop X 1939 ret 1940 1941 # (nond ('any1 . prg1) ('any2 . prg2) ..) -> any 1942 (code 'doNond 2) 1943 push X 1944 ld X E # Clauses in X 1945 do 1946 ld X (X CDR) # Next clause 1947 atom X # Any? 1948 while z # Yes 1949 ld E ((X)) # Eval CAR 1950 eval 1951 cmp E Nil 1952 if eq # NIL 1953 ld X ((X) CDR) # Run body 1954 prog X 1955 pop X 1956 ret 1957 end 1958 ld (At) E 1959 loop 1960 ld E Nil # Return NIL 1961 pop X 1962 ret 1963 1964 # (case 'any (any1 . prg1) (any2 . prg2) ..) -> any 1965 (code 'doCase 2) 1966 push X 1967 ld X (E CDR) # Arguments in X 1968 ld E (X) # Eval argument item 1969 eval 1970 ld (At) E 1971 do 1972 ld X (X CDR) # Next clause 1973 atom X # Any? 1974 while z # Yes 1975 ld C ((X)) # Item(s) in C 1976 cmp C TSym # Catch-all? 1977 jeq 10 # Yes 1978 ld A (At) # Equal to argument item? 1979 ld E C 1980 call equalAE_F 1981 if eq # Yes 1982 10 ld X ((X) CDR) # Run body 1983 prog X 1984 pop X 1985 ret 1986 end 1987 atom C # List of items? 1988 if z # Yes 1989 do 1990 ld A (At) # Argument item member? 1991 ld E (C) 1992 call equalAE_F 1993 if eq # Yes 1994 ld X ((X) CDR) # Run body 1995 prog X 1996 pop X 1997 ret 1998 end 1999 ld C (C CDR) # End of list? 2000 atom C 2001 until nz # Yes 2002 end 2003 loop 2004 ld E Nil # Return NIL 2005 pop X 2006 ret 2007 2008 # (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any 2009 (code 'doCasq 2) 2010 push X 2011 ld X (E CDR) # Arguments in X 2012 ld E (X) # Eval argument item 2013 eval 2014 ld (At) E 2015 do 2016 ld X (X CDR) # Next clause 2017 atom X # Any? 2018 while z # Yes 2019 ld C ((X)) # Item(s) in C 2020 cmp C TSym # Catch-all? 2021 jeq 10 # Yes 2022 cmp C E # Equal to argument item? 2023 if eq # Yes 2024 10 ld X ((X) CDR) # Run body 2025 prog X 2026 pop X 2027 ret 2028 end 2029 atom C # List of items? 2030 if z # Yes 2031 do 2032 cmp (C) E # Argument item member? 2033 if eq # Yes 2034 ld X ((X) CDR) # Run body 2035 prog X 2036 pop X 2037 ret 2038 end 2039 ld C (C CDR) # End of list? 2040 atom C 2041 until nz # Yes 2042 end 2043 loop 2044 ld E Nil # Return NIL 2045 pop X 2046 ret 2047 2048 # (state 'var (sym|lst exe [. prg]) ..) -> any 2049 (code 'doState 2) 2050 push X 2051 push Y 2052 ld X E 2053 ld Y (E CDR) # Y on args 2054 ld E (Y) # Eval 'var' 2055 eval 2056 link 2057 push E # <L I> 'var' 2058 link 2059 call needVarEX # Need variable 2060 do 2061 ld Y (Y CDR) # Next clause 2062 atom Y # Any? 2063 while z # Yes 2064 ld X (Y) # Get clause in X 2065 ld E (X) # Get sym|lst in E 2066 cmp E TSym # T? 2067 jeq 10 # Yes 2068 ld A ((L I)) # 'var's value 2069 cmp A E # Same? 2070 jeq 10 # Yes 2071 do # 'memq' 2072 atom E # List? 2073 while z # Yes 2074 cmp A (E) # Member? 2075 while ne # No 2076 ld E (E CDR) 2077 loop 2078 if eq # Yes 2079 10 ld X (X CDR) # Eval 'exe' 2080 ld E (X) 2081 eval 2082 cmp E Nil 2083 if ne # Non-NIL 2084 ld ((L I)) E # Set target state 2085 ld (At) E 2086 drop 2087 ld X (X CDR) # Get body in X 2088 pop Y 2089 prog X # Run body 2090 pop X 2091 ret 2092 end 2093 end 2094 loop 2095 drop 2096 pop Y 2097 pop X 2098 ret 2099 2100 # (while 'any . prg) -> any 2101 (code 'doWhile 2) 2102 push X 2103 push Y 2104 ld X (E CDR) # X arguments 2105 link 2106 push Nil # <L I> Result 2107 link 2108 do 2109 ld E (X) # Eval condition 2110 eval 2111 cmp E Nil 2112 while ne # Non-NIL 2113 ld (At) E 2114 ld Y (X CDR) # Run body 2115 prog Y 2116 ld (L I) E # Save result 2117 loop 2118 ld E (L I) # Get result 2119 drop 2120 pop Y 2121 pop X 2122 ret 2123 2124 # (until 'any . prg) -> any 2125 (code 'doUntil 2) 2126 push X 2127 push Y 2128 ld X (E CDR) # X arguments 2129 link 2130 push Nil # <L I> Result 2131 link 2132 do 2133 ld E (X) # Eval condition 2134 eval 2135 cmp E Nil 2136 while eq # NIL 2137 ld Y (X CDR) # Run body 2138 prog Y 2139 ld (L I) E # Save result 2140 loop 2141 ld (At) E 2142 ld E (L I) # Get result 2143 drop 2144 pop Y 2145 pop X 2146 ret 2147 2148 # (at '(cnt1 . cnt2|NIL) . prg) -> any 2149 (code 'doAt 2) 2150 push X 2151 push Y 2152 ld X E 2153 ld Y (E CDR) # Y on args 2154 ld E (Y) # Eval first 2155 eval 2156 atom E # Need pair 2157 jnz pairErrEX 2158 cmp (E CDR) Nil # CDR? 2159 jeq 10 # No 2160 ld A (E) # Get 'cnt1' 2161 cnt A # Need short 2162 jz cntErrAX 2163 ld C (E CDR) # Get 'cnt2' 2164 cnt C # Need short 2165 jz cntErrCX 2166 add A (hex "10") # Increment 2167 cmp A C # Reached count? 2168 if lt # No 2169 ld (E) A 2170 10 ld E Nil 2171 else 2172 ld (E) ZERO 2173 ld Y (Y CDR) # Run body 2174 prog Y 2175 end 2176 pop Y 2177 pop X 2178 ret 2179 2180 # (do 'flg|cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 2181 (code 'doDo 2) 2182 push X 2183 push Y 2184 push Z 2185 ld X (E CDR) # Args 2186 ld E (X) # Eval 'flg|cnt' 2187 ld X (X CDR) # Body 2188 eval 2189 cmp E Nil # Ever? 2190 if ne # Yes 2191 cnt E # Short number? 2192 jz loopX # No: Non-NIL 'flg' 2193 shr E 4 # Normalize 2194 if gt # Greater zero 2195 push E # <S> Count 2196 do 2197 ld Y X # Loop body 2198 call loopY_FE 2199 while nz 2200 dec (S) # Decrement count 2201 until z 2202 add S I # Drop count 2203 else 2204 ld E Nil # Return NIL if zero 2205 end 2206 end 2207 pop Z 2208 pop Y 2209 pop X 2210 ret 2211 2212 # (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 2213 (code 'doLoop 2) 2214 push X 2215 push Y 2216 push Z 2217 ld X (E CDR) # Body 2218 : loopX 2219 do 2220 ld Y X # Body in Y 2221 do 2222 ld E (Y) # Next expression 2223 atom E # Pair? 2224 if z # Yes 2225 ld A (E) # Get CAR 2226 cmp A Nil # NIL? 2227 if eq # Yes 2228 ld Z (E CDR) # Sub-body in Z 2229 ld E (Z) 2230 eval # Evaluate condition 2231 cmp E Nil # NIL? 2232 if eq # Yes 2233 ld Y (Z CDR) # Run sub-body 2234 prog Y 2235 pop Z 2236 pop Y 2237 pop X 2238 ret 2239 end 2240 ld (At) E 2241 else 2242 cmp A TSym # T? 2243 if eq # Yes 2244 ld Z (E CDR) # Sub-body in Z 2245 ld E (Z) 2246 eval # Evaluate condition 2247 cmp E Nil # NIL? 2248 if ne # No 2249 ld (At) E 2250 ld Y (Z CDR) # Run sub-body 2251 prog Y 2252 pop Z 2253 pop Y 2254 pop X 2255 ret 2256 end 2257 else 2258 call evListE_E # Else evaluate expression 2259 end 2260 end 2261 end 2262 ld Y (Y CDR) 2263 atom Y # Finished one pass? 2264 until nz # Yes 2265 loop 2266 2267 # (for sym 'cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 2268 # (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 2269 # (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any 2270 (code 'doFor 2) 2271 push X 2272 push Y 2273 push Z 2274 ld X (E CDR) # X on args 2275 ld Y (X) # Y on first arg 2276 ld X (X CDR) 2277 push (EnvBind) # Build bind frame 2278 link 2279 atom Y # 'sym'? 2280 if nz # Yes 2281 # (for sym 'cnt|lst ..) 2282 push (Y) # Save old value 2283 push Y # <L V> and 'sym' 2284 link 2285 ld (EnvBind) L # Close bind frame 2286 push 0 # Init env swap 2287 ld E (X) # Eval 'cnt|lst' 2288 eval 2289 link 2290 push E # <L I> 'cnt|lst' 2291 link 2292 ld X (X CDR) # X on body 2293 ld A E 2294 ld E Nil # Preload NIL 2295 num A # Number? 2296 if nz # Yes 2297 test A SIGN # Negative? 2298 if z # No 2299 ld (Y) ZERO # Init 'sym' to zero 2300 do 2301 ld A ((L V)) # Get value of 'sym' 2302 add A (hex "10") # Increment 2303 cmp A (L I) # Greater than 'num'? 2304 while le # No 2305 ld ((L V)) A # Set incremented value of 'sym' 2306 ld Y X # Loop body 2307 call loopY_FE 2308 until z 2309 end 2310 else 2311 do 2312 ld A (L I) # Get 'lst' 2313 atom A # Any? 2314 while z # Yes 2315 ld (L I) (A CDR) 2316 ld ((L V)) (A) # Set value 2317 ld Y X # Loop body 2318 call loopY_FE 2319 until z 2320 end 2321 drop 2322 add S I # Drop env swap 2323 pop L # Get link 2324 else 2325 ld Z (Y CDR) # CDR of first arg 2326 atom Z # 'sym'? 2327 if nz # Yes 2328 # (for (sym2 . sym) 'lst ..) 2329 push (Z) # Value of 'sym' 2330 push Z # <L VII> 'sym' 2331 ld Z (Y) 2332 push (Z) # Value of 'sym2' 2333 push Z # <L V> 'sym2' 2334 link 2335 ld (EnvBind) L # Close bind frame 2336 push 0 # Init env swap 2337 ld E (X) # Eval 'lst' 2338 eval 2339 link 2340 push E # <L I> 'lst' 2341 link 2342 ld (Z) ZERO # Init 'sym2' to zero 2343 ld X (X CDR) # X on body 2344 do 2345 ld A (L I) # Get 'lst' 2346 atom A # Any? 2347 while z # Yes 2348 ld (L I) (A CDR) 2349 ld ((L VII)) (A) # Set value of 'sym' 2350 add ((L V)) (hex "10") # Increment 'sym2' 2351 ld Y X # Loop body 2352 call loopY_FE 2353 until z 2354 drop 2355 add S I # Drop env swap 2356 pop L # Get link 2357 pop X # Unbind 'sym2' 2358 pop (X) # Restore value 2359 else 2360 ld Z (Y) # CAR of first arg 2361 ld Y (Y CDR) 2362 atom Z # 'sym'? 2363 if nz # Yes 2364 # (for (sym ..) ..) 2365 push (Z) # Save old value 2366 push Z # <L V> and 'sym' 2367 link 2368 ld (EnvBind) L # Close bind frame 2369 push 0 # Init env swap 2370 ld E (Y) # Eval 'any1' init-expression 2371 eval 2372 ld (Z) E # Set new value 2373 link 2374 push Nil # <L I> Result 2375 link 2376 push (Y CDR) # <S> (any2 . prg) 2377 do 2378 ld E ((S)) # Evaluate condition 2379 eval 2380 cmp E Nil # NIL? 2381 if eq # Yes 2382 ld E (L I) # Get result 2383 break T 2384 end 2385 ld (At) E 2386 ld Y X # Loop body 2387 call loopY_FE 2388 while nz 2389 ld (L I) E # Keep result 2390 ld Y ((S) CDR) # 'prg' re-init? 2391 atom Y 2392 if z # Yes 2393 prog Y 2394 ld ((L V)) E # Set new value 2395 end 2396 loop 2397 drop 2398 add S I # Drop env swap 2399 pop L # Get link 2400 else 2401 # (for ((sym2 . sym) ..) ..) 2402 ld C (Z CDR) # 'sym' 2403 push (C) # Save old value 2404 push C # <L VII> and 'sym' 2405 ld C (Z) # 'sym2' 2406 push (C) # Value of 'sym2' 2407 push C # <L V> and 'sym2' 2408 link 2409 ld (EnvBind) L # Close bind frame 2410 push 0 # Init env swap 2411 ld E (Y) # Eval 'any1' init-expression 2412 eval 2413 ld ((Z CDR)) E # Set new value of 'sym' 2414 ld ((Z)) ZERO # Init 'sym2' to zero 2415 link 2416 push Nil # <L I> Result 2417 link 2418 push (Y CDR) # <S> (any2 . prg) 2419 do 2420 add ((L V)) (hex "10") # Increment 'sym2' 2421 ld E ((S)) # Evaluate condition 2422 eval 2423 cmp E Nil # NIL? 2424 if eq # Yes 2425 ld E (L I) # Get result 2426 break T 2427 end 2428 ld (At) E 2429 ld Y X # Loop body 2430 call loopY_FE 2431 while nz 2432 ld (L I) E # Keep result 2433 ld Y ((S) CDR) # 'prg' re-init? 2434 atom Y 2435 if z # Yes 2436 prog Y 2437 ld ((L VII)) E # Set new value 2438 end 2439 loop 2440 drop 2441 add S I # Drop env swap 2442 pop L # Get link 2443 pop X # Unbind 'sym2' 2444 pop (X) # Restore value 2445 end 2446 end 2447 end 2448 pop X # Unbind 'sym' 2449 pop (X) # Restore value 2450 pop L # Restore link 2451 pop (EnvBind) # Restore bind link 2452 pop Z 2453 pop Y 2454 pop X 2455 ret 2456 2457 (code 'loopY_FE 0) # Z 2458 do 2459 ld E (Y) # Next expression 2460 num E # Number? 2461 if z # No 2462 sym E # Symbol? 2463 if nz # Yes 2464 ld E (E) # Get value 2465 else 2466 ld A (E) # Else get CAR 2467 cmp A Nil # NIL? 2468 if eq # Yes 2469 ld Z (E CDR) # Sub-body in Z 2470 ld E (Z) 2471 eval # Evaluate condition 2472 cmp E Nil # NIL? 2473 if eq # Yes 2474 ld Y (Z CDR) # Run sub-body 2475 prog Y 2476 setz # Return 'z' 2477 ret 2478 end 2479 ld (At) E 2480 ld E Nil 2481 else 2482 cmp A TSym # T? 2483 if eq # Yes 2484 ld Z (E CDR) # Sub-body in Z 2485 ld E (Z) 2486 eval # Evaluate condition 2487 cmp E Nil # NIL? 2488 if ne # No 2489 ld (At) E 2490 ld Y (Z CDR) # Run sub-body 2491 prog Y 2492 setz # Return 'z' 2493 ret 2494 end 2495 else 2496 call evListE_E # Else evaluate expression 2497 end 2498 end 2499 end 2500 end 2501 ld Y (Y CDR) 2502 atom Y # Done? 2503 until nz # Yes 2504 ret # Return 'nz' 2505 2506 # (catch 'any . prg) -> any 2507 (code 'doCatch 2) 2508 push X 2509 push Y 2510 push Z 2511 push L 2512 ld X (E CDR) 2513 ld E (X) # Eval tag 2514 eval 2515 sub S "EnvEnd-Env" # Build catch frame 2516 save (Env) (EnvEnd) (S) # Save environment 2517 push ZERO # 'fin' 2518 push E # 'tag' 2519 push (Catch) # Link 2520 ld (Catch) S # Close catch frame 2521 ld X (X CDR) # Run body 2522 prog X 2523 : caught 2524 pop (Catch) # Restore catch link 2525 add S (pack II "+(EnvEnd-Env)") # Clean up 2526 pop L 2527 pop Z 2528 pop Y 2529 pop X 2530 ret 2531 2532 # (throw 'sym 'any) 2533 (code 'doThrow 2) 2534 ld X E 2535 ld Y (X CDR) 2536 ld E (Y) # Get sym 2537 ld Y (Y CDR) 2538 eval # Evaluate tag 2539 ld Z E # into Z 2540 ld E (Y) # Get value 2541 eval # Keep thrown value in E 2542 ld C (Catch) # Search catch frames 2543 do 2544 null C # Any? 2545 jz throwErrZX # No 2546 cmp (C I) TSym # Catch-all? 2547 while ne # No 2548 cmp Z (C I) # Found tag? 2549 while ne # No 2550 ld C (C) # Next frame 2551 loop 2552 push E # Save thrown value 2553 call unwindC_Z # Unwind environments 2554 pop E 2555 ld S Z # Restore stack 2556 jmp caught # Return E 2557 2558 (code 'throwErrZX) 2559 ld E Z 2560 ld Y ThrowErr 2561 jmp errEXYZ 2562 2563 # (finally exe . prg) -> any 2564 (code 'doFinally 2) 2565 push X 2566 sub S "EnvEnd-Env" # Build catch frame 2567 save (Env) (EnvEnd) (S) # Save environment 2568 ld X (E CDR) 2569 push (X) # 'exe' -> 'fin' 2570 ld X (X CDR) 2571 push 0 # 'tag' 2572 push (Catch) # Link 2573 ld (Catch) S # Close catch frame 2574 prog X # Run body 2575 link 2576 push E # <L I> Result 2577 link 2578 ld E (S V) # Get 'fin' 2579 eval # Evaluate it 2580 ld E (L I) # Get result 2581 drop 2582 pop (Catch) # Restore catch link 2583 add S (pack II "+(EnvEnd-Env)") # Clean up 2584 pop X 2585 ret 2586 2587 # (co 'sym [. prg]) -> any 2588 (code 'doCo 2) 2589 push X 2590 ld X (E CDR) # Get tag 2591 ld E (X) # Eval 'sym' 2592 eval 2593 atom (X CDR) # 'prg'? 2594 if z # Yes 2595 push Y 2596 push Z 2597 push L 2598 sub S "EnvMid-EnvCo" # Space for env 2599 ld Y (Stack1) # Search through stack segments 2600 ld C (Stacks) # Segment count 2601 do 2602 null C # Any? 2603 while nz # Yes 2604 null (Y -I) # In use? 2605 if nz # Yes 2606 cmp E (Y -I) # Found tag? 2607 if eq # Yes 2608 null (Y -II) # Already active? 2609 jz reentErrEX # Yes 2610 push Y # Resume coroutine: Save 'seg' 2611 push (StkLimit) # and 'lim' 2612 push (EnvCo7) # Link 2613 ld (EnvCo7) S # Close coroutine frame 2614 ld Z S # Point Z to main frame 2615 save (EnvCo) (EnvMid) (Z III) # Save environment 2616 ld E Nil # Final 'yield's return value 2617 : resumeCoroutine 2618 ld S (Y -II) # Restore stack pointer 2619 ld (Y -II) 0 # Mark as active 2620 lea A (Y 4096) # Set stack limit 2621 sub A (StkSize) 2622 ld (StkLimit) A 2623 load (EnvCo) (EnvMid) (Y (pack -II "-(EnvMid-EnvCo)")) # Restore environment 2624 ld X Catch # Pointer to catch frames 2625 do 2626 null (X) # More locals? 2627 while nz # Yes 2628 ld X (X) # Next frame pointer 2629 loop 2630 ld (X) (Z (pack III "+(Catch-EnvCo)")) # Join 2631 ld X (EnvBind) # Reversed bindings 2632 ld C (Z (pack III "+(EnvBind-EnvCo)")) # Main bindings 2633 do 2634 null X # More reversed bindings? 2635 while nz # Yes 2636 ld Y (X) # Link address in Y 2637 null (X -I) # Env swap zero? 2638 if z # Yes 2639 lea A (Y -II) # End of bindings in A 2640 do 2641 xchg ((A)) (A I) # Exchange symbol value with saved value 2642 sub A II 2643 cmp A X # More? 2644 until lt # No 2645 end 2646 ld A (Y I) # Get down link 2647 ld (Y I) C # Undo reversal 2648 ld C X 2649 ld X A 2650 loop 2651 ld (EnvBind) C # Set local bindings 2652 ld X EnvInFrames # Pointer to input frames 2653 null (X) # Any locals? 2654 if z # No 2655 ld (Chr) (Z (pack III "+(Chr-EnvCo)")) # Adapt In 2656 ld (Get_A) (Z (pack III "+(Get_A-EnvCo)")) 2657 ld (InFile) (Z (pack III "+(InFile-EnvCo)")) 2658 else 2659 do 2660 ld X (X) # Next frame pointer 2661 null (X) # More locals? 2662 until z # No 2663 end 2664 ld (X) (Z (pack III "+(EnvInFrames-EnvCo)")) # Join 2665 ld X EnvOutFrames # Pointer to output frames 2666 null (X) # Any locals? 2667 if z # No 2668 ld (PutB) (Z (pack III "+(PutB-EnvCo)")) # Adapt Out 2669 ld (OutFile) (Z (pack III "+(OutFile-EnvCo)")) 2670 else 2671 do 2672 ld X (X) # Next frame pointer 2673 null (X) # More locals? 2674 until z # No 2675 end 2676 ld (X) (Z (pack III "+(EnvOutFrames-EnvCo)")) # Join 2677 ld X EnvApply # Local apply stack 2678 do 2679 null (X) # Any? 2680 while nz # Yes 2681 ld X ((X)) # Follow link 2682 loop 2683 ld (X) (Z (pack III "+(EnvApply-EnvCo)")) # Join 2684 pop X # Get saved L 2685 null X # Any? 2686 if nz # Yes 2687 ld Y (X) # Pointer to link 2688 do 2689 ld A (Y) # Get link 2690 null A # Found end? 2691 while nz # No 2692 ld Y (A) # Next frame 2693 loop 2694 ld (Y) (Z (pack III "+(EnvMid-EnvCo)")) # Link to main stack 2695 ld L X 2696 end 2697 pop Z 2698 pop Y 2699 pop X 2700 ret 2701 end 2702 dec C # Decrement count 2703 end 2704 sub Y (StkSize) # Next segment 2705 loop 2706 ld Y (Stack1) # Find unused stack segment 2707 ld C (Stacks) # Segment count 2708 null C # Starting first coroutine? 2709 if z # Yes 2710 lea A (Y 4096) # Set stack limit 2711 cmp S A # Check it 2712 jlt stkErr 2713 ld (StkLimit) A 2714 else 2715 do 2716 null (Y -I) # Found free segment? 2717 while nz # No 2718 sub Y (StkSize) # Next segment 2719 dec C # Any? 2720 until z # Yes 2721 end 2722 inc (Stacks) # Increment segment count 2723 push Y # Save 'seg' 2724 push (StkLimit) # and 'lim' 2725 push (EnvCo7) # Link 2726 ld (EnvCo7) S # Close coroutine frame 2727 save (EnvCo) (EnvMid) (S III) # Save environment 2728 ld (EnvMake) 0 # Init local 'make' env 2729 ld (EnvYoke) 0 2730 lea A (Y 4096) # Calculate stack limit 2731 sub A (StkSize) 2732 ld (StkLimit) A 2733 ld S Y # Set stack pointer 2734 push E # Save 'tag' 2735 push 0 # Mark 'stk' as active 2736 sub S "EnvMid-EnvCo" # Space for 'env' 2737 ld X (X CDR) 2738 link 2739 push X # Save 'prg' 2740 link 2741 prog X # Run 'prg' 2742 ld S (EnvCo7) # Not yielded: Restore stack pointer 2743 load (Env) (EnvMid) (S (pack III "+(Env-EnvCo)")) # Restore environment 2744 pop (EnvCo7) # Restore coroutine link 2745 pop (StkLimit) # 'lim' 2746 ld (Y -I) 0 # Mark segment as unused 2747 dec (Stacks) # Last coroutine? 2748 if z # Yes 2749 ld (StkLimit) 0 # Clear stack limit 2750 end 2751 add S (pack I "+(EnvMid-EnvCo)") # Clean up 2752 pop L 2753 pop Z 2754 pop Y 2755 pop X 2756 ret 2757 end 2758 ld X (Stack1) # Search through stack segments 2759 ld C (Stacks) # Segment count 2760 do 2761 null C # Any? 2762 while nz # Yes 2763 null (X -I) # In use? 2764 if nz # Yes 2765 cmp E (X -I) # Found tag? 2766 if eq # Yes 2767 null (X -II) # Active? 2768 ldz E Nil 2769 if nz # No 2770 ld C (X (pack -II "-(EnvMid-EnvInFrames)")) # Open input frames 2771 call closeCoFilesC 2772 ld C (X (pack -II "-(EnvMid-EnvOutFrames)")) # Open output frames 2773 call closeCoFilesC 2774 ld (X -I) 0 # Mark segment as unused 2775 dec (Stacks) # Last coroutine? 2776 if z # Yes 2777 ld (StkLimit) 0 # Clear stack limit 2778 end 2779 ld E TSym # Return T 2780 end 2781 pop X 2782 ret 2783 end 2784 dec C # Decrement count 2785 end 2786 sub X (StkSize) # Next segment 2787 loop 2788 ld E Nil # Return NIL 2789 pop X 2790 ret 2791 2792 # (yield 'any ['sym]) -> any 2793 (code 'doYield 2) 2794 push X 2795 push Y 2796 push Z 2797 ld X E 2798 ld Y (E CDR) 2799 ld E (Y) # Eval 'any' 2800 eval 2801 link 2802 push E # <L I> Result 2803 link 2804 ld Y (Y CDR) # Next arg 2805 ld E (Y) 2806 eval # Eval optional 'sym' 2807 ld Y 0 # Preload "no target" 2808 cmp E Nil # Any? 2809 if ne # Yes 2810 ld Y (Stack1) # Search for target coroutine 2811 ld C (Stacks) # Segment count 2812 do 2813 null C # Any? 2814 jz yieldErrEX # No 2815 null (Y -I) # In use? 2816 if nz # Yes 2817 cmp E (Y -I) # Found tag? 2818 break eq # Yes 2819 dec C # Decrement count 2820 end 2821 sub Y (StkSize) # Next segment 2822 loop 2823 null (Y -II) # Already active? 2824 jz reentErrEX # Yes 2825 end 2826 ld E (L I) # Get result 2827 drop 2828 ld Z (EnvCo7) # Get main 2829 null Z # Any? 2830 if z # No 2831 null Y # Target coroutine? 2832 jz yieldErrX # No 2833 push L # Else resume with argument 2834 sub S "EnvMid-EnvCo" # Space for env 2835 push Y # Save 'seg' 2836 push (StkLimit) # and 'lim' 2837 push Z # Link (NULL) 2838 ld (EnvCo7) S # Close coroutine frame 2839 ld Z S # Point Z to main frame 2840 save (EnvCo) (EnvMid) (Z III) # Save environment 2841 jmp resumeCoroutine # Resume 2842 end 2843 null L # Stack? 2844 if nz # Yes 2845 ld C (Z (pack III "+(EnvMid-EnvCo)")) # Main routine's link 2846 cmp L C # Local stack? 2847 ldz L 0 2848 if ne # Yes 2849 ld X (L) # Pointer to link 2850 do 2851 ld A (X) # Get link 2852 null A # Any? 2853 jz 10 # No 2854 cmp A C # Reached main routine's link? 2855 while ne # No 2856 ld X (A) # Follow link 2857 loop 2858 ld (X) 0 # Clear link 2859 end 2860 end 2861 10 push L # End of segment 2862 push Y # Save taget coroutine 2863 ld X EnvApply # Pointer to apply stack 2864 do 2865 ld A (X) 2866 cmp A (Z (pack III "+(EnvApply-EnvCo)")) # Local apply stack? 2867 while ne # Yes 2868 lea X ((A) I) # Get link 2869 loop 2870 ld (X) 0 # Cut off 2871 ld X EnvOutFrames # Pointer to output frames 2872 do 2873 cmp (X) (Z (pack III "+(EnvOutFrames-EnvCo)")) # More locals? 2874 while ne # Yes 2875 ld X (X) # Next frame pointer 2876 loop 2877 ld (X) 0 # Cut off 2878 ld X EnvInFrames # Pointer to input frames 2879 do 2880 cmp (X) (Z (pack III "+(EnvInFrames-EnvCo)")) # More locals? 2881 while ne # Yes 2882 ld X (X) # Next frame pointer 2883 loop 2884 ld (X) 0 # Cut off 2885 ld C 0 # Back link 2886 ld X (EnvBind) # Reverse bindings 2887 null X # Any? 2888 if nz # Yes 2889 do 2890 cmp X (Z (pack III "+(EnvBind-EnvCo)")) # Reached main routine's bindings? 2891 while ne # No 2892 ld Y X # Keep bind frame in Y 2893 null (X -I) # Env swap zero? 2894 if z # Yes 2895 add X I # X on bindings 2896 do 2897 xchg ((X)) (X I) # Exchange symbol value with saved value 2898 add X II 2899 cmp X (Y) # More? 2900 until eq # No 2901 end 2902 ld A (Y) # A on bind link 2903 ld X (A I) # X on next frame 2904 ld (A I) C # Set back link 2905 ld C Y 2906 loop 2907 end 2908 ld (EnvBind) C # Store back link in coroutine's env 2909 ld X Catch # Pointer to catch frames 2910 do 2911 cmp (X) (Z (pack III "+(Catch-EnvCo)")) # More locals? 2912 while ne # Yes 2913 ld X (X) # Next frame pointer 2914 loop 2915 ld (X) 0 # Cut off 2916 pop Y # Restore taget coroutine 2917 ld X (Z II) # Get 'seg' 2918 ld (X -II) S # Save stack pointer 2919 save (EnvCo) (EnvMid) (X (pack -II "-(EnvMid-EnvCo)")) # Save environment 2920 null Y # Target coroutine? 2921 if z # No 2922 null (EnvInFrames) # Adapt In? 2923 if nz # Yes 2924 ld (Chr) (Z (pack III "+(Chr-EnvCo)")) 2925 ld (Get_A) (Z (pack III "+(Get_A-EnvCo)")) 2926 ld (InFile) (Z (pack III "+(InFile-EnvCo)")) 2927 end 2928 null (EnvOutFrames) # Adapt Out? 2929 if nz # Yes 2930 ld (PutB) (Z (pack III "+(PutB-EnvCo)")) 2931 ld (OutFile) (Z (pack III "+(OutFile-EnvCo)")) 2932 end 2933 ld S Z # Set stack pointer 2934 load (Env) (EnvMid) (Z (pack III "+(Env-EnvCo)")) # Restore environment 2935 pop (EnvCo7) # Restore coroutine link 2936 pop (StkLimit) # 'lim' 2937 add S (pack I "+(EnvMid-EnvCo)") # Clean up 2938 pop L 2939 pop Z 2940 pop Y 2941 pop X 2942 ret 2943 end 2944 ld (Z II) Y # Set new 'seg' 2945 jmp resumeCoroutine # Resume 2946 2947 (code 'closeCoFilesC 0) 2948 do 2949 null C 2950 while nz 2951 null (C II) # 'pid'? 2952 if nz # Yes 2953 cc close((C I)) # Close 'fd' 2954 call waitFileC # Wait for pipe process if necessary 2955 end 2956 ld C (C) 2957 loop 2958 ret 2959 2960 # (! . exe) -> any 2961 (code 'doBreak 2) 2962 ld E (E CDR) # exe 2963 cmp (Dbg) Nil # Debug? 2964 if ne # Yes 2965 call brkLoadE_E # Enter debug breakpoint 2966 end 2967 eval/ret 2968 2969 (code 'brkLoadE_E) 2970 null (Break) # Already in breakpoint? 2971 if z # No 2972 cc isatty(0) # STDIN 2973 nul4 # on a tty? 2974 if nz # Yes 2975 cc isatty(1) # STDOUT 2976 nul4 # on a tty? 2977 if nz # Yes 2978 push X 2979 push Y 2980 push (EnvBind) # Build bind frame 2981 link 2982 push (Up) # <L VI> Bind '^' 2983 push Up 2984 ld (Up) E # to expression 2985 push (Run) # <L IV> Bind '*Run' to NIL 2986 push Run 2987 ld (Run) Nil 2988 push (At) # <L II> Save '@' 2989 push At 2990 link 2991 ld (EnvBind) L # Close bind frame 2992 ld (Break) L # Set break env 2993 push 0 # Init env swap 2994 sub S IV # <L -V> OutFrame 2995 ld Y S 2996 ld (Y I) 1 # fd = stdout 2997 ld (Y II) 0 # pid = 0 2998 call pushOutFilesY 2999 call printE # Print expression 3000 call newline 3001 ld B (char "!") # Prompt 3002 ld E Nil # REPL 3003 ld X 0 # Runtime expression 3004 call loadBEX_E 3005 call popOutFiles 3006 add S (+ IV III) # Drop outFrame, env swap, bind link and '@' 3007 pop (At) # Restore '@' 3008 pop A 3009 pop (Run) # '*Run' 3010 pop A 3011 ld E (Up) # runtime expression 3012 pop (Up) # and '^' 3013 pop L # Restore link 3014 pop (EnvBind) # Restore bind link 3015 ld (Break) 0 # Leave breakpoint 3016 pop Y 3017 pop X 3018 end 3019 end 3020 end 3021 ret 3022 3023 # (e . prg) -> any 3024 (code 'doE 2) 3025 push X 3026 push Y 3027 ld X E 3028 null (Break) # Breakpoint? 3029 jz brkErrX # No 3030 link 3031 push (Dbg) # Save '*Dbg' 3032 push (At) # '@' 3033 push (Run) # and '*Run' 3034 link 3035 ld (Dbg) Nil # Switch off debug mode 3036 ld C (Break) # Get break env 3037 ld (At) (C II) # Set '@' 3038 ld (Run) (C IV) # and '*Run' 3039 call popOutFiles # Leave debug I/O env 3040 ld Y (EnvInFrames) # Keep InFrames 3041 call popInFiles 3042 ld X (X CDR) # 'prg'? 3043 atom X 3044 if z # Yes 3045 prog X 3046 else 3047 ld E (Up) # Get '^' 3048 eval 3049 end 3050 call pushInFilesY # Restore debug I/O env 3051 lea Y ((Break) -V) 3052 call pushOutFilesY 3053 pop L # Restore debug env 3054 pop (Run) 3055 pop (At) 3056 pop (Dbg) 3057 pop L 3058 pop Y 3059 pop X 3060 ret 3061 3062 # ($ sym|lst lst . prg) -> any 3063 (code 'doTrace 2) 3064 push X 3065 ld X (E CDR) # Get args 3066 cmp (Dbg) Nil # Debug? 3067 if eq # No 3068 ld X ((X CDR) CDR) # Get 'prg' 3069 prog X # Run it 3070 else 3071 push Y 3072 push Z 3073 push (OutFile) # Save output channel 3074 ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) 3075 push (PutB) # Save 'put' 3076 ld (PutB) putStdoutB # Set new 3077 ld Y (X) # Get 'sym|lst' 3078 ld X (X CDR) 3079 ld Z (X CDR) # Get 'prg' 3080 inc (EnvTrace) # Increment trace level 3081 ld C (EnvTrace) # Get it 3082 call traceCY # Print trace information 3083 ld C Trc1 # Print " :" 3084 call outStringC 3085 ld X (X) # Get 'lst' 3086 do 3087 atom X # List? 3088 while z # Yes 3089 call space 3090 ld E (X) # Print value of CAR 3091 ld E (E) 3092 call printE 3093 ld X (X CDR) 3094 loop 3095 cmp X Nil # Last CDR is NIL? 3096 if ne # No 3097 cmp X At # Variable arguments? 3098 if ne # No 3099 call space 3100 ld E (X) # Print value 3101 call printE 3102 else 3103 ld X (EnvNext) # VarArgs 3104 do 3105 cmp X (EnvArgs) # Any? 3106 while ne # Yes 3107 call space 3108 sub X I # Next 3109 ld E (X) # Next arg 3110 call printE 3111 loop 3112 end 3113 end 3114 call newline 3115 ld (PutB) (S) # Restore 'put' 3116 ld (OutFile) (S I) # and output channel 3117 prog Z # Run 'prg' 3118 ld (OutFile) ((OutFiles) II) # Set output channel again 3119 ld (PutB) putStdoutB 3120 ld C (EnvTrace) # Get trace level 3121 dec (EnvTrace) # Decrement it 3122 call traceCY # Print trace information 3123 ld C Trc2 # Print " = " 3124 call outStringC 3125 call printE_E # Print result 3126 call newline 3127 pop (PutB) # Restore 'put' 3128 pop (OutFile) # and output channel 3129 pop Z 3130 pop Y 3131 end 3132 pop X 3133 ret 3134 3135 (code 'traceCY) 3136 cmp C 64 # Limit to 64 3137 if gt 3138 ld C 64 3139 end 3140 do 3141 call space # Output spaces 3142 dec C # 'cnt' times 3143 until sz 3144 push E 3145 atom Y # 'sym'? 3146 if nz # Yes 3147 ld E Y # Print symbol 3148 call printE 3149 else 3150 ld E (Y) # Print method 3151 call printE 3152 call space 3153 ld E (Y CDR) # Print class 3154 call printE 3155 call space 3156 ld E (This) # Print 'This' 3157 call printE 3158 end 3159 pop E 3160 ret 3161 3162 # (call 'any ..) -> flg 3163 (code 'doCall 2) 3164 push X 3165 push Z 3166 ld X (E CDR) # X on args 3167 push E # Save expression 3168 push 0 # End-of-buffers marker 3169 call evSymX_E # Pathname 3170 call pathStringE_SZ # Write to stack buffer 3171 do 3172 ld X (X CDR) # Arguments? 3173 atom X 3174 while z # Yes 3175 push Z # Buffer chain 3176 call evSymX_E # Next argument 3177 call bufStringE_SZ # Write to stack buffer 3178 loop 3179 push Z 3180 ld Z S # Point to chain 3181 ld X Z 3182 push 0 # NULL terminator 3183 do 3184 lea A (X I) # Buffer pointer 3185 push A # Push to vector 3186 ld X (X) # Follow chain 3187 null (X) # Done? 3188 until z # Yes 3189 ld X (X I) # Retrieve expression 3190 call flushAll # Flush all output channels 3191 cc fork() # Fork child process 3192 nul4 # In child? 3193 if z # Yes 3194 cc setpgid(0 0) # Set process group 3195 cc execvp((S) S) # Execute program 3196 jmp execErrS # Error if failed 3197 end 3198 js forkErrX 3199 do 3200 ld S Z # Clean up buffers 3201 pop Z # Chain 3202 null Z # End? 3203 until z # Yes 3204 ld Z A # Keep pid in Z 3205 cc setpgid(Z 0) # Set process group 3206 null (Termio) # Raw mode? 3207 if nz # Yes 3208 cc tcsetpgrp(0 Z) # Set terminal process group 3209 end 3210 do # Re-use expression stack entry 3211 do 3212 cc waitpid(Z S WUNTRACED) # Wait for child 3213 nul4 # OK? 3214 while s # No 3215 call errno_A 3216 cmp A EINTR # Interrupted? 3217 jne waitPidErrX # No 3218 null (Signal) # Signal? 3219 if nz # Yes 3220 call sighandlerX 3221 end 3222 loop 3223 null (Termio) # Raw mode? 3224 if nz # Yes 3225 cc getpgrp() # Set terminal process group 3226 cc tcsetpgrp(0 A) 3227 end 3228 call wifstoppedS_F # WIFSTOPPED(S)? 3229 if ne # No 3230 ld4 (S) # Result? 3231 or A A 3232 ld E TSym # Return 'flg' 3233 ldnz E Nil 3234 add S I # Drop expression 3235 pop Z 3236 pop X 3237 ret 3238 end 3239 ld B (char "+") # Prompt 3240 ld E Nil # REPL 3241 call loadBEX_E 3242 null (Termio) # Raw mode? 3243 if nz # Yes 3244 cc tcsetpgrp(0 Z) # Set terminal process group 3245 end 3246 cc kill(Z SIGCONT) 3247 loop 3248 3249 # (tick (cnt1 . cnt2) . prg) -> any 3250 (code 'doTick 2) 3251 push X 3252 push (TickU) # <S III> User ticks 3253 push (TickS) # <S II> System ticks 3254 cc times(Tms) # Get ticks 3255 push (Tms TMS_UTIME) # <S I> User time 3256 push (Tms TMS_STIME) # <S> User time 3257 ld E (E CDR) 3258 push (E) # Save pointer to count pair 3259 ld X (E CDR) 3260 prog X # Run 'prg' 3261 pop X # Get count pair 3262 cc times(Tms) # Get ticks again 3263 ld A (Tms TMS_UTIME) # User time 3264 sub A (S I) # Subtract previous user time 3265 sub A (TickU) # Subtract user ticks 3266 add A (S III) # Adjust by saved ticks 3267 add (TickU) A # Save new user ticks 3268 shl A 4 # Adjust to short number 3269 add (X) A # Add to 'cnt1' 3270 ld A (Tms TMS_STIME) # System time 3271 sub A (S) # Subtract previous system time 3272 sub A (TickS) # Subtract system ticks 3273 add A (S II) # Adjust by saved ticks 3274 add (TickS) A # Save new system ticks 3275 shl A 4 # Adjust to short number 3276 add (X CDR) A # Add to 'cnt2' 3277 add S IV # Drop locals 3278 pop X 3279 ret 3280 3281 # (ipid) -> pid | NIL 3282 (code 'doIpid 2) 3283 ld C (EnvInFrames) # OutFrames? 3284 null C 3285 if nz 3286 ld E (C II) # 'pid' 3287 cmp E 1 # 'pid' > 1? 3288 if gt # Yes 3289 shl E 4 # Make short number 3290 or E CNT 3291 ret 3292 end 3293 end 3294 ld E Nil # Return NIL 3295 ret 3296 3297 # (opid) -> pid | NIL 3298 (code 'doOpid 2) 3299 ld C (EnvOutFrames) # OutFrames? 3300 null C 3301 if nz 3302 ld E (C II) # 'pid' 3303 cmp E 1 # 'pid' > 1? 3304 if gt # Yes 3305 shl E 4 # Make short number 3306 or E CNT 3307 ret 3308 end 3309 end 3310 ld E Nil # Return NIL 3311 ret 3312 3313 # (kill 'pid ['cnt]) -> flg 3314 (code 'doKill 2) 3315 push X 3316 push Y 3317 ld X E 3318 ld Y (E CDR) # Y on args 3319 call evCntXY_FE # Eval 'pid' 3320 ld Y (Y CDR) # Second arg? 3321 atom Y 3322 if nz # No 3323 cc kill(E SIGTERM) # Send TERM signal 3324 else 3325 push E # Save signal number 3326 call evCntXY_FE # Eval 'cnt' 3327 cc kill(pop E) # Send signal 3328 end 3329 nul4 # OK? 3330 ld E TSym # Yes 3331 ldnz E Nil # No 3332 pop Y 3333 pop X 3334 ret 3335 3336 # (fork) -> pid | NIL 3337 (code 'doFork 2) 3338 push X 3339 ld X E # Get expression 3340 call forkLispX_FE # Fork child process 3341 if c 3342 ld E Nil # In child 3343 else 3344 shl E 4 # In parent 3345 or E CNT # Return PID 3346 end 3347 pop X 3348 ret 3349 3350 (code 'forkLispX_FE 0) 3351 call flushAll # Flush all output channels 3352 null (Spkr) # Not listening for children yet? 3353 if z # Yes 3354 cc pipe(SpMiPipe) # Open speaker/microphone pipe 3355 nul4 # OK? 3356 jnz pipeErrX 3357 ld4 (SpMiPipe) # Read end 3358 ld (Spkr) A # into the speaker 3359 call closeOnExecAX 3360 ld4 (SpMiPipe 4) # Write end 3361 call closeOnExecAX 3362 end 3363 sub S II # Create 'hear' and 'tell' pipes 3364 cc pipe(S) # Open 'hear' pipe 3365 nul4 # OK? 3366 jnz pipeErrX 3367 cc pipe(&(S 8)) # Open 'tell' pipe 3368 nul4 # OK? 3369 jnz pipeErrX 3370 ld4 (S) # Read end of 'hear' 3371 call closeOnExecAX 3372 ld4 (S 4) # Write end 3373 call closeOnExecAX 3374 ld4 (S 8) # Read end of 'tell' 3375 call closeOnExecAX 3376 ld4 (S 12) # Write end 3377 call closeOnExecAX 3378 ld C 0 # Index 3379 ld A (Child) # Find a free child slot 3380 do 3381 cmp C (Children) # Tried all children? 3382 while ne # No 3383 null (A) # Found empty 'pid'? 3384 while nz # No 3385 add A VI # Increment by sizeof(child) 3386 add C VI 3387 loop 3388 cc fork() # Fork child process 3389 nul4 # In child? 3390 js forkErrX 3391 if z # Yes 3392 ld (Slot) C # Set child index 3393 ld (Spkr) 0 # No children yet 3394 ld4 (SpMiPipe 4) # Set microphone to write end 3395 ld (Mic) A 3396 ld4 (S 4) # Close write end of 'hear' 3397 call closeAX 3398 ld4 (S 8) # Close read end of 'tell' 3399 call closeAX 3400 ld4 (SpMiPipe) # Close read end 3401 call closeAX 3402 ld A (Hear) # Already hearing? 3403 null A 3404 if nz # Yes 3405 call closeAX # Close it 3406 ld A (Hear) 3407 call closeInFileA 3408 ld A (Hear) 3409 call closeOutFileA 3410 end 3411 ld4 (S) # Read end of 'hear' 3412 ld (Hear) A 3413 call initInFileA_A # Create input file 3414 ld A (Tell) # Telling? 3415 null A 3416 if nz # Yes 3417 call closeAX 3418 end 3419 ld4 (S 12) # Write end of 'tell' 3420 ld (Tell) A 3421 ld E (Child) # Iterate children 3422 ld C (Children) # Count 3423 do 3424 sub C VI # More? 3425 while ge # Yes 3426 null (E) # 'pid'? 3427 if nz # Yes 3428 cc close((E I)) # Close 'hear' 3429 cc close((E II)) # Close 'tell' 3430 cc free((E V)) # Free buffer 3431 end 3432 add E VI # Increment by sizeof(child) 3433 loop 3434 ld (Children) 0 # No children 3435 cc free((Child)) 3436 ld (Child) 0 3437 ld A (EnvInFrames) # Clear pids in InFrames 3438 do 3439 null A # More frames? 3440 while nz # Yes 3441 ld (A II) 0 # Clear 'pid' 3442 ld A (A) # Follow link 3443 loop 3444 ld A (EnvOutFrames) # Clear pids in OutFrames 3445 do 3446 null A # More frames? 3447 while nz # Yes 3448 ld (A II) 0 # Clear 'pid' 3449 ld A (A) # Follow link 3450 loop 3451 ld A (Catch) # Clear 'finally' expressions in Catch frames 3452 do 3453 null A # More frames? 3454 while nz # Yes 3455 ld (A II) ZERO # Clear 'fin' 3456 ld A (A) # Follow link 3457 loop 3458 cc free((Termio)) # Give up terminal control 3459 ld (Termio) 0 3460 set (PRepl) (Repl) # Set parent REPL flag 3461 ld (PPid) (Pid) # Set parent process ID 3462 cc getpid() # Get new process ID 3463 shl A 4 # Make short number 3464 or A CNT 3465 ld (Pid) A # Set new process ID 3466 ld E (Fork) # Run '*Fork' 3467 call execE 3468 ld (Fork) Nil # Clear '*Fork' 3469 add S II # Drop 'hear' and 'tell' pipes 3470 setc # Return "in child" 3471 ret 3472 end 3473 cmp C (Children) # Children table full? 3474 ldnz E A # No: Get 'pid' into E 3475 if eq # Yes 3476 push A # Save child's 'pid' 3477 ld A (Child) # Get vector 3478 ld E C # Children 3479 add E (* 8 VI) # Eight more slots 3480 ld (Children) E 3481 call allocAE_A # Extend vector 3482 ld (Child) A 3483 add A E # Point A to the end 3484 ld E 8 # Init eight new slots 3485 do 3486 sub A VI # Decrement pointer 3487 ld (A) 0 # Clear 'pid' 3488 dec E # Done? 3489 until z # Yes 3490 pop E # Get 'pid' 3491 end 3492 add C (Child) # Point C to free 'child' entry 3493 ld (C) E # Set 'pid' 3494 ld4 (S) # Close read end of 'hear' 3495 call closeAX 3496 ld4 (S 4) # Write end of 'hear' 3497 ld (C II) A # Into 'tell' 3498 call nonblockingA_A # Set to non-blocking 3499 ld4 (S 8) # Read end of 'tell' 3500 ld (C I) A # Into 'hear' 3501 ld4 (S 12) # Close write end of 'tell' 3502 call closeAX 3503 ld (C III) 0 # Init buffer offset 3504 ld (C IV) 0 # buffer count 3505 ld (C V) 0 # No buffer yet 3506 add S II # Drop 'hear' and 'tell' pipes 3507 clrc # Return "in parent" 3508 ret 3509 3510 # (bye 'cnt|NIL) 3511 (code 'doBye 2) 3512 ld X E 3513 ld E (E CDR) 3514 ld E (E) 3515 eval # Get exit code 3516 cmp E Nil 3517 if eq 3518 ld E 0 # Zero if NIL 3519 else 3520 call xCntEX_FE 3521 end 3522 # Exit 3523 (code 'byeE) 3524 nul (InBye) # Re-entered? 3525 if z # No 3526 set (InBye) 1 3527 push E # Save exit code 3528 ld C 0 # Top frame 3529 call unwindC_Z # Unwind 3530 ld E (Bye) # Run exit expression(s) 3531 call execE 3532 pop E # Restore exit code 3533 end 3534 call flushAll # Flush all output channels 3535 (code 'finishE) 3536 call setCooked # Set terminal to cooked mode 3537 cc exit(E) 3538 3539 # vi:et:ts=3:sw=3