Changeset 11142
 Timestamp:
 Oct 18, 2008, 1:02:50 AM (13 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/source/level0/l0numbers.lisp
r10152 r11142 72 72 73 73 74 (defmacro twoarg+/ (name op bigop) 75 `(defun ,name (x y) 76 (numbercase x 77 (fixnum (numbercase y 78 (fixnum (,op (the fixnum x) (the fixnum y))) 79 (doublefloat (ratdfloat ,op x y)) 80 (shortfloat (ratsfloat ,op x y)) 81 (bignum (withsmallbignumbuffers ((bx x)) 82 (,bigop bx y))) 83 (complex (complex (,op x (%realpart y)) 84 ,(if (eq op ')`( (%imagpart y)) `(%imagpart y)))) 85 (ratio (let* ((dy (%denominator y)) 86 (n (,op (* x dy) (%numerator y)))) 87 (%makeratio n dy))))) 88 (doublefloat (numbercase y 89 (doublefloat (,op (the doublefloat x) (the doublefloat y))) 90 (shortfloat (withstackdoublefloats ((dy y)) 91 (,op (the doublefloat x) (the doublefloat dy)))) 92 (rational (dfloatrat ,op x y)) 93 (complex (complex (,op x (%realpart y)) 94 ,(if (eq op ')`( (%imagpart y)) `(%imagpart y)))))) 95 (shortfloat (numbercase y 96 (shortfloat (,op (the shortfloat x) (the shortfloat y))) 97 (doublefloat (withstackdoublefloats ((dx x)) 98 (,op (the doublefloat dx) (the doublefloat y)))) 99 (rational (sfloatrat ,op x y)) 100 (complex (complex (,op x (%realpart y)) 101 ,(if (eq op ') `( (%imagpart y)) `(%imagpart y)))))) 102 (bignum (numbercase y 103 (bignum (,bigop x y)) 104 (fixnum (withsmallbignumbuffers ((by y)) 105 (,bigop x by))) 106 (doublefloat (ratdfloat ,op x y)) 107 (shortfloat (ratsfloat ,op x y)) 108 (complex (complex (,op x (realpart y)) 109 ,(if (eq op ')`( (%imagpart y)) `(%imagpart y)))) 110 (ratio 111 (let* ((dy (%denominator y)) 112 (n (,op (* x dy) (%numerator y)))) 113 (%makeratio n dy))))) 114 (complex (numbercase y 115 (complex (canonicalcomplex (,op (%realpart x) (%realpart y)) 116 (,op (%imagpart x) (%imagpart y)))) 117 ((rational float) (complex (,op (%realpart x) y) (%imagpart x))))) 118 (ratio (numbercase y 119 (ratio 120 (let* ((nx (%numerator x)) 121 (dx (%denominator x)) 122 (ny (%numerator y)) 123 (dy (%denominator y)) 124 (g1 (gcd dx dy))) 125 (if (eql g1 1) 126 (%makeratio (,op (* nx dy) (* dx ny)) (* dx dy)) 127 (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny))) 128 (g2 (gcd t1 g1)) 129 (t2 (truncate dx g1))) 130 (cond ((eql t1 0) 0) 131 ((eql g2 1) (%makeratio t1 (* t2 dy))) 132 (t 133 (let* ((nn (truncate t1 g2)) 134 (t3 (truncate dy g2)) 135 (nd (if (eql t2 1) t3 (* t2 t3)))) 136 (if (eql nd 1) nn (%makeratio nn nd))))))))) 137 (integer 138 (let* ((dx (%denominator x)) (n (,op (%numerator x) (* y dx)))) 139 (%makeratio n dx))) 140 (doublefloat (ratdfloat ,op x y)) 141 (shortfloat (ratsfloat ,op x y)) 142 (complex (complex (,op x (%realpart y)) 143 ,(if (eq op ')`( (%imagpart y)) `(%imagpart y))))))))) 74 144 75 145 76 (declaim (inline %makecomplex %makeratio)) … … 577 508 578 509 579 (twoarg+/ +2 + addbignums) 580 (twoarg+/ 2  subtractbignum) 510 (defun +2 (x y) 511 (numbercase x 512 (fixnum (numbercase y 513 (fixnum (+ (the fixnum x) (the fixnum y))) 514 (doublefloat (ratdfloat + x y)) 515 (shortfloat (ratsfloat + x y)) 516 (bignum (addbignumandfixnum y x)) 517 (complex (complex (+ x (%realpart y)) 518 (%imagpart y))) 519 (ratio (let* ((dy (%denominator y)) 520 (n (+ (* x dy) (%numerator y)))) 521 (%makeratio n dy))))) 522 (doublefloat (numbercase y 523 (doublefloat (+ (the doublefloat x) (the doublefloat y))) 524 (shortfloat (withstackdoublefloats ((dy y)) 525 (+ (the doublefloat x) (the doublefloat dy)))) 526 (rational (dfloatrat + x y)) 527 (complex (complex (+ x (%realpart y)) 528 (%imagpart y))))) 529 (shortfloat (numbercase y 530 (shortfloat (+ (the shortfloat x) (the shortfloat y))) 531 (doublefloat (withstackdoublefloats ((dx x)) 532 (+ (the doublefloat dx) (the doublefloat y)))) 533 (rational (sfloatrat + x y)) 534 (complex (complex (+ x (%realpart y)) 535 (%imagpart y))))) 536 (bignum (numbercase y 537 (bignum (addbignums x y)) 538 (fixnum (addbignumandfixnum x y)) 539 (doublefloat (ratdfloat + x y)) 540 (shortfloat (ratsfloat + x y)) 541 (complex (complex (+ x (realpart y)) 542 (%imagpart y))) 543 (ratio 544 (let* ((dy (%denominator y)) 545 (n (+ (* x dy) (%numerator y)))) 546 (%makeratio n dy))))) 547 (complex (numbercase y 548 (complex (canonicalcomplex (+ (%realpart x) (%realpart y)) 549 (+ (%imagpart x) (%imagpart y)))) 550 ((rational float) (complex (+ (%realpart x) y) (%imagpart x))))) 551 (ratio (numbercase y 552 (ratio 553 (let* ((nx (%numerator x)) 554 (dx (%denominator x)) 555 (ny (%numerator y)) 556 (dy (%denominator y)) 557 (g1 (gcd dx dy))) 558 (if (eql g1 1) 559 (%makeratio (+ (* nx dy) (* dx ny)) (* dx dy)) 560 (let* ((t1 (+ (* nx (truncate dy g1)) (* (truncate dx g1) ny))) 561 (g2 (gcd t1 g1)) 562 (t2 (truncate dx g1))) 563 (cond ((eql t1 0) 0) 564 ((eql g2 1) (%makeratio t1 (* t2 dy))) 565 (t 566 (let* ((nn (truncate t1 g2)) 567 (t3 (truncate dy g2)) 568 (nd (if (eql t2 1) t3 (* t2 t3)))) 569 (if (eql nd 1) nn (%makeratio nn nd))))))))) 570 (integer 571 (let* ((dx (%denominator x)) (n (+ (%numerator x) (* y dx)))) 572 (%makeratio n dx))) 573 (doublefloat (ratdfloat + x y)) 574 (shortfloat (ratsfloat + x y)) 575 (complex (complex (+ x (%realpart y)) 576 (%imagpart y))))))) 577 578 (defun 2 (x y) 579 (numbercase x 580 (fixnum (numbercase y 581 (fixnum ( (the fixnum x) (the fixnum y))) 582 (doublefloat (ratdfloat  x y)) 583 (shortfloat (ratsfloat  x y)) 584 (bignum 585 (withsmallbignumbuffers ((bx x)) 586 (subtractbignum bx y))) 587 (complex (complex ( x (%realpart y)) 588 ( (%imagpart y)))) 589 (ratio (let* ((dy (%denominator y)) 590 (n ( (* x dy) (%numerator y)))) 591 (%makeratio n dy))))) 592 (doublefloat (numbercase y 593 (doublefloat ( (the doublefloat x) (the doublefloat y))) 594 (shortfloat (withstackdoublefloats ((dy y)) 595 ( (the doublefloat x) (the doublefloat dy)))) 596 (rational (dfloatrat  x y)) 597 (complex (complex ( x (%realpart y)) 598 ( (%imagpart y)))))) 599 (shortfloat (numbercase y 600 (shortfloat ( (the shortfloat x) (the shortfloat y))) 601 (doublefloat (withstackdoublefloats ((dx x)) 602 ( (the doublefloat dx) (the doublefloat y)))) 603 (rational (sfloatrat  x y)) 604 (complex (complex ( x (%realpart y)) 605 ( (%imagpart y)))))) 606 (bignum (numbercase y 607 (bignum (subtractbignum x y)) 608 (fixnum (if (eql y target::targetmostnegativefixnum) 609 (withsmallbignumbuffers ((by y)) 610 (subtractbignum x by)) 611 (addbignumandfixnum x ( y)))) 612 (doublefloat (ratdfloat  x y)) 613 (shortfloat (ratsfloat  x y)) 614 (complex (complex ( x (realpart y)) 615 ( (%imagpart y)))) 616 (ratio 617 (let* ((dy (%denominator y)) 618 (n ( (* x dy) (%numerator y)))) 619 (%makeratio n dy))))) 620 (complex (numbercase y 621 (complex (canonicalcomplex ( (%realpart x) (%realpart y)) 622 ( (%imagpart x) (%imagpart y)))) 623 ((rational float) (complex ( (%realpart x) y) (%imagpart x))))) 624 (ratio (numbercase y 625 (ratio 626 (let* ((nx (%numerator x)) 627 (dx (%denominator x)) 628 (ny (%numerator y)) 629 (dy (%denominator y)) 630 (g1 (gcd dx dy))) 631 (if (eql g1 1) 632 (%makeratio ( (* nx dy) (* dx ny)) (* dx dy)) 633 (let* ((t1 ( (* nx (truncate dy g1)) (* (truncate dx g1) ny))) 634 (g2 (gcd t1 g1)) 635 (t2 (truncate dx g1))) 636 (cond ((eql t1 0) 0) 637 ((eql g2 1) (%makeratio t1 (* t2 dy))) 638 (t 639 (let* ((nn (truncate t1 g2)) 640 (t3 (truncate dy g2)) 641 (nd (if (eql t2 1) t3 (* t2 t3)))) 642 (if (eql nd 1) nn (%makeratio nn nd))))))))) 643 (integer 644 (let* ((dx (%denominator x)) (n ( (%numerator x) (* y dx)))) 645 (%makeratio n dx))) 646 (doublefloat (ratdfloat  x y)) 647 (shortfloat (ratsfloat  x y)) 648 (complex (complex ( x (%realpart y)) 649 ( (%imagpart y)))))))) 581 650 582 651
Note: See TracChangeset
for help on using the changeset viewer.