apply.l (43339B)
1 # 13nov12abu 2 # (c) Software Lab. Alexander Burger 3 4 (code 'applyXYZ_E 0) 5 ld C (Y) # Get 'foo' 6 do 7 cnt C # Short number? 8 if nz # Yes 9 push (EnvApply) # Build apply frame 10 link 11 sym S # Align stack to cell boundary 12 if nz 13 push ZERO 14 end 15 ld E Nil # Init 'args' list 16 do 17 cmp Z Y # Any args? 18 while ne # Yes 19 push (Z) # Next arg 20 ld A S # Value address 21 push ZERO # Dummy symbol's tail 22 push E # Dummy cell's CDR 23 push A # CAR 24 cmp S (StkLimit) # Stack check 25 jlt stkErrX 26 ld E S # Set 'args' list 27 add Z I 28 loop 29 push E # 'args' list 30 push C # 'fun' 31 ld E S # Set 'exe' 32 link 33 ld (EnvApply) L # Close apply frame 34 call (C T) # Eval SUBR 35 drop 36 pop (EnvApply) 37 ret 38 end 39 big C # Undefined if bignum 40 jnz undefinedCX 41 cmp S (StkLimit) # Stack check 42 jlt stkErrX 43 atom C # Pair? 44 if z # Yes 45 # Apply EXPR 46 push X # Save 'exe' 47 ld X (C) # Parameter list in X 48 push (EnvBind) # Build bind frame 49 link 50 push (At) # Bind At 51 push At 52 do 53 atom X # More parameters? 54 while z # Yes 55 ld E (X) # Get symbol 56 ld X (X CDR) 57 push (E) # Save old value 58 push E # Save symbol 59 cmp Y Z # More args? 60 if ne # Yes 61 sub Y I 62 ld (E) (Y) # Set new value to next arg 63 else 64 ld (E) Nil # New value NIL 65 end 66 loop 67 cmp X Nil # NIL-terminated parameter list? 68 if eq # Yes 69 link 70 ld (EnvBind) L # Close bind frame 71 push 0 # Init env swap 72 ld Z (C CDR) # Body in Z 73 prog Z # Run body 74 add S I # Drop env swap 75 pop L # Get link 76 do # Unbind symbols 77 pop X # Next symbol 78 pop (X) # Restore value 79 cmp S L # More? 80 until eq # No 81 pop L # Restore link 82 pop (EnvBind) # Restore bind link 83 pop X # 'exe' 84 ret 85 end 86 # Non-NIL parameter 87 cmp X At # '@'? 88 if ne # No 89 push (X) # Save last parameter's old value 90 push X # and the last parameter 91 link 92 ld (EnvBind) L # Close bind frame 93 push 0 # Init env swap 94 cmp Y Z # More args? 95 if eq # No 96 ld (X) Nil # Set new value to NIL 97 ld Z (C CDR) # Body in Z 98 prog Z # Run body 99 else 100 push (EnvApply) # Build apply frame 101 link 102 sym S # Align stack to cell boundary 103 if nz 104 push ZERO 105 end 106 ld E Nil # Init 'args' list 107 do 108 push (Z) # Next arg 109 push ZERO # Dummy symbol's tail 110 push E # Dummy cell's CDR 111 lea A (S II) # Value address 112 push A # CAR 113 cmp S (StkLimit) # Stack check 114 jlt stkErrX 115 ld E S # Set 'args' list 116 add Z I 117 cmp Z Y # More args? 118 until eq # No 119 ld (X) E # Set new value to 'args' list 120 link 121 ld (EnvApply) L # Close apply frame 122 ld Z (C CDR) # Body in Z 123 prog Z # Run body 124 drop 125 pop (EnvApply) 126 end 127 add S I # Drop env swap 128 pop L # Get link 129 do # Unbind symbols 130 pop X # Next symbol 131 pop (X) # Restore value 132 cmp S L # More? 133 until eq # No 134 pop L # Restore link 135 pop (EnvBind) # Restore bind link 136 pop X # 'exe' 137 ret 138 end 139 # Evaluated argument list 140 link 141 ld (EnvBind) L # Close bind frame 142 push 0 # Init env swap 143 push (EnvNext) # Save current 'next' 144 push (EnvArgs) # and varArgs base 145 cmp Y Z # Any args? 146 if eq # No 147 ld (EnvArgs) 0 148 ld (EnvNext) 0 149 else 150 link # Build varArgs frame 151 do 152 sub Y I 153 push (Y) # Push next argument 154 cmp S (StkLimit) # Stack check 155 jlt stkErrX 156 cmp Y Z # More args? 157 until eq # No 158 ld (EnvArgs) S # Set new varArgs base 159 ld (EnvNext) L # Set new 'next' 160 link # Close varArgs frame 161 end 162 ld Z (C CDR) # Body in Z 163 prog Z # Run body 164 null (EnvArgs) # VarArgs? 165 if nz # Yes 166 drop # Drop varArgs 167 end 168 pop (EnvArgs) # Restore varArgs base 169 pop (EnvNext) # and 'next' 170 add S I # Drop env swap 171 pop L # Get link 172 do # Unbind symbols 173 pop X # Next symbol 174 pop (X) # Restore value 175 cmp S L # More? 176 until eq # No 177 pop L # Restore link 178 pop (EnvBind) # Restore bind link 179 pop X # 'exe' 180 ret 181 end 182 ld A (C) # Else symbolic, get value 183 cmp A (Meth) # Method? 184 if eq # Yes 185 sub Y I # First arg 186 ld E (Y) # Get object 187 num E # Need symbol 188 jnz symErrEX 189 sym E 190 jz symErrEX 191 sym (E TAIL) # External symbol? 192 if nz # Yes 193 call dbFetchEX # Fetch it 194 end 195 push Z # Save arg pointers 196 push Y 197 ld Y C # 'msg' 198 ld Z 0 # No classes 199 call methodEY_FCYZ # Found? 200 jne msgErrYX # No 201 xchg Z (S I) # 'cls' 202 xchg (S I) (EnvCls) 203 xchg Y (S) # 'key' 204 xchg (S) (EnvKey) # 'key' 205 push X # 'exe' 206 ld X (C) # Parameter list in X 207 push (EnvBind) # Build bind frame 208 link 209 push (At) # Bind At 210 push At 211 push (This) # Bind This 212 push This 213 ld (This) (Y) # to object 214 do 215 atom X # More parameters? 216 while z # Yes 217 ld E (X) # Get symbol 218 ld X (X CDR) 219 push (E) # Save old value 220 push E # Save symbol 221 cmp Y Z # More args? 222 if ne # Yes 223 sub Y I 224 ld (E) (Y) # Set new value to next arg 225 else 226 ld (E) Nil # New value NIL 227 end 228 loop 229 cmp X Nil # NIL-terminated parameter list? 230 if eq # Yes 231 link 232 ld (EnvBind) L # Close bind frame 233 push 0 # Init env swap 234 ld Z (C CDR) # Body in Z 235 prog Z # Run body 236 add S I # Drop env swap 237 pop L # Get link 238 do # Unbind symbols 239 pop X # Next symbol 240 pop (X) # Restore value 241 cmp S L # More? 242 until eq # No 243 pop L # Restore link 244 pop (EnvBind) # Restore bind link 245 pop X # 'exe' 246 pop (EnvKey) # 'key' 247 pop (EnvCls) # and 'cls' 248 ret 249 end 250 # Non-NIL parameter 251 cmp X At # '@'? 252 if ne # No 253 push (X) # Save last parameter's old value 254 push X # and the last parameter 255 link 256 ld (EnvBind) L # Close bind frame 257 push 0 # Init env swap 258 cmp Y Z # More args? 259 if eq # No 260 ld (X) Nil # Set new value to NIL 261 ld Z (C CDR) # Body in Z 262 prog Z # Run body 263 else 264 push (EnvApply) # Build apply frame 265 link 266 sym S # Align stack to cell boundary 267 if nz 268 push ZERO 269 end 270 ld E Nil # Init 'args' list 271 do 272 push (Z) # Next arg 273 push ZERO # Dummy symbol's tail 274 push E # Dummy cell's CDR 275 lea A (S II) # Value address 276 push A # CAR 277 cmp S (StkLimit) # Stack check 278 jlt stkErrX 279 ld E S # Set 'args' list 280 add Z I 281 cmp Z Y # More args? 282 until eq # No 283 ld (X) E # Set new value to 'args' list 284 link 285 ld (EnvApply) L # Close apply frame 286 ld Z (C CDR) # Body in Z 287 prog Z # Run body 288 drop 289 pop (EnvApply) 290 end 291 add S I # Drop env swap 292 pop L # Get link 293 do # Unbind symbols 294 pop X # Next symbol 295 pop (X) # Restore value 296 cmp S L # More? 297 until eq # No 298 pop L # Restore link 299 pop (EnvBind) # Restore bind link 300 pop X # 'exe' 301 pop (EnvKey) # 'key' 302 pop (EnvCls) # and 'cls' 303 ret 304 end 305 # Evaluated argument list 306 link 307 ld (EnvBind) L # Close bind frame 308 push 0 # Init env swap 309 push (EnvNext) # Save current 'next' 310 push (EnvArgs) # and varArgs base 311 cmp Y Z # Any args? 312 if eq # No 313 ld (EnvArgs) 0 314 ld (EnvNext) 0 315 else 316 link # Build varArgs frame 317 do 318 sub Y I 319 push (Y) # Push next argument 320 cmp S (StkLimit) # Stack check 321 jlt stkErrX 322 cmp Y Z # More args? 323 until eq # No 324 ld (EnvArgs) S # Set new varArgs base 325 ld (EnvNext) L # Set new 'next' 326 link # Close varArgs frame 327 end 328 ld Z (C CDR) # Body in Z 329 prog Z # Run body 330 null (EnvArgs) # VarArgs? 331 if nz # Yes 332 drop # Drop varArgs 333 end 334 pop (EnvArgs) # Restore varArgs base 335 pop (EnvNext) # and 'next' 336 add S I # Drop env swap 337 pop L # Get link 338 do # Unbind symbols 339 pop X # Next symbol 340 pop (X) # Restore value 341 cmp S L # More? 342 until eq # No 343 pop L # Restore link 344 pop (EnvBind) # Restore bind link 345 pop X # 'exe' 346 pop (EnvKey) # 'key' 347 pop (EnvCls) # and 'cls' 348 ret 349 end 350 cmp A (A) # Auto-symbol? 351 if eq # Yes 352 call sharedLibC_FA # Try dynamic load 353 jz undefinedCX 354 end 355 ld C A 356 loop 357 358 (code 'applyVarXYZ_E 0) 359 ld C (Y) # Get 'foo' 360 do 361 cnt C # Short number? 362 if nz # Yes 363 push (EnvApply) # Build apply frame 364 link 365 sym S # Align stack to cell boundary 366 if nz 367 push ZERO 368 end 369 ld E Nil # Init 'args' list 370 do 371 cmp Z Y # Any args? 372 while ne # Yes 373 push ((Z)) # Next arg 374 ld A S # Value address 375 push ZERO # Dummy symbol's tail 376 push E # Dummy cell's CDR 377 push A # CAR 378 cmp S (StkLimit) # Stack check 379 jlt stkErrX 380 ld E S # Set 'args' list 381 add Z I 382 loop 383 push E # 'args' list 384 push C # 'fun' 385 ld E S # Set 'exe' 386 link 387 ld (EnvApply) L # Close apply frame 388 call (C T) # Eval SUBR 389 drop 390 pop (EnvApply) 391 ret 392 end 393 big C # Undefined if bignum 394 jnz undefinedCX 395 cmp S (StkLimit) # Stack check 396 jlt stkErrX 397 atom C # Pair? 398 if z # Yes 399 # Apply EXPR 400 push X # Save 'exe' 401 ld X (C) # Parameter list in X 402 push (EnvBind) # Build bind frame 403 link 404 push (At) # Bind At 405 push At 406 do 407 atom X # More parameters? 408 while z # Yes 409 ld E (X) # Get symbol 410 ld X (X CDR) 411 push (E) # Save old value 412 push E # Save symbol 413 cmp Y Z # More args? 414 if ne # Yes 415 sub Y I 416 ld (E) ((Y)) # Set new value to CAR of next arg 417 else 418 ld (E) Nil # New value NIL 419 end 420 loop 421 cmp X Nil # NIL-terminated parameter list? 422 if eq # Yes 423 link 424 ld (EnvBind) L # Close bind frame 425 push 0 # Init env swap 426 ld Z (C CDR) # Body in Z 427 prog Z # Run body 428 add S I # Drop env swap 429 pop L # Get link 430 do # Unbind symbols 431 pop X # Next symbol 432 pop (X) # Restore value 433 cmp S L # More? 434 until eq # No 435 pop L # Restore link 436 pop (EnvBind) # Restore bind link 437 pop X # 'exe' 438 ret 439 end 440 # Non-NIL parameter 441 cmp X At # '@'? 442 if ne # No 443 push (X) # Save last parameter's old value 444 push X # and the last parameter 445 link 446 ld (EnvBind) L # Close bind frame 447 push 0 # Init env swap 448 cmp Y Z # More args? 449 if eq # No 450 ld (X) Nil # Set new value to NIL 451 ld Z (C CDR) # Body in Z 452 prog Z # Run body 453 else 454 push (EnvApply) # Build apply frame 455 link 456 sym S # Align stack to cell boundary 457 if nz 458 push ZERO 459 end 460 ld E Nil # Init 'args' list 461 do 462 push ((Z)) # Next arg 463 push ZERO # Dummy symbol's tail 464 push E # Dummy cell's CDR 465 lea A (S II) # Value address 466 push A # CAR 467 cmp S (StkLimit) # Stack check 468 jlt stkErrX 469 ld E S # Set 'args' list 470 add Z I 471 cmp Z Y # More args? 472 until eq # No 473 ld (X) E # Set new value to 'args' list 474 link 475 ld (EnvApply) L # Close apply frame 476 ld Z (C CDR) # Body in Z 477 prog Z # Run body 478 drop 479 pop (EnvApply) 480 end 481 add S I # Drop env swap 482 pop L # Get link 483 do # Unbind symbols 484 pop X # Next symbol 485 pop (X) # Restore value 486 cmp S L # More? 487 until eq # No 488 pop L # Restore link 489 pop (EnvBind) # Restore bind link 490 pop X # 'exe' 491 ret 492 end 493 # Evaluated argument list 494 link 495 ld (EnvBind) L # Close bind frame 496 push 0 # Init env swap 497 push (EnvNext) # Save current 'next' 498 push (EnvArgs) # and varArgs base 499 cmp Y Z # Any args? 500 if eq # No 501 ld (EnvArgs) 0 502 ld (EnvNext) 0 503 else 504 link # Build varArgs frame 505 do 506 sub Y I 507 push ((Y)) # Push CAR of next argument 508 cmp S (StkLimit) # Stack check 509 jlt stkErrX 510 cmp Y Z # More args? 511 until eq # No 512 ld (EnvArgs) S # Set new varArgs base 513 ld (EnvNext) L # Set new 'next' 514 link # Close varArgs frame 515 end 516 ld Z (C CDR) # Body in Z 517 prog Z # Run body 518 null (EnvArgs) # VarArgs? 519 if nz # Yes 520 drop # Drop varArgs 521 end 522 pop (EnvArgs) # Restore varArgs base 523 pop (EnvNext) # and 'next' 524 add S I # Drop env swap 525 pop L # Get link 526 do # Unbind symbols 527 pop X # Next symbol 528 pop (X) # Restore value 529 cmp S L # More? 530 until eq # No 531 pop L # Restore link 532 pop (EnvBind) # Restore bind link 533 pop X # 'exe' 534 ret 535 end 536 ld A (C) # Else symbolic, get value 537 cmp A (Meth) # Method? 538 if eq # Yes 539 sub Y I # First arg 540 ld E ((Y)) # Get object 541 num E # Need symbol 542 jnz symErrEX 543 sym E 544 jz symErrEX 545 sym (E TAIL) # External symbol? 546 if nz # Yes 547 call dbFetchEX # Fetch it 548 end 549 push Z # Save arg pointers 550 push Y 551 ld Y C # 'msg' 552 ld Z 0 # No classes 553 call methodEY_FCYZ # Found? 554 jne msgErrYX # No 555 xchg Z (S I) # 'cls' 556 xchg (S I) (EnvCls) 557 xchg Y (S) # 'key' 558 xchg (S) (EnvKey) # 'key' 559 push X # 'exe' 560 ld X (C) # Parameter list in X 561 push (EnvBind) # Build bind frame 562 link 563 push (At) # Bind At 564 push At 565 push (This) # Bind This 566 push This 567 ld (This) ((Y)) # to object 568 do 569 atom X # More parameters? 570 while z # Yes 571 ld E (X) # Get symbol 572 ld X (X CDR) 573 push (E) # Save old value 574 push E # Save symbol 575 cmp Y Z # More args? 576 if ne # Yes 577 sub Y I 578 ld (E) ((Y)) # Set new value to CAR of next arg 579 else 580 ld (E) Nil # New value NIL 581 end 582 loop 583 cmp X Nil # NIL-terminated parameter list? 584 if eq # Yes 585 link 586 ld (EnvBind) L # Close bind frame 587 push 0 # Init env swap 588 ld Z (C CDR) # Body in Z 589 prog Z # Run body 590 add S I # Drop env swap 591 pop L # Get link 592 do # Unbind symbols 593 pop X # Next symbol 594 pop (X) # Restore value 595 cmp S L # More? 596 until eq # No 597 pop L # Restore link 598 pop (EnvBind) # Restore bind link 599 pop X # 'exe' 600 pop (EnvKey) # 'key' 601 pop (EnvCls) # and 'cls' 602 ret 603 end 604 # Non-NIL parameter 605 cmp X At # '@'? 606 if ne # No 607 push (X) # Save last parameter's old value 608 push X # and the last parameter 609 link 610 ld (EnvBind) L # Close bind frame 611 push 0 # Init env swap 612 cmp Y Z # More args? 613 if eq # No 614 ld (X) Nil # Set new value to NIL 615 ld Z (C CDR) # Body in Z 616 prog Z # Run body 617 else 618 push (EnvApply) # Build apply frame 619 link 620 sym S # Align stack to cell boundary 621 if nz 622 push ZERO 623 end 624 ld E Nil # Init 'args' list 625 do 626 push ((Z)) # Next arg 627 push ZERO # Dummy symbol's tail 628 push E # Dummy cell's CDR 629 lea A (S II) # Value address 630 push A # CAR 631 cmp S (StkLimit) # Stack check 632 jlt stkErrX 633 ld E S # Set 'args' list 634 add Z I 635 cmp Z Y # More args? 636 until eq # No 637 ld (X) E # Set new value to 'args' list 638 link 639 ld (EnvApply) L # Close apply frame 640 ld Z (C CDR) # Body in Z 641 prog Z # Run body 642 drop 643 pop (EnvApply) 644 end 645 add S I # Drop env swap 646 pop L # Get link 647 do # Unbind symbols 648 pop X # Next symbol 649 pop (X) # Restore value 650 cmp S L # More? 651 until eq # No 652 pop L # Restore link 653 pop (EnvBind) # Restore bind link 654 pop X # 'exe' 655 pop (EnvKey) # 'key' 656 pop (EnvCls) # and 'cls' 657 ret 658 end 659 # Evaluated argument list 660 link 661 ld (EnvBind) L # Close bind frame 662 push 0 # Init env swap 663 push (EnvNext) # Save current 'next' 664 push (EnvArgs) # and varArgs base 665 cmp Y Z # Any args? 666 if eq # No 667 ld (EnvArgs) 0 668 ld (EnvNext) 0 669 else 670 link # Build varArgs frame 671 do 672 sub Y I 673 push ((Y)) # Push CAR of next argument 674 cmp S (StkLimit) # Stack check 675 jlt stkErrX 676 cmp Y Z # More args? 677 until eq # No 678 ld (EnvArgs) S # Set new varArgs base 679 ld (EnvNext) L # Set new 'next' 680 link # Close varArgs frame 681 end 682 ld Z (C CDR) # Body in Z 683 prog Z # Run body 684 null (EnvArgs) # VarArgs? 685 if nz # Yes 686 drop # Drop varArgs 687 end 688 pop (EnvArgs) # Restore varArgs base 689 pop (EnvNext) # and 'next' 690 add S I # Drop env swap 691 pop L # Get link 692 do # Unbind symbols 693 pop X # Next symbol 694 pop (X) # Restore value 695 cmp S L # More? 696 until eq # No 697 pop L # Restore link 698 pop (EnvBind) # Restore bind link 699 pop X # 'exe' 700 pop (EnvKey) # 'key' 701 pop (EnvCls) # and 'cls' 702 ret 703 end 704 cmp A (A) # Auto-symbol? 705 if eq # Yes 706 call sharedLibC_FA # Try dynamic load 707 jz undefinedCX 708 end 709 ld C A 710 loop 711 712 # (apply 'fun 'lst ['any ..]) -> any 713 (code 'doApply 2) 714 push X 715 push Y 716 push Z 717 ld X E # Keep expression in X 718 ld Z (E CDR) # Z on args 719 ld E (Z) 720 eval # Eval 'fun' 721 link 722 push E 723 ld Y S # Pointer to 'fun' in Y 724 ld Z (Z CDR) # Second arg 725 ld E (Z) 726 eval+ # Eval 'lst' 727 do 728 ld Z (Z CDR) # Args 729 atom Z # More? 730 while z # Yes 731 push E # Save 'lst' 732 ld E (Z) 733 eval+ # Eval next arg 734 xchg E (S) # Keep 'lst' in E 735 loop 736 do 737 atom E # Expand 'lst' 738 while z 739 push (E) 740 cmp S (StkLimit) # Stack check 741 jlt stkErrX 742 ld E (E CDR) 743 loop 744 ld Z S # Z on last argument 745 link # Close frame 746 call applyXYZ_E # Apply 747 drop 748 pop Z 749 pop Y 750 pop X 751 ret 752 753 # (pass 'fun ['any ..]) -> any 754 (code 'doPass 2) 755 push X 756 push Y 757 push Z 758 ld X E # Keep expression in X 759 ld Z (E CDR) # Z on args 760 ld E (Z) 761 eval # Eval 'fun' 762 link 763 push E # Push 'fun' 764 ld Y S # Pointer to 'fun' in Y 765 do # 'any' args 766 ld Z (Z CDR) # Any? 767 atom Z 768 while z # Yes 769 ld E (Z) 770 eval+ # Eval next 'lst' 771 push E 772 loop 773 ld C (EnvNext) # VarArgs 774 do 775 cmp C (EnvArgs) # Any? 776 while ne # Yes 777 sub C I 778 push (C) # Next arg 779 loop 780 ld Z S # Z on last argument 781 link # Close frame 782 call applyXYZ_E # Apply 783 drop 784 pop Z 785 pop Y 786 pop X 787 ret 788 789 # (maps 'fun 'sym ['lst ..]) -> any 790 (code 'doMaps 2) 791 push X 792 push Y 793 push Z 794 ld X E # Keep expression in X 795 ld Z (E CDR) # Z on args 796 ld E (Z) 797 ld Z (Z CDR) 798 eval # Eval 'fun' 799 link 800 push E # Save 'fun' 801 ld Y S # Pointer to 'fun' in Y 802 ld E (Z) 803 ld Z (Z CDR) 804 eval+ # Eval 'sym' 805 push E # <Y -I> 'sym' 806 do # 'lst' args 807 atom Z # More 'lst' args? 808 while z # Yes 809 ld E (Z) 810 eval+ # Eval next 'lst' 811 push E 812 ld Z (Z CDR) 813 loop 814 link # <L I> Last argument 815 ld E (Y -I) # Get 'sym' 816 num E # Need symbol 817 jnz symErrEX 818 sym E 819 jz symErrEX 820 sym (E TAIL) # External symbol? 821 if nz # Yes 822 call dbFetchEX # Fetch it 823 end 824 ld E (E TAIL) # Get property list 825 off E SYM # Clear 'extern' tag 826 ld (Y -I) E 827 ld E Nil # Preset return value 828 do 829 atom (Y -I) # First 'lst' done? 830 while z # No 831 push Y 832 lea Z (L I) # Last arg 833 call applyVarXYZ_E # Apply 834 pop Y 835 lea Z (L I) # Last arg 836 do 837 ld (Z) ((Z) CDR) # Pop all lists 838 add Z I 839 cmp Z Y # Reached 'fun'? 840 until eq # Yes 841 loop 842 drop 843 pop Z 844 pop Y 845 pop X 846 ret 847 848 # (map 'fun 'lst ..) -> lst 849 (code 'doMap 2) 850 push X 851 push Y 852 push Z 853 ld X E # Keep expression in X 854 ld Z (E CDR) # Z on args 855 ld E (Z) 856 ld Z (Z CDR) 857 eval # Eval 'fun' 858 link 859 push E # Push 'fun' 860 ld Y S # Pointer to 'fun' in Y 861 do # 'lst' args 862 ld E (Z) 863 eval+ # Eval next 'lst' 864 push E 865 ld Z (Z CDR) 866 atom Z # More 'lst' args? 867 until nz # No 868 link # <L I> Last argument 869 ld E Nil # Preset return value 870 do 871 atom (Y -I) # First 'lst' done? 872 while z # No 873 push Y 874 lea Z (L I) # Last arg 875 call applyXYZ_E # Apply 876 pop Y 877 lea Z (L I) # Last arg 878 do 879 ld (Z) ((Z) CDR) # Pop all lists 880 add Z I 881 cmp Z Y # Reached 'fun'? 882 until eq # Yes 883 loop 884 drop 885 pop Z 886 pop Y 887 pop X 888 ret 889 890 # (mapc 'fun 'lst ..) -> lst 891 (code 'doMapc 2) 892 push X 893 push Y 894 push Z 895 ld X E # Keep expression in X 896 ld Z (E CDR) # Z on args 897 ld E (Z) 898 ld Z (Z CDR) 899 eval # Eval 'fun' 900 link 901 push E # Push 'fun' 902 ld Y S # Pointer to 'fun' in Y 903 do # 'lst' args 904 ld E (Z) 905 eval+ # Eval next 'lst' 906 push E 907 ld Z (Z CDR) 908 atom Z # More 'lst' args? 909 until nz # No 910 link # <L I> Last argument 911 ld E Nil # Preset return value 912 do 913 atom (Y -I) # First 'lst' done? 914 while z # No 915 push Y 916 lea Z (L I) # Last arg 917 call applyVarXYZ_E # Apply 918 pop Y 919 lea Z (L I) # Last arg 920 do 921 ld (Z) ((Z) CDR) # Pop all lists 922 add Z I 923 cmp Z Y # Reached 'fun'? 924 until eq # Yes 925 loop 926 drop 927 pop Z 928 pop Y 929 pop X 930 ret 931 932 # (maplist 'fun 'lst ..) -> lst 933 (code 'doMaplist 2) 934 push X 935 push Y 936 push Z 937 ld X E # Keep expression in X 938 ld Z (E CDR) # Z on args 939 ld E (Z) 940 ld Z (Z CDR) 941 eval # Eval 'fun' 942 link 943 push E # Push 'fun' 944 ld Y S # Pointer to 'fun' in Y 945 do # 'lst' args 946 ld E (Z) 947 eval+ # Eval next 'lst' 948 push E 949 ld Z (Z CDR) 950 atom Z # More 'lst' args? 951 until nz # No 952 push Nil # <L I> Result 953 link # <L II> Last argument 954 push 0 # <L -I> Result tail 955 do 956 atom (Y -I) # First 'lst' done? 957 while z # No 958 push Y 959 lea Z (L II) # Last arg 960 call applyXYZ_E # Apply 961 pop Y 962 call consE_C # Cons with NIL 963 ld (C) E 964 ld (C CDR) Nil 965 null (L -I) # Result tail? 966 if z # No 967 ld (L I) C # Store result 968 else 969 ld ((L -I) CDR) C # Set new CDR of result tail 970 end 971 ld (L -I) C # Store result tail 972 lea Z (L II) # Last arg 973 do 974 ld (Z) ((Z) CDR) # Pop all lists 975 add Z I 976 cmp Z Y # Reached 'fun'? 977 until eq # Yes 978 loop 979 ld E (L I) # Result 980 drop 981 pop Z 982 pop Y 983 pop X 984 ret 985 986 # (mapcar 'fun 'lst ..) -> lst 987 (code 'doMapcar 2) 988 push X 989 push Y 990 push Z 991 ld X E # Keep expression in X 992 ld Z (E CDR) # Z on args 993 ld E (Z) 994 ld Z (Z CDR) 995 eval # Eval 'fun' 996 link 997 push E # Push 'fun' 998 ld Y S # Pointer to 'fun' in Y 999 do # 'lst' args 1000 ld E (Z) 1001 eval+ # Eval next 'lst' 1002 push E 1003 ld Z (Z CDR) 1004 atom Z # More 'lst' args? 1005 until nz # No 1006 push Nil # <L I> Result 1007 link # <L II> Last argument 1008 push 0 # <L -I> Result tail 1009 do 1010 atom (Y -I) # First 'lst' done? 1011 while z # No 1012 push Y 1013 lea Z (L II) # Last arg 1014 call applyVarXYZ_E # Apply 1015 pop Y 1016 call consE_C # Cons with NIL 1017 ld (C) E 1018 ld (C CDR) Nil 1019 null (L -I) # Result tail? 1020 if z # No 1021 ld (L I) C # Store result 1022 else 1023 ld ((L -I) CDR) C # Set new CDR of result tail 1024 end 1025 ld (L -I) C # Store result tail 1026 lea Z (L II) # Last arg 1027 do 1028 ld (Z) ((Z) CDR) # Pop all lists 1029 add Z I 1030 cmp Z Y # Reached 'fun'? 1031 until eq # Yes 1032 loop 1033 ld E (L I) # Result 1034 drop 1035 pop Z 1036 pop Y 1037 pop X 1038 ret 1039 1040 # (mapcon 'fun 'lst ..) -> lst 1041 (code 'doMapcon 2) 1042 push X 1043 push Y 1044 push Z 1045 ld X E # Keep expression in X 1046 ld Z (E CDR) # Z on args 1047 ld E (Z) 1048 ld Z (Z CDR) 1049 eval # Eval 'fun' 1050 link 1051 push E # Push 'fun' 1052 ld Y S # Pointer to 'fun' in Y 1053 do # 'lst' args 1054 ld E (Z) 1055 eval+ # Eval next 'lst' 1056 push E 1057 ld Z (Z CDR) 1058 atom Z # More 'lst' args? 1059 until nz # No 1060 push Nil # <L I> Result 1061 link # <L II> Last argument 1062 push 0 # <L -I> Result tail 1063 do 1064 atom (Y -I) # First 'lst' done? 1065 while z # No 1066 push Y 1067 lea Z (L II) # Last arg 1068 call applyXYZ_E # Apply 1069 pop Y 1070 atom E # Got pair? 1071 if z # Yes 1072 null (L -I) # Result tail? 1073 if z # No 1074 ld (L I) E # Store result 1075 else 1076 ld A (L -I) # Else get result tail 1077 do 1078 atom (A CDR) # Find last cell 1079 while z 1080 ld A (A CDR) 1081 loop 1082 ld (A CDR) E # Set new CDR 1083 end 1084 ld (L -I) E # Store result tail 1085 end 1086 lea Z (L II) # Last arg 1087 do 1088 ld (Z) ((Z) CDR) # Pop all lists 1089 add Z I 1090 cmp Z Y # Reached 'fun'? 1091 until eq # Yes 1092 loop 1093 ld E (L I) # Result 1094 drop 1095 pop Z 1096 pop Y 1097 pop X 1098 ret 1099 1100 # (mapcan 'fun 'lst ..) -> lst 1101 (code 'doMapcan 2) 1102 push X 1103 push Y 1104 push Z 1105 ld X E # Keep expression in X 1106 ld Z (E CDR) # Z on args 1107 ld E (Z) 1108 ld Z (Z CDR) 1109 eval # Eval 'fun' 1110 link 1111 push E # Push 'fun' 1112 ld Y S # Pointer to 'fun' in Y 1113 do # 'lst' args 1114 ld E (Z) 1115 eval+ # Eval next 'lst' 1116 push E 1117 ld Z (Z CDR) 1118 atom Z # More 'lst' args? 1119 until nz # No 1120 push Nil # <L I> Result 1121 link # <L II> Last argument 1122 push 0 # <L -I> Result tail 1123 do 1124 atom (Y -I) # First 'lst' done? 1125 while z # No 1126 push Y 1127 lea Z (L II) # Last arg 1128 call applyVarXYZ_E # Apply 1129 pop Y 1130 atom E # Got pair? 1131 if z # Yes 1132 null (L -I) # Result tail? 1133 if z # No 1134 ld (L I) E # Store result 1135 else 1136 ld A (L -I) # Else get result tail 1137 do 1138 atom (A CDR) # Find last cell 1139 while z 1140 ld A (A CDR) 1141 loop 1142 ld (A CDR) E # Set new CDR 1143 end 1144 ld (L -I) E # Store result tail 1145 end 1146 lea Z (L II) # Last arg 1147 do 1148 ld (Z) ((Z) CDR) # Pop all lists 1149 add Z I 1150 cmp Z Y # Reached 'fun'? 1151 until eq # Yes 1152 loop 1153 ld E (L I) # Result 1154 drop 1155 pop Z 1156 pop Y 1157 pop X 1158 ret 1159 1160 # (filter 'fun 'lst ..) -> lst 1161 (code 'doFilter 2) 1162 push X 1163 push Y 1164 push Z 1165 ld X E # Keep expression in X 1166 ld Z (E CDR) # Z on args 1167 ld E (Z) 1168 ld Z (Z CDR) 1169 eval # Eval 'fun' 1170 link 1171 push E # Push 'fun' 1172 ld Y S # Pointer to 'fun' in Y 1173 do # 'lst' args 1174 ld E (Z) 1175 eval+ # Eval next 'lst' 1176 push E 1177 ld Z (Z CDR) 1178 atom Z # More 'lst' args? 1179 until nz # No 1180 push Nil # <L I> Result 1181 link # <L II> Last argument 1182 push 0 # <L -I> Result tail 1183 do 1184 atom (Y -I) # First 'lst' done? 1185 while z # No 1186 push Y 1187 lea Z (L II) # Last arg 1188 call applyVarXYZ_E # Apply 1189 pop Y 1190 cmp E Nil # NIL? 1191 if ne # No 1192 call consE_C # Cons with NIL 1193 ld (C) ((Y -I)) # Element of first 'lst' 1194 ld (C CDR) Nil 1195 null (L -I) # Result tail? 1196 if z # No 1197 ld (L I) C # Store result 1198 else 1199 ld ((L -I) CDR) C # Set new CDR of result tail 1200 end 1201 ld (L -I) C # Store result tail 1202 end 1203 lea Z (L II) # Last arg 1204 do 1205 ld (Z) ((Z) CDR) # Pop all lists 1206 add Z I 1207 cmp Z Y # Reached 'fun'? 1208 until eq # Yes 1209 loop 1210 ld E (L I) # Result 1211 drop 1212 pop Z 1213 pop Y 1214 pop X 1215 ret 1216 1217 # (extract 'fun 'lst ..) -> lst 1218 (code 'doExtract 2) 1219 push X 1220 push Y 1221 push Z 1222 ld X E # Keep expression in X 1223 ld Z (E CDR) # Z on args 1224 ld E (Z) 1225 ld Z (Z CDR) 1226 eval # Eval 'fun' 1227 link 1228 push E # Push 'fun' 1229 ld Y S # Pointer to 'fun' in Y 1230 do # 'lst' args 1231 ld E (Z) 1232 eval+ # Eval next 'lst' 1233 push E 1234 ld Z (Z CDR) 1235 atom Z # More 'lst' args? 1236 until nz # No 1237 push Nil # <L I> Result 1238 link # <L II> Last argument 1239 push 0 # <L -I> Result tail 1240 do 1241 atom (Y -I) # First 'lst' done? 1242 while z # No 1243 push Y 1244 lea Z (L II) # Last arg 1245 call applyVarXYZ_E # Apply 1246 pop Y 1247 cmp E Nil # NIL? 1248 if ne # No 1249 call consE_C # Cons with NIL 1250 ld (C) E 1251 ld (C CDR) Nil 1252 null (L -I) # Result tail? 1253 if z # No 1254 ld (L I) C # Store result 1255 else 1256 ld ((L -I) CDR) C # Set new CDR of result tail 1257 end 1258 ld (L -I) C # Store result tail 1259 end 1260 lea Z (L II) # Last arg 1261 do 1262 ld (Z) ((Z) CDR) # Pop all lists 1263 add Z I 1264 cmp Z Y # Reached 'fun'? 1265 until eq # Yes 1266 loop 1267 ld E (L I) # Result 1268 drop 1269 pop Z 1270 pop Y 1271 pop X 1272 ret 1273 1274 # (seek 'fun 'lst ..) -> lst 1275 (code 'doSeek 2) 1276 push X 1277 push Y 1278 push Z 1279 ld X E # Keep expression in X 1280 ld Z (E CDR) # Z on args 1281 ld E (Z) 1282 ld Z (Z CDR) 1283 eval # Eval 'fun' 1284 link 1285 push E # Push 'fun' 1286 ld Y S # Pointer to 'fun' in Y 1287 do # 'lst' args 1288 ld E (Z) 1289 eval+ # Eval next 'lst' 1290 push E 1291 ld Z (Z CDR) 1292 atom Z # More 'lst' args? 1293 until nz # No 1294 link # <L I> Last argument 1295 ld E Nil # Preset return value 1296 do 1297 atom (Y -I) # First 'lst' done? 1298 while z # No 1299 push Y 1300 lea Z (L I) # Last arg 1301 call applyXYZ_E # Apply 1302 pop Y 1303 cmp E Nil # NIL? 1304 if ne # No 1305 ld E (Y -I) # Return first 'lst' 1306 break T 1307 end 1308 lea Z (L I) # Last arg 1309 do 1310 ld (Z) ((Z) CDR) # Pop all lists 1311 add Z I 1312 cmp Z Y # Reached 'fun'? 1313 until eq # Yes 1314 loop 1315 drop 1316 pop Z 1317 pop Y 1318 pop X 1319 ret 1320 1321 # (find 'fun 'lst ..) -> any 1322 (code 'doFind 2) 1323 push X 1324 push Y 1325 push Z 1326 ld X E # Keep expression in X 1327 ld Z (E CDR) # Z on args 1328 ld E (Z) 1329 ld Z (Z CDR) 1330 eval # Eval 'fun' 1331 link 1332 push E # Push 'fun' 1333 ld Y S # Pointer to 'fun' in Y 1334 do # 'lst' args 1335 ld E (Z) 1336 eval+ # Eval next 'lst' 1337 push E 1338 ld Z (Z CDR) 1339 atom Z # More 'lst' args? 1340 until nz # No 1341 link # <L I> Last argument 1342 ld E Nil # Preset return value 1343 do 1344 atom (Y -I) # First 'lst' done? 1345 while z # No 1346 push Y 1347 lea Z (L I) # Last arg 1348 call applyVarXYZ_E # Apply 1349 pop Y 1350 cmp E Nil # NIL? 1351 if ne # No 1352 ld E ((Y -I)) # Return CAR of first 'lst' 1353 break T 1354 end 1355 lea Z (L I) # Last arg 1356 do 1357 ld (Z) ((Z) CDR) # Pop all lists 1358 add Z I 1359 cmp Z Y # Reached 'fun'? 1360 until eq # Yes 1361 loop 1362 drop 1363 pop Z 1364 pop Y 1365 pop X 1366 ret 1367 1368 # (pick 'fun 'lst ..) -> any 1369 (code 'doPick 2) 1370 push X 1371 push Y 1372 push Z 1373 ld X E # Keep expression in X 1374 ld Z (E CDR) # Z on args 1375 ld E (Z) 1376 ld Z (Z CDR) 1377 eval # Eval 'fun' 1378 link 1379 push E # Push 'fun' 1380 ld Y S # Pointer to 'fun' in Y 1381 do # 'lst' args 1382 ld E (Z) 1383 eval+ # Eval next 'lst' 1384 push E 1385 ld Z (Z CDR) 1386 atom Z # More 'lst' args? 1387 until nz # No 1388 link # <L I> Last argument 1389 ld E Nil # Preset return value 1390 do 1391 atom (Y -I) # First 'lst' done? 1392 while z # No 1393 push Y 1394 lea Z (L I) # Last arg 1395 call applyVarXYZ_E # Apply 1396 pop Y 1397 cmp E Nil # NIL? 1398 break ne # No 1399 lea Z (L I) # Last arg 1400 do 1401 ld (Z) ((Z) CDR) # Pop all lists 1402 add Z I 1403 cmp Z Y # Reached 'fun'? 1404 until eq # Yes 1405 loop 1406 drop 1407 pop Z 1408 pop Y 1409 pop X 1410 ret 1411 1412 # (cnt 'fun 'lst ..) -> cnt 1413 (code 'doCnt 2) 1414 push X 1415 push Y 1416 push Z 1417 ld X E # Keep expression in X 1418 ld Z (E CDR) # Z on args 1419 ld E (Z) 1420 ld Z (Z CDR) 1421 eval # Eval 'fun' 1422 link 1423 push E # Push 'fun' 1424 ld Y S # Pointer to 'fun' in Y 1425 do # 'lst' args 1426 ld E (Z) 1427 eval+ # Eval next 'lst' 1428 push E 1429 ld Z (Z CDR) 1430 atom Z # More 'lst' args? 1431 until nz # No 1432 link # <L I> Last argument 1433 push ZERO # <L -I> Result 1434 do 1435 atom (Y -I) # First 'lst' done? 1436 while z # No 1437 push Y 1438 lea Z (L I) # Last arg 1439 call applyVarXYZ_E # Apply 1440 pop Y 1441 cmp E Nil # NIL? 1442 if ne # No 1443 add (S) (hex "10") # Increment count 1444 end 1445 lea Z (L I) # Last arg 1446 do 1447 ld (Z) ((Z) CDR) # Pop all lists 1448 add Z I 1449 cmp Z Y # Reached 'fun'? 1450 until eq # Yes 1451 loop 1452 pop E # Get result 1453 drop 1454 pop Z 1455 pop Y 1456 pop X 1457 ret 1458 1459 # (sum 'fun 'lst ..) -> num 1460 (code 'doSum 2) 1461 push X 1462 push Y 1463 push Z 1464 ld X E # Keep expression in X 1465 ld Z (E CDR) # Z on args 1466 ld E (Z) 1467 ld Z (Z CDR) 1468 eval # Eval 'fun' 1469 link 1470 push E # Push 'fun' 1471 ld Y S # Pointer to 'fun' in Y 1472 do # 'lst' args 1473 ld E (Z) 1474 eval+ # Eval next 'lst' 1475 push E 1476 ld Z (Z CDR) 1477 atom Z # More 'lst' args? 1478 until nz # No 1479 push ZERO # <L II> Safe 1480 push ZERO # <L I> Result 1481 link # <L III> Last argument 1482 do 1483 atom (Y -I) # First 'lst' done? 1484 while z # No 1485 push Y 1486 lea Z (L III) # Last arg 1487 call applyVarXYZ_E # Apply 1488 pop Y 1489 num E # Number? 1490 if nz # Yes 1491 ld (L II) E # Save 1492 ld A (L I) # Result so far 1493 call addAE_A # Add 1494 ld (L I) A # Result 1495 end 1496 lea Z (L III) # Last arg 1497 do 1498 ld (Z) ((Z) CDR) # Pop all lists 1499 add Z I 1500 cmp Z Y # Reached 'fun'? 1501 until eq # Yes 1502 loop 1503 ld E (L I) # Result 1504 drop 1505 pop Z 1506 pop Y 1507 pop X 1508 ret 1509 1510 # (maxi 'fun 'lst ..) -> any 1511 (code 'doMaxi 2) 1512 push X 1513 push Y 1514 push Z 1515 ld X E # Keep expression in X 1516 ld Z (E CDR) # Z on args 1517 ld E (Z) 1518 ld Z (Z CDR) 1519 eval # Eval 'fun' 1520 link 1521 push E # Push 'fun' 1522 ld Y S # Pointer to 'fun' in Y 1523 do # 'lst' args 1524 ld E (Z) 1525 eval+ # Eval next 'lst' 1526 push E 1527 ld Z (Z CDR) 1528 atom Z # More 'lst' args? 1529 until nz # No 1530 push Nil # <L II> Value 1531 push Nil # <L I> Result 1532 link # <L III> Last argument 1533 do 1534 atom (Y -I) # First 'lst' done? 1535 while z # No 1536 push Y 1537 lea Z (L III) # Last arg 1538 call applyVarXYZ_E # Apply 1539 ld Y E # Keep 1540 ld A (L II) # Maximal value 1541 call compareAE_F # Compare with current 1542 if lt 1543 ld (L I) (((S) -I)) # New result 1544 ld (L II) Y # New maximum 1545 end 1546 pop Y 1547 lea Z (L III) # Last arg 1548 do 1549 ld (Z) ((Z) CDR) # Pop all lists 1550 add Z I 1551 cmp Z Y # Reached 'fun'? 1552 until eq # Yes 1553 loop 1554 ld E (L I) # Result 1555 drop 1556 pop Z 1557 pop Y 1558 pop X 1559 ret 1560 1561 # (mini 'fun 'lst ..) -> any 1562 (code 'doMini 2) 1563 push X 1564 push Y 1565 push Z 1566 ld X E # Keep expression in X 1567 ld Z (E CDR) # Z on args 1568 ld E (Z) 1569 ld Z (Z CDR) 1570 eval # Eval 'fun' 1571 link 1572 push E # Push 'fun' 1573 ld Y S # Pointer to 'fun' in Y 1574 do # 'lst' args 1575 ld E (Z) 1576 eval+ # Eval next 'lst' 1577 push E 1578 ld Z (Z CDR) 1579 atom Z # More 'lst' args? 1580 until nz # No 1581 push TSym # <L II> Value 1582 push Nil # <L I> Result 1583 link # <L III> Last argument 1584 do 1585 atom (Y -I) # First 'lst' done? 1586 while z # No 1587 push Y 1588 lea Z (L III) # Last arg 1589 call applyVarXYZ_E # Apply 1590 ld Y E # Keep 1591 ld A (L II) # Minimal value 1592 call compareAE_F # Compare with current 1593 if gt 1594 ld (L I) (((S) -I)) # New result 1595 ld (L II) Y # New minimum 1596 end 1597 pop Y 1598 lea Z (L III) # Last arg 1599 do 1600 ld (Z) ((Z) CDR) # Pop all lists 1601 add Z I 1602 cmp Z Y # Reached 'fun'? 1603 until eq # Yes 1604 loop 1605 ld E (L I) # Result 1606 drop 1607 pop Z 1608 pop Y 1609 pop X 1610 ret 1611 1612 # (fish 'fun 'any) -> lst 1613 (code 'doFish 2) 1614 push X 1615 push Y 1616 push Z 1617 ld X E # Keep expression in X 1618 ld Z (E CDR) # Z on args 1619 ld E (Z) 1620 eval # Eval 'fun' 1621 link 1622 push E # Push 'fun' 1623 ld Y S # Pointer to 'fun' in Y 1624 ld Z (Z CDR) # Second arg 1625 ld E (Z) 1626 eval+ # Eval 'any' 1627 push ZERO # <L III> Apply arg 1628 push E # <L II> 'any' 1629 push Nil # <L I> Result 1630 link # Close frame 1631 ld A (L II) # Get 'any' 1632 call fishAXY # Fish for results 1633 ld E (L I) # Result 1634 drop 1635 pop Z 1636 pop Y 1637 pop X 1638 ret 1639 1640 (code 'fishAXY 0) 1641 push A # Save arg 1642 push Y 1643 lea Z (L III) # Set apply arg 1644 ld (Z) A 1645 call applyXYZ_E # Apply 1646 pop Y 1647 pop A 1648 cmp E Nil # NIL? 1649 if ne # No 1650 call cons_C # New cell 1651 ld (C) A # Cons arg 1652 ld (C CDR) (L I) # into result 1653 ld (L I) C 1654 ret 1655 end 1656 atom A # Pair? 1657 jnz ret # No 1658 cmp (A CDR) Nil # CDR? 1659 if ne # Yes 1660 push A 1661 ld A (A CDR) 1662 call fishAXY # Recurse on CDR 1663 pop A 1664 end 1665 ld A (A) 1666 jmp fishAXY # Recurse on CAR 1667 1668 # (by 'fun1 'fun2 'lst ..) -> lst 1669 (code 'doBy 2) 1670 push X 1671 push Y 1672 push Z 1673 ld X E # Keep expression in X 1674 ld Z (E CDR) # Z on args 1675 ld E (Z) 1676 ld Z (Z CDR) 1677 eval # Eval 'fun1' 1678 link 1679 push E # Push 'fun1' 1680 ld E (Z) 1681 ld Z (Z CDR) 1682 eval+ # Eval 'fun2' 1683 xchg E (S) # Push 1684 push E # Push 'fun1' 1685 ld Y S # Pointer to 'fun1' in Y 1686 do # 'lst' args 1687 ld E (Z) 1688 eval+ # Eval next 'lst' 1689 push E 1690 ld Z (Z CDR) 1691 atom Z # More 'lst' args? 1692 until nz # No 1693 push Nil # <L I> Result 1694 link # <L II> Last argument 1695 push 0 # <L -I> Result tail 1696 do 1697 atom (Y -I) # First 'lst' done? 1698 while z # No 1699 push Y 1700 lea Z (L II) # Last arg 1701 call applyVarXYZ_E # Apply 1702 pop Y 1703 call consE_C # Cons with element from first 'lst' 1704 ld (C) E 1705 ld (C CDR) ((Y -I)) 1706 call consC_A # Concat to result 1707 ld (A) C 1708 ld (A CDR) Nil 1709 null (L -I) # Result tail? 1710 if z # No 1711 ld (L I) A # Store result 1712 else 1713 ld ((L -I) CDR) A # Set new CDR of result tail 1714 end 1715 ld (L -I) A # Store result tail 1716 lea Z (L II) # Last arg 1717 do 1718 ld (Z) ((Z) CDR) # Pop all lists 1719 add Z I 1720 cmp Z Y # Reached 'fun1'? 1721 until eq # Yes 1722 loop 1723 ld Z Y # Point to 'fun1' 1724 add Y I # Pointer to 'fun2' in Y 1725 ld (Z) (L I) # Result 1726 call applyXYZ_E # Apply 1727 ld C E # Remove CARs in result list 1728 do 1729 atom C # More elements? 1730 while z # Yes 1731 ld (C) ((C) CDR) 1732 ld C (C CDR) 1733 loop 1734 drop 1735 pop Z 1736 pop Y 1737 pop X 1738 ret 1739 1740 # vi:et:ts=3:sw=3