big.l (72413B)
1 # 07jun12abu 2 # (c) Software Lab. Alexander Burger 3 4 ### Destructive primitives ### 5 # Remove leading zeroes 6 (code 'zapZeroA_A 0) 7 push A # Save number 8 ld C S # Short-tail in C 9 ld E C # Null-tail in E 10 do 11 cnt (A BIG) # Last cell? 12 while z # No 13 null (A DIG) # Null digit? 14 if nz # No 15 ld E C # New null-tail 16 end 17 lea C (A BIG) # New short-tail 18 ld A (C) # Next cell 19 loop 20 cmp (A BIG) ZERO # Trailing short zero? 21 if eq # Yes 22 ld A (A DIG) 23 null A # Null digit? 24 if nz # No 25 test A (hex "F000000000000000") # Fit in short number? 26 if z # Yes 27 shl A 4 # Make short number 28 or A CNT 29 ld (C) A # Store in short-tail 30 end 31 else 32 ld A ((E) DIG) # Digit in null-tail 33 test A (hex "F000000000000000") # Fit in short number? 34 if nz # No 35 ld ((E) BIG) ZERO # Trim null-tail 36 else 37 shl A 4 # Make short number 38 or A CNT 39 ld (E) A # Store in null-tail 40 end 41 end 42 end 43 pop A # Result 44 ret 45 46 # Multiply (unsigned) number by 2 47 (code 'twiceA_A 0) 48 cnt A # A short? 49 if nz # Yes 50 xor A 3 # Prepare tag bit 51 shl A 1 # Shift left 52 jnc Ret # Done 53 rcr A 1 # Else normalize 54 shr A 3 55 jmp boxNumA_A # Return bignum 56 end 57 : twiceBigA_A 58 push A # Save bignum 59 ld C (A DIG) # Lowest digit 60 shl C 1 # Shift left 61 do 62 push F # Save carry 63 ld (A DIG) C # Store digit 64 ld E (A BIG) # Next cell 65 cnt E # End of bignum? 66 while z # No 67 ld A E 68 ld C (A DIG) # Next digit 69 pop F 70 rcl C 1 # Rotate left 71 loop 72 shr E 4 # Normalize 73 pop F 74 rcl E 1 # Rotate left 75 test E (hex "F000000000000000") # Fit in short number? 76 if z # Yes 77 shl E 4 # Make short number 78 or E CNT 79 else 80 call boxNumE_E # New cell 81 end 82 ld (A BIG) E # Store in final cell 83 pop A # Return bignum 84 ret 85 86 # Divide (unsigned) number by 2 87 (code 'halfA_A 0) 88 cnt A # A short? 89 if nz # Yes 90 shr A 1 # Shift right 91 off A 9 # Clear lowest bit and tag 92 or A CNT # Make short number 93 ret 94 end 95 ld C (A DIG) # Lowest digit 96 ld E (A BIG) # Next cell 97 cnt E # Any? 98 if nz # No 99 shr E 5 # Normalize and shift right 100 if nz # Non-empty 101 rcr C 1 # Rotate right 102 else 103 rcr C 1 # Rotate right 104 test C (hex "F000000000000000") # Fit in short number? 105 if z # Yes 106 shl C 4 # Return short number 107 or C CNT 108 ld A C 109 ret 110 end 111 end 112 ld (A DIG) C # Store lowest digit 113 shl E 4 # Make short number 114 or E CNT 115 ld (A BIG) E # Store in the cell 116 ret 117 end 118 push A # Save bignum 119 do 120 test (E DIG) 1 # Shift bit? 121 if nz # Yes 122 setc 123 end 124 rcr C 1 # Rotate right with carry 125 ld (A DIG) C # Store digit 126 ld C (E BIG) # More cells? 127 cnt C 128 while z # Yes 129 ld A E # Advance pointers 130 ld E C 131 ld C (A DIG) # Next digit 132 loop 133 shr C 5 # Normalize and shift right 134 if nz # Non-empty 135 rcr (E DIG) 1 # Shift previous digit 136 shl C 4 # Make short number 137 or C CNT 138 else 139 ld C (E DIG) # Shift previous digit 140 rcr C 1 141 test C (hex "F000000000000000") # Fit in short number? 142 if z # Yes 143 shl C 4 # Make short number 144 or C CNT 145 ld (A BIG) C 146 pop A # Return bignum 147 ret 148 end 149 ld (E DIG) C 150 ld C ZERO 151 end 152 ld (E BIG) C # Store in the cell 153 pop A # Return bignum 154 ret 155 156 # Multiply (unsigned) number by 10 157 (code 'tenfoldA_A 0) 158 cnt A # A short? 159 if nz # Yes 160 shr A 4 # Normalize 161 mul 10 # Multiply by 10 162 test A (hex "F000000000000000") # Fit in short number? 163 jnz boxNumA_A # No: Return bignum 164 shl A 4 # Make short number 165 or A CNT 166 ret 167 end 168 push X 169 push A # Save bignum 170 ld X A # Bignum in X 171 ld A (X DIG) # Multiply lowest digit by 10 172 mul 10 173 do 174 ld (X DIG) A # Store lower word 175 ld E C # Keep upper word in E 176 ld A (X BIG) # Next cell 177 cnt A # End of bignum? 178 while z # No 179 ld X A 180 ld A (X DIG) # Next digit 181 mul 10 # Multiply by 10 182 add D E # Add previous upper word 183 loop 184 shr A 4 # Normalize 185 mul 10 # Multiply by 10 186 add A E # Add previous upper word 187 test A (hex "F000000000000000") # Fit in short number? 188 if z # Yes 189 shl A 4 # Make short number 190 or A CNT 191 else 192 call boxNumA_A # Return bignum 193 end 194 ld (X BIG) A # Store in final cell 195 pop A # Return bignum 196 pop X 197 ret 198 199 ### Non-destructive primitives ### 200 # Multiply (unsigned) number by 2 201 (code 'shluA_A 0) 202 cnt A # A short? 203 if nz # Yes 204 xor A 3 # Prepare tag bit 205 shl A 1 # Shift left 206 jnc Ret # Done 207 rcr A 1 # Else normalize 208 shr A 3 209 jmp boxNumA_A # Return bignum 210 end 211 call boxNum_E # Build new head 212 ld (E DIG) (A DIG) # Lowest digit 213 link 214 push E # <L I> Result 215 link 216 shl (E DIG) 1 # Shift left 217 push F # Save carry 218 do 219 ld A (A BIG) # Next cell 220 cnt A # End of bignum? 221 while z # No 222 call boxNum_C # Build next cell 223 ld (E BIG) C 224 ld E (A DIG) # Next digit 225 pop F 226 rcl E 1 # Rotate left 227 push F # Save carry 228 ld (C DIG) E 229 ld E C 230 loop 231 shr A 4 # Normalize 232 pop F 233 rcl A 1 # Rotate left 234 test A (hex "F000000000000000") # Fit in short number? 235 if z # Yes 236 shl A 4 # Make short number 237 or A CNT 238 else 239 call boxNumA_A # New cell 240 end 241 ld (E BIG) A # Store in final cell 242 ld A (L I) # Return bignum 243 drop 244 ret 245 246 # Divide (unsigned) number by 2 247 (code 'shruA_A 0) 248 cnt A # A short? 249 if nz # Yes 250 shr A 1 # Shift right 251 off A 9 # Clear lowest bit and tag 252 or A CNT # Make short number 253 ret 254 end 255 ld E (A BIG) # Next cell 256 cnt E # Any? 257 if nz # No 258 ld C (A DIG) # Lowest digit 259 shr E 5 # Normalize and shift right 260 if nz # Non-empty 261 rcr C 1 # Rotate right 262 else 263 rcr C 1 # Rotate right 264 test C (hex "F000000000000000") # Fit in short number? 265 if z # Yes 266 shl C 4 # Return short number 267 or C CNT 268 ld A C 269 ret 270 end 271 end 272 shl E 4 # Make short number 273 or E CNT 274 jmp consNumCE_A # Return bignum 275 end 276 call boxNum_C # Build new head 277 ld (C DIG) (A DIG) # Lowest digit 278 link 279 push C # <L I> Result 280 link 281 do 282 test (E DIG) 1 # Shift bit? 283 if nz # Yes 284 setc 285 end 286 rcr (C DIG) 1 # Rotate right with carry 287 cnt (E BIG) # More cells? 288 while z # Yes 289 call boxNum_A # Build next digit 290 ld (A DIG) (E DIG) 291 ld (C BIG) A 292 ld E (E BIG) # Advance pointers 293 ld C A 294 loop 295 ld A (E BIG) # Final short number 296 shr A 5 # Normalize and shift right 297 if nz # Non-empty 298 ld E (E DIG) # Shift previous digit 299 rcr E 1 300 shl A 4 # Make short number 301 or A CNT 302 call consNumEA_E # Last cell 303 ld (C BIG) E # Store in the cell 304 else 305 ld E (E DIG) # Shift previous digit 306 rcr E 1 307 test E (hex "F000000000000000") # Fit in short number? 308 if z # Yes 309 shl E 4 # Make short number 310 or E CNT 311 ld (C BIG) E 312 ld A (L I) # Return bignum 313 drop 314 ret 315 end 316 call boxNum_A # New cell 317 ld (A DIG) E 318 ld (C BIG) A 319 end 320 ld A (L I) # Return bignum 321 drop 322 ret 323 324 # Bitwise AND of two (unsigned) numbers 325 (code 'anduAE_A 0) 326 cnt A # A short? 327 if nz # Yes 328 cnt E # E also short? 329 if z # No 330 ld E (E DIG) # Get digit 331 shl E 4 # Make short number 332 or E CNT 333 end 334 and A E # Return short number 335 ret 336 end 337 # A is big 338 cnt E # E short? 339 if nz # Yes 340 ld A (A DIG) # Get digit 341 shl A 4 # Make short number 342 or A CNT 343 and A E # Return short number 344 ret 345 end 346 # Both are big 347 push X 348 link 349 push ZERO # <L I> Result 350 link 351 ld C (A DIG) # AND first digits 352 and C (E DIG) 353 call boxNum_X # Make bignum 354 ld (X DIG) C 355 ld (L I) X # Init result 356 do 357 ld A (A BIG) # Get tails 358 ld E (E BIG) 359 cnt A # End of A? 360 if nz # Yes 361 cnt E # Also end of E? 362 if z # No 363 ld E (E DIG) # Get digit 364 shl E 4 # Make short number 365 or E CNT 366 end 367 and A E # Concat short 368 ld (X BIG) A 369 ld A (L I) # Return bignum 370 drop 371 pop X 372 jmp zapZeroA_A # Remove leading zeroes 373 end 374 cnt E # End of E? 375 if nz # Yes 376 ld A (A DIG) # Get digit 377 shl A 4 # Make short number 378 or A CNT 379 and A E # Concat short 380 ld (X BIG) A 381 ld A (L I) # Return bignum 382 drop 383 pop X 384 jmp zapZeroA_A # Remove leading zeroes 385 end 386 ld C (A DIG) # AND digits 387 and C (E DIG) 388 call consNumCE_C # New bignum cell 389 ld (X BIG) C # Concat to result 390 ld X C 391 loop 392 393 # Bitwise OR of two (unsigned) numbers 394 (code 'oruAE_A 0) 395 cnt A # A short? 396 if nz # Yes 397 cnt E # E also short? 398 if nz # Yes 399 or A E # Return short number 400 ret 401 end 402 shr A 4 # Normalize 403 or A (E DIG) # OR digit 404 ld E (E BIG) # Rest of E 405 jmp consNumAE_A # Append rest 406 end 407 # A is big 408 cnt E # E short? 409 if nz # Yes 410 shr E 4 # Normalize 411 or E (A DIG) # OR digit 412 ld A (A BIG) # Rest of A 413 jmp consNumEA_A # Append rest 414 end 415 # Both are big 416 push X 417 link 418 push ZERO # <L I> Result 419 link 420 ld C (A DIG) # OR first digits 421 or C (E DIG) 422 call boxNum_X # Make bignum 423 ld (X DIG) C 424 ld (L I) X # Init result 425 do 426 ld A (A BIG) # Get tails 427 ld E (E BIG) 428 cnt A # End of A? 429 if nz # Yes 430 cnt E # Also end of E? 431 if nz # Yes 432 or A E # Concat short number 433 else 434 shr A 4 # Normalize 435 or A (E DIG) # OR digit 436 ld E (E BIG) # Rest of E 437 call consNumAE_A # Append rest 438 end 439 ld (X BIG) A 440 ld A (L I) # Return bignum 441 drop 442 pop X 443 ret 444 end 445 cnt E # End of E? 446 if nz # Yes 447 shr E 4 # Normalize 448 or E (A DIG) # OR digit 449 ld A (A BIG) # Rest of A 450 call consNumEA_A # Append rest 451 ld (X BIG) A 452 ld A (L I) # Return bignum 453 drop 454 pop X 455 ret 456 end 457 ld C (A DIG) # OR digits 458 or C (E DIG) 459 call consNumCE_C # New bignum cell 460 ld (X BIG) C # Concat to result 461 ld X C 462 loop 463 464 # Bitwise XOR of two (unsigned) numbers 465 (code 'xoruAE_A 0) 466 cnt A # A short? 467 if nz # Yes 468 cnt E # E also short? 469 if nz # Yes 470 xor A E # Return short number 471 or A CNT 472 ret 473 end 474 shr A 4 # Normalize 475 xor A (E DIG) # XOR digit 476 ld E (E BIG) # Rest of E 477 call consNumAE_A # Append rest 478 jmp zapZeroA_A # Remove leading zeroes 479 end 480 # A is big 481 cnt E # E short? 482 if nz # Yes 483 shr E 4 # Normalize 484 xor E (A DIG) # XOR digit 485 ld A (A BIG) # Rest of A 486 call consNumEA_A # Append rest 487 jmp zapZeroA_A # Remove leading zeroes 488 end 489 # Both are big 490 push X 491 link 492 push ZERO # <L I> Result 493 link 494 ld C (A DIG) # XOR first digits 495 xor C (E DIG) 496 call boxNum_X # Make bignum 497 ld (X DIG) C 498 ld (L I) X # Init result 499 do 500 ld A (A BIG) # Get tails 501 ld E (E BIG) 502 cnt A # End of A? 503 if nz # Yes 504 cnt E # Also end of E? 505 if nz # Yes 506 xor A E # Concat short number 507 or A CNT 508 else 509 shr A 4 # Normalize 510 xor A (E DIG) # XOR digit 511 ld E (E BIG) # Rest of E 512 call consNumAE_A # Append rest 513 end 514 ld (X BIG) A 515 ld A (L I) # Return bignum 516 drop 517 pop X 518 jmp zapZeroA_A # Remove leading zeroes 519 end 520 cnt E # End of E? 521 if nz # Yes 522 shr E 4 # Normalize 523 xor E (A DIG) # XOR digit 524 ld A (A BIG) # Rest of A 525 call consNumEA_A # Append rest 526 ld (X BIG) A 527 ld A (L I) # Return bignum 528 drop 529 pop X 530 jmp zapZeroA_A # Remove leading zeroes 531 end 532 ld C (A DIG) # XOR digits 533 xor C (E DIG) 534 call consNumCE_C # New bignum cell 535 ld (X BIG) C # Concat to result 536 ld X C 537 loop 538 539 # Add two (unsigned) numbers 540 (code 'adduAE_A 0) 541 cnt A # A short? 542 if nz # Yes 543 cnt E # E also short? 544 jz 10 # No: Jump 545 off E CNT # Else clear tag 546 add A E # Add short numbers 547 jnc Ret # Done 548 rcr A 1 # Get top bit 549 shr A 3 # Normalize 550 jmp boxNumA_A # Return bignum 551 end 552 # A is big 553 cnt E # E short? 554 if nz # Yes 555 xchg A E # Exchange args 556 10 shr A 4 # Normalize short 557 add A (E DIG) # Add first digit 558 ld E (E BIG) # Tail in E 559 jnc consNumAE_A # Cons new cell if no carry 560 call consNumAE_A # Else build new head 561 link 562 push A # <L I> Result 563 link 564 do 565 cnt E # Short number? 566 if nz # Yes 567 add E (hex "10") # Add carry 568 if nc # No further carry 569 ld (A BIG) E # Append it 570 else # Again carry 571 rcr E 1 # Get top bit 572 shr E 3 # Normalize 573 call boxNum_C # New cell 574 ld (C DIG) E 575 ld (A BIG) C # Append it 576 end 577 ld A (L I) # Return bignum 578 drop 579 ret 580 end 581 ld C (E DIG) # Next digit 582 ld E (E BIG) 583 add C 1 # Add carry 584 if nc # None 585 call consNumCE_E # New last cell 586 ld (A BIG) E 587 ld A (L I) # Return bignum 588 drop 589 ret 590 end 591 call consNumCE_C # New cell 592 ld (A BIG) C # Append it 593 ld A C # Tail of result 594 loop 595 end 596 # Both are big 597 push X 598 link 599 push ZERO # <L I> Result 600 link 601 ld C (A DIG) # Add first digits 602 add C (E DIG) 603 push F # Save carry 604 call boxNum_X # Make bignum 605 ld (X DIG) C 606 ld (L I) X # Init result 607 do 608 ld A (A BIG) # Get tails 609 ld E (E BIG) 610 cnt A # End of A? 611 if nz # Yes 612 cnt E # Also end of E? 613 jz 20 # No: Jump 614 shr A 4 # Normalize A 615 shr E 4 # Normalize E 616 pop F 617 addc A E # Add final shorts with carry 618 shl A 4 619 if nc 620 or A CNT # Make short number 621 else # Again carry 622 rcr A 1 # Get top bit 623 shr A 3 # Normalize 624 call boxNumA_A # Make bignum 625 end 626 ld (X BIG) A 627 ld A (L I) # Return bignum 628 drop 629 pop X 630 ret 631 end 632 cnt E # End of E? 633 if nz # Yes 634 xchg A E # Exchange args 635 20 shr A 4 # Normalize A 636 pop F 637 addc A (E DIG) # Add next digit with carry 638 do 639 ld E (E BIG) 640 if nc # No carry 641 call consNumAE_A # Append rest 642 ld (X BIG) A 643 ld A (L I) # Return bignum 644 drop 645 pop X 646 ret 647 end 648 call consNumAE_A # New cell 649 ld (X BIG) A # Concat to result 650 ld X A # Pointer to last cell 651 cnt E # End of E? 652 if nz # Yes 653 add E (hex "10") # Add carry 654 if nc # No further carry 655 ld (X BIG) E # Append it 656 else # Again carry 657 rcr E 1 # Get top bit 658 shr E 3 # Normalize 659 call boxNum_C # New cell 660 ld (C DIG) E 661 ld (X BIG) C # Append it 662 end 663 ld A (L I) # Return bignum 664 drop 665 pop X 666 ret 667 end 668 ld A (E DIG) # Add carry to next digit 669 add A 1 670 loop 671 end 672 ld C (A DIG) # Add digits 673 pop F 674 addc C (E DIG) 675 push F 676 call consNumCE_C # New bignum cell 677 ld (X BIG) C # Concat to result 678 ld X C 679 loop 680 681 # Subtract two (unsigned) numbers 682 (code 'subuAE_A 0) 683 cnt A # A short? 684 if nz # Yes 685 cnt E # E also short? 686 if nz # Yes 687 off E CNT # Clear tag 688 sub A E # Subtract short numbers 689 jnc Ret # Done 690 xor A -16 # 2-complement 691 add A (hex "18") 692 ret 693 end 694 xchg A E # Exchange args 695 call 10 # Subtract short from big 696 cmp A ZERO # Zero? 697 if ne # No 698 or A SIGN # Set negative 699 end 700 ret 701 end 702 # A is big 703 cnt E # E short? 704 if nz # Yes 705 10 shr E 4 # Normalize short 706 ld C (A DIG) 707 sub C E # Subtract from first digit 708 ld E (A BIG) # Tail in E 709 if nc # No borrow 710 cmp E ZERO # Leading zero? 711 jne consNumCE_A # No: Cons new cell 712 test C (hex "F000000000000000") # Fit in short number? 713 jnz consNumCE_A # No: Cons new cell 714 ld A C # Get digit 715 shl A 4 # Make short number 716 or A CNT 717 ret 718 end 719 call consNumCE_A # Else build new head 720 link 721 push A # <L I> Result 722 link 723 do 724 cnt E # Short number? 725 if nz # Yes 726 sub E (hex "10") # Subtract borrow 727 if c # Again borrow: Must be the first pass 728 ld A C # C still has lowest digit 729 neg A # Negate 730 shl A 4 731 or A (| SIGN CNT) # Make short negative number 732 drop 733 ret 734 end 735 ld (A BIG) E # Append it 736 ld A (L I) # Return bignum 737 drop 738 jmp zapZeroA_A # Remove leading zeroes 739 end 740 ld C (E DIG) # Next digit 741 ld E (E BIG) 742 sub C 1 # Subtract borrow 743 if nc # None 744 call consNumCE_E # New last cell 745 ld (A BIG) E # Append it 746 ld A (L I) # Return bignum 747 drop 748 jmp zapZeroA_A # Remove leading zeroes 749 end 750 call consNumCE_C # New cell 751 ld (A BIG) C # Append it 752 ld A C # Tail of result 753 loop 754 end 755 # Both are big 756 push X 757 link 758 push ZERO # <L I> Result 759 link 760 ld C (A DIG) # Subtract first digits 761 sub C (E DIG) 762 push F # Save borrow 763 ld A (A BIG) # Get tail 764 call consNumCA_C # First bignum cell 765 ld (L I) C # Init result 766 do 767 ld X C # Keep last cell in X 768 ld E (E BIG) # Get tail 769 cnt E # End of E? 770 if nz # Yes 771 shr E 4 # Normalize E 772 do 773 cnt A # Also end of A? 774 while z # No 775 ld C (A DIG) # Subtract final digit with borrow 776 ld A (A BIG) # Next cell 777 pop F 778 subc C E # Borrow again? 779 if nc # No 780 call consNumCA_C # Final new bignum tail 781 ld (X BIG) C # Concat to result 782 20 ld A (L I) # Return bignum 783 drop 784 pop X 785 jmp zapZeroA_A # Remove leading zeroes 786 end 787 push F # Save borrow 788 call consNumCA_C # New bignum tail 789 ld (X BIG) C # Concat to result 790 ld X C # Keep last cell 791 ld E 0 792 loop 793 shr A 4 # Normalize A 794 break T 795 end 796 cnt A # End of A? 797 if nz # Yes 798 shr A 4 # Normalize A 799 do 800 pop F 801 subc A (E DIG) # Subtract next digit with borrow 802 push F 803 call boxNum_C # New bignum tail 804 ld (C DIG) A 805 ld (X BIG) C # Concat to result 806 ld X C # Keep last cell 807 ld E (E BIG) # Next cell 808 ld A 0 809 cnt E # Also end of E? 810 until nz # Yes 811 shr E 4 # Normalize E 812 break T 813 end 814 ld C (A DIG) # Subtract digits 815 pop F 816 subc C (E DIG) 817 push F # Save borrow 818 ld A (A BIG) 819 call consNumCA_C # New bignum cell 820 ld (X BIG) C # Concat to result 821 loop 822 pop F 823 subc A E # Subtract final shorts with borrow 824 push F # Save borrow 825 shl A 4 826 or A CNT # Make short number 827 ld (X BIG) A 828 pop F # Borrow? 829 jnc 20 # No 830 ld A (L I) # Get result 831 ld E A # 2-complement 832 do 833 not (E DIG) # Invert 834 ld C (E BIG) # Next digit 835 cnt C # Done? 836 while z # No 837 ld E C # Next digit 838 loop 839 xor C -16 # Invert final short 840 ld (E BIG) C 841 ld E A # Result again 842 do 843 add (E DIG) 1 # Increment 844 jnc 90 # Skip if no carry 845 ld C (E BIG) # Next digit 846 cnt C # Done? 847 while z # No 848 ld E C # Next digit 849 loop 850 add C (hex "10") # Increment final short 851 ld (E BIG) C 852 90 drop 853 pop X 854 call zapZeroA_A # Remove leading zeroes 855 or A SIGN # Set negative 856 ret 857 858 # Multiply two (unsigned) numbers 859 (code 'muluAE_A 0) 860 cnt A # A short? 861 if nz # Yes 862 cmp A ZERO # Multiply with zero? 863 jeq ret # Yes: Return zero 864 shr A 4 # Normalize 865 cnt E # E also short? 866 if nz # Yes 867 xchg A E 868 shr A 4 # Normalize 869 mul E # Multiply 870 null C # Only lower word? 871 if z # Yes 872 test A (hex "F000000000000000") # Fit in short number? 873 if z # Yes 874 shl A 4 # Make short number 875 or A CNT 876 ret 877 end 878 end 879 shl C 4 # Make short number 880 or C CNT 881 jmp consNumAC_A # Return bignum 882 end 883 10 push X 884 push Y 885 push Z 886 ld Y A # Save digit in Y 887 mul (E DIG) # Multiply lowest digit 888 call boxNum_X # First cell 889 ld (X DIG) A 890 link 891 push X # <L I> Safe 892 link 893 ld Z C # Keep upper word in Z 894 do 895 ld E (E BIG) 896 cnt E # End of bignum? 897 while z # No 898 ld A (E DIG) # Get next digit 899 mul Y # Multiply digit 900 add D Z # Add previous upper word 901 ld Z C 902 call boxNum_C # Next cell 903 ld (C DIG) A 904 ld (X BIG) C 905 ld X C 906 loop 907 ld A Y # Retrieve digit 908 shr E 4 # Normalize 909 mul E # Multiply 910 add D Z # Add previous upper word 911 if z # Only lower word 912 test A (hex "F000000000000000") # Fit in short number? 913 if z # Yes 914 shl A 4 # Make short number 915 or A CNT 916 20 ld (X BIG) A # Store in final cell 917 ld A (L I) # Return bignum 918 drop 919 pop Z 920 pop Y 921 pop X 922 ret 923 end 924 end 925 shl C 4 # Make short number 926 or C CNT 927 call consNumAC_A # Return bignum 928 jmp 20 929 end 930 # A is big 931 cnt E # E short? 932 if nz # Yes 933 cmp E ZERO # Multiply with zero? 934 jeq ret # Yes: Return zero 935 xchg A E # Exchange args 936 shr A 4 # Normalize 937 jmp 10 938 end 939 # Both are big 940 push X 941 push Y 942 push Z 943 ld Y A # Arg1 in Y 944 ld Z E # Arg2 in Z 945 call boxNum_X # Zero bignum 946 ld (X DIG) 0 947 link 948 push X # <L I> Safe 949 link 950 push X # <L -I> Safe index 951 push Y # <L -II> Arg1 index 952 do 953 ld A (Y DIG) # Multiply digits 954 mul (Z DIG) 955 add D (X DIG) # Add lower word to safe 956 do 957 ld (X DIG) A # Store lower word 958 ld E C # Keep upper word in E 959 ld A (X BIG) # Next safe cell 960 cnt A # End of safe? 961 if nz # Yes 962 call boxNum_A # Extend safe 963 ld (A DIG) 0 964 ld (X BIG) A 965 end 966 ld X A 967 ld Y (Y BIG) # Next cell of Arg1 968 cnt Y # End of bignum? 969 while z # No 970 ld A (Y DIG) # Multiply digits 971 mul (Z DIG) 972 add D (X DIG) # Add safe 973 addc D E # plus carry 974 loop 975 ld A Y # Final short number 976 shr A 4 # Normalize 977 mul (Z DIG) 978 add D (X DIG) # Add safe 979 addc D E # plus carry 980 ld (X DIG) A 981 if nz # Uppper word 982 ld A (X BIG) # Next safe cell 983 cnt A # End of safe? 984 if nz # Yes 985 call boxNum_A # Extend safe 986 ld (A DIG) 0 987 ld (X BIG) A 988 end 989 ld (A DIG) C # Store uppper word 990 end 991 ld Y (L -II) # Get Arg1 index 992 ld X ((L -I) BIG) # Advance safe index 993 ld (L -I) X 994 ld Z (Z BIG) # Next cell of Arg2 995 cnt Z # End of bignum? 996 until nz # Yes 997 ld A Z 998 shr A 4 # Normalize 999 ld Z A 1000 mul (Y DIG) # Multiply digit 1001 add D (X DIG) # Add lower word to safe 1002 do 1003 ld (X DIG) A # Store lower word 1004 ld E C # Keep upper word in E 1005 ld A (X BIG) # Next safe cell 1006 cnt A # End of safe? 1007 if nz # Yes 1008 call boxNum_A # Extend safe 1009 ld (A DIG) 0 1010 ld (X BIG) A 1011 end 1012 ld X A 1013 ld Y (Y BIG) # Next cell of Arg1 1014 cnt Y # End of bignum? 1015 while z # No 1016 ld A (Y DIG) # Multiply digit 1017 mul Z 1018 add D (X DIG) # Add safe 1019 addc D E # plus carry 1020 loop 1021 ld A Y # Final short number 1022 shr A 4 # Normalize 1023 mul Z # Multiply digit 1024 add D (X DIG) # Add safe 1025 addc D E # plus carry 1026 ld (X DIG) A 1027 if nz # Uppper word 1028 ld A (X BIG) # Next safe cell 1029 cnt A # End of safe? 1030 if nz # Yes 1031 call boxNum_A # Extend safe 1032 ld (A DIG) 0 1033 ld (X BIG) A 1034 end 1035 ld (A DIG) C # Store uppper word 1036 end 1037 ld A (L I) # Return bignum 1038 drop 1039 pop Z 1040 pop Y 1041 pop X 1042 jmp zapZeroA_A # Remove leading zeroes 1043 1044 # Divide two (unsigned) numbers (Knuth Vol.2, p.257) 1045 (code 'divuAE_A 0) 1046 cnt A # A short? 1047 if nz # Yes 1048 cnt E # E also short? 1049 if nz # Yes 1050 shr A 4 # Normalize A 1051 ld C 0 1052 shr E 4 # Normalize E 1053 div E # Divide 1054 shl A 4 # Make short number 1055 or A CNT # Quotient 1056 ret 1057 end 1058 ld A ZERO # Else return zero 1059 ret 1060 end 1061 push X 1062 push Y 1063 push Z 1064 link 1065 push ZERO # <L III> Quotient 1066 push A # <L II> Dividend 'u' 1067 push E # <L I> Divisor 'v' 1068 link 1069 ld E (A DIG) # Copy dividend 1070 call boxNumE_E 1071 ld (L II) E # Save new 'u' 1072 ld X 0 # Calculate 'm' 1073 do 1074 ld A (A BIG) # Next cell of 'u' 1075 cnt A # Last one? 1076 while z # No 1077 call boxNum_C # Copy next digit 1078 ld (C DIG) (A DIG) 1079 ld (E BIG) C 1080 ld E C 1081 inc X # Increment 'm' 1082 loop 1083 cmp A ZERO # Trailing short zero? 1084 if ne # No 1085 shr A 4 # Normalize 1086 call boxNum_C # Append in new cell 1087 ld (C DIG) A 1088 ld (E BIG) C 1089 ld E C 1090 inc X # Increment 'm' 1091 end 1092 ld Z E # Keep last cell in Z 1093 push X # <L -I> 'm' 1094 ld Y 0 # Last cell 1095 ld C 0 # Calculate 'n' 1096 ld A (L I) # Get divisor 1097 cnt A # Short? 1098 if nz # Yes 1099 shr A 4 # Normalize 1100 call boxNumA_A # Make big 1101 ld (L I) A # Save new 'v' 1102 ld X A # Keep in X 1103 inc C # 'n' = 1 1104 else 1105 call boxNum_X # Copy divisor 1106 ld (X DIG) (A DIG) 1107 ld (L I) X # Save new 'v' 1108 do 1109 inc C # Increment 'n' 1110 ld A (A BIG) # Next cell of 'v' 1111 cnt A # Last one? 1112 while z # No 1113 ld E (A DIG) # Copy next digit 1114 call boxNumE_E 1115 ld (X BIG) E # Append to 'v' 1116 ld Y X # Keep last cell 1117 ld X E 1118 dec (L -I) # Decrement 'm' 1119 loop 1120 cmp A ZERO # Trailing short zero? 1121 if ne # No 1122 shr A 4 # Normalize 1123 call boxNumA_A # Append in new cell 1124 ld (X BIG) A # Append to 'v' 1125 ld Y X # Set last cell 1126 ld X A 1127 dec (L -I) # Decrement 'm' 1128 inc C # Increment 'n' 1129 end 1130 null (L -I) # 'm' negative? 1131 js divUnder # Yes 1132 end 1133 push C # <L -II> 'n' 1134 ld A 0 # Append additional cell 1135 call boxNumA_A 1136 ld (Z BIG) A 1137 ld Z 0 # Calculate 'd' 1138 do 1139 null (X DIG) # Max left position? 1140 while ns # No 1141 ld A (L II) # Shift left 'u' 1142 call twiceBigA_A 1143 ld A (L I) # and 'v' 1144 call twiceBigA_A 1145 inc Z # Increment 'd' 1146 loop 1147 push Z # <L -III> 'd' 1148 push (X DIG) # <L -IV> 'v1' 1149 null Y # Last cell? 1150 if nz # Yes 1151 ld Y (Y DIG) # Yes: Get digit 1152 end 1153 push Y # <L -V> Last cell 'v2' 1154 push 0 # <S> tmp 1155 do 1156 ld C (L -I) # Get 'm' 1157 ld X (L II) # and 'u' 1158 do 1159 sub C 1 1160 while ge 1161 ld X (X BIG) # Index X -> u 1162 loop 1163 ld E (L -II) # Get 'n' in E 1164 ld Y X 1165 ld C 0 # 'u1' in C 1166 ld A 0 # 'u2' in A 1167 do 1168 ld (S) A # Save 'u3' im tmp 1169 ld A C # Shift words 1170 ld C (Y DIG) 1171 ld Y (Y BIG) 1172 sub E 1 1173 until lt 1174 ld Z C # Keep 'r' = 't' in Z,Y 1175 ld Y A 1176 cmp C (L -IV) # 'u1' = 'v1'? 1177 if ne # No 1178 div (L -IV) # 'q' = 't' / 'v1' 1179 else 1180 ld A -1 # 'q' = MAX 1181 end 1182 ld E A # Save 'q' in E 1183 mul (L -IV) # 'q' * 'v1' 1184 sub Y A # Subtract from 'r' 1185 subc Z C 1186 do 1187 null Z # 'r' <= MAX? 1188 while z # Yes 1189 ld A E # 'q' * 'v2' 1190 mul (L -V) 1191 cmp C Y # > lo(r), 'u3'? 1192 while ge 1193 if eq 1194 cmp A (S) # 'u3' in tmp 1195 break le 1196 end 1197 dec E # Yes: Decrement 'q' 1198 add Y (L -IV) # Increment 'r' by 'v1' 1199 addc Z 0 1200 loop 1201 ld (S) E # Save 'q' in tmp 1202 ld Z X # Get 'x' 1203 ld Y (L I) # 'v' 1204 ld A E # and 'q' 1205 mul (Y DIG) # Multiply lowest digit 1206 sub (Z DIG) A # Subtract from 'x' 1207 addc C 0 1208 ld E C # Borrow in E 1209 do 1210 ld Y (Y BIG) # More in 'v'? 1211 cnt Y 1212 while z # Yes 1213 ld Z (Z BIG) # Next 'x' 1214 ld A (S) # Multiply with 'q' in tmp 1215 mul (Y DIG) # 't' in D 1216 sub (Z DIG) E # Subtract borrow 1217 ld E 0 1218 rcl E 1 # New borrow 1219 sub (Z DIG) A # Subtract lo(t) 1220 addc E C # Adjust borrow plus hi(t) 1221 loop 1222 null E # Borrow? 1223 if nz # Yes 1224 ld Z (Z BIG) # Next 'x' 1225 sub (Z DIG) E # Subtract borrow 1226 if c 1227 dec (S) # Decrement 'q' 1228 null (L -I) # 'm' ? 1229 if nz # Yes 1230 ld Y (L I) # Get 'v' 1231 add (X DIG) (Y DIG) # 'x' += 'v' 1232 push F # Save carry 1233 do 1234 ld X (X BIG) # More? 1235 ld Y (Y BIG) 1236 cnt Y 1237 while z # Yes 1238 pop F # Get carry 1239 addc (X DIG) (Y DIG) # Add digits 1240 push F 1241 loop 1242 pop F # Final carry 1243 addc (X DIG) 0 1244 end 1245 end 1246 end 1247 ld A (S) # Get 'q' 1248 ld C (L III) # Quotient so far 1249 call consNumAC_A # Prepend 'q' 1250 ld (L III) A # Store result 1251 sub (L -I) 1 # Decrement 'm' 1252 until lt 1253 ld A (L III) # Return quotient in A 1254 call zapZeroA_A 1255 : divDone 1256 drop 1257 pop Z 1258 pop Y 1259 pop X 1260 ret 1261 : divUnder # Dividend smaller than divisor 1262 ld A ZERO # Return quotient 0 1263 jmp divDone 1264 1265 # Remainder of two (unsigned) numbers 1266 (code 'remuAE_A 0) 1267 cnt A # A short? 1268 if nz # Yes 1269 cnt E # E also short? 1270 if nz # Yes 1271 shr A 4 # Normalize A 1272 ld C 0 1273 shr E 4 # Normalize E 1274 div E # Divide 1275 ld A C # Get remainder 1276 shl A 4 # Make short number 1277 or A CNT # Quotient 1278 ret 1279 end 1280 ret # Remainder is in A 1281 end 1282 push X 1283 push Y 1284 push Z 1285 link 1286 push ZERO # <L III> Quotient 1287 push A # <L II> Dividend 'u' 1288 push E # <L I> Divisor 'v' 1289 link 1290 ld E (A DIG) # Copy dividend 1291 call boxNumE_E 1292 ld (L II) E # Save new 'u' 1293 ld X 0 # Calculate 'm' 1294 do 1295 ld A (A BIG) # Next cell of 'u' 1296 cnt A # Last one? 1297 while z # No 1298 call boxNum_C # Copy next digit 1299 ld (C DIG) (A DIG) 1300 ld (E BIG) C 1301 ld E C 1302 inc X # Increment 'm' 1303 loop 1304 cmp A ZERO # Trailing short zero? 1305 if ne # No 1306 shr A 4 # Normalize 1307 call boxNum_C # Append in new cell 1308 ld (C DIG) A 1309 ld (E BIG) C 1310 ld E C 1311 inc X # Increment 'm' 1312 end 1313 ld Z E # Keep last cell in Z 1314 push X # <L -I> 'm' 1315 ld Y 0 # Last cell 1316 ld C 0 # Calculate 'n' 1317 ld A (L I) # Get divisor 1318 cnt A # Short? 1319 if nz # Yes 1320 shr A 4 # Normalize 1321 call boxNumA_A # Make big 1322 ld (L I) A # Save new 'v' 1323 ld X A # Keep in X 1324 inc C # 'n' = 1 1325 else 1326 call boxNum_X # Copy divisor 1327 ld (X DIG) (A DIG) 1328 ld (L I) X # Save new 'v' 1329 do 1330 inc C # Increment 'n' 1331 ld A (A BIG) # Next cell of 'v' 1332 cnt A # Last one? 1333 while z # No 1334 ld E (A DIG) # Copy next digit 1335 call boxNumE_E 1336 ld (X BIG) E # Append to 'v' 1337 ld Y X # Keep last cell 1338 ld X E 1339 dec (L -I) # Decrement 'm' 1340 loop 1341 cmp A ZERO # Trailing short zero? 1342 if ne # No 1343 shr A 4 # Normalize 1344 call boxNumA_A # Append in new cell 1345 ld (X BIG) A # Append to 'v' 1346 ld Y X # Set last cell 1347 ld X A 1348 dec (L -I) # Decrement 'm' 1349 inc C # Increment 'n' 1350 end 1351 null (L -I) # 'm' negative? 1352 js remUnder # Yes 1353 end 1354 push C # <L -II> 'n' 1355 ld A 0 # Append additional cell 1356 call boxNumA_A 1357 ld (Z BIG) A 1358 ld Z 0 # Calculate 'd' 1359 do 1360 null (X DIG) # Max left position? 1361 while ns # No 1362 ld A (L II) # Shift left 'u' 1363 call twiceBigA_A 1364 ld A (L I) # and 'v' 1365 call twiceBigA_A 1366 inc Z # Increment 'd' 1367 loop 1368 push Z # <L -III> 'd' 1369 push (X DIG) # <L -IV> 'v1' 1370 null Y # Last cell? 1371 if nz # Yes 1372 ld Y (Y DIG) # Yes: Get digit 1373 end 1374 push Y # <L -V> Last cell 'v2' 1375 push 0 # <S> tmp 1376 do 1377 ld C (L -I) # Get 'm' 1378 ld X (L II) # and 'u' 1379 do 1380 sub C 1 1381 while ge 1382 ld X (X BIG) # Index X -> u 1383 loop 1384 ld E (L -II) # Get 'n' in E 1385 ld Y X 1386 ld C 0 # 'u1' in C 1387 ld A 0 # 'u2' in A 1388 do 1389 ld (S) A # Save 'u3' im tmp 1390 ld A C # Shift words 1391 ld C (Y DIG) 1392 ld Y (Y BIG) 1393 sub E 1 1394 until lt 1395 ld Z C # Keep 'r' = 't' in Z,Y 1396 ld Y A 1397 cmp C (L -IV) # 'u1' = 'v1'? 1398 if ne # No 1399 div (L -IV) # 'q' = 't' / 'v1' 1400 else 1401 ld A -1 # 'q' = MAX 1402 end 1403 ld E A # Save 'q' in E 1404 mul (L -IV) # 'q' * 'v1' 1405 sub Y A # Subtract from 'r' 1406 subc Z C 1407 do 1408 null Z # 'r' <= MAX? 1409 while z # Yes 1410 ld A E # 'q' * 'v2' 1411 mul (L -V) 1412 cmp C Y # > lo(r), 'u3'? 1413 while ge 1414 if eq 1415 cmp A (S) # 'u3' in tmp 1416 break le 1417 end 1418 dec E # Yes: Decrement 'q' 1419 add Y (L -IV) # Increment 'r' by 'v1' 1420 addc Z 0 1421 loop 1422 ld (S) E # Save 'q' in tmp 1423 ld Z X # Get 'x' 1424 ld Y (L I) # 'v' 1425 ld A E # and 'q' 1426 mul (Y DIG) # Multiply lowest digit 1427 sub (Z DIG) A # Subtract from 'x' 1428 addc C 0 1429 ld E C # Borrow in E 1430 do 1431 ld Y (Y BIG) # More in 'v'? 1432 cnt Y 1433 while z # Yes 1434 ld Z (Z BIG) # Next 'x' 1435 ld A (S) # Multiply with 'q' in tmp 1436 mul (Y DIG) # 't' in D 1437 sub (Z DIG) E # Subtract borrow 1438 ld E 0 1439 rcl E 1 # New borrow 1440 sub (Z DIG) A # Subtract lo(t) 1441 addc E C # Adjust borrow plus hi(t) 1442 loop 1443 null E # Borrow? 1444 if nz # Yes 1445 ld Z (Z BIG) # Next 'x' 1446 sub (Z DIG) E # Subtract borrow 1447 if c 1448 dec (S) # Decrement 'q' 1449 ld Y (L I) # Get 'v' 1450 add (X DIG) (Y DIG) # 'x' += 'v' 1451 push F # Save carry 1452 do 1453 ld X (X BIG) # More? 1454 ld Y (Y BIG) 1455 cnt Y 1456 while z # Yes 1457 pop F # Get carry 1458 addc (X DIG) (Y DIG) # Add digits 1459 push F 1460 loop 1461 pop F # Final carry 1462 addc (X DIG) 0 1463 end 1464 end 1465 ld A (S) # Get 'q' 1466 ld C (L III) # Quotient so far 1467 call consNumAC_A # Prepend 'q' 1468 ld (L III) A # Store result 1469 sub (L -I) 1 # Decrement 'm' 1470 until lt 1471 ld A (L II) # Get remainder 1472 call zapZeroA_A 1473 do 1474 null (L -III) # 'd'? 1475 while nz # Yes 1476 call halfA_A # Shift right (destructive) 1477 dec (L -III) # Decrement 'd' 1478 loop 1479 : remDone 1480 drop 1481 pop Z 1482 pop Y 1483 pop X 1484 ret 1485 : remUnder # Dividend smaller than divisor 1486 ld A (L II) # Get remainder 1487 call zapZeroA_A 1488 jmp remDone 1489 1490 # Increment a (signed) number 1491 (code 'incE_A 0) 1492 ld A ONE 1493 test E SIGN # Positive? 1494 jz adduAE_A # Increment 1495 off E SIGN # Make positive 1496 call subuAE_A # Subtract 1497 cmp A ZERO # Zero? 1498 if ne # No 1499 or A SIGN # Negate again 1500 end 1501 ret 1502 1503 # Decrement a (signed) number 1504 (code 'decE_A 0) 1505 ld A ONE 1506 test E SIGN # Positive? 1507 if z # Yes 1508 xchg A E 1509 jmp subuAE_A # Decrement 1510 end 1511 off E SIGN # Make positive 1512 call adduAE_A # Add 1513 or A SIGN # Negate again 1514 ret 1515 1516 # Add two (signed) numbers 1517 (code 'addAE_A 0) 1518 test A SIGN # Positive? 1519 if z # Yes 1520 test E SIGN # Arg also positive? 1521 jz adduAE_A # Add [+ A E] 1522 off E SIGN # [+ A -E] 1523 jmp subuAE_A # Sub 1524 end 1525 # Result negatve 1526 test E SIGN # Arg positive? 1527 if z # [+ -A E] 1528 off A SIGN 1529 call subuAE_A # Sub 1530 else # [+ -A -E] 1531 off A SIGN 1532 off E SIGN 1533 call adduAE_A # Add 1534 end 1535 cmp A ZERO # Zero? 1536 if ne # No 1537 xor A SIGN # Negate 1538 end 1539 ret 1540 1541 # Subtract to (signed) numbers 1542 (code 'subAE_A 0) 1543 test A SIGN # Positive? 1544 if z # Yes 1545 test E SIGN # Arg also positive? 1546 jz subuAE_A # Sub [- A E] 1547 off E SIGN # [- A -E] 1548 jmp adduAE_A # Add 1549 end 1550 # Result negatve 1551 test E SIGN # Arg positive? 1552 if z # [- -A E] 1553 off A SIGN 1554 call adduAE_A # Add 1555 else # [- -A -E] 1556 off A SIGN 1557 off E SIGN 1558 call subuAE_A # Sub 1559 end 1560 cmp A ZERO # Zero? 1561 if ne # No 1562 xor A SIGN # Negate 1563 end 1564 ret 1565 1566 ### Comparisons ### 1567 (code 'cmpNumAE_F 0) 1568 test A SIGN # A positive? 1569 if z # Yes 1570 test E SIGN # E also positive? 1571 jz cmpuAE_F # Yes [A E] 1572 clrc # gt [A -E] 1573 ret 1574 end 1575 # A negative 1576 test E SIGN # E positive? 1577 if z # Yes 1578 or B B # nz [-A E] 1579 setc # lt 1580 ret 1581 end 1582 xchg A E # [-A -E] 1583 off A SIGN 1584 off E SIGN 1585 1586 # Compare two (unsigned) numbers 1587 (code 'cmpuAE_F 0) 1588 cnt A # A short? 1589 if nz # Yes 1590 cnt E # E also short? 1591 if nz # Yes 1592 cmp A E # F 1593 ret 1594 end 1595 or B B # nz (E is big) 1596 setc # lt 1597 ret 1598 end 1599 # A is big 1600 cnt E # E short? 1601 if nz # Yes 1602 clrc # gt (E is short) 1603 ret 1604 end 1605 # Both are big 1606 push X 1607 push Y 1608 ld X 0 # Clear reverse pointers 1609 ld Y 0 1610 do 1611 ld C (A BIG) # Tails equal? 1612 cmp C (E BIG) 1613 if eq # Yes 1614 do 1615 ld C (A DIG) # Compare digits 1616 cmp C (E DIG) 1617 while eq 1618 null X # End of reversed list? 1619 if z # Yes 1620 pop Y # eq 1621 pop X 1622 ret 1623 end 1624 ld C (X BIG) # Restore A 1625 ld (X BIG) A 1626 ld A X 1627 ld X C 1628 ld C (Y BIG) # Restore E 1629 ld (Y BIG) E 1630 ld E Y 1631 ld Y C 1632 loop 1633 push F 1634 break T 1635 end 1636 cnt C # End of A? 1637 if nz # Yes 1638 cnt (E BIG) # Also end of E? 1639 if nz # Yes 1640 cmp C (E BIG) # F 1641 else 1642 or B B # nz (E is bigger) 1643 setc # lt 1644 end 1645 push F 1646 break T 1647 end 1648 cnt (E BIG) # End of E? 1649 if nz # Yes 1650 clrc # gt 1651 push F 1652 break T 1653 end 1654 ld (A BIG) X # Reverse A 1655 ld X A 1656 ld A C 1657 ld C (E BIG) # Reverse E 1658 ld (E BIG) Y 1659 ld Y E 1660 ld E C 1661 loop 1662 do 1663 null X # Reversed? 1664 while nz # Yes 1665 ld C (X BIG) # Restore A 1666 ld (X BIG) A 1667 ld A X 1668 ld X C 1669 ld C (Y BIG) # Restore E 1670 ld (Y BIG) E 1671 ld E Y 1672 ld Y C 1673 loop 1674 pop F # Return flags 1675 pop Y 1676 pop X 1677 ret 1678 1679 ### Conversions ### 1680 # Make number from symbol 1681 (code 'symToNumXA_FE 0) 1682 link 1683 push ZERO # <L I> Safe 1684 link 1685 push A # <L -I> Scale 1686 push 0 # <L -II> Sign flag 1687 push 0 # <L -III> Fraction flag 1688 ld C 0 1689 call symByteCX_FACX # Get first byte 1690 jz 99 # None 1691 do 1692 cmp B 32 # Skip white space 1693 while le 1694 call symByteCX_FACX # Next byte 1695 jz 99 # None 1696 loop 1697 cmp B (char "+") # Plus sign? 1698 jz 10 # Yes 1699 cmp B (char "-") # Minus sign? 1700 if eq # Yes 1701 or (L -II) 1 # Set Sign 1702 10 call symByteCX_FACX # Next byte 1703 jz 99 # None 1704 end 1705 sub A (char "0") # First digit 1706 cmp A 10 # Too big? 1707 jge 99 # Return NO 1708 shl A 4 # Make short number 1709 or A CNT 1710 ld (L I) A # Save 1711 do 1712 call symCharCX_FACX # More? 1713 while nz # Yes 1714 test (L -III) 1 # Fraction? 1715 if nz # Yes 1716 null (L -I) # Scale? 1717 if z # No 1718 sub A (char "0") # Next digit 1719 cmp A 10 # Too big? 1720 jge 99 # Return NO 1721 cmp A 5 # Round? 1722 if ge # Yes 1723 ld A ONE # Increment 1724 ld E (L I) 1725 push C 1726 call adduAE_A 1727 pop C 1728 ld (L I) A 1729 end 1730 do 1731 call symByteCX_FACX # More? 1732 while nz # Yes 1733 sub A (char "0") # Next digit 1734 cmp A 10 # Too big? 1735 jge 99 # Return NO 1736 loop 1737 break T 1738 end 1739 end 1740 cmp A (Sep0) # Decimal separator? 1741 if eq # Yes 1742 test (L -III) 1 # Fraction? 1743 jnz 99 # Return NO 1744 or (L -III) 1 # Set Fraction 1745 else 1746 cmp A (Sep3) # Thousand separator? 1747 if ne # No 1748 sub A (char "0") # Next digit 1749 cmp A 10 # Too big? 1750 jge 99 # Return NO 1751 push C # Save symByte args 1752 push X 1753 push A # Save digit 1754 ld A (L I) # Multiply number by 10 1755 call tenfoldA_A 1756 ld (L I) A # Save 1757 pop E # Get digit 1758 shl E 4 # Make short number 1759 or E CNT 1760 call adduAE_A # Add to number 1761 ld (L I) A # Save again 1762 pop X # Pop symByte args 1763 pop C 1764 test (L -III) 1 # Fraction? 1765 if nz # Yes 1766 dec (L -I) # Decrement Scale 1767 end 1768 end 1769 end 1770 loop 1771 test (L -III) 1 # Fraction? 1772 if nz # Yes 1773 do 1774 sub (L -I) 1 # Decrement Scale 1775 while nc # >= 0 1776 ld A (L I) # Multiply number by 10 1777 call tenfoldA_A 1778 ld (L I) A # Save 1779 loop 1780 end 1781 ld E (L I) # Get result 1782 test (L -II) 1 # Sign? 1783 if nz # Yes 1784 cmp E ZERO # Zero? 1785 if ne # No 1786 xor E SIGN # Negate 1787 end 1788 end 1789 setc # Return YES 1790 99 drop 1791 ret 1792 1793 # Format number to output, length, or symbol 1794 (code 'fmtNum0AE_E 0) 1795 ld (Sep3) 0 # Thousand separator 0 1796 ld (Sep0) 0 # Decimal separator 0 1797 (code 'fmtNumAE_E) 1798 push C 1799 push X 1800 push Y 1801 push Z 1802 link 1803 push ZERO # <L I> Name 1804 link 1805 push A # <L -I> Scale 1806 ld A E # Get number 1807 cnt A # Short number? 1808 if nz # Yes 1809 push 16 # <L -II> mask 1810 else 1811 push 1 # <L -II> mask 1812 end 1813 shr B 3 # Get sign bit 1814 push A # <L -III> Sign flag 1815 off E SIGN 1816 # Calculate buffer size 1817 ld A 19 # Decimal length of 'cnt' (60 bit) 1818 ld C E # Get number 1819 do 1820 cnt C # Last digit? 1821 while z # No 1822 add A 20 # Add decimal length of 'digit' (64 bit) 1823 ld C (C BIG) 1824 loop 1825 add A 17 # Round up 1826 ld C 0 # Divide by 18 1827 div 18 1828 shl A 3 # Word count 1829 sub S A # Space for incrementor 1830 ld (S) 1 # Init to '1' 1831 ld X S # Keep pointer to incrementor in X 1832 sub S A # <S III> Accumulator 1833 cmp S (StkLimit) # Stack check 1834 jlt stkErr 1835 ld (S) 0 # Init to '0' 1836 push S # <S II> Top of accumulator 1837 push X # <S I> Pointer to incrementor 1838 push X # <S> Top of incrementor 1839 do 1840 cnt E # Short number? 1841 ldnz Z E # Yes 1842 if z 1843 ld Z (E DIG) # Digit in Z 1844 end 1845 do 1846 ld A Z # Current digit 1847 test A (L -II) # Test next bit with mask 1848 if nz 1849 # Add incrementor to accumulator 1850 ld C 0 # Carry for BCD addition 1851 lea X (S III) # Accumulator 1852 ld Y (S I) # Incrementor 1853 do 1854 cmp X (S II) # X > Top of accumulator? 1855 if gt # Yes 1856 add (S II) 8 # Extend accumulator 1857 ld (X) 0 # with '0' 1858 end 1859 ld A (X) 1860 add A (Y) # Add BCD 1861 add A C # Add BCD-Carry 1862 ld C 0 # Clear BCD-Carry 1863 cmp A 1000000000000000000 # BCD overflow? 1864 if ge # Yes 1865 sub A 1000000000000000000 1866 ld C 1 # Set BCD-Carry 1867 end 1868 ld (X) A # Store BCD digit in accumulator 1869 add X 8 1870 add Y 8 1871 cmp Y (S) # Reached top of incrementor? 1872 until gt # Yes 1873 null C # BCD-Carry? 1874 if ne # Yes 1875 add (S II) 8 # Extend accumulator 1876 ld (X) 1 # With '1' 1877 end 1878 end 1879 # Shift incrementor left 1880 ld C 0 # Clear BCD-Carry 1881 ld Y (S I) # Incrementor 1882 do 1883 ld A (Y) 1884 add A A # Double 1885 add A C # Add BCD-Carry 1886 ld C 0 # Clear BCD-Carry 1887 cmp A 1000000000000000000 # BCD overflow? 1888 if ge # Yes 1889 sub A 1000000000000000000 1890 ld C 1 # Set BCD-Carry 1891 end 1892 ld (Y) A # Store BCD digit in incrementor 1893 add Y 8 1894 cmp Y (S) # Reached top of incrementor? 1895 until gt # Yes 1896 null C # BCD-Carry? 1897 if ne # Yes 1898 add (S) 8 # Extend incrementor 1899 ld (Y) 1 # With '1' 1900 end 1901 shl (L -II) 1 # Shift bit mask 1902 until z 1903 cnt E # Short number? 1904 while z # No 1905 ld E (E BIG) # Next digit 1906 cnt E # Short number? 1907 if nz # Yes 1908 ld A 16 # Mask 1909 else 1910 ld A 1 1911 end 1912 ld (L -II) A # Set bit mask 1913 loop 1914 ld Y (S II) # Top of accumulator 1915 lea Z (S III) # Accumulator 1916 null (L -I) # Scale negative? 1917 if s # Yes 1918 cmp (L -I) -1 # Direct print? 1919 if eq # Yes 1920 test (L -III) 1 # Sign? 1921 if nz # Yes 1922 ld B (char "-") # Output sign 1923 call (PutB) 1924 end 1925 ld A (Y) # Output highest word 1926 call outWordA 1927 do 1928 sub Y 8 # More? 1929 cmp Y Z 1930 while ge # Yes 1931 ld A (Y) # Output words in reverse order 1932 ld E 100000000000000000 # Digit scale 1933 do 1934 ld C 0 # Divide by digit scale 1935 div E 1936 push C # Save remainder 1937 add B (char "0") # Output next digit 1938 call (PutB) 1939 cmp E 1 # Done? 1940 while ne # No 1941 ld C 0 # Divide digit scale by 10 1942 ld A E 1943 div 10 1944 ld E A 1945 pop A # Get remainder 1946 loop 1947 loop 1948 else # Calculate length 1949 ld A Y # Top of accumulator 1950 sub A Z # Accumulator 1951 shr A 3 # Number of accumulator words 1952 mul 18 # Number of digits 1953 ld E A 1954 ld A (Y) # Length of highest word 1955 do 1956 inc E # Increment length 1957 ld C 0 # Divide by 10 1958 div 10 1959 null A # Done? 1960 until z # Yes 1961 test (L -III) 1 # Sign? 1962 if nz # Yes 1963 inc E # Space for '-' 1964 end 1965 shl E 4 # Make short number 1966 or E CNT 1967 end 1968 drop 1969 else 1970 ld C 4 # Build name 1971 lea X (L I) 1972 test (L -III) 1 # Sign? 1973 if nz # Yes 1974 ld B (char "-") # Insert sign 1975 call byteSymBCX_CX 1976 end 1977 push C # Save name index 1978 ld A Y # Top of accumulator 1979 sub A Z # Accumulator 1980 shr A 3 # Number of accumulator words 1981 mul 18 # Number of digits 1982 ld E A # Calculate length-1 1983 ld A (Y) # Highest word 1984 do 1985 ld C 0 # Divide by 10 1986 div 10 1987 null A # Done? 1988 while nz # No 1989 inc E # Increment length 1990 loop 1991 pop C # Restore name index 1992 sub E (L -I) # Scale 1993 ld (L -I) E # Decrement by Length-1 1994 if lt # Scale < 0 1995 ld B (char "0") # Prepend '0' 1996 call byteSymBCX_CX 1997 ld A (Sep0) # Prepend decimal separator 1998 call charSymACX_CX 1999 do 2000 cmp (L -I) -1 # Scale 2001 while lt 2002 inc (L -I) # Increment scale 2003 ld B (char "0") # Ouput zeroes 2004 call byteSymBCX_CX 2005 loop 2006 end 2007 ld A (Y) # Pack highest word 2008 call fmtWordACX_CX 2009 do 2010 sub Y 8 # More? 2011 cmp Y Z 2012 while ge # Yes 2013 ld A (Y) # Pack words in reverse order 2014 ld E 100000000000000000 # Digit scale 2015 do 2016 push A 2017 call fmtScaleCX_CX # Handle scale character(s) 2018 pop A 2019 push C # Save name index 2020 ld C 0 # Divide by digit scale 2021 div E 2022 xchg C (S) # Save remainder, restore name index 2023 add B (char "0") # Pack next digit 2024 call byteSymBCX_CX 2025 cmp E 1 # Done? 2026 while ne # No 2027 push C # Save name index 2028 ld C 0 # Divide digit scale by 10 2029 ld A E 2030 div 10 2031 pop C # Restore name index 2032 ld E A 2033 pop A # Get remainder 2034 loop 2035 loop 2036 ld X (L I) # Get name 2037 drop 2038 call consSymX_E 2039 end 2040 pop Z 2041 pop Y 2042 pop X 2043 pop C 2044 ret 2045 2046 (code 'fmtWordACX_CX 0) 2047 cmp A 9 # Single digit? 2048 if gt # No 2049 ld E C # Save C 2050 ld C 0 # Divide by 10 2051 div 10 2052 push C # Save remainder 2053 ld C E # Restore C 2054 call fmtWordACX_CX # Recurse 2055 call fmtScaleCX_CX # Handle scale character(s) 2056 pop A 2057 end 2058 add B (char "0") # Make ASCII digit 2059 jmp byteSymBCX_CX 2060 2061 (code 'fmtScaleCX_CX 0) 2062 null (L -I) # Scale null? 2063 if z # Yes 2064 ld A (Sep0) # Output decimal separator 2065 call charSymACX_CX 2066 else 2067 null (Sep3) # Thousand separator? 2068 if nz # Yes 2069 ld A (L -I) # Scale > 0? 2070 null A 2071 if nsz # Yes 2072 push C 2073 ld C 0 # Modulus 3 2074 div 3 2075 null C 2076 pop C 2077 if z 2078 ld A (Sep3) # Output thousand separator 2079 call charSymACX_CX 2080 end 2081 end 2082 end 2083 end 2084 dec (L -I) # Decrement scale 2085 ret 2086 2087 # (format 'num ['cnt ['sym1 ['sym2]]]) -> sym 2088 # (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num 2089 (code 'doFormat 2) 2090 push X 2091 push Y 2092 ld X E 2093 ld Y (E CDR) # Y on args 2094 ld E (Y) # Eval first 2095 eval 2096 link 2097 push E # <L I> 'num' | 'sym' 2098 link 2099 ld Y (Y CDR) # Second arg 2100 ld E (Y) 2101 eval # Eval 'cnt' 2102 cmp E Nil # Any? 2103 if eq # No 2104 ld E 0 # Zero 2105 else 2106 call xCntEX_FE # Extract 'cnt' 2107 end 2108 push E # <L -I> Scale 2109 push (char ".") # <L -II> Sep0 2110 push 0 # Sep3 2111 ld Y (Y CDR) # Third arg? 2112 atom Y 2113 if z # Yes 2114 ld E (Y) 2115 eval # Eval 'sym1' 2116 num E # Need symbol 2117 jnz symErrEX 2118 sym E 2119 jz symErrEX 2120 call firstCharE_A 2121 ld (L -II) A # Sep0 2122 ld Y (Y CDR) # Fourth arg? 2123 atom Y 2124 if z # Yes 2125 ld E (Y) 2126 eval # Eval 'sym2' 2127 num E # Need symbol 2128 jnz symErrEX 2129 sym E 2130 jz symErrEX 2131 call firstCharE_A 2132 ld (S) A 2133 end 2134 end 2135 pop (Sep3) # Get Sep3 2136 pop (Sep0) # and Sep0 2137 ld E (L I) # Get 'num' | 'sym' 2138 num E # Number? 2139 if nz # Yes 2140 pop A # Get scale 2141 call fmtNumAE_E # Convert to string 2142 else 2143 sym E # Symbol? 2144 if nz # Yes 2145 ld X (E TAIL) 2146 call nameX_X # Get name 2147 else 2148 link 2149 push ZERO # <L II> Number safe 2150 push ZERO # <L I> Result 2151 ld C 4 # Build name 2152 ld X S 2153 link 2154 call packECX_CX 2155 ld X (L I) # Get result 2156 drop 2157 end 2158 pop A # Get scale 2159 call symToNumXA_FE # Convert to number 2160 if nc # Failed 2161 ld E Nil 2162 end 2163 end 2164 drop 2165 pop Y 2166 pop X 2167 ret 2168 2169 ### Arithmetics ### 2170 # (+ 'num ..) -> num 2171 (code 'doAdd 2) 2172 push X 2173 push Y 2174 ld X E 2175 ld Y (E CDR) # Y on args 2176 ld E (Y) 2177 eval # Eval first arg 2178 cmp E Nil 2179 if ne # Non-NIL 2180 num E # Number? 2181 jz numErrEX # No 2182 link 2183 push ZERO # <L II> Safe 2184 push E # <L I> Result 2185 link 2186 do 2187 ld Y (Y CDR) # More args? 2188 atom Y 2189 while z # Yes 2190 ld E (Y) 2191 eval # Eval next arg 2192 cmp E Nil 2193 jz 10 # Abort if NIL 2194 num E # Number? 2195 jz numErrEX # No 2196 ld (L II) E # Save arg 2197 ld A (L I) # Result 2198 call addAE_A # Add 2199 ld (L I) A # Result 2200 loop 2201 ld E (L I) # Result 2202 10 drop 2203 end 2204 pop Y 2205 pop X 2206 ret 2207 2208 # (- 'num ..) -> num 2209 (code 'doSub 2) 2210 push X 2211 push Y 2212 ld X E 2213 ld Y (E CDR) # Y on args 2214 ld E (Y) 2215 eval # Eval first arg 2216 cmp E Nil 2217 if ne # Non-NIL 2218 num E # Number? 2219 jz numErrEX # No 2220 ld Y (Y CDR) # More than one arg? 2221 atom Y 2222 if nz # No: Unary minus 2223 cmp E ZERO # Zero? 2224 if ne # No 2225 xor E SIGN # Negate 2226 end 2227 else 2228 link 2229 push ZERO # <L II> Safe 2230 push E # <L I> Result 2231 link 2232 do 2233 ld E (Y) 2234 eval # Eval next arg 2235 cmp E Nil 2236 jz 10 # Abort if NIL 2237 num E # Number? 2238 jz numErrEX # No 2239 ld (L II) E # Save arg 2240 ld A (L I) # Result 2241 call subAE_A # Subtract 2242 ld (L I) A # Result 2243 ld Y (Y CDR) # More args? 2244 atom Y 2245 until nz # No 2246 ld E (L I) # Result 2247 10 drop 2248 end 2249 end 2250 pop Y 2251 pop X 2252 ret 2253 2254 # (inc 'num) -> num 2255 # (inc 'var ['num]) -> num 2256 (code 'doInc 2) 2257 push X 2258 push Y 2259 ld X E 2260 ld Y (E CDR) # Y on args 2261 ld E (Y) 2262 eval # Eval first arg 2263 cmp E Nil 2264 if ne # Non-NIL 2265 link 2266 push E # <L I/II> First arg 2267 link 2268 num E # Number? 2269 if nz # Yes 2270 call incE_A # Increment it 2271 else 2272 call checkVarEX 2273 sym E # Symbol? 2274 if nz # Yes 2275 sym (E TAIL) # External symbol? 2276 if nz # Yes 2277 call dbTouchEX # Touch it 2278 end 2279 end 2280 ld Y (Y CDR) # Next arg? 2281 atom Y 2282 if nz # No 2283 ld E (E) # Get VAL 2284 cmp E Nil # NIL? 2285 ldz A E 2286 if ne # No 2287 num E # Number? 2288 jz numErrEX # No 2289 call incE_A # Increment it 2290 ld ((L I)) A # Set new value 2291 end 2292 else 2293 ld E (Y) 2294 eval # Eval next arg 2295 tuck E # <L I> Second arg 2296 link 2297 ld A ((L II)) # First arg's VAL 2298 cmp A Nil # NIL? 2299 if ne # No 2300 num A # Number? 2301 jz numErrAX # No 2302 ld E (L I) # Second arg 2303 cmp E Nil # NIL? 2304 ldz A E 2305 if ne # No 2306 num E 2307 jz numErrEX # No 2308 call addAE_A # Add 2309 ld ((L II)) A # Set new value 2310 end 2311 end 2312 end 2313 end 2314 ld E A # Get result 2315 drop 2316 end 2317 pop Y 2318 pop X 2319 ret 2320 2321 # (dec 'num) -> num 2322 # (dec 'var ['num]) -> num 2323 (code 'doDec 2) 2324 push X 2325 push Y 2326 ld X E 2327 ld Y (E CDR) # Y on args 2328 ld E (Y) 2329 eval # Eval first arg 2330 cmp E Nil 2331 if ne # Non-NIL 2332 link 2333 push E # <L I/II> First arg 2334 link 2335 num E # Number? 2336 if nz # Yes 2337 call decE_A # Decrement it 2338 else 2339 call checkVarEX 2340 sym E # Symbol? 2341 if nz # Yes 2342 sym (E TAIL) # External symbol? 2343 if nz # Yes 2344 call dbTouchEX # Touch it 2345 end 2346 end 2347 ld Y (Y CDR) # Next arg? 2348 atom Y 2349 if nz # No 2350 ld E (E) # Get VAL 2351 cmp E Nil # NIL? 2352 ldz A E 2353 if ne # No 2354 num E # Number? 2355 jz numErrEX # No 2356 call decE_A # Decrement it 2357 ld ((L I)) A # Set new value 2358 end 2359 else 2360 ld E (Y) 2361 eval # Eval next arg 2362 tuck E # <L I> Second arg 2363 link 2364 ld A ((L II)) # First arg's VAL 2365 cmp A Nil # NIL? 2366 if ne # No 2367 num A # Number? 2368 jz numErrAX # No 2369 ld E (L I) # Second arg 2370 cmp E Nil # NIL? 2371 ldz A E 2372 if ne # No 2373 num E 2374 jz numErrEX # No 2375 call subAE_A # Subtract 2376 ld ((L II)) A # Set new value 2377 end 2378 end 2379 end 2380 end 2381 ld E A # Get result 2382 drop 2383 end 2384 pop Y 2385 pop X 2386 ret 2387 2388 # (* 'num ..) -> num 2389 (code 'doMul 2) 2390 push X 2391 push Y 2392 ld X E 2393 ld Y (E CDR) # Y on args 2394 ld E (Y) 2395 eval # Eval first arg 2396 cmp E Nil 2397 if ne # Non-NIL 2398 num E # Number? 2399 jz numErrEX # No 2400 ld B 0 # Init sign 2401 test E SIGN 2402 if nz 2403 off E SIGN 2404 inc B 2405 end 2406 link 2407 push ZERO # <L II> Safe 2408 push E # <L I> Result 2409 link 2410 push A # <L -I> Sign flag 2411 do 2412 ld Y (Y CDR) # More args? 2413 atom Y 2414 while z # Yes 2415 ld E (Y) 2416 eval # Eval next arg 2417 cmp E Nil 2418 jz 10 # Abort if NIL 2419 num E # Number? 2420 jz numErrEX # No 2421 test E SIGN # Arg negative? 2422 if nz # Yes 2423 off E SIGN # Make argument positive 2424 xor (L -I) 1 # Toggle result sign 2425 end 2426 ld (L II) E # Save arg 2427 ld A (L I) # Result 2428 call muluAE_A # Multiply 2429 ld (L I) A # Result 2430 loop 2431 ld E (L I) # Result 2432 test (L -I) 1 # Sign? 2433 if nz # Yes 2434 cmp E ZERO # Zero? 2435 if ne # No 2436 or E SIGN # Set negative 2437 end 2438 end 2439 10 drop 2440 end 2441 pop Y 2442 pop X 2443 ret 2444 2445 # (*/ 'num1 ['num2 ..] 'num3) -> num 2446 (code 'doMulDiv 2) 2447 push X 2448 push Y 2449 ld X E 2450 ld Y (E CDR) # Y on args 2451 ld E (Y) 2452 eval # Eval first arg 2453 cmp E Nil 2454 if ne # Non-NIL 2455 num E # Number? 2456 jz numErrEX # No 2457 ld B 0 # Init sign 2458 test E SIGN 2459 if nz 2460 off E SIGN 2461 inc B 2462 end 2463 link 2464 push ZERO # <L II> Safe 2465 push E # <L I> Result 2466 link 2467 push A # <L -I> Sign flag 2468 do 2469 ld Y (Y CDR) # Next arg 2470 ld E (Y) 2471 eval # Eval next arg 2472 cmp E Nil 2473 jz 10 # Abort if NIL 2474 num E # Number? 2475 jz numErrEX # No 2476 test E SIGN # Arg negative? 2477 if nz # Yes 2478 off E SIGN # Make argument positive 2479 xor (L -I) 1 # Toggle result sign 2480 end 2481 ld (L II) E # Save arg 2482 atom (Y CDR) # More args? 2483 while z # Yes 2484 ld A (L I) # Result 2485 call muluAE_A # Multiply 2486 ld (L I) A # Result 2487 loop 2488 cmp E ZERO # Zero? 2489 jeq divErrX # Yes 2490 ld A E # Last argument 2491 call shruA_A # / 2 2492 ld E (L I) # Get product 2493 ld (L I) A # Save halved argument 2494 call adduAE_A # Add for rounding 2495 ld (L I) A # Save rounded product 2496 ld E (L II) # Last argument 2497 call divuAE_A # Divide 2498 ld E A # Result 2499 test (L -I) 1 # Sign? 2500 if nz # Yes 2501 cmp E ZERO # Zero? 2502 if ne # No 2503 or E SIGN # Set negative 2504 end 2505 end 2506 10 drop 2507 end 2508 pop Y 2509 pop X 2510 ret 2511 2512 # (/ 'num ..) -> num 2513 (code 'doDiv 2) 2514 push X 2515 push Y 2516 ld X E 2517 ld Y (E CDR) # Y on args 2518 ld E (Y) 2519 eval # Eval first arg 2520 cmp E Nil 2521 if ne # Non-NIL 2522 num E # Number? 2523 jz numErrEX # No 2524 ld B 0 # Init sign 2525 test E SIGN 2526 if nz 2527 off E SIGN 2528 inc B 2529 end 2530 link 2531 push ZERO # <L II> Safe 2532 push E # <L I> Result 2533 link 2534 push A # <L -I> Sign flag 2535 do 2536 ld Y (Y CDR) # More args? 2537 atom Y 2538 while z # Yes 2539 ld E (Y) 2540 eval # Eval next arg 2541 cmp E Nil 2542 jz 10 # Abort if NIL 2543 num E # Number? 2544 jz numErrEX # No 2545 cmp E ZERO # Zero? 2546 jeq divErrX # Yes 2547 test E SIGN # Arg negative? 2548 if nz # Yes 2549 off E SIGN # Make argument positive 2550 xor (L -I) 1 # Toggle result sign 2551 end 2552 ld (L II) E # Save arg 2553 ld A (L I) # Result 2554 call divuAE_A # Divide 2555 ld (L I) A # Result 2556 loop 2557 ld E (L I) # Result 2558 test (L -I) 1 # Sign? 2559 if nz # Yes 2560 cmp E ZERO # Zero? 2561 if ne # No 2562 or E SIGN # Set negative 2563 end 2564 end 2565 10 drop 2566 end 2567 pop Y 2568 pop X 2569 ret 2570 2571 # (% 'num ..) -> num 2572 (code 'doRem 2) 2573 push X 2574 push Y 2575 ld X E 2576 ld Y (E CDR) # Y on args 2577 ld E (Y) 2578 eval # Eval first arg 2579 cmp E Nil 2580 if ne # Non-NIL 2581 num E # Number? 2582 jz numErrEX # No 2583 ld B 0 # Init sign 2584 test E SIGN 2585 if nz 2586 off E SIGN 2587 ld B 1 2588 end 2589 link 2590 push ZERO # <L II> Safe 2591 push E # <L I> Result 2592 link 2593 push A # <L -I> Sign flag 2594 do 2595 ld Y (Y CDR) # More args? 2596 atom Y 2597 while z # Yes 2598 ld E (Y) 2599 eval # Eval next arg 2600 cmp E Nil 2601 jz 10 # Abort if NIL 2602 num E # Number? 2603 jz numErrEX # No 2604 cmp E ZERO # Zero? 2605 jeq divErrX # Yes 2606 off E SIGN # Make argument positive 2607 ld (L II) E # Save arg 2608 ld A (L I) # Result 2609 call remuAE_A # Remainder 2610 ld (L I) A # Result 2611 loop 2612 ld E (L I) # Result 2613 test (L -I) 1 # Sign? 2614 if nz # Yes 2615 cmp E ZERO # Zero? 2616 if ne # No 2617 or E SIGN # Set negative 2618 end 2619 end 2620 10 drop 2621 end 2622 pop Y 2623 pop X 2624 ret 2625 2626 # (>> 'cnt 'num) -> num 2627 (code 'doShift 2) 2628 push X 2629 push Y 2630 ld X E 2631 ld Y (E CDR) # Y on args 2632 call evCntXY_FE # Get shift count 2633 link 2634 push ZERO # <L I> Safe 2635 link 2636 push E # <L -I> Shift count 2637 ld Y (Y CDR) # Second arg 2638 ld E (Y) 2639 eval # Eval number 2640 cmp E Nil # Any? 2641 if nz # Yes 2642 num E # Number? 2643 jz numErrEX # No 2644 ld A E # Number in A 2645 off A SIGN # Make positive 2646 and E SIGN # Sign bit 2647 push E # <L -II> Sign bit 2648 null (L -I) # Shift count? 2649 if nz # Yes 2650 if ns # Positive 2651 call shruA_A # Non-destructive 2652 ld (L I) A 2653 do 2654 dec (L -I) # Shift count? 2655 while nz 2656 call halfA_A # Shift right (destructive) 2657 ld (L I) A 2658 loop 2659 else 2660 call shluA_A # Non-destructive 2661 ld (L I) A 2662 do 2663 inc (L -I) # Shift count? 2664 while nz 2665 call twiceA_A # Shift left (destructive) 2666 ld (L I) A 2667 loop 2668 end 2669 end 2670 cmp A ZERO # Result zero? 2671 if ne # No 2672 or A (L -II) # Sign bit 2673 end 2674 ld E A # Get result 2675 end 2676 drop 2677 pop Y 2678 pop X 2679 ret 2680 2681 # (lt0 'any) -> num | NIL 2682 (code 'doLt0 2) 2683 ld E (E CDR) # Get arg 2684 ld E (E) 2685 eval # Eval it 2686 num E # Number? 2687 jz retNil 2688 test E SIGN # Negative? 2689 jz retNil 2690 ret # Yes: Return num 2691 2692 # (le0 'any) -> num | NIL 2693 (code 'doLe0 2) 2694 ld E (E CDR) # Get arg 2695 ld E (E) 2696 eval # Eval it 2697 num E # Number? 2698 jz retNil 2699 cmp E ZERO # Zero? 2700 if ne # No 2701 test E SIGN # Negative? 2702 jz retNil 2703 end 2704 ret # Yes: Return num 2705 2706 # (ge0 'any) -> num | NIL 2707 (code 'doGe0 2) 2708 ld E (E CDR) # Get arg 2709 ld E (E) 2710 eval # Eval it 2711 num E # Number? 2712 jz retNil 2713 test E SIGN # Positive? 2714 jnz retNil 2715 ret # Yes: Return num 2716 2717 # (gt0 'any) -> num | NIL 2718 (code 'doGt0 2) 2719 ld E (E CDR) # Get arg 2720 ld E (E) 2721 eval # Eval it 2722 num E # Number? 2723 jz retNil 2724 cmp E ZERO # Zero? 2725 jeq retNil 2726 test E SIGN # Positive? 2727 jnz retNil 2728 ret # Yes: Return num 2729 2730 # (abs 'num) -> num 2731 (code 'doAbs 2) 2732 push X 2733 ld X E 2734 ld E (E CDR) # Get arg 2735 ld E (E) 2736 eval # Eval it 2737 cmp E Nil # Any? 2738 if nz # Yes 2739 num E # Number? 2740 jz numErrEX # No 2741 off E SIGN # Clear sign 2742 end 2743 pop X 2744 ret 2745 2746 ### Bit operations ### 2747 # (bit? 'num ..) -> num | NIL 2748 (code 'doBitQ 2) 2749 push X 2750 push Y 2751 ld X E 2752 ld Y (E CDR) # Y on args 2753 ld E (Y) 2754 eval # Eval first arg 2755 num E # Number? 2756 jz numErrEX # No 2757 off E SIGN # Clear sign 2758 link 2759 push E # <L I> Bit mask 2760 link 2761 do 2762 ld Y (Y CDR) # More args? 2763 atom Y 2764 while z # Yes 2765 ld E (Y) 2766 eval # Eval next arg 2767 cmp E Nil 2768 while ne # Abort if NIL 2769 num E # Number? 2770 jz numErrEX # No 2771 off E SIGN # Clear sign 2772 ld C (L I) # Get mask 2773 do 2774 cnt C # C short? 2775 while z # No 2776 cnt E # E short? 2777 jnz 10 # Yes: Return NIL 2778 ld A (E DIG) # Get digit 2779 and A (C DIG) # Match? 2780 cmp A (C DIG) 2781 jne 10 # No: Return NIL 2782 ld C (C BIG) 2783 ld E (E BIG) 2784 loop 2785 cnt E # E also short? 2786 if z # No 2787 shr C 4 # Normalize 2788 ld E (E DIG) # Get digit 2789 end 2790 and E C # Match? 2791 cmp E C 2792 if ne # No 2793 10 ld E Nil # Return NIL 2794 drop 2795 pop Y 2796 pop X 2797 ret 2798 end 2799 loop 2800 ld E (L I) # Return bit mask 2801 drop 2802 pop Y 2803 pop X 2804 ret 2805 2806 # (& 'num ..) -> num 2807 (code 'doBitAnd 2) 2808 push X 2809 push Y 2810 ld X E 2811 ld Y (E CDR) # Y on args 2812 ld E (Y) 2813 eval # Eval first arg 2814 cmp E Nil 2815 if ne # Non-NIL 2816 num E # Number? 2817 jz numErrEX # No 2818 off E SIGN # Clear sign 2819 link 2820 push ZERO # <L II> Safe 2821 push E # <L I> Result 2822 link 2823 do 2824 ld Y (Y CDR) # More args? 2825 atom Y 2826 while z # Yes 2827 ld E (Y) 2828 eval # Eval next arg 2829 cmp E Nil 2830 jeq 10 # Abort if NIL 2831 num E # Number? 2832 jz numErrEX # No 2833 off E SIGN # Clear sign 2834 ld (L II) E # Save arg 2835 ld A (L I) # Result 2836 call anduAE_A # Bitwise AND 2837 ld (L I) A # Result 2838 loop 2839 ld E (L I) # Result 2840 10 drop 2841 end 2842 pop Y 2843 pop X 2844 ret 2845 2846 # (| 'num ..) -> num 2847 (code 'doBitOr 2) 2848 push X 2849 push Y 2850 ld X E 2851 ld Y (E CDR) # Y on args 2852 ld E (Y) 2853 eval # Eval first arg 2854 cmp E Nil 2855 if ne # Non-NIL 2856 num E # Number? 2857 jz numErrEX # No 2858 off E SIGN # Clear sign 2859 link 2860 push ZERO # <L II> Safe 2861 push E # <L I> Result 2862 link 2863 do 2864 ld Y (Y CDR) # More args? 2865 atom Y 2866 while z # Yes 2867 ld E (Y) 2868 eval # Eval next arg 2869 cmp E Nil 2870 jeq 10 # Abort if NIL 2871 num E # Number? 2872 jz numErrEX # No 2873 off E SIGN # Clear sign 2874 ld (L II) E # Save arg 2875 ld A (L I) # Result 2876 call oruAE_A # Bitwise OR 2877 ld (L I) A # Result 2878 loop 2879 ld E (L I) # Result 2880 10 drop 2881 end 2882 pop Y 2883 pop X 2884 ret 2885 2886 # (x| 'num ..) -> num 2887 (code 'doBitXor 2) 2888 push X 2889 push Y 2890 ld X E 2891 ld Y (E CDR) # Y on args 2892 ld E (Y) 2893 eval # Eval first arg 2894 cmp E Nil 2895 if ne # Non-NIL 2896 num E # Number? 2897 jz numErrEX # No 2898 off E SIGN # Clear sign 2899 link 2900 push ZERO # <L II> Safe 2901 push E # <L I> Result 2902 link 2903 do 2904 ld Y (Y CDR) # More args? 2905 atom Y 2906 while z # Yes 2907 ld E (Y) 2908 eval # Eval next arg 2909 cmp E Nil 2910 jeq 10 # Abort if NIL 2911 num E # Number? 2912 jz numErrEX # No 2913 off E SIGN # Clear sign 2914 ld (L II) E # Save arg 2915 ld A (L I) # Result 2916 call xoruAE_A # Bitwise XOR 2917 ld (L I) A # Result 2918 loop 2919 ld E (L I) # Result 2920 10 drop 2921 end 2922 pop Y 2923 pop X 2924 ret 2925 2926 ### Random generator ### 2927 (code 'initSeedE_E 0) 2928 push C # Counter 2929 ld C 0 2930 do 2931 atom E # Pair? 2932 while z # Yes 2933 push E # Recurse on CAR 2934 ld E (E) 2935 call initSeedE_E 2936 add C E 2937 pop E # Loop on CDR 2938 ld E (E CDR) 2939 loop 2940 cmp E Nil # NIL? 2941 if ne # No 2942 num E # Need number 2943 if z # Must be symbol 2944 ld E (E TAIL) 2945 call nameE_E # Get name 2946 end 2947 do 2948 cnt E # Short? 2949 while z # No 2950 add C (E DIG) # Add next digit 2951 ld E (E BIG) 2952 loop 2953 shr E 3 # Keep sign 2954 add C E # Add final short 2955 end 2956 ld E C # Return counter 2957 pop C 2958 ret 2959 2960 # (seed 'any) -> cnt 2961 (code 'doSeed 2) 2962 ld E (E CDR) # Get arg 2963 ld E (E) 2964 eval # Eval it 2965 call initSeedE_E # Initialize 'Seed' 2966 ld A 6364136223846793005 # Multiplier 2967 mul E # times 'Seed' 2968 ld (Seed) D # Save 2969 shr A (- 32 3) # Get higher 32 bits 2970 ld E A 2971 off E 7 # Keep sign 2972 or E CNT # Make short number 2973 ret 2974 2975 # (hash 'any) -> cnt 2976 (code 'doHash 2) 2977 push X 2978 ld E (E CDR) # Get arg 2979 ld E (E) 2980 eval # Eval it 2981 call initSeedE_E # Initialize 2982 ld X E # Value in X 2983 ld C 64 # Counter 2984 ld E 0 # Result 2985 do 2986 ld A X # Value XOR Result 2987 xor A E 2988 test A 1 # LSB set? 2989 if nz # Yes 2990 xor E (hex "14002") # CRC Polynom x**16 + x**15 + x**2 + 1 2991 end 2992 shr X 1 # Shift value 2993 shr E 1 # and result 2994 dec C # Done? 2995 until z # Yes 2996 inc E # Plus 1 2997 shl E 4 # Make short number 2998 or E CNT # Make short number 2999 pop X 3000 ret 3001 3002 # (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg 3003 (code 'doRand 2) 3004 push X 3005 push Y 3006 ld X E 3007 ld Y (E CDR) # Y on args 3008 ld A 6364136223846793005 # Multiplier 3009 mul (Seed) # times 'Seed' 3010 add D 1 # plus 1 3011 ld (Seed) D # Save 3012 ld E (Y) 3013 eval # Eval first arg 3014 cmp E Nil # Any? 3015 if eq # No 3016 shr A (- 32 3) # Get higher 32 bits 3017 ld E A 3018 off E 7 # Keep sign 3019 or E CNT # Make short number 3020 pop Y 3021 pop X 3022 ret 3023 end 3024 cmp E TSym # Boolean 3025 if eq 3026 ld A (Seed) 3027 rcl A 1 # Highest bit? 3028 if nc # No 3029 ld E Nil # Return NIL 3030 end # else return T 3031 pop Y 3032 pop X 3033 ret 3034 end 3035 call xCntEX_FE # Get cnt1 3036 push E # Save it 3037 ld Y (Y CDR) # Second arg 3038 call evCntXY_FE # Get cnt2 3039 inc E # Seed % (cnt2 + 1 - cnt1) + cnt1 3040 sub E (S) 3041 ld D (Seed) # Get 'Seed' 3042 shl C 32 # Get middle 64 bits 3043 shr A 32 3044 or A C 3045 ld C 0 3046 div E # Modulus in C 3047 pop E # + cnt1 3048 add E C 3049 pop Y 3050 pop X 3051 jmp boxE_E # Return short number 3052 3053 # vi:et:ts=3:sw=3