subr.l (90151B)
1 # 22jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # (car 'var) -> any 5 (code 'doCar 2) 6 push X 7 ld X E 8 ld E ((E CDR)) # Get arg 9 eval 10 num E # Need variable 11 jnz varErrEX 12 ld E (E) # Take CAR 13 pop X 14 ret 15 16 # (cdr 'lst) -> any 17 (code 'doCdr 2) 18 push X 19 ld X E 20 ld E ((E CDR)) # Get arg 21 eval 22 cmp E Nil # Need list 23 if ne 24 atom E 25 jnz lstErrEX 26 end 27 ld E (E CDR) # Take CDR 28 pop X 29 ret 30 31 (code 'doCaar 2) 32 push X 33 ld X E 34 ld E ((E CDR)) # Get arg 35 eval 36 num E # Need variable 37 jnz varErrEX 38 ld E (E) # Take CAR 39 num E # Need variable 40 jnz varErrEX 41 ld E (E) # Take CAR 42 pop X 43 ret 44 45 (code 'doCadr 2) 46 push X 47 ld X E 48 ld E ((E CDR)) # Get arg 49 eval 50 cmp E Nil # Need list 51 if ne 52 atom E 53 jnz lstErrEX 54 end 55 ld E (E CDR) # Take CDR 56 num E # Need variable 57 jnz varErrEX 58 ld E (E) # Take CAR 59 pop X 60 ret 61 62 (code 'doCdar 2) 63 push X 64 ld X E 65 ld E ((E CDR)) # Get arg 66 eval 67 num E # Need variable 68 jnz varErrEX 69 ld E (E) # Take CAR 70 cmp E Nil # Need list 71 if ne 72 atom E 73 jnz lstErrEX 74 end 75 ld E (E CDR) # Take CDR 76 pop X 77 ret 78 79 (code 'doCddr 2) 80 push X 81 ld X E 82 ld E ((E CDR)) # Get arg 83 eval 84 cmp E Nil # Need list 85 if ne 86 atom E 87 jnz lstErrEX 88 end 89 ld E (E CDR) # Take CDR 90 cmp E Nil # Need list 91 if ne 92 atom E 93 jnz lstErrEX 94 end 95 ld E (E CDR) # Take CDR 96 pop X 97 ret 98 99 (code 'doCaaar 2) 100 push X 101 ld X E 102 ld E ((E CDR)) # Get arg 103 eval 104 num E # Need variable 105 jnz varErrEX 106 ld E (E) # Take CAR 107 num E # Need variable 108 jnz varErrEX 109 ld E (E) # Take CAR 110 num E # Need variable 111 jnz varErrEX 112 ld E (E) # Take CAR 113 pop X 114 ret 115 116 (code 'doCaadr 2) 117 push X 118 ld X E 119 ld E ((E CDR)) # Get arg 120 eval 121 cmp E Nil # Need list 122 if ne 123 atom E 124 jnz lstErrEX 125 end 126 ld E (E CDR) # Take CDR 127 num E # Need variable 128 jnz varErrEX 129 ld E (E) # Take CAR 130 num E # Need variable 131 jnz varErrEX 132 ld E (E) # Take CAR 133 pop X 134 ret 135 136 (code 'doCadar 2) 137 push X 138 ld X E 139 ld E ((E CDR)) # Get arg 140 eval 141 num E # Need variable 142 jnz varErrEX 143 ld E (E) # Take CAR 144 cmp E Nil # Need list 145 if ne 146 atom E 147 jnz lstErrEX 148 end 149 ld E (E CDR) # Take CDR 150 num E # Need variable 151 jnz varErrEX 152 ld E (E) # Take CAR 153 pop X 154 ret 155 156 (code 'doCaddr 2) 157 push X 158 ld X E 159 ld E ((E CDR)) # Get arg 160 eval 161 cmp E Nil # Need list 162 if ne 163 atom E 164 jnz lstErrEX 165 end 166 ld E (E CDR) # Take CDR 167 cmp E Nil # Need list 168 if ne 169 atom E 170 jnz lstErrEX 171 end 172 ld E (E CDR) # Take CDR 173 num E # Need variable 174 jnz varErrEX 175 ld E (E) # Take CAR 176 pop X 177 ret 178 179 (code 'doCdaar 2) 180 push X 181 ld X E 182 ld E ((E CDR)) # Get arg 183 eval 184 num E # Need variable 185 jnz varErrEX 186 ld E (E) # Take CAR 187 num E # Need variable 188 jnz varErrEX 189 ld E (E) # Take CAR 190 cmp E Nil # Need list 191 if ne 192 atom E 193 jnz lstErrEX 194 end 195 ld E (E CDR) # Take CDR 196 pop X 197 ret 198 199 (code 'doCdadr 2) 200 push X 201 ld X E 202 ld E ((E CDR)) # Get arg 203 eval 204 cmp E Nil # Need list 205 if ne 206 atom E 207 jnz lstErrEX 208 end 209 ld E (E CDR) # Take CDR 210 num E # Need variable 211 jnz varErrEX 212 ld E (E) # Take CAR 213 cmp E Nil # Need list 214 if ne 215 atom E 216 jnz lstErrEX 217 end 218 ld E (E CDR) # Take CDR 219 pop X 220 ret 221 222 (code 'doCddar 2) 223 push X 224 ld X E 225 ld E ((E CDR)) # Get arg 226 eval 227 num E # Need variable 228 jnz varErrEX 229 ld E (E) # Take CAR 230 cmp E Nil # Need list 231 if ne 232 atom E 233 jnz lstErrEX 234 end 235 ld E (E CDR) # Take CDR 236 cmp E Nil # Need list 237 if ne 238 atom E 239 jnz lstErrEX 240 end 241 ld E (E CDR) # Take CDR 242 pop X 243 ret 244 245 (code 'doCdddr 2) 246 push X 247 ld X E 248 ld E ((E CDR)) # Get arg 249 eval 250 cmp E Nil # Need list 251 if ne 252 atom E 253 jnz lstErrEX 254 end 255 ld E (E CDR) # Take CDR 256 cmp E Nil # Need list 257 if ne 258 atom E 259 jnz lstErrEX 260 end 261 ld E (E CDR) # Take CDR 262 cmp E Nil # Need list 263 if ne 264 atom E 265 jnz lstErrEX 266 end 267 ld E (E CDR) # Take CDR 268 pop X 269 ret 270 271 (code 'doCaaaar 2) 272 push X 273 ld X E 274 ld E ((E CDR)) # Get arg 275 eval 276 num E # Need variable 277 jnz varErrEX 278 ld E (E) # Take CAR 279 num E # Need variable 280 jnz varErrEX 281 ld E (E) # Take CAR 282 num E # Need variable 283 jnz varErrEX 284 ld E (E) # Take CAR 285 pop X 286 ret 287 288 (code 'doCaaadr 2) 289 push X 290 ld X E 291 ld E ((E CDR)) # Get arg 292 eval 293 cmp E Nil # Need list 294 if ne 295 atom E 296 jnz lstErrEX 297 end 298 ld E (E CDR) # Take CDR 299 num E # Need variable 300 jnz varErrEX 301 ld E (E) # Take CAR 302 num E # Need variable 303 jnz varErrEX 304 ld E (E) # Take CAR 305 num E # Need variable 306 jnz varErrEX 307 ld E (E) # Take CAR 308 pop X 309 ret 310 311 (code 'doCaadar 2) 312 push X 313 ld X E 314 ld E ((E CDR)) # Get arg 315 eval 316 num E # Need variable 317 jnz varErrEX 318 ld E (E) # Take CAR 319 cmp E Nil # Need list 320 if ne 321 atom E 322 jnz lstErrEX 323 end 324 ld E (E CDR) # Take CDR 325 num E # Need variable 326 jnz varErrEX 327 ld E (E) # Take CAR 328 num E # Need variable 329 jnz varErrEX 330 ld E (E) # Take CAR 331 pop X 332 ret 333 334 (code 'doCaaddr 2) 335 push X 336 ld X E 337 ld E ((E CDR)) # Get arg 338 eval 339 cmp E Nil # Need list 340 if ne 341 atom E 342 jnz lstErrEX 343 end 344 ld E (E CDR) # Take CDR 345 cmp E Nil # Need list 346 if ne 347 atom E 348 jnz lstErrEX 349 end 350 ld E (E CDR) # Take CDR 351 num E # Need variable 352 jnz varErrEX 353 ld E (E) # Take CAR 354 num E # Need variable 355 jnz varErrEX 356 ld E (E) # Take CAR 357 pop X 358 ret 359 360 (code 'doCadaar 2) 361 push X 362 ld X E 363 ld E ((E CDR)) # Get arg 364 eval 365 num E # Need variable 366 jnz varErrEX 367 ld E (E) # Take CAR 368 num E # Need variable 369 jnz varErrEX 370 ld E (E) # Take CAR 371 cmp E Nil # Need list 372 if ne 373 atom E 374 jnz lstErrEX 375 end 376 ld E (E CDR) # Take CDR 377 num E # Need variable 378 jnz varErrEX 379 ld E (E) # Take CAR 380 pop X 381 ret 382 383 (code 'doCadadr 2) 384 push X 385 ld X E 386 ld E ((E CDR)) # Get arg 387 eval 388 cmp E Nil # Need list 389 if ne 390 atom E 391 jnz lstErrEX 392 end 393 ld E (E CDR) # Take CDR 394 num E # Need variable 395 jnz varErrEX 396 ld E (E) # Take CAR 397 cmp E Nil # Need list 398 if ne 399 atom E 400 jnz lstErrEX 401 end 402 ld E (E CDR) # Take CDR 403 num E # Need variable 404 jnz varErrEX 405 ld E (E) # Take CAR 406 pop X 407 ret 408 409 (code 'doCaddar 2) 410 push X 411 ld X E 412 ld E ((E CDR)) # Get arg 413 eval 414 num E # Need variable 415 jnz varErrEX 416 ld E (E) # Take CAR 417 cmp E Nil # Need list 418 if ne 419 atom E 420 jnz lstErrEX 421 end 422 ld E (E CDR) # Take CDR 423 cmp E Nil # Need list 424 if ne 425 atom E 426 jnz lstErrEX 427 end 428 ld E (E CDR) # Take CDR 429 num E # Need variable 430 jnz varErrEX 431 ld E (E) # Take CAR 432 pop X 433 ret 434 435 (code 'doCadddr 2) 436 push X 437 ld X E 438 ld E ((E CDR)) # Get arg 439 eval 440 cmp E Nil # Need list 441 if ne 442 atom E 443 jnz lstErrEX 444 end 445 ld E (E CDR) # Take CDR 446 cmp E Nil # Need list 447 if ne 448 atom E 449 jnz lstErrEX 450 end 451 ld E (E CDR) # Take CDR 452 cmp E Nil # Need list 453 if ne 454 atom E 455 jnz lstErrEX 456 end 457 ld E (E CDR) # Take CDR 458 num E # Need variable 459 jnz varErrEX 460 ld E (E) # Take CAR 461 pop X 462 ret 463 464 (code 'doCdaaar 2) 465 push X 466 ld X E 467 ld E ((E CDR)) # Get arg 468 eval 469 num E # Need variable 470 jnz varErrEX 471 ld E (E) # Take CAR 472 num E # Need variable 473 jnz varErrEX 474 ld E (E) # Take CAR 475 num E # Need variable 476 jnz varErrEX 477 ld E (E) # Take CAR 478 cmp E Nil # Need list 479 if ne 480 atom E 481 jnz lstErrEX 482 end 483 ld E (E CDR) # Take CDR 484 pop X 485 ret 486 487 (code 'doCdaadr 2) 488 push X 489 ld X E 490 ld E ((E CDR)) # Get arg 491 eval 492 cmp E Nil # Need list 493 if ne 494 atom E 495 jnz lstErrEX 496 end 497 ld E (E CDR) # Take CDR 498 num E # Need variable 499 jnz varErrEX 500 ld E (E) # Take CAR 501 num E # Need variable 502 jnz varErrEX 503 ld E (E) # Take CAR 504 cmp E Nil # Need list 505 if ne 506 atom E 507 jnz lstErrEX 508 end 509 ld E (E CDR) # Take CDR 510 pop X 511 ret 512 513 (code 'doCdadar 2) 514 push X 515 ld X E 516 ld E ((E CDR)) # Get arg 517 eval 518 num E # Need variable 519 jnz varErrEX 520 ld E (E) # Take CAR 521 cmp E Nil # Need list 522 if ne 523 atom E 524 jnz lstErrEX 525 end 526 ld E (E CDR) # Take CDR 527 num E # Need variable 528 jnz varErrEX 529 ld E (E) # Take CAR 530 cmp E Nil # Need list 531 if ne 532 atom E 533 jnz lstErrEX 534 end 535 ld E (E CDR) # Take CDR 536 pop X 537 ret 538 539 (code 'doCdaddr 2) 540 push X 541 ld X E 542 ld E ((E CDR)) # Get arg 543 eval 544 cmp E Nil # Need list 545 if ne 546 atom E 547 jnz lstErrEX 548 end 549 ld E (E CDR) # Take CDR 550 cmp E Nil # Need list 551 if ne 552 atom E 553 jnz lstErrEX 554 end 555 ld E (E CDR) # Take CDR 556 num E # Need variable 557 jnz varErrEX 558 ld E (E) # Take CAR 559 cmp E Nil # Need list 560 if ne 561 atom E 562 jnz lstErrEX 563 end 564 ld E (E CDR) # Take CDR 565 pop X 566 ret 567 568 (code 'doCddaar 2) 569 push X 570 ld X E 571 ld E ((E CDR)) # Get arg 572 eval 573 num E # Need variable 574 jnz varErrEX 575 ld E (E) # Take CAR 576 num E # Need variable 577 jnz varErrEX 578 ld E (E) # Take CAR 579 cmp E Nil # Need list 580 if ne 581 atom E 582 jnz lstErrEX 583 end 584 ld E (E CDR) # Take CDR 585 cmp E Nil # Need list 586 if ne 587 atom E 588 jnz lstErrEX 589 end 590 ld E (E CDR) # Take CDR 591 pop X 592 ret 593 594 (code 'doCddadr 2) 595 push X 596 ld X E 597 ld E ((E CDR)) # Get arg 598 eval 599 cmp E Nil # Need list 600 if ne 601 atom E 602 jnz lstErrEX 603 end 604 ld E (E CDR) # Take CDR 605 num E # Need variable 606 jnz varErrEX 607 ld E (E) # Take CAR 608 cmp E Nil # Need list 609 if ne 610 atom E 611 jnz lstErrEX 612 end 613 ld E (E CDR) # Take CDR 614 cmp E Nil # Need list 615 if ne 616 atom E 617 jnz lstErrEX 618 end 619 ld E (E CDR) # Take CDR 620 pop X 621 ret 622 623 (code 'doCdddar 2) 624 push X 625 ld X E 626 ld E ((E CDR)) # Get arg 627 eval 628 num E # Need variable 629 jnz varErrEX 630 ld E (E) # Take CAR 631 cmp E Nil # Need list 632 if ne 633 atom E 634 jnz lstErrEX 635 end 636 ld E (E CDR) # Take CDR 637 cmp E Nil # Need list 638 if ne 639 atom E 640 jnz lstErrEX 641 end 642 ld E (E CDR) # Take CDR 643 cmp E Nil # Need list 644 if ne 645 atom E 646 jnz lstErrEX 647 end 648 ld E (E CDR) # Take CDR 649 pop X 650 ret 651 652 (code 'doCddddr 2) 653 push X 654 ld X E 655 ld E ((E CDR)) # Get arg 656 eval 657 cmp E Nil # Need list 658 if ne 659 atom E 660 jnz lstErrEX 661 end 662 ld E (E CDR) # Take CDR 663 cmp E Nil # Need list 664 if ne 665 atom E 666 jnz lstErrEX 667 end 668 ld E (E CDR) # Take CDR 669 cmp E Nil # Need list 670 if ne 671 atom E 672 jnz lstErrEX 673 end 674 ld E (E CDR) # Take CDR 675 cmp E Nil # Need list 676 if ne 677 atom E 678 jnz lstErrEX 679 end 680 ld E (E CDR) # Take CDR 681 pop X 682 ret 683 684 # (nth 'lst 'cnt ..) -> lst 685 (code 'doNth 2) 686 push X 687 push Y 688 ld X E 689 ld Y (E CDR) # Y on args 690 ld E (Y) # Eval 'lst' 691 eval 692 link 693 push E # <L I> Safe 694 link 695 ld Y (Y CDR) 696 do 697 atom E # End of 'lst'? 698 while z # No 699 call evCntXY_FE # Next 'cnt' 700 ld C E # into C 701 dec C # 'cnt' greater zero? 702 if ns # Yes 703 ld E (L I) # Get result 704 do 705 dec C # Iterate 706 while ns 707 ld E (E CDR) 708 loop 709 else 710 ld E Nil # Return NIL 711 break T 712 end 713 ld Y (Y CDR) # Next arg? 714 atom Y 715 while z # Yes 716 ld E (E) # Take CAR 717 ld (L I) E # Save 718 loop 719 drop 720 pop Y 721 pop X 722 ret 723 724 # (con 'lst 'any) -> any 725 (code 'doCon 2) 726 push X 727 push Y 728 ld X E 729 ld Y (E CDR) # Y on args 730 ld E (Y) # Eval 'lst' 731 eval 732 atom E # Need pair 733 jnz pairErrEX 734 link 735 push E # <L I> Safe 736 link 737 ld Y (Y CDR) # Next arg 738 ld E (Y) # Eval 'any' 739 eval 740 ld ((L I) CDR) E # Concatenate 741 drop 742 pop Y 743 pop X 744 ret 745 746 # (cons 'any ['any ..]) -> lst 747 (code 'doCons 2) 748 push X 749 push Y 750 ld X (E CDR) # Args 751 ld E (X) # Eval first 752 eval 753 call consE_C # Cons with NIL 754 ld (C) E 755 ld (C CDR) Nil 756 link 757 push C # <L I> Safe 758 link 759 do 760 ld Y C # Y on last cell 761 ld X (X CDR) # Args 762 atom (X CDR) # more than one left? 763 while z # Yes 764 ld E (X) 765 eval # Eval next arg 766 call consE_C # Cons with NIL 767 ld (C) E 768 ld (C CDR) Nil 769 ld (Y CDR) C # Store in CDR of last cell 770 loop 771 ld E (X) # Last arg 772 eval # Eval it 773 ld (Y CDR) E # Store in CDR of last cell 774 ld E (L I) # Return pair(s) 775 drop 776 pop Y 777 pop X 778 ret 779 780 # (conc 'lst ..) -> lst 781 (code 'doConc 2) 782 push X 783 push Y 784 ld X (E CDR) # Args 785 ld E (X) # Eval first 786 eval 787 ld Y E # Keep in Y 788 link 789 push E # <L I> Safe 790 link 791 do 792 ld X (X CDR) # Next arg? 793 atom X 794 while z # Yes 795 ld E (X) 796 eval # Eval next arg 797 atom Y # Result list? 798 if nz # No 799 ld (L I) E # Init result 800 ld Y E # Keep in Y 801 else 802 do 803 atom (Y CDR) # Find end of result list 804 while z 805 ld Y (Y CDR) 806 loop 807 ld (Y CDR) E 808 end 809 loop 810 ld E (L I) # Return list 811 drop 812 pop Y 813 pop X 814 ret 815 816 # (circ 'any ..) -> lst 817 (code 'doCirc 2) 818 push X 819 push Y 820 ld X (E CDR) # Args 821 ld E (X) # Eval first 822 eval 823 call consE_C # Cons with NIL 824 ld (C) E 825 ld (C CDR) Nil 826 link 827 push C # <L I> Safe 828 link 829 do 830 ld Y C # Keep in Y 831 ld X (X CDR) # Next arg? 832 atom X 833 while z # Yes 834 ld E (X) 835 eval # Eval next arg 836 call consE_C # Cons with NIL 837 ld (C) E 838 ld (C CDR) Nil 839 ld (Y CDR) C # Store in CDR of last cell 840 loop 841 ld E (L I) # Return list 842 ld (Y CDR) E # Make circular 843 drop 844 pop Y 845 pop X 846 ret 847 848 # (rot 'lst ['cnt]) -> lst 849 (code 'doRot 2) 850 push X 851 push Y 852 ld X E 853 ld Y (E CDR) # Y on args 854 ld E (Y) # Eval 'lst' 855 eval 856 atom E # Pair? 857 if z # Yes 858 link 859 push E # <L I> Safe 860 link 861 ld Y (Y CDR) 862 atom Y # Second arg? 863 ldnz E 0 # Yes 864 if z # No 865 call evCntXY_FE # Eval 'cnt' 866 end 867 ld Y (L I) # Retrieve 'lst' 868 ld X (Y) # Keep CAR 869 do 870 dec E # Decrement count 871 while nz 872 ld Y (Y CDR) # Next cell? 873 atom Y 874 while z # Yes 875 cmp Y (L I) # Circular? 876 while ne # No 877 xchg X (Y) # Swap 878 loop 879 ld ((L I)) X # Store new CAR 880 ld E (L I) 881 drop 882 end 883 pop Y 884 pop X 885 ret 886 887 # (list 'any ['any ..]) -> lst 888 (code 'doList 2) 889 push X 890 push Y 891 ld X (E CDR) # Args 892 ld E (X) # Eval first 893 eval 894 call consE_C # Cons with NIL 895 ld (C) E 896 ld (C CDR) Nil 897 link 898 push C # <L I> Safe 899 link 900 do 901 ld Y C # Keep in Y 902 ld X (X CDR) # Next arg? 903 atom X 904 while z # Yes 905 ld E (X) 906 eval # Eval next arg 907 call consE_C # Cons with NIL 908 ld (C) E 909 ld (C CDR) Nil 910 ld (Y CDR) C # Store in CDR of last cell 911 loop 912 ld E (L I) # Return list 913 drop 914 pop Y 915 pop X 916 ret 917 918 # (need 'cnt ['lst ['any]]) -> lst 919 # (need 'cnt ['num|sym]) -> lst 920 (code 'doNeed 2) 921 push X 922 push Y 923 ld X E 924 ld Y (E CDR) # Y on args 925 call evCntXY_FE # Eval 'cnt' 926 ld X E # Keep in X 927 ld Y (Y CDR) 928 ld E (Y) # Eval next 929 eval 930 link 931 atom E # First form? 932 jz 10 # Yes 933 cmp E Nil 934 if eq # Yes 935 10 push E # <L II> 'lst' 936 ld Y (Y CDR) 937 ld E (Y) # Eval 'any' 938 eval+ 939 push E # <L I> 'any' 940 else 941 push Nil # <L II> 'lst' 942 push E # <L I> 'num|sym' 943 end 944 link 945 ld E (L II) # Get 'lst' 946 or X X # 'cnt'? 947 if nz # Yes 948 if ns # > 0 949 ld Y E # 'lst' in Y 950 do 951 atom Y # Find end of 'lst' 952 while z 953 ld Y (Y CDR) 954 dec X # Decrement 'cnt' 955 loop 956 do 957 dec X # 'cnt' > 0? 958 while ns # Yes 959 ld C E 960 call consC_E # Cons 'any' with 'lst' 961 ld (E) (L I) 962 ld (E CDR) C 963 loop 964 else 965 atom E # 'lst' atomic? 966 if nz 967 call cons_E # Cons 'any' with NIL 968 ld (E) (L I) 969 ld (E CDR) Nil 970 ld (L II) E # Save 971 else 972 do 973 ld Y (E CDR) # Find last cell 974 atom Y 975 while z 976 inc X # Increment 'cnt' 977 ld E Y 978 loop 979 end 980 do 981 inc X # Increment 'cnt' 982 while s 983 call cons_A # Cons 'any' with NIL 984 ld (A) (L I) 985 ld (A CDR) Nil 986 ld (E CDR) A # Append 987 ld E (E CDR) 988 loop 989 ld E (L II) # Get result 990 end 991 end 992 drop 993 pop Y 994 pop X 995 ret 996 997 # (range 'num1 'num2 ['num3]) -> lst 998 (code 'doRange 2) 999 push X 1000 push Y 1001 ld X E 1002 ld Y (E CDR) # Y on args 1003 ld E (Y) # Eval 'num1' 1004 eval 1005 num E # Number? 1006 jz numErrEX # No 1007 link 1008 push E # <L IV> Start value 1009 ld Y (Y CDR) 1010 ld E (Y) # Eval 'num2' 1011 eval+ 1012 num E # Number? 1013 jz numErrEX # No 1014 push E # <L III> End value 1015 push ONE # <L II> Increment 1016 ld E ((Y CDR)) # Eval 'num3' 1017 eval+ 1018 cmp E Nil # NIL? 1019 if ne # No 1020 num E # Number? 1021 jz numErrEX # No 1022 cmp E ZERO # Zero? 1023 jeq argErrEX # Yes 1024 test E SIGN # Negative? 1025 jnz argErrEX # Yes 1026 ld (S) E # Else set increment 1027 end 1028 link 1029 call cons_X # Build first cell 1030 tuck X # <L I> Result 1031 link 1032 ld (X) (L IV) # Start value 1033 ld (X CDR) Nil 1034 ld A (L IV) # Get start value 1035 ld E (L III) # and end value 1036 call cmpNumAE_F # Start <= end? 1037 ld A (L IV) # Get start value again 1038 if le # Yes 1039 do 1040 ld E (L II) # Increment start value 1041 call addAE_A 1042 push A 1043 ld E (L III) # Start <= end? 1044 call cmpNumAE_F 1045 while le # Yes 1046 pop A 1047 call consA_Y # Append to result 1048 ld (Y) A 1049 ld (Y CDR) Nil 1050 ld (X CDR) Y 1051 ld X Y 1052 loop 1053 else 1054 do 1055 ld E (L II) # Decrement start value 1056 call subAE_A 1057 push A 1058 ld E (L III) # Start >= end? 1059 call cmpNumAE_F 1060 while ge # Yes 1061 pop A 1062 call consA_Y # Append to result 1063 ld (Y) A 1064 ld (Y CDR) Nil 1065 ld (X CDR) Y 1066 ld X Y 1067 loop 1068 end 1069 ld E (L I) 1070 drop 1071 pop Y 1072 pop X 1073 ret 1074 1075 # (full 'any) -> bool 1076 (code 'doFull 2) 1077 ld E (E CDR) # Get arg 1078 ld E (E) # Eval it 1079 eval 1080 do 1081 atom E # Pair? 1082 jnz retT # Yes 1083 cmp (E) Nil # Found NIL? 1084 jz retNil # Yes 1085 ld E (E CDR) 1086 loop 1087 1088 # (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any 1089 (code 'doMake 2) 1090 push X 1091 ld X (E CDR) # Body 1092 push (EnvMake) # Save current 'make' env 1093 push (EnvYoke) 1094 link 1095 push Nil # <L I> Result 1096 ld (EnvMake) S # Tail address 1097 ld (EnvYoke) S # Head address 1098 link 1099 exec X 1100 ld E (L I) # Get result 1101 drop 1102 pop (EnvYoke) # Restore 'make' env 1103 pop (EnvMake) 1104 pop X 1105 ret 1106 1107 # (made ['lst1 ['lst2]]) -> lst 1108 (code 'doMade 2) 1109 push X 1110 ld X E 1111 null (EnvMake) # In 'make'? 1112 jz makeErrX # No 1113 push Y 1114 ld Y (E CDR) # Y on args 1115 atom Y # Any? 1116 if z # Yes 1117 ld E (Y) # Eval 'lst1' 1118 eval 1119 ld ((EnvYoke)) E # Set new list 1120 ld Y (Y CDR) 1121 ld E (Y) # Eval 'lst2' 1122 eval 1123 atom E # Pair? 1124 if nz # No 1125 ld E ((EnvYoke)) # Retrieve new 'lst1' 1126 do 1127 ld A (E CDR) # Find last cell 1128 atom A 1129 while z 1130 ld E A 1131 loop 1132 end 1133 lea E (E CDR) # Set new tail address 1134 ld (EnvMake) E 1135 end 1136 ld E ((EnvYoke)) # Return list 1137 pop Y 1138 pop X 1139 ret 1140 1141 # (chain 'lst ..) -> lst 1142 (code 'doChain 2) 1143 push X 1144 ld X E 1145 null (EnvMake) # In 'make'? 1146 jz makeErrX # No 1147 push Y 1148 ld Y (E CDR) # Y on args 1149 do 1150 ld E (Y) # Eval arg 1151 eval 1152 ld ((EnvMake)) E # Store new list 1153 atom E # Got a list? 1154 if z # Yes 1155 ld C E 1156 do 1157 ld A (C CDR) # Find last cell 1158 atom A 1159 while z 1160 ld C A 1161 loop 1162 lea C (C CDR) # Set new tail address 1163 ld (EnvMake) C 1164 end 1165 ld Y (Y CDR) # More args? 1166 atom Y 1167 until nz 1168 pop Y 1169 pop X 1170 ret 1171 1172 # (link 'any ..) -> any 1173 (code 'doLink 2) 1174 push X 1175 ld X E 1176 null (EnvMake) # In 'make'? 1177 jz makeErrX # No 1178 push Y 1179 ld Y (E CDR) # Y on args 1180 do 1181 ld E (Y) # Eval arg 1182 eval 1183 call consE_C # Make new cell 1184 ld (C) E 1185 ld (C CDR) Nil 1186 ld ((EnvMake)) C # Store new tail 1187 lea C (C CDR) # Set new tail address 1188 ld (EnvMake) C 1189 ld Y (Y CDR) # More args? 1190 atom Y 1191 until nz 1192 pop Y 1193 pop X 1194 ret 1195 1196 # (yoke 'any ..) -> any 1197 (code 'doYoke 2) 1198 push X 1199 ld X E 1200 null (EnvMake) # In 'make'? 1201 jz makeErrX # No 1202 push Y 1203 ld Y (E CDR) # Y on args 1204 do 1205 ld E (Y) # Eval arg 1206 eval 1207 call consE_A # Make new cell 1208 ld (A) E 1209 ld (A CDR) ((EnvYoke)) # Set head 1210 ld ((EnvYoke)) A 1211 ld Y (Y CDR) # More args? 1212 atom Y 1213 until nz 1214 do 1215 ld C ((EnvMake)) # Adjust tail address? 1216 atom C 1217 while z # Yes 1218 lea C (C CDR) # Set new tail address 1219 ld (EnvMake) C 1220 loop 1221 pop Y 1222 pop X 1223 ret 1224 1225 # (copy 'any) -> any 1226 (code 'doCopy 2) 1227 ld E ((E CDR)) # Eval arg 1228 eval 1229 atom E # List? 1230 if z # Yes 1231 push Z 1232 ld Z E # Keep head in Z 1233 call consE_C # Copy first cell 1234 ld (C) (E) 1235 ld (C CDR) (E CDR) 1236 link 1237 push C # <L I> Result 1238 link 1239 do 1240 ld E (E CDR) 1241 atom E # More cells? 1242 while z # Yes 1243 cmp E Z # Circular? 1244 if eq # Yes 1245 ld (C CDR) (L I) # Concat head 1246 break T 1247 end 1248 call consE_A # Copy next cell 1249 ld (A) (E) 1250 ld (A CDR) (E CDR) 1251 ld (C CDR) A # Concat to result 1252 ld C A 1253 loop 1254 ld E (L I) # Get result 1255 drop 1256 pop Z 1257 end 1258 ret 1259 1260 # (mix 'lst cnt|'any ..) -> lst 1261 (code 'doMix 2) 1262 push X 1263 ld X (E CDR) # X on args 1264 ld E (X) # Eval first 1265 eval 1266 cmp E Nil # Empty list? 1267 jz 10 # Yes 1268 atom E # Atomic? 1269 if z # No 1270 10 push Y 1271 ld X (X CDR) # Next arg? 1272 atom X 1273 if z # Yes 1274 link 1275 push E # <L II> List 1276 link 1277 ld C (X) 1278 cnt C # Literal second arg? 1279 if z # No 1280 ld E C # Eval second arg 1281 eval 1282 else 1283 shr C 4 # Normalize 1284 if le # Negative 1285 ld E Nil 1286 else 1287 do 1288 dec C # nth 1289 while nz 1290 ld E (E CDR) 1291 loop 1292 ld E (E) 1293 end 1294 end 1295 call consE_C # Cons first result cell 1296 ld (C) E 1297 ld (C CDR) Nil 1298 tuck C # <L I> Result 1299 link 1300 do 1301 ld Y C # Keep in Y 1302 ld X (X CDR) # Next arg? 1303 atom X 1304 while z # Yes 1305 ld E (X) 1306 cnt E # Literal next arg? 1307 if z # No 1308 eval # Eval next arg 1309 else 1310 shr E 4 # Normalize 1311 if le # Negative 1312 ld E Nil 1313 else 1314 ld C (L II) # Get list 1315 do 1316 dec E # nth 1317 while nz 1318 ld C (C CDR) 1319 loop 1320 ld E (C) 1321 end 1322 end 1323 call consE_C # Cons first result cell 1324 ld (C) E 1325 ld (C CDR) Nil 1326 ld (Y CDR) C # Store in CDR of last cell 1327 loop 1328 ld E (L I) # Get result 1329 drop 1330 else 1331 ld E Nil # Return NIL 1332 end 1333 pop Y 1334 end 1335 pop X 1336 ret 1337 1338 # (append 'lst ..) -> lst 1339 (code 'doAppend 2) 1340 push X 1341 ld X (E CDR) # Args 1342 do 1343 atom (X CDR) # More than one left? 1344 while z # Yes 1345 ld E (X) # Eval first 1346 eval 1347 atom E # Found a list? 1348 if z # Yes 1349 ld A E 1350 call consE_E # Copy first cell 1351 ld (E) (A) 1352 ld C (A CDR) 1353 ld (E CDR) C 1354 link 1355 push E # <L I> Result 1356 link 1357 do 1358 atom C # More cells? 1359 while z # Yes 1360 call consC_A # Copy next cell 1361 ld (A) (C) 1362 ld C (C CDR) 1363 ld (A CDR) C 1364 ld (E CDR) A # Concat to result 1365 ld E A 1366 loop 1367 push E # Save last cell 1368 do 1369 ld X (X CDR) # More than one left? 1370 atom (X CDR) 1371 while z # Yes 1372 ld E (X) # Eval next argument 1373 eval 1374 do 1375 atom E # Found a list? 1376 while z # Yes 1377 call consE_A # Copy cells 1378 ld (A) (E) 1379 ld E (E CDR) 1380 ld (A CDR) E 1381 ld ((S) CDR) A # Concat with last cell 1382 ld (S) A # New last cell 1383 loop 1384 loop 1385 ld E (X) # Eval last argument 1386 eval 1387 pop A # Get last cell 1388 ld (A CDR) E # Concat last list 1389 ld E (L I) # Get result 1390 drop 1391 pop X 1392 ret 1393 end 1394 ld X (X CDR) # Next arg 1395 loop 1396 ld E (X) # Eval last arg 1397 eval 1398 pop X 1399 ret 1400 1401 # (delete 'any 'lst) -> lst 1402 (code 'doDelete 2) 1403 push X 1404 ld X (E CDR) # Args 1405 ld E (X) # Eval 'any' 1406 eval 1407 link 1408 push E # <L II/III> 'any' 1409 ld E ((X CDR)) # Eval 'lst' 1410 eval+ 1411 push E # <L I/II> 'lst' 1412 link 1413 atom E # Atomic? 1414 if z # No 1415 ld X E # Keep in X 1416 ld A (L II) # 'any' 1417 ld E (X) # Equal to CAR? 1418 call equalAE_F 1419 if eq # Yes 1420 ld E (X CDR) # Return CDR 1421 else 1422 call cons_C # Cons first item into C 1423 ld (C) (X) 1424 ld (C CDR) Nil 1425 tuck C # <L I> Result 1426 link 1427 do 1428 ld X (X CDR) # Next item 1429 atom X # More cells? 1430 while z # Yes 1431 ld A (L III) # 'any' 1432 ld E (X) # Equal to CAR? 1433 call equalAE_F 1434 if eq # Yes 1435 ld X (X CDR) # Skip this item 1436 break T 1437 end 1438 call cons_A # Cons next item 1439 ld (A) (X) 1440 ld (A CDR) Nil 1441 ld (C CDR) A # Append 1442 ld C A 1443 loop 1444 ld (C CDR) X # Set tail 1445 ld E (L I) # Get result 1446 end 1447 end 1448 drop 1449 pop X 1450 ret 1451 1452 # (delq 'any 'lst) -> lst 1453 (code 'doDelq 2) 1454 push X 1455 ld X (E CDR) # Args 1456 ld E (X) # Eval 'any' 1457 eval 1458 link 1459 push E # <L II/III> 'any' 1460 ld E ((X CDR)) # Eval 'lst' 1461 eval+ 1462 push E # <L I/II> 'lst' 1463 link 1464 atom E # Atomic? 1465 if z # No 1466 ld X (L II) # 'any' 1467 cmp X (E) # Equal to CAR? 1468 if eq # Yes 1469 ld E (E CDR) # Return CDR 1470 else 1471 call cons_C # Cons first item into C 1472 ld (C) (E) 1473 ld (C CDR) Nil 1474 tuck C # <L I> Result 1475 link 1476 do 1477 ld E (E CDR) # Next item 1478 atom E # More cells? 1479 while z # Yes 1480 cmp X (E) # 'any' equal to CAR? 1481 if eq # Yes 1482 ld E (E CDR) # Skip this item 1483 break T 1484 end 1485 call cons_A # Cons next item 1486 ld (A) (E) 1487 ld (A CDR) Nil 1488 ld (C CDR) A # Append 1489 ld C A 1490 loop 1491 ld (C CDR) E # Set tail 1492 ld E (L I) # Get result 1493 end 1494 end 1495 drop 1496 pop X 1497 ret 1498 1499 # (replace 'lst 'any1 'any2 ..) -> lst 1500 (code 'doReplace 2) 1501 push X 1502 ld X (E CDR) # X on args 1503 ld E (X) # Eval 'lst' 1504 eval 1505 atom E # Atomic? 1506 if z # No 1507 push Y 1508 push Z 1509 link 1510 push E # Save 'lst' 1511 ld Y E # Keep in Y 1512 do 1513 ld X (X CDR) # 'anyN' args? 1514 atom X 1515 while z # Yes 1516 ld E (X) # Eval next two args 1517 eval+ 1518 push E # Save first 1519 ld X (X CDR) 1520 ld E (X) # Eval second 1521 eval+ 1522 push E # Save second 1523 loop 1524 ld X L # X above 'any1' 1525 link 1526 ld C S # C below end of 'any' items 1527 call cons_Z # Build first result cell 1528 do 1529 sub X II # Try next 'any' pair 1530 cmp X C # Reached last 'any' item? 1531 while ne # No 1532 ld A (X) # Next item 1533 ld E (Y) # Equal to CAR of 'lst'? 1534 call equalAE_F 1535 if eq # Yes 1536 ld (Z) (X -I) # First result item is 'any2' 1537 jmp 10 1538 end 1539 loop 1540 ld (Z) (Y) # First result item is CAR of 'lst' 1541 10 ld (Z CDR) Nil 1542 tuck Z # <L I> Result 1543 link 1544 do 1545 ld Y (Y CDR) # More in 'lst'? 1546 atom Y 1547 while z # Yes 1548 ld X (L) # X above 'any1' 1549 do 1550 sub X II # Try next 'any' pair 1551 cmp X C # Reached top? 1552 while ne # No 1553 ld A (X) # Next item 1554 ld E (Y) # Equal to next item in 'lst'? 1555 call equalAE_F 1556 if eq # Yes 1557 call cons_E # Build next result cell 1558 ld (E) (X -I) # Next result item 1559 jmp 20 1560 end 1561 loop 1562 call cons_E # Build next result cell 1563 ld (E) (Y) # Next result item from 'lst' 1564 20 ld (E CDR) Nil 1565 ld (Z CDR) E # Concat to result 1566 ld Z E 1567 loop 1568 ld E (L I) # Get result 1569 drop 1570 pop Z 1571 pop Y 1572 end 1573 pop X 1574 ret 1575 1576 # (strip 'any) -> any 1577 (code 'doStrip 2) 1578 ld E ((E CDR)) # Get arg 1579 eval # Eval it 1580 do 1581 atom E # List? 1582 while z # Yes 1583 cmp (E) Quote # CAR is 'quote'? 1584 while eq # Yes 1585 ld A (E CDR) # Get CDR 1586 cmp A E # Circular? 1587 while ne # No 1588 ld E A # Go to CDR 1589 loop 1590 ret 1591 1592 # (split 'lst 'any ..) -> lst 1593 (code 'doSplit 2) 1594 push X 1595 ld X (E CDR) # Args 1596 ld E (X) # Eval 'lst' 1597 eval 1598 atom E # List? 1599 if z # Yes 1600 push Y 1601 push Z 1602 link 1603 push E # Save 'lst' 1604 do 1605 ld X (X CDR) # Next 'any' arg? 1606 atom X 1607 while z # Yes 1608 ld E (X) # Eval next arg 1609 eval+ 1610 push E # and save it 1611 loop # <L III/..> 'any' items 1612 lea C (L -I) # C is top of 'any' items, and adr of 'lst' 1613 ld Y Nil 1614 push Y # <L II> Result in Y 1615 ld Z Y 1616 push Z # <L I> Sublist in Z 1617 link 1618 do 1619 lea X (L III) # X on 'any' items 1620 do 1621 cmp X C # Reached top? 1622 while ne # No 1623 ld A (X) # Next item 1624 ld E ((C)) # Equal to CAR of 'lst'? 1625 call equalAE_F 1626 if eq # Yes 1627 atom Y # Result? 1628 if nz # No 1629 call cons_Y # Initial result cell 1630 ld (Y) (L I) # with sublist 1631 ld (Y CDR) Nil 1632 ld (L II) Y # Store in result 1633 else 1634 call cons_A # New cell 1635 ld (A) (L I) # with sublist 1636 ld (A CDR) Nil 1637 ld (Y CDR) A # Concat to result 1638 ld Y A 1639 end 1640 ld Z Nil # Clear sublist 1641 ld (L I) Z 1642 jmp 10 1643 end 1644 add X I # Next 'any' item 1645 loop 1646 atom Z # Sublist? 1647 if nz # No 1648 call cons_Z # Initial sublist cell 1649 ld (Z) ((C)) 1650 ld (Z CDR) Nil 1651 ld (L I) Z # Store in sublist 1652 else 1653 call cons_A # New cell 1654 ld (A) ((C)) 1655 ld (A CDR) Nil 1656 ld (Z CDR) A # Concat to sublist 1657 ld Z A 1658 end 1659 10 ld A ((C) CDR) # Next element of 'lst' 1660 ld (C) A 1661 atom A # Any? 1662 until nz # No 1663 call cons_E # Cons final sublist 1664 ld (E) (L I) 1665 ld (E CDR) Nil 1666 atom Y # Result so far? 1667 if z # Yes 1668 ld (Y CDR) E # Concat final sublist 1669 ld E (L II) # Get result 1670 end 1671 drop 1672 pop Z 1673 pop Y 1674 end 1675 pop X 1676 ret 1677 1678 # (reverse 'lst) -> lst 1679 (code 'doReverse 2) 1680 ld E ((E CDR)) # Get arg 1681 eval # Eval it 1682 link 1683 push E # <L II> Safe 1684 link 1685 ld A Nil # Result 1686 do 1687 atom E # More cells? 1688 while z # Yes 1689 call consA_C # Cons next CAR 1690 ld (C) (E) 1691 ld (C CDR) A 1692 ld A C 1693 ld E (E CDR) 1694 loop 1695 ld E A # Return list 1696 drop 1697 ret 1698 1699 # (flip 'lst ['cnt]) -> lst 1700 (code 'doFlip 2) 1701 push X 1702 push Y 1703 ld X E 1704 ld Y (E CDR) # Y on args 1705 ld E (Y) # Eval 'lst' 1706 eval 1707 atom E # Pair? 1708 if z # Yes 1709 ld Y (Y CDR) 1710 atom Y # Second arg? 1711 if nz # No 1712 ld C (E CDR) # More than one element? 1713 atom C 1714 if z # Yes 1715 ld (E CDR) Nil # Make it the last cell 1716 do 1717 ld A (C CDR) # Get next cell 1718 ld (C CDR) E # Concat previous 1719 ld E C # Set to first 1720 atom A # Done? 1721 while z # No 1722 ld C A 1723 loop 1724 end 1725 else 1726 link 1727 push E # <L I> 'lst' 1728 link 1729 call evCntXY_FE # Eval 'cnt' 1730 ld C (L I) # Retrieve 'lst' 1731 drop 1732 ld X (C CDR) # More than one element? 1733 atom X 1734 if z # Yes 1735 dec E # 'cnt' > 1? 1736 if nsz # Yes 1737 ld (C CDR) (X CDR) # Swap first two cells 1738 ld (X CDR) C 1739 do 1740 dec E # Done? 1741 while nz # No 1742 ld A (C CDR) # More cells? 1743 atom A 1744 while z # Yes 1745 ld (C CDR) (A CDR) # Swap next two cells 1746 ld (A CDR) X 1747 ld X A 1748 loop 1749 ld C X # Return 'lst' 1750 end 1751 end 1752 ld E C # Return 'lst' 1753 end 1754 end 1755 pop Y 1756 pop X 1757 ret 1758 1759 # (trim 'lst) -> lst 1760 (code 'doTrim 2) 1761 ld E ((E CDR)) # Get arg 1762 eval # Eval it 1763 link 1764 push E # Save 1765 link 1766 call trimE_E # Trim 1767 drop 1768 ret 1769 1770 (code 'trimE_E 0) 1771 atom E # List? 1772 if z # Yes 1773 push (E) # Save CAR 1774 ld E (E CDR) # Trim CDR 1775 cmp S (StkLimit) # Stack check 1776 jlt stkErr 1777 call trimE_E 1778 cmp E Nil # All trimmed? 1779 if eq # Yes 1780 ld E (S) # Get CAR 1781 call isBlankE_F # Blank? 1782 if eq # Yes 1783 add S I # Drop CAR 1784 ld E Nil # Return NIL 1785 ret 1786 end 1787 call cons_E # New tail cell 1788 pop (E) # Copy CAR 1789 ld (E CDR) Nil 1790 ret 1791 end 1792 ld A E 1793 call consE_E # New cell 1794 pop (E) # Copy CAR 1795 ld (E CDR) A 1796 end 1797 ret 1798 1799 # (clip 'lst) -> lst 1800 (code 'doClip 2) 1801 ld E ((E CDR)) # Get arg 1802 eval # Eval it 1803 do 1804 atom E # List? 1805 jnz ret # No 1806 push E 1807 ld E (E) # CAR blank? 1808 call isBlankE_F 1809 pop E 1810 while z # Yes 1811 ld E (E CDR) # Try next 1812 loop 1813 link 1814 push E # Save 1815 link 1816 call trimE_E # Trim 1817 drop 1818 ret 1819 1820 # (head 'cnt|lst 'lst) -> lst 1821 (code 'doHead 2) 1822 push X 1823 push Y 1824 ld X E 1825 ld Y (E CDR) # Y on args 1826 ld E (Y) # Eval first 1827 ld Y (Y CDR) # Y on rest 1828 eval 1829 cmp E Nil # NIL? 1830 if ne # No 1831 atom E # 'lst' arg? 1832 if z # Yes 1833 link 1834 push E # <L I> First 'lst' 1835 link 1836 ld E (Y) # Eval second 1837 eval 1838 atom E # 'lst'? 1839 if z # Yes 1840 ld X E # 'lst' 1841 ld Y (L I) # Head list 1842 do 1843 ld A (X) 1844 ld E (Y) # Compare elements 1845 call equalAE_F # Equal? 1846 while eq # Yes 1847 ld Y (Y CDR) # Head done? 1848 atom Y 1849 if nz # Yes 1850 ld E (L I) # Return head 1851 drop 1852 pop Y 1853 pop X 1854 ret 1855 end 1856 ld X (X CDR) 1857 loop 1858 end 1859 drop 1860 jmp 10 1861 end 1862 call xCntEX_FE # 'cnt' zero? 1863 if nz # No 1864 ld X E # 'cnt' in X 1865 ld E (Y) # Eval second 1866 eval 1867 atom E # List? 1868 if z # Yes 1869 null X # 'cnt' negative? 1870 if s # Yes 1871 ld Y E 1872 do 1873 inc X # Increment 'cnt' by length 1874 ld Y (Y CDR) 1875 atom Y 1876 until nz 1877 null X # 'cnt' still negative or zero? 1878 jsz 10 # Yes 1879 end 1880 link 1881 push E # Save 'lst' 1882 link 1883 call cons_Y # Build first cell 1884 ld (Y) (E) # From CAR of 'lst' 1885 ld (Y CDR) Nil 1886 tuck Y # <L I> Result 1887 link 1888 do 1889 dec X # Counted down? 1890 while nz # No 1891 ld E (E CDR) # List done? 1892 atom E 1893 while z # No 1894 call cons_A # Build next cell 1895 ld (A) (E) # From next list item 1896 ld (A CDR) Nil 1897 ld (Y CDR) A # Concat to result 1898 ld Y A 1899 loop 1900 ld E (L I) # Get result 1901 drop 1902 end 1903 else 1904 10 ld E Nil # Return NIL 1905 end 1906 end 1907 pop Y 1908 pop X 1909 ret 1910 1911 # (tail 'cnt|lst 'lst) -> lst 1912 (code 'doTail 2) 1913 push X 1914 push Y 1915 ld X E 1916 ld Y (E CDR) # Y on args 1917 ld E (Y) # Eval first 1918 ld Y (Y CDR) # Y on rest 1919 eval 1920 cmp E Nil # NIL? 1921 if ne # No 1922 atom E # 'lst' arg? 1923 if z # Yes 1924 link 1925 push E # <L I> First 'lst' 1926 link 1927 ld E (Y) # Eval second 1928 eval 1929 atom E # 'lst'? 1930 if z # Yes 1931 ld X E # 'lst' 1932 ld Y (L I) # Tail list 1933 do 1934 ld A X 1935 ld E Y # Compare lists 1936 call equalAE_F # Equal? 1937 if eq # Yes 1938 ld E (L I) # Return tail 1939 drop 1940 pop Y 1941 pop X 1942 ret 1943 end 1944 ld X (X CDR) # List done? 1945 atom X 1946 until nz # Yes 1947 end 1948 drop 1949 jmp 10 1950 end 1951 call xCntEX_FE # 'cnt' zero? 1952 if nz # No 1953 ld X E # 'cnt' in X 1954 ld E (Y) # Eval second 1955 eval 1956 atom E # List? 1957 if z # Yes 1958 null X # 'cnt' negative? 1959 if s # Yes 1960 do 1961 ld E (E CDR) 1962 inc X # Take -nth 1963 until z 1964 else 1965 ld Y (E CDR) # Traverse CDR 1966 do 1967 dec X # Decrement 'cnt' 1968 while nz 1969 atom Y # End of list? 1970 while z # No 1971 ld Y (Y CDR) 1972 loop 1973 do 1974 atom Y # Traverse rest 1975 while z 1976 ld E (E CDR) # Step result 1977 ld Y (Y CDR) # and rest 1978 loop 1979 end 1980 end 1981 else 1982 10 ld E Nil # Return NIL 1983 end 1984 end 1985 pop Y 1986 pop X 1987 ret 1988 1989 # (stem 'lst 'any ..) -> lst 1990 (code 'doStem 2) 1991 push X 1992 push Y 1993 ld X (E CDR) # Args 1994 ld E (X) # Eval 'lst' 1995 eval 1996 link 1997 push E # Save 'lst' 1998 do 1999 ld X (X CDR) # Next 'any' arg? 2000 atom X 2001 while z # Yes 2002 ld E (X) # Eval next arg 2003 eval+ 2004 push E # and save it 2005 loop # <L I/..> 'any' items 2006 lea C (L -I) # C is top of 'any' items, and adr of 'lst' 2007 link 2008 ld Y (C) # Get 'lst' 2009 do 2010 atom Y # End of 'lst'? 2011 while z # No 2012 lea X (L I) # X on 'any' items 2013 do 2014 cmp X C # Reached top? 2015 while ne # No 2016 ld A (X) # Next item 2017 ld E (Y) # Found in 'lst'? 2018 call equalAE_F 2019 if eq # Yes 2020 ld (C) (Y CDR) # Set result 2021 break T 2022 end 2023 add X I # Next 'any' item 2024 loop 2025 ld Y (Y CDR) # Next in 'lst' 2026 loop 2027 ld E (C) # Get Result 2028 drop 2029 pop Y 2030 pop X 2031 ret 2032 2033 # (fin 'any) -> num|sym 2034 (code 'doFin 2) 2035 ld E ((E CDR)) # Get arg 2036 eval # Eval it 2037 do 2038 atom E # Final atom? 2039 while z # No 2040 ld E (E CDR) # Try next 2041 loop 2042 ret 2043 2044 # (last 'lst) -> any 2045 (code 'doLast 2) 2046 ld E ((E CDR)) # Get arg 2047 eval # Eval it 2048 atom E # List? 2049 if z # Yes 2050 do 2051 atom (E CDR) # Last cell? 2052 while z # No 2053 ld E (E CDR) # Try next 2054 loop 2055 ld E (E) # Get CAR 2056 end 2057 ret 2058 2059 # (== 'any ..) -> flg 2060 (code 'doEq 2) 2061 push X 2062 ld X (E CDR) # X on args 2063 ld E (X) 2064 eval # Eval first arg 2065 link 2066 push E # <L I> Safe 2067 link 2068 do 2069 ld X (X CDR) # More args? 2070 atom X 2071 while z # Yes 2072 ld E (X) 2073 eval # Eval next arg 2074 cmp E (L I) # Eq to first arg? 2075 if ne # No 2076 drop 2077 ld E Nil # Return NIL 2078 pop X 2079 ret 2080 end 2081 loop 2082 drop 2083 ld E TSym # Return T 2084 pop X 2085 ret 2086 2087 # (n== 'any ..) -> flg 2088 (code 'doNEq 2) 2089 push X 2090 ld X (E CDR) # X on args 2091 ld E (X) 2092 eval # Eval first arg 2093 link 2094 push E # <L I> Safe 2095 link 2096 do 2097 ld X (X CDR) # More args? 2098 atom X 2099 while z # Yes 2100 ld E (X) 2101 eval # Eval next arg 2102 cmp E (L I) # Eq to first arg? 2103 if ne # No 2104 drop 2105 ld E TSym # Return T 2106 pop X 2107 ret 2108 end 2109 loop 2110 drop 2111 ld E Nil # Return NIL 2112 pop X 2113 ret 2114 2115 # (= 'any ..) -> flg 2116 (code 'doEqual 2) 2117 push X 2118 ld X (E CDR) # X on args 2119 ld E (X) 2120 eval # Eval first arg 2121 link 2122 push E # <L I> Safe 2123 link 2124 do 2125 ld X (X CDR) # More args? 2126 atom X 2127 while z # Yes 2128 ld E (X) 2129 eval # Eval next arg 2130 ld A (L I) # Get first arg 2131 call equalAE_F # Equal to previous? 2132 if ne # No 2133 drop 2134 ld E Nil # Return NIL 2135 pop X 2136 ret 2137 end 2138 loop 2139 drop 2140 ld E TSym # Return T 2141 pop X 2142 ret 2143 2144 # (<> 'any ..) -> flg 2145 (code 'doNEqual 2) 2146 push X 2147 ld X (E CDR) # X on args 2148 ld E (X) 2149 eval # Eval first arg 2150 link 2151 push E # <L I> Safe 2152 link 2153 do 2154 ld X (X CDR) # More args? 2155 atom X 2156 while z # Yes 2157 ld E (X) 2158 eval # Eval next arg 2159 ld A (L I) # Get first arg 2160 call equalAE_F # Equal to previous? 2161 if ne # No 2162 drop 2163 ld E TSym # Return T 2164 pop X 2165 ret 2166 end 2167 loop 2168 drop 2169 ld E Nil # Return NIL 2170 pop X 2171 ret 2172 2173 # (=0 'any) -> 0 | NIL 2174 (code 'doEq0 2) 2175 ld E ((E CDR)) # Get arg 2176 eval # Eval it 2177 cmp E ZERO # Zero? 2178 jne retNil # No 2179 ret 2180 2181 # (=T 'any) -> flg 2182 (code 'doEqT 2) 2183 ld E ((E CDR)) # Get arg 2184 eval # Eval it 2185 cmp E TSym # T? 2186 jne retNil # No 2187 ret 2188 2189 # (n0 'any) -> flg 2190 (code 'doNEq0 2) 2191 ld E ((E CDR)) # Get arg 2192 eval # Eval it 2193 cmp E ZERO # Zero? 2194 jne retT # No 2195 ld E Nil 2196 ret 2197 2198 # (nT 'any) -> flg 2199 (code 'doNEqT 2) 2200 ld E ((E CDR)) # Get arg 2201 eval # Eval it 2202 cmp E TSym # T? 2203 jne retT # No 2204 ld E Nil 2205 ret 2206 2207 # (< 'any ..) -> flg 2208 (code 'doLt 2) 2209 push X 2210 ld X (E CDR) # X on args 2211 ld E (X) 2212 eval # Eval first arg 2213 link 2214 push E # <L I> Safe 2215 link 2216 do 2217 ld X (X CDR) # More args? 2218 atom X 2219 while z # Yes 2220 ld E (X) 2221 eval # Eval next arg 2222 ld A (L I) # Get previous arg 2223 ld (L I) E # Store current 2224 call compareAE_F # Compare current with previous 2225 if ge # Not greater or equal 2226 drop 2227 ld E Nil # Return NIL 2228 pop X 2229 ret 2230 end 2231 loop 2232 drop 2233 ld E TSym # Return T 2234 pop X 2235 ret 2236 2237 # (<= 'any ..) -> flg 2238 (code 'doLe 2) 2239 push X 2240 ld X (E CDR) # X on args 2241 ld E (X) 2242 eval # Eval first arg 2243 link 2244 push E # <L I> Safe 2245 link 2246 do 2247 ld X (X CDR) # More args? 2248 atom X 2249 while z # Yes 2250 ld E (X) 2251 eval # Eval next arg 2252 ld A (L I) # Get previous arg 2253 ld (L I) E # Store current 2254 call compareAE_F # Compare current with previous 2255 if gt # Not greater or equal 2256 drop 2257 ld E Nil # Return NIL 2258 pop X 2259 ret 2260 end 2261 loop 2262 drop 2263 ld E TSym # Return T 2264 pop X 2265 ret 2266 2267 # (> 'any ..) -> flg 2268 (code 'doGt 2) 2269 push X 2270 ld X (E CDR) # X on args 2271 ld E (X) 2272 eval # Eval first arg 2273 link 2274 push E # <L I> Safe 2275 link 2276 do 2277 ld X (X CDR) # More args? 2278 atom X 2279 while z # Yes 2280 ld E (X) 2281 eval # Eval next arg 2282 ld A (L I) # Get previous arg 2283 ld (L I) E # Store current 2284 call compareAE_F # Compare current with previous 2285 if le # Not greater or equal 2286 drop 2287 ld E Nil # Return NIL 2288 pop X 2289 ret 2290 end 2291 loop 2292 drop 2293 ld E TSym # Return T 2294 pop X 2295 ret 2296 2297 # (>= 'any ..) -> flg 2298 (code 'doGe 2) 2299 push X 2300 ld X (E CDR) # X on args 2301 ld E (X) 2302 eval # Eval first arg 2303 link 2304 push E # <L I> Safe 2305 link 2306 do 2307 ld X (X CDR) # More args? 2308 atom X 2309 while z # Yes 2310 ld E (X) 2311 eval # Eval next arg 2312 ld A (L I) # Get previous arg 2313 ld (L I) E # Store current 2314 call compareAE_F # Compare current with previous 2315 if lt # Not greater or equal 2316 drop 2317 ld E Nil # Return NIL 2318 pop X 2319 ret 2320 end 2321 loop 2322 drop 2323 ld E TSym # Return T 2324 pop X 2325 ret 2326 2327 # (max 'any ..) -> any 2328 (code 'doMax 2) 2329 push X 2330 push Y 2331 ld X (E CDR) # X on args 2332 ld E (X) 2333 eval # Eval first arg 2334 link 2335 push E # <L I> Result 2336 link 2337 do 2338 ld X (X CDR) # More args? 2339 atom X 2340 while z # Yes 2341 ld E (X) 2342 eval # Eval next arg 2343 ld A (L I) # Get result 2344 ld Y E # Save next arg 2345 call compareAE_F # Compare arg with result 2346 if lt # Result is less than 2347 ld (L I) Y # Set new result 2348 end 2349 loop 2350 ld E (L I) # Result 2351 drop 2352 pop Y 2353 pop X 2354 ret 2355 2356 # (min 'any ..) -> any 2357 (code 'doMin 2) 2358 push X 2359 push Y 2360 ld X (E CDR) # X on args 2361 ld E (X) 2362 eval # Eval first arg 2363 link 2364 push E # <L I> Result 2365 link 2366 do 2367 ld X (X CDR) # More args? 2368 atom X 2369 while z # Yes 2370 ld E (X) 2371 eval # Eval next arg 2372 ld A (L I) # Get result 2373 ld Y E # Save next arg 2374 call compareAE_F # Compare arg with result 2375 if gt # Result is greater 2376 ld (L I) Y # Set new result 2377 end 2378 loop 2379 ld E (L I) # Result 2380 drop 2381 pop Y 2382 pop X 2383 ret 2384 2385 # (atom 'any) -> flg 2386 (code 'doAtom 2) 2387 ld E ((E CDR)) # Get arg 2388 eval # Eval it 2389 atom E # Atom? 2390 jnz retT # Yes 2391 ld E Nil 2392 ret 2393 2394 # (pair 'any) -> any 2395 (code 'doPair 2) 2396 ld E ((E CDR)) # Get arg 2397 eval # Eval it 2398 atom E # Atom? 2399 jnz retNil # Yes 2400 ret 2401 2402 # (circ? 'any) -> any 2403 (code 'doCircQ 2) 2404 ld E ((E CDR)) # Get arg 2405 eval # Eval it 2406 atom E # Atom? 2407 jnz retNil # Yes 2408 push Y 2409 call circE_YF # Circular? 2410 ldz E Y # Yes 2411 ldnz E Nil 2412 pop Y 2413 ret 2414 2415 # (lst? 'any) -> flg 2416 (code 'doLstQ 2) 2417 ld E ((E CDR)) # Get arg 2418 eval # Eval it 2419 atom E # Pair? 2420 jz retT # Yes 2421 cmp E Nil # NIL? 2422 jeq retT # Yes 2423 ld E Nil 2424 ret 2425 2426 # (num? 'any) -> num | NIL 2427 (code 'doNumQ 2) 2428 ld E ((E CDR)) # Get arg 2429 eval # Eval it 2430 num E # Number? 2431 jz retNil # No 2432 ret 2433 2434 # (sym? 'any) -> flg 2435 (code 'doSymQ 2) 2436 ld E ((E CDR)) # Get arg 2437 eval # Eval it 2438 num E # Number? 2439 jnz retNil # Yes 2440 sym E # Symbol? 2441 jnz retT # Yes 2442 ld E Nil 2443 ret 2444 2445 # (flg? 'any) -> flg 2446 (code 'doFlgQ 2) 2447 ld E ((E CDR)) # Get arg 2448 eval # Eval it 2449 cmp E Nil # NIL? 2450 jeq retT # Yes 2451 cmp E TSym # T? 2452 jne retNil # No 2453 ret 2454 2455 # (member 'any 'lst) -> any 2456 (code 'doMember 2) 2457 push X 2458 push Y 2459 ld X (E CDR) # Args 2460 ld E (X) # Eval 'any' 2461 eval 2462 link 2463 push E # <L I> 'any' 2464 link 2465 ld E ((X CDR)) # Eval 'lst' 2466 eval 2467 ld X (L I) # Retrieve 'any' 2468 ld Y E # Get 'lst 2469 call memberXY_FY # Member? 2470 ld E Y 2471 ldnz E Nil # No 2472 drop 2473 pop Y 2474 pop X 2475 ret 2476 2477 # (memq 'any 'lst) -> any 2478 (code 'doMemq 2) 2479 push X 2480 ld X (E CDR) # Args 2481 ld E (X) # Eval 'any' 2482 eval 2483 link 2484 push E # <L I> 'any' 2485 link 2486 ld E ((X CDR)) # Eval 'lst' 2487 eval 2488 ld A (L I) # Retrieve 'any' 2489 drop # Clean up 2490 pop X 2491 ld C E # Keep head in C 2492 do 2493 atom E # List? 2494 while z # Yes 2495 cmp A (E) # Member? 2496 jeq ret # Return list 2497 ld E (E CDR) # Next item 2498 cmp C E # Hit head? 2499 jeq retNil # Yes 2500 loop 2501 cmp A E # Same atoms? 2502 jne retNil # No 2503 ret 2504 2505 # (mmeq 'lst 'lst) -> any 2506 (code 'doMmeq 2) 2507 push X 2508 ld X (E CDR) # Args 2509 ld E (X) # Eval first 2510 eval 2511 link 2512 push E # <L I> 'lst' 2513 link 2514 ld E ((X CDR)) # Eval second 2515 eval 2516 ld X (L I) # Retrieve first list 2517 ld C E # Keep second in C 2518 do 2519 atom X # Done? 2520 while z # No 2521 ld A (X) # Next item from first 2522 do 2523 atom E # List? 2524 while z # Yes 2525 cmp A (E) # Member? 2526 jeq 20 # Return list 2527 ld E (E CDR) # Next item 2528 cmp C E # Hit head? 2529 jz 10 # Yes 2530 loop 2531 cmp A E # Same atoms? 2532 jeq 20 # Yes 2533 ld X (X CDR) # Get CDR of first 2534 ld E C # Get second arg again 2535 loop 2536 10 ld E Nil # Return NIL 2537 20 drop 2538 pop X 2539 ret 2540 2541 # (sect 'lst 'lst) -> lst 2542 (code 'doSect 2) 2543 push X 2544 push Y 2545 push Z 2546 ld X (E CDR) # Args 2547 ld E (X) # Eval first 2548 eval 2549 link 2550 push E # <L III> First 'lst' 2551 ld E ((X CDR)) # Eval second arg 2552 eval+ 2553 push E # <L II> Second 'lst' 2554 push Nil # <L I> Result 2555 link 2556 ld Z 0 # Empty result cell 2557 ld X (L III) # Get first list 2558 do 2559 atom X # Done? 2560 while z # No 2561 ld X (X) # CAR of first 2562 ld Y (L II) # Second 2563 call memberXY_FY # Member? 2564 if eq # Yes 2565 null Z # Result still empty? 2566 if z # Yes 2567 call cons_Z # Build first cell 2568 ld (Z) X 2569 ld (Z CDR) Nil 2570 ld (L I) Z # Store in result 2571 else 2572 call cons_A # Build next cell 2573 ld (A) X 2574 ld (A CDR) Nil 2575 ld (Z CDR) A # Concat to result 2576 ld Z A 2577 end 2578 end 2579 ld X ((L III) CDR) # Next item in first 2580 ld (L III) X 2581 loop 2582 ld E (L I) # Get result 2583 drop 2584 pop Z 2585 pop Y 2586 pop X 2587 ret 2588 2589 # (diff 'lst 'lst) -> lst 2590 (code 'doDiff 2) 2591 push X 2592 push Y 2593 push Z 2594 ld X (E CDR) # Args 2595 ld E (X) # Eval first 2596 eval 2597 link 2598 push E # <L III> First 'lst' 2599 ld E ((X CDR)) # Eval second arg 2600 eval+ 2601 push E # <L II> Second 'lst' 2602 push Nil # <L I> Result 2603 link 2604 ld Z 0 # Empty result cell 2605 ld X (L III) # Get first list 2606 do 2607 atom X # Done? 2608 while z # No 2609 ld X (X) # CAR of first 2610 ld Y (L II) # Second 2611 call memberXY_FY # Member? 2612 if ne # No 2613 null Z # Result still empty? 2614 if z # Yes 2615 call cons_Z # Build first cell 2616 ld (Z) X 2617 ld (Z CDR) Nil 2618 ld (L I) Z # Store in result 2619 else 2620 call cons_A # Build next cell 2621 ld (A) X 2622 ld (A CDR) Nil 2623 ld (Z CDR) A # Concat to result 2624 ld Z A 2625 end 2626 end 2627 ld X ((L III) CDR) # Next item in first 2628 ld (L III) X 2629 loop 2630 ld E (L I) # Get result 2631 drop 2632 pop Z 2633 pop Y 2634 pop X 2635 ret 2636 2637 # (index 'any 'lst) -> cnt | NIL 2638 (code 'doIndex 2) 2639 push X 2640 push Y 2641 push Z 2642 ld X (E CDR) # Args 2643 ld E (X) # Eval first 2644 eval 2645 link 2646 push E # <L I> 'any' 2647 link 2648 ld E ((X CDR)) # Eval second 2649 eval 2650 ld X (L I) # Get 'any' 2651 ld Y E # and 'lst' 2652 ld Z Y # Keep head in Z 2653 ld C 1 # Count in C 2654 do 2655 atom Y # List? 2656 while z # Yes 2657 ld A X 2658 ld E (Y) 2659 call equalAE_F # Found item? 2660 if eq # Yes 2661 ld E C # Get result 2662 shl E 4 # Make short number 2663 or E CNT 2664 jmp 90 # Found 2665 end 2666 inc C # Increment result 2667 ld Y (Y CDR) # Next item 2668 cmp Z Y # Hit head? 2669 until eq # Yes 2670 ld E Nil # Not found 2671 90 drop 2672 pop Z 2673 pop Y 2674 pop X 2675 ret 2676 2677 # (offset 'lst1 'lst2) -> cnt | NIL 2678 (code 'doOffset 2) 2679 push X 2680 ld X (E CDR) # Args 2681 ld E (X) # Eval first 2682 eval 2683 link 2684 push E # <L I> 'lst1' 2685 link 2686 ld E ((X CDR)) # Eval 'lst2' 2687 eval 2688 ld C 0 # Init result 2689 ld X (L I) # Get 'lst1' 2690 do 2691 atom E # Any? 2692 while z # Yes 2693 inc C # Increment result 2694 ld A X # Get 'lst1' 2695 push E 2696 call equalAE_F # Same rest? 2697 if eq # Yes 2698 ld E C # Get result 2699 shl E 4 # Make short number 2700 or E CNT 2701 drop 2702 pop X 2703 ret 2704 end 2705 pop E 2706 ld E (E CDR) 2707 loop 2708 ld E Nil 2709 drop 2710 pop X 2711 ret 2712 2713 # (prior 'lst1 'lst2) -> lst | NIL 2714 (code 'doPrior 2) 2715 push X 2716 ld X (E CDR) # Args 2717 ld E (X) # Eval first 2718 eval 2719 link 2720 push E # <L I> 'lst1' 2721 link 2722 ld E ((X CDR)) # Eval 'lst2' 2723 eval 2724 ld C (L I) # Get 'lst1' 2725 drop 2726 pop X 2727 cmp C E # First cell? 2728 if ne # No 2729 do 2730 atom E # More? 2731 while z # Yes 2732 ld A (E CDR) 2733 cmp A C # Found prior cell? 2734 jeq ret # Yes 2735 ld E A 2736 loop 2737 end 2738 ld E Nil 2739 ret 2740 2741 # (length 'any) -> cnt | T 2742 (code 'doLength 2) 2743 ld E ((E CDR)) # Get arg 2744 eval # Eval it 2745 num E # Number? 2746 if nz # Yes 2747 ld A -2 # Scale 2748 jmp fmtNum0AE_E # Calculate length 2749 end 2750 sym E # Symbol? 2751 if z # No (list) 2752 ld C E # Keep list in C 2753 ld A ONE # Init counter 2754 do 2755 or (E) 1 # Mark 2756 ld E (E CDR) # Normal list? 2757 atom E 2758 if nz # Yes 2759 do 2760 off (C) 1 # Unmark 2761 ld C (C CDR) 2762 atom C # Done? 2763 until nz # Yes 2764 ld E A # Get count 2765 ret # Return length 2766 end 2767 test (E) 1 # Detected circularity? 2768 if nz # Yes 2769 do 2770 cmp C E # Skip non-circular part 2771 while ne 2772 off (C) 1 # Unmark 2773 ld C (C CDR) 2774 loop 2775 do 2776 off (C) 1 # Unmark circular part 2777 ld C (C CDR) 2778 cmp C E # Done? 2779 until eq # Yes 2780 ld E TSym 2781 ret # Return T 2782 end 2783 add A (hex "10") # Increment counter 2784 loop 2785 end 2786 # Symbol 2787 cmp E Nil # NIL? 2788 if eq # Yes 2789 ld E ZERO 2790 ret 2791 end 2792 push X 2793 ld X (E TAIL) 2794 ld E ZERO # Counter 2795 sym X # External symbol? 2796 if z # No 2797 call nameX_X # Get name 2798 ld C 0 2799 do 2800 call symCharCX_FACX # Next char 2801 while nz 2802 add E (hex "10") # Increment counter 2803 loop 2804 end 2805 pop X 2806 ret 2807 2808 # (size 'any) -> cnt 2809 (code 'doSize 2) 2810 push X 2811 ld X E 2812 ld E ((E CDR)) # E on arg 2813 eval # Eval 'any' 2814 num E # Number? 2815 if nz # Yes 2816 cnt E # Short number? 2817 if nz # Yes 2818 ld C ONE # Init counter 2819 shr E 3 # Normalize short, keep sign bit 2820 do 2821 shr E 8 # More bytes? 2822 while nz # Yes 2823 add C (hex "10") # Increment count 2824 loop 2825 else # Big number 2826 ld C (hex "82") # Count '8' significant bytes 2827 do 2828 ld A (E DIG) # Keep digit 2829 ld E (E BIG) # More cells? 2830 cnt E 2831 while z # Yes 2832 add C (hex "80") # Increment count by '8' 2833 loop 2834 shr E 4 # Normalize short 2835 shl A 1 # Get most significant bit of last digit 2836 addc E E # Any significant bits in short number? 2837 if nz # Yes 2838 do 2839 add C (hex "10") # Increment count 2840 shr E 8 # More bytes? 2841 until z # No 2842 end 2843 end 2844 else 2845 sym E # List? 2846 if z # Yes 2847 ld C ZERO # Init count 2848 call sizeCE_C # Count cell structures 2849 else # Symbol 2850 cmp E Nil # NIL? 2851 if eq # Yes 2852 ld C ZERO # Return zero 2853 else 2854 sym (E TAIL) # External symbol? 2855 if nz # Yes 2856 push Z 2857 call dbFetchEX 2858 ld X (E) # Get value 2859 call binSizeX_A # Calculate size 2860 add A (+ BLK 1) # plus block overhead 2861 ld Z A # Count in Z 2862 ld E (E TAIL) # Get properties 2863 off E SYM # Clear 'extern' tag 2864 do 2865 atom E # More properties? 2866 while z # Yes 2867 ld X (E) # Next property 2868 ld E (E CDR) 2869 atom X # Flag? 2870 if nz # Yes 2871 call binSizeX_A # Flag's size 2872 add Z A # Add to count 2873 add Z 2 # Plus 2 2874 else 2875 push (X) # Save value 2876 ld X (X CDR) # Get key 2877 call binSizeX_A # Calculate size 2878 add Z A # Add to count 2879 pop X # Retrieve value 2880 call binSizeX_A # Calculate size 2881 add Z A # Add to count 2882 end 2883 loop 2884 ld C Z # Get count 2885 shl C 4 # Make short number 2886 or C CNT 2887 pop Z 2888 else 2889 ld E (E TAIL) 2890 call nameE_E # Get name 2891 cmp E ZERO # Any? 2892 if eq # No 2893 ld C ZERO # Return zero 2894 else 2895 cnt E # Short name? 2896 if nz # Yes 2897 ld C ONE # Init counter 2898 shr E 4 # Normalize 2899 do 2900 shr E 8 # More bytes? 2901 while nz # Yes 2902 add C (hex "10") # Increment count 2903 loop 2904 else # Long name 2905 ld C (hex "82") # Count '8' significant bytes 2906 do 2907 ld E (E BIG) # More cells? 2908 cnt E 2909 while z # Yes 2910 add C (hex "80") # Increment count 2911 loop 2912 shr E 4 # Any significant bits in short name? 2913 if nz # Yes 2914 do 2915 add C (hex "10") # Increment count 2916 shr E 8 # More bytes? 2917 until z # No 2918 end 2919 end 2920 end 2921 end 2922 end 2923 end 2924 end 2925 ld E C # Get count 2926 pop X 2927 ret 2928 2929 (code 'sizeCE_C 0) 2930 push E # Save list 2931 do 2932 add C (hex "10") # Increment count 2933 atom (E) # Is CAR a pair? 2934 if z # Yes 2935 push E 2936 ld E (E) # Count CAR 2937 cmp S (StkLimit) # Stack check 2938 jlt stkErr 2939 call sizeCE_C 2940 pop E 2941 end 2942 or (E) 1 # Mark 2943 ld E (E CDR) # Normal list? 2944 atom E 2945 if nz # Yes 2946 pop E # Get original list 2947 do 2948 off (E) 1 # Unmark 2949 ld E (E CDR) 2950 atom E # Done? 2951 until nz # Yes 2952 ret 2953 end 2954 test (E) 1 # Detected circularity? 2955 if nz # Yes 2956 pop A # Get original list 2957 do 2958 cmp A E # Skip non-circular part 2959 while ne 2960 off (A) 1 # Unmark 2961 ld A (A CDR) 2962 loop 2963 do 2964 off (A) 1 # Unmark circular part 2965 ld A (A CDR) 2966 cmp A E # Done? 2967 until eq # Yes 2968 ret 2969 end 2970 loop 2971 2972 # (bytes 'any) -> cnt 2973 (code 'doBytes 2) 2974 push X 2975 ld E ((E CDR)) # Get arg 2976 eval # Eval it 2977 ld X E 2978 call binSizeX_A # Calculate size 2979 ld E A 2980 shl E 4 # Make short number 2981 or E CNT 2982 pop X 2983 ret 2984 2985 # (assoc 'any 'lst) -> lst 2986 (code 'doAssoc 2) 2987 push X 2988 ld X (E CDR) # Args 2989 ld E (X) # Eval 'any' 2990 eval 2991 link 2992 push E # <L I> 'any' 2993 link 2994 ld E ((X CDR)) # Eval 'lst' 2995 eval 2996 ld X E # into X 2997 do # assoc 2998 atom X # Done? 2999 if z # No 3000 atom (X) # CAR atomic? 3001 if z # No 3002 ld A (L I) # Retrieve 'any' 3003 ld E ((X)) # and CAAR 3004 call equalAE_F # Found? 3005 break eq # Yes 3006 end 3007 ld X (X CDR) # Next 3008 else 3009 ld E Nil # Return NIL 3010 drop 3011 pop X 3012 ret 3013 end 3014 loop 3015 ld E (X) # Return CAR 3016 drop 3017 pop X 3018 ret 3019 3020 # (asoq 'any 'lst) -> lst 3021 (code 'doAsoq 2) 3022 push X 3023 ld X (E CDR) # Args 3024 ld E (X) # Eval 'any' 3025 eval 3026 link 3027 push E # <L I> 'any' 3028 link 3029 ld E ((X CDR)) # Eval 'lst' 3030 eval 3031 ld A (L I) # Retrieve 'any' 3032 drop # Clean up 3033 pop X 3034 do # asoq 3035 atom E # Done? 3036 jnz retNil # Yes 3037 ld C (E) # Get CAR 3038 atom C # Atomic? 3039 if z # No 3040 cmp A (C) # Found? 3041 break eq # Yes 3042 end 3043 ld E (E CDR) # Next 3044 loop 3045 ld E C # Return CAR 3046 ret 3047 3048 # (rank 'any 'lst ['flg]) -> lst 3049 (code 'doRank 2) 3050 push X 3051 push Y 3052 push Z 3053 ld X (E CDR) # Args 3054 ld E (X) # Eval first 3055 eval 3056 link 3057 push E # <L II> 'any' 3058 ld X (X CDR) 3059 ld E (X) # Eval next 3060 eval+ 3061 push E # <L I> 'lst' 3062 link 3063 ld E ((X CDR)) # Eval 'flg' 3064 eval 3065 ld X (L I) # Get 'lst' in X 3066 atom X # Empty? 3067 if z # No 3068 ld Z 0 # Calculate length in Z 3069 ld Y X 3070 do 3071 inc Z # Increment length 3072 ld Y (Y CDR) # Next cell? 3073 atom Y 3074 until nz # No 3075 ld A ((X)) # First CAAR 3076 cmp E Nil # 'flg'? 3077 if eq # No 3078 ld E (L II) # Compare CAAR with 'any' 3079 call compareAE_F 3080 jgt 10 # Return NIL if too big 3081 do 3082 ld C Z # Length 3083 shr C 1 # One? 3084 while nz # No 3085 ld Y X # Offset Y 3086 do 3087 ld Y (Y CDR) 3088 dec C 3089 until z 3090 ld A ((Y)) # Compare CAAR 3091 ld E (L II) # with 'any' 3092 call compareAE_F # Greater? 3093 if gt # Search left half 3094 ld Y X # Move right pointer back 3095 shr Z 1 # Half length 3096 else # Search right half 3097 ld X Y # Move left pointer to offset 3098 ld C Z 3099 shr C 1 # Set length to remainder 3100 sub Z C 3101 end 3102 loop 3103 else 3104 ld E (L II) # Compare CAAR with 'any' 3105 call compareAE_F 3106 jlt 10 # Return NIL if too small 3107 do 3108 ld C Z # Length 3109 shr C 1 # One? 3110 while nz # No 3111 ld Y X # Offset Y 3112 do 3113 ld Y (Y CDR) 3114 dec C 3115 until z 3116 ld A ((Y)) # Compare CAAR 3117 ld E (L II) # with 'any' 3118 call compareAE_F # Smaller? 3119 if lt # Search left half 3120 ld Y X # Move right pointer back 3121 shr Z 1 # Half length 3122 else # Search right half 3123 ld X Y # Move left pointer to offset 3124 ld C Z 3125 shr C 1 # Set length to remainder 3126 sub Z C 3127 end 3128 loop 3129 end 3130 ld E (X) # Return CAR 3131 else 3132 10 ld E Nil 3133 end 3134 drop 3135 pop Z 3136 pop Y 3137 pop X 3138 ret 3139 3140 # (match 'lst1 'lst2) -> flg 3141 (code 'doMatch 2) 3142 push X 3143 ld X (E CDR) # Args 3144 ld E (X) # Eval 'lst1' 3145 eval 3146 link 3147 push E # <L II> Pattern 3148 ld E ((X CDR)) # Eval 'lst2' 3149 eval+ 3150 push E # <L I> Data 3151 link 3152 ld C (L II) # Pattern 3153 call matchCE_F # Match with data? 3154 ld E TSym # Yes 3155 ldnz E Nil # No 3156 drop 3157 pop X 3158 ret 3159 3160 : matchCE_F 3161 do 3162 atom C # Pattern atomic? 3163 if nz # Yes 3164 num C # Symbol? 3165 if z # Yes 3166 ld A (C TAIL) 3167 call firstByteA_B # starting with "@"? 3168 cmp B (char "@") 3169 if eq # Yes 3170 ld (C) E # Set value to matched data 3171 ret # Return 'z' 3172 end 3173 end 3174 ld A C # Check if equal 3175 jmp equalAE_F 3176 end 3177 ld X (C) # CAR of pattern 3178 num X 3179 if z 3180 sym X # Symbolic? 3181 if nz # Yes 3182 ld A (X TAIL) 3183 call firstByteA_B # starting with "@"? 3184 cmp B (char "@") 3185 if eq # Yes 3186 atom E # Data atomic? 3187 if nz # Yes 3188 ld A (C CDR) # CDR of pattern equal to data? 3189 call equalAE_F 3190 jnz ret # No 3191 ld (X) Nil # Else clear value 3192 ret # Return 'z' 3193 end 3194 push C # Save pattern 3195 push E # and Data 3196 ld C (C CDR) # Get CDRs 3197 ld E (E CDR) 3198 cmp S (StkLimit) # Stack check 3199 jlt stkErr 3200 call matchCE_F # Match? 3201 pop E 3202 pop C 3203 if eq # Yes 3204 call cons_A # Cons CAR of data with NIL 3205 ld (A) (E) 3206 ld (A CDR) Nil 3207 ld ((C)) A # Set value 3208 jmp retz 3209 end 3210 push C # Save pattern 3211 push E # and Data 3212 ld C (C CDR) # CDR of pattern 3213 cmp S (StkLimit) # Stack check 3214 jlt stkErr 3215 call matchCE_F # Match with data? 3216 pop E 3217 pop C 3218 if eq # Yes 3219 ld ((C)) Nil # Set value to NIL 3220 ret # Return 'z' 3221 end 3222 push C # Save pattern 3223 push E # and Data 3224 ld E (E CDR) # CDR of data 3225 cmp S (StkLimit) # Stack check 3226 jlt stkErr 3227 call matchCE_F # Match with pattern? 3228 pop E 3229 pop C 3230 if eq # Yes 3231 ld X (C) # Pattern symbol 3232 call cons_A # Cons CAR of data into value 3233 ld (A) (E) 3234 ld (A CDR) (X) 3235 ld (X) A # Set value 3236 jmp retz 3237 end 3238 end 3239 end 3240 end 3241 atom E # Data atomic? 3242 jnz ret # Yes 3243 push (C CDR) # Save rests 3244 push (E CDR) 3245 ld C (C) # Get CARs 3246 ld E (E) 3247 cmp S (StkLimit) # Stack check 3248 jlt stkErr 3249 call matchCE_F # Match? 3250 pop E 3251 pop C 3252 jnz ret # No 3253 loop 3254 3255 # (fill 'any ['sym|lst]) -> any 3256 (code 'doFill 2) 3257 push X 3258 ld X (E CDR) # Args 3259 ld E (X) # Eval 'any' 3260 eval 3261 link 3262 push E # <L II> Pattern 3263 ld E ((X CDR)) # Eval 'sym|lst' 3264 eval+ 3265 push E # <L I> 'sym|lst' 3266 link 3267 ld X E # in X 3268 ld E (L II) # Fill pattern 3269 call fillE_FE 3270 drop 3271 pop X 3272 ret 3273 3274 : fillE_FE 3275 num E # Data numeric? 3276 jnz ret # Return 'nz' 3277 sym E # Data symbolic? 3278 if nz # Yes 3279 cmp E (E) # Auto-quoting? 3280 jeq retnz # Yes 3281 cmp X Nil # 'sym|lst'? 3282 if eq # No 3283 cmp E At # '@'? 3284 jeq retnz # Return 'nz' 3285 ld A (E TAIL) 3286 call firstByteA_B # starting with "@"? 3287 cmp B (char "@") 3288 if eq # Yes 3289 ld E (E) # Return 'z' 3290 end 3291 ret # Else 'nz' 3292 end 3293 ld C X # 'memq' 3294 do 3295 atom C # List? 3296 while z # Yes 3297 cmp E (C) # Member? 3298 if eq # Yes 3299 ld E (E) # Return 'z' 3300 ret 3301 end 3302 ld C (C CDR) # Next element 3303 loop 3304 cmp E C # Same? 3305 if eq # Yes 3306 ld E (E) # Return 'z' 3307 end 3308 ret # Else 'nz' 3309 end 3310 push E # <S> Save 3311 ld E (E) # Recurse on CAR 3312 cmp S (StkLimit) # Stack check 3313 jlt stkErr 3314 cmp E Up # Expand expression? 3315 if eq # Yes 3316 pop E # Get pattern 3317 ld E (E CDR) # Skip '^' 3318 push (E CDR) # Save rest 3319 ld E (E) # Eval expression 3320 eval 3321 atom E # List? 3322 if nz # No 3323 pop E # Recurse on rest 3324 call fillE_FE 3325 setz # Set modified 3326 ret 3327 end 3328 pop C # Get pattern 3329 link 3330 push E # <L I> Result 3331 link 3332 ld E C # Recurse on rest 3333 call fillE_FE 3334 ld C (L I) # Result 3335 do 3336 atom (C CDR) # Find last cell 3337 while z 3338 ld C (C CDR) 3339 loop 3340 ld (C CDR) E # Set rest 3341 ld E (L I) # Get result 3342 drop 3343 setz # Modified 3344 ret 3345 end 3346 call fillE_FE # Modified? 3347 if z # Yes 3348 pop C # Get pattern 3349 link 3350 push E # <L I> Modified CAR 3351 link 3352 ld E (C CDR) # Recurse on CDR 3353 call fillE_FE 3354 call consE_A # Cons result 3355 ld (A) (L I) 3356 ld (A CDR) E 3357 ld E A 3358 drop 3359 setz # Modified 3360 ret 3361 end 3362 ld E ((S) CDR) # Recurse on CDR 3363 call fillE_FE # Modified? 3364 if z # Yes 3365 call consE_A # Cons result 3366 pop C 3367 ld (A) (C) # Unmodified CAR 3368 ld (A CDR) E # Modified CDR 3369 ld E A 3370 setz # Modified 3371 ret 3372 end 3373 pop E # Return 'nz' 3374 ret 3375 3376 ### Declarative Programming ### 3377 (code 'unifyCEYZ_F 0) 3378 10 num Y # x1 symbolic? 3379 if z 3380 sym Y 3381 if nz # Yes 3382 ld A (Y TAIL) # x1 3383 call firstByteA_B # starting with "@"? 3384 cmp B (char "@") 3385 if eq # Yes 3386 ld X ((Penv)) # Get pilog environment 3387 do 3388 ld A (X) # car(x) 3389 atom A # List? 3390 while z # Yes 3391 ld A (A) # caar(x) 3392 cmp C (A) # n1 == caaar(x)? 3393 if eq # Yes 3394 cmp Y (A CDR) # x1 == cdaar(x)? 3395 if eq # Yes 3396 ld A ((X) CDR) 3397 ld C (A) # n1 = cadar(x) 3398 ld Y (A CDR) # x1 = cddar(x) 3399 jmp 10 3400 end 3401 end 3402 ld X (X CDR) 3403 loop 3404 end 3405 end 3406 end 3407 20 num Z # x2 symbolic? 3408 if z 3409 sym Z 3410 if nz # Yes 3411 ld A (Z TAIL) # x2 3412 call firstByteA_B # starting with "@"? 3413 cmp B (char "@") 3414 if eq # Yes 3415 ld X ((Penv)) # Get pilog environment 3416 do 3417 ld A (X) # car(x) 3418 atom A # List? 3419 while z # Yes 3420 ld A (A) # caar(x) 3421 cmp E (A) # n2 == caaar(x)? 3422 if eq # Yes 3423 cmp Z (A CDR) # x2 == cdaar(x)? 3424 if eq # Yes 3425 ld A ((X) CDR) 3426 ld E (A) # n2 = cadar(x) 3427 ld Z (A CDR) # x2 = cddar(x) 3428 jmp 20 3429 end 3430 end 3431 ld X (X CDR) 3432 loop 3433 end 3434 end 3435 end 3436 cmp C E # n1 == n2? 3437 if eq # Yes 3438 ld A Y # x1 3439 push E 3440 ld E Z # x2 3441 call equalAE_F # Equal? 3442 pop E 3443 jeq ret # Yes 3444 end 3445 num Y # x1 symbolic? 3446 if z 3447 sym Y 3448 if nz # Yes 3449 ld A (Y TAIL) # x1 3450 call firstByteA_B # starting with "@"? 3451 cmp B (char "@") 3452 if eq # Yes 3453 cmp Y At # x1 == @? 3454 if ne # No 3455 call cons_A # (n1 . x1) 3456 ld (A) C 3457 ld (A CDR) Y 3458 call consA_C # (n2 . x2) 3459 ld (C) E 3460 ld (C CDR) Z 3461 call consAC_E # ((n1 . x1) . (n2 . x2)) 3462 ld (E) A 3463 ld (E CDR) C 3464 ld X (Penv) # Concat to pilog environment 3465 call consE_A 3466 ld (A) E 3467 ld (A CDR) (X) 3468 ld (X) A # Store in environment 3469 end 3470 setz 3471 ret 3472 end 3473 end 3474 end 3475 num Z # x2 symbolic? 3476 if z 3477 sym Z 3478 if nz # Yes 3479 ld A (Z TAIL) # x2 3480 call firstByteA_B # starting with "@"? 3481 cmp B (char "@") 3482 if eq # Yes 3483 cmp Z At # x2 == @? 3484 if ne # No 3485 call cons_A # (n1 . x1) 3486 ld (A) C 3487 ld (A CDR) Y 3488 call consA_C # (n2 . x2) 3489 ld (C) E 3490 ld (C CDR) Z 3491 call consAC_E # ((n2 . x2) . (n1 . x1)) 3492 ld (E CDR) A 3493 ld (E) C 3494 ld X (Penv) # Concat to pilog environment 3495 call consE_A 3496 ld (A) E 3497 ld (A CDR) (X) 3498 ld (X) A # Store in environment 3499 end 3500 setz 3501 ret 3502 end 3503 end 3504 end 3505 atom Y # x1 atomic? 3506 if z # No 3507 atom Z # x2 atomic? 3508 if z # No 3509 push ((Penv)) # Save pilog environment 3510 push C # and parameters 3511 push E 3512 push Y 3513 push Z 3514 ld Y (Y) # car(x1) 3515 ld Z (Z) # car(x2) 3516 cmp S (StkLimit) # Stack check 3517 jlt stkErr 3518 call unifyCEYZ_F # Match? 3519 pop Z 3520 pop Y 3521 pop E 3522 pop C 3523 if eq # Yes 3524 ld Y (Y CDR) # cdr(x1) 3525 ld Z (Z CDR) # cdr(x2) 3526 cmp S (StkLimit) # Stack check 3527 jlt stkErr 3528 call unifyCEYZ_F # Match? 3529 if eq # Yes 3530 lea S (S I) # Drop pilog environment 3531 ret # 'z' 3532 end 3533 end 3534 pop ((Penv)) # Restore pilog environment 3535 ret # nz 3536 end 3537 end 3538 ld A Y # Compare x1 and x2 3539 ld E Z 3540 jmp equalAE_F 3541 3542 # (prove 'lst ['lst]) -> lst 3543 (code 'doProve 2) 3544 push X 3545 ld X (E CDR) # Args 3546 ld E (X) # Eval first 3547 eval 3548 atom E # Atomic? 3549 if nz # Yes 3550 pop X 3551 ld E Nil # Return NIL 3552 ret 3553 end 3554 push Y 3555 push Z 3556 push (Penv) # Save pilog environment pointers 3557 push (Pnl) 3558 link 3559 push (At) # <L (+ IX I)> @ 3560 push E # <L IX> q 3561 ld Z E # Keep in Z 3562 ld X (X CDR) # Second arg 3563 ld E (X) # Eval debug list 3564 eval+ 3565 push E # <L VIII> dbg 3566 ld Y ((Z)) # env = caar(q) 3567 push Y # <L VII> env 3568 ld (Penv) S # Set pilog environment pointer 3569 ld (Z) ((Z) CDR) # car(q) = cdar(q) 3570 push (Y) # <L VI> n 3571 ld Y (Y CDR) 3572 push (Y) # <L V> nl 3573 ld (Pnl) S # Set pointer 3574 ld Y (Y CDR) 3575 push (Y) # <L IV> alt 3576 ld Y (Y CDR) 3577 push (Y) # <L III> tp1 3578 ld Y (Y CDR) 3579 push (Y) # <L II> tp2 3580 ld Y (Y CDR) 3581 push Nil # <L I> e 3582 link 3583 ld (L VII) Y # Set env 3584 do 3585 atom (L III) # tp1? 3586 jz 10 # Yes 3587 atom (L II) # or tp2? 3588 while z # Yes 3589 10 atom (L IV) # alt? 3590 if z # Yes 3591 ld (L I) (L VII) # e = env 3592 ld C ((L V)) # car(nl) 3593 ld Y (((L III)) CDR) # cdar(tp1) 3594 ld E (L VI) # n 3595 ld Z (((L IV))) # caar(alt) 3596 call unifyCEYZ_F # Match? 3597 if ne # No 3598 ld X ((L IV) CDR) # alt = cdr(alt) 3599 ld (L IV) X 3600 atom X # Atomic? 3601 if nz # Yes 3602 ld X (((L IX))) # env = caar(q) 3603 ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) 3604 ld (L VI) (X) # n = car(env) 3605 ld X (X CDR) # env = cdr(env) 3606 ld (L V) (X) # nl = car(env) 3607 ld X (X CDR) # env = cdr(env) 3608 ld (L IV) (X) # alt = car(env) 3609 ld X (X CDR) # env = cdr(env) 3610 ld (L III) (X) # tp1 = car(env) 3611 ld X (X CDR) # env = cdr(env) 3612 ld (L II) (X) # tp2 = car(env) 3613 ld X (X CDR) # env = cdr(env) 3614 ld (L VII) X # Set env 3615 end 3616 else 3617 atom (L VIII) # dbg? 3618 if z # Yes 3619 ld A (((L III))) # memq(caar(tp1), dbg) 3620 ld E (L VIII) 3621 do 3622 cmp A (E) # memq? 3623 if eq # Yes 3624 ld C TSym # get(caar(tp1), T) 3625 ld E (((L III))) 3626 call getEC_E 3627 ld X E 3628 ld C 0 # Index count 3629 do 3630 inc C # Increment 3631 ld A ((L IV)) # Found car(alt)? 3632 ld E (X) 3633 ld X (X CDR) 3634 call equalAE_F 3635 until eq # Yes 3636 ld A C 3637 call outWordA # Print level number 3638 call space 3639 ld E ((L III)) # car(tp1) 3640 call uniFillE_E # Fill with values 3641 call printE_E # and print 3642 call newline 3643 break T 3644 end 3645 ld E (E CDR) # Next debug symbol 3646 atom E # Any? 3647 until nz # No 3648 end 3649 atom ((L IV) CDR) # cdr(alt)? 3650 if z # Yes 3651 call cons_A # cons(tp2, e) 3652 ld (A) (L II) 3653 ld (A CDR) (L I) 3654 call consA_C # cons(tp1, @) 3655 ld (C) (L III) 3656 ld (C CDR) A 3657 call consC_A # cons(cdr(alt), @) 3658 ld (A) ((L IV) CDR) 3659 ld (A CDR) C 3660 call consA_C # cons(nl, @) 3661 ld (C) (L V) 3662 ld (C CDR) A 3663 call consC_A # cons(n, @) 3664 ld (A) (L VI) 3665 ld (A CDR) C 3666 call consA_C # cons(@, car(q)) 3667 ld (C) A 3668 ld (C CDR) ((L IX)) 3669 ld ((L IX)) C # -> car(q) 3670 end 3671 ld C (L VI) # n 3672 call cons_A # cons(n, nl) 3673 ld (A) C 3674 ld (A CDR) (L V) 3675 ld (L V) A # -> nl 3676 add C (hex "10") # Increment 3677 ld (L VI) C # -> n 3678 call cons_A # cons(cdr(tp1), tp2) 3679 ld (A) ((L III) CDR) 3680 ld (A CDR) (L II) 3681 ld (L II) A # -> tp2 3682 ld (L III) (((L IV)) CDR) # cdar(alt) -> tp1 3683 ld (L IV) Nil # alt = NIL 3684 end 3685 continue T 3686 end 3687 ld X (L III) # tp1? 3688 atom X 3689 if nz # No 3690 ld C (L II) # tp2 3691 ld (L III) (C) # tp1 = car(tp2) 3692 ld (L II) (C CDR) # tp2 = cdr(tp2) 3693 ld (L V) ((L V) CDR) # nl = cdr(nl) 3694 continue T 3695 end 3696 ld Y (X) # car(tp1) 3697 cmp Y TSym # car(tp1) == T? 3698 if eq 3699 do 3700 ld C ((L IX)) # car(q) 3701 atom C # Any? 3702 while z # Yes 3703 cmp ((C)) ((L V)) # caaar(q) >= car(nl)? 3704 while ge # Yes 3705 ld ((L IX)) (C CDR) # car(q) = cdar(q) 3706 loop 3707 ld (L III) (X CDR) # tp1 = cdr(tp1) 3708 continue T 3709 end 3710 num (Y) # caar(tp1) numeric? 3711 if nz # Yes 3712 ld Z (Y CDR) # Run Lisp body 3713 prog Z 3714 ld (L I) E # -> e 3715 ld C (Y) # Get count 3716 shr C 4 # Normalize short 3717 ld A (L V) # nl 3718 do 3719 dec C # Decrement 3720 while nsz 3721 ld A (A CDR) # Skip 3722 loop 3723 call cons_C # cons(car(A), nl) 3724 ld (C) (A) 3725 ld (C CDR) (L V) 3726 ld (L V) C # -> nl 3727 call cons_C # cons(cdr(tp1), tp2) 3728 ld (C) (X CDR) 3729 ld (C CDR) (L II) 3730 ld (L II) C # -> tp2 3731 ld (L III) (L I) # tp1 = e 3732 continue T 3733 end 3734 ld E (Y) # caar(tp1) 3735 cmp E Up # Lisp call? 3736 if eq # Yes 3737 ld Z ((Y CDR) CDR) # Run Lisp body 3738 prog Z 3739 ld (L I) E # -> e 3740 cmp E Nil # Any? 3741 jeq 20 # No 3742 ld C ((L V)) # car(nl) 3743 ld Y ((Y CDR)) # cadar(tp1) 3744 ld E C # car(nl) 3745 ld Z (L I) # e 3746 call unifyCEYZ_F # Match? 3747 jne 20 # No 3748 ld (L III) ((L III) CDR) # tp1 = cdr(tp1) 3749 continue T 3750 end 3751 ld C TSym # get(caar(tp1), T) 3752 call getEC_E 3753 ld (L IV) E # -> alt 3754 atom E # Atomic? 3755 if nz # Yes 3756 20 ld X (((L IX))) # env = caar(q) 3757 ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) 3758 ld (L VI) (X) # n = car(env) 3759 ld X (X CDR) # env = cdr(env) 3760 ld (L V) (X) # nl = car(env) 3761 ld X (X CDR) # env = cdr(env) 3762 ld (L IV) (X) # alt = car(env) 3763 ld X (X CDR) # env = cdr(env) 3764 ld (L III) (X) # tp1 = car(env) 3765 ld X (X CDR) # env = cdr(env) 3766 ld (L II) (X) # tp2 = car(env) 3767 ld X (X CDR) # env = cdr(env) 3768 ld (L VII) X # Set env 3769 end 3770 loop 3771 ld (L I) Nil # e = NIL 3772 ld X (L VII) # env 3773 do 3774 atom (X CDR) 3775 while z 3776 ld Y ((X)) # Next binding 3777 cmp (Y) ZERO # Top? 3778 if eq # Yes 3779 ld C ZERO # Look up 3780 ld E (Y CDR) 3781 call lookupCE_E 3782 call consE_A # Cons with variable 3783 ld (A) (Y CDR) 3784 ld (A CDR) E 3785 call consA_E # and e 3786 ld (E) A 3787 ld (E CDR) (L I) 3788 ld (L I) E # -> e 3789 end 3790 ld X (X CDR) 3791 loop 3792 ld (At) (L (+ IX I)) # Restore '@' 3793 ld E (L I) # Get e 3794 atom E # Atomic? 3795 if nz # Yes 3796 atom (L VII) # 'env' atomic? 3797 ld E Nil 3798 ldz E TSym # No 3799 end 3800 drop 3801 pop (Pnl) # Restore pilog environment pointers 3802 pop (Penv) 3803 pop Z 3804 pop Y 3805 pop X 3806 ret 3807 3808 (code 'lupCE_E 0) # Z 3809 num E # x symbolic? 3810 if z 3811 sym E 3812 if nz # Yes 3813 ld A (E TAIL) # x 3814 call firstByteA_B # starting with "@"? 3815 cmp B (char "@") 3816 if eq # Yes 3817 ld Z ((Penv)) # Get pilog environment 3818 do 3819 ld A (Z) # car(y) 3820 atom A # List? 3821 while z # Yes 3822 ld A (A) # caar(y) 3823 cmp C (A) # n == caaar(y)? 3824 if eq # Yes 3825 cmp E (A CDR) # x == cdaar(y)? 3826 if eq # Yes 3827 ld A ((Z) CDR) 3828 ld C (A) # n = cadar(y) 3829 ld E (A CDR) # x = cddar(y) 3830 cmp S (StkLimit) # Stack check 3831 jlt stkErr 3832 jmp lupCE_E 3833 end 3834 end 3835 ld Z (Z CDR) 3836 loop 3837 end 3838 end 3839 end 3840 atom E # Atomic? 3841 if z # No 3842 push C # Save parameters 3843 push E 3844 ld E (E) # lup(n, car(x)) 3845 cmp S (StkLimit) # Stack check 3846 jlt stkErr 3847 call lupCE_E 3848 pop A 3849 pop C 3850 link 3851 push E # Save 3852 link 3853 ld E (A CDR) # lup(n, cdr(x)) 3854 cmp S (StkLimit) # Stack check 3855 jlt stkErr 3856 call lupCE_E 3857 call consE_A # Cons 3858 ld (A) (L I) 3859 ld (A CDR) E 3860 ld E A 3861 drop 3862 end 3863 ret 3864 3865 (code 'lookupCE_E 0) # Z 3866 call lupCE_E 3867 num E # Symbolic? 3868 if z 3869 sym E 3870 if nz # Yes 3871 ld A (E TAIL) 3872 call firstByteA_B # starting with "@"? 3873 cmp B (char "@") 3874 jeq retNil # Yes 3875 end 3876 end 3877 ret 3878 3879 (code 'uniFillE_E 0) 3880 num E # Number? 3881 if z # No 3882 sym E # Symbol? 3883 if nz # Yes 3884 ld C (((Pnl))) # Get Env 3885 jmp lupCE_E # Look up 3886 end 3887 push E # Save list 3888 ld E (E) # Recurse on CAR 3889 cmp S (StkLimit) # Stack check 3890 jlt stkErr 3891 call uniFillE_E 3892 pop A # Get list 3893 link 3894 push E # Save result 3895 link 3896 ld E (A CDR) # Recurse on CDR 3897 cmp S (StkLimit) # Stack check 3898 jlt stkErr 3899 call uniFillE_E 3900 call consE_A # Return cell 3901 ld (A) (L I) 3902 ld (A CDR) E 3903 ld E A 3904 drop 3905 end 3906 ret 3907 3908 # (-> any [num]) -> any 3909 (code 'doArrow 2) 3910 push Z 3911 ld E (E CDR) # E on args 3912 ld C ((Pnl)) # Environments 3913 ld A (E CDR) 3914 num (A) # 'num' arg? 3915 if nz # Yes 3916 ld A (A) # Get count 3917 shr A 4 # Normalize short 3918 do 3919 dec A # Decrement 3920 while nsz 3921 ld C (C CDR) # Skip 3922 loop 3923 end 3924 ld C (C) # Get env 3925 ld E (E) # 'sym' 3926 call lookupCE_E 3927 pop Z 3928 ret 3929 3930 # (unify 'any) -> lst 3931 (code 'doUnify 2) 3932 push X 3933 push Y 3934 push Z 3935 ld E ((E CDR)) # Get arg 3936 eval # Eval it 3937 link 3938 push E # Save 'any' 3939 link 3940 ld A ((Pnl)) # Environments 3941 ld C ((A CDR)) # Second environment 3942 ld E (A) # First environment 3943 ld Y (L I) # 'any' 3944 ld Z Y # 'any' 3945 call unifyCEYZ_F # Match? 3946 ld E Nil 3947 if eq # Yes 3948 ld E ((Penv)) 3949 end 3950 drop 3951 pop Z 3952 pop Y 3953 pop X 3954 ret 3955 3956 ## List Merge Sort: Bill McDaniel, DDJ Jun99 ### 3957 # (sort 'lst ['fun]) -> lst 3958 (code 'doSort 2) 3959 push X 3960 push Y 3961 ld X E 3962 ld Y (E CDR) # Y on args 3963 ld E (Y) # Eval 'lst' 3964 eval 3965 atom E # List? 3966 if z # Yes 3967 push Z 3968 link 3969 push E # Save 'lst' 3970 ld E ((Y CDR)) # Eval 'fun' 3971 eval+ 3972 ld A Nil # Init local elements 3973 cmp E Nil # User function? 3974 if eq # No 3975 ld Z cmpDfltA_F # Use default sort function 3976 xchg E (S) # <L VII> out[1] 3977 else 3978 ld Z cmpUserAX_F # Use user supplied sort function 3979 xchg E (S) # 'fun' 3980 push A 3981 push A # <L VIII> Apply args 3982 push A # <L VII> out[1] 3983 end 3984 push E # <L VI> out[0] 'lst' 3985 push A # <L V> in[1] 3986 push A # <L IV> in[0] 3987 push A # <L III> last[1] 3988 push A # <L II> last[0] 3989 push A # <L I> p 3990 link 3991 push A # <L -I> tail[1] 3992 push A # <L -II> tail[0] 3993 do 3994 ld (L IV) (L VI) # in[0] = out[0] 3995 ld (L V) (L VII) # in[1] = out[1] 3996 lea Y (L IV) # &in[0] 3997 atom (L V) # in[1] list? 3998 if z # Yes 3999 ld A Y # in 4000 call (Z) # Less? 4001 if ge # No 4002 lea Y (L V) # &in[1] 4003 end 4004 end 4005 ld A (Y) # p = in[i] 4006 ld (L I) A 4007 atom A # List? 4008 if z # Yes 4009 ld (Y) (A CDR) # in[i] = cdr(in[i]) 4010 end 4011 ld (L VI) A # out[0] = p 4012 lea (L -II) (A CDR) # tail[0] = &cdr(p) 4013 ld (L III) (L VI) # last[1] = out[0] 4014 ld (A CDR) Nil # cdr(p) = Nil 4015 ld (L VII) Nil # out[1] = Nil 4016 lea (L -I) (L VII) # tail[1] = &out[1] 4017 do 4018 atom (L V) # in[1] atomic? 4019 if nz # Yes 4020 atom (L IV) # in[0] also atomic? 4021 break nz # Yes 4022 ld Y (L IV) # p = in[0] 4023 ld (L I) Y 4024 atom Y # List? 4025 if z # Yes 4026 ld (L IV) (Y CDR) # in[0] = cdr(in[0]) 4027 end 4028 ld (L II) Y # last[0] = p 4029 lea A (L II) # last 4030 call (Z) # Less? 4031 if lt # Yes 4032 xchg (L -I) (L -II) # Exchange tail[0] and tail[1] 4033 end 4034 else 4035 atom (L IV) # in[0] atomic? 4036 if nz # Yes 4037 atom (L V) # in[1] also atomic? 4038 break nz # Yes 4039 ld Y (L V) # p = in[1] 4040 ld (L I) Y 4041 ld (L II) Y # last[0] = p 4042 ld (L V) (Y CDR) # in[1] = cdr(in[1]) 4043 lea A (L II) # last 4044 call (Z) # Less? 4045 if lt # Yes 4046 xchg (L -I) (L -II) # Exchange tail[0] and tail[1] 4047 end 4048 else # Both in[0] and in[1] are lists 4049 lea A (L II) # last 4050 ld (A) (L IV) # last[0] = in[0] 4051 call (Z) # Less? 4052 if lt # Yes 4053 lea A (L II) # last 4054 ld (A) (L V) # last[0] = in[1] 4055 call (Z) # Less? 4056 if ge # No 4057 ld Y (L V) # p = in[1] 4058 ld (L I) Y 4059 ld (L V) (Y CDR) # in[1] = cdr(in[1]) 4060 else 4061 lea A (L IV) # in 4062 call (Z) # Less? 4063 if lt # Yes 4064 ld Y (L IV) # p = in[0] 4065 ld (L I) Y 4066 ld (L IV) (Y CDR) # in[0] = cdr(in[0]) 4067 else 4068 ld Y (L V) # p = in[1] 4069 ld (L I) Y 4070 ld (L V) (Y CDR) # in[1] = cdr(in[1]) 4071 end 4072 xchg (L -I) (L -II) # Exchange tail[0] and tail[1] 4073 end 4074 else 4075 lea A (L II) # last 4076 ld (A) (L V) # last[0] = in[1] 4077 call (Z) # Less? 4078 if lt # Yes 4079 ld Y (L IV) # p = in[0] 4080 ld (L I) Y 4081 ld (L IV) (Y CDR) # in[0] = cdr(in[0]) 4082 else 4083 lea A (L IV) # in 4084 call (Z) # Less? 4085 if lt # Yes 4086 ld Y (L IV) # p = in[0] 4087 ld (L I) Y 4088 ld (L IV) (Y CDR) # in[0] = cdr(in[0]) 4089 else 4090 ld Y (L V) # p = in[1] 4091 ld (L I) Y 4092 ld (L V) (Y CDR) # in[1] = cdr(in[1]) 4093 end 4094 end 4095 end 4096 end 4097 end 4098 ld ((L -II)) Y # *tail[0] = p 4099 lea (L -II) (Y CDR) # tail[0] = &cdr(p) 4100 ld (Y CDR) Nil # cdr(p) = Nil 4101 ld (L III) Y # last[1] = p 4102 loop 4103 atom (L VII) # out[1] 4104 until nz 4105 ld E (L VI) # Return out[0] 4106 drop 4107 pop Z 4108 end 4109 pop Y 4110 pop X 4111 ret 4112 4113 (code 'cmpDfltA_F 0) 4114 ld E ((A I)) # Get CAR of second item 4115 ld A ((A)) # and CAR of first item 4116 jmp compareAE_F # Build-in compare function 4117 4118 (code 'cmpUserAX_F 0) 4119 push Y 4120 push Z 4121 lea Z (L VIII) # Point Z to apply args 4122 ld (Z) ((A I)) # Copy CAR of second item 4123 ld (Z I) ((A)) # and CAR of first item 4124 lea Y (Z II) # Point Y to 'fun' 4125 call applyXYZ_E # Apply 4126 cmp E Nil # Check result 4127 if ne 4128 setc # Set carry if "less" 4129 end 4130 pop Z 4131 pop Y 4132 ret 4133 4134 # vi:et:ts=3:sw=3