Changeset 11142


Ignore:
Timestamp:
Oct 18, 2008, 1:02:50 AM (11 years ago)
Author:
gb
Message:

Don't try to define two-arg + and - via macros; use ADD-BIGNUM-AND-FIXNUM
as appropriate.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-numbers.lisp

    r10152 r11142  
    7272
    7373 
    74   (defmacro two-arg-+/- (name op big-op)
    75     `(defun ,name (x y)     
    76       (number-case x
    77         (fixnum (number-case y
    78                   (fixnum (,op (the fixnum x) (the fixnum y)))
    79                   (double-float (rat-dfloat ,op x y))
    80                   (short-float (rat-sfloat ,op x y))
    81                   (bignum (with-small-bignum-buffers ((bx x))
    82                             (,big-op 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                            (%make-ratio n dy)))))
    88         (double-float (number-case y
    89                         (double-float (,op (the double-float x) (the double-float y)))
    90                         (short-float (with-stack-double-floats ((dy y))
    91                                        (,op (the double-float x) (the double-float dy))))
    92                         (rational (dfloat-rat ,op x y))
    93                         (complex (complex (,op x (%realpart y))
    94                                           ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart y))))))
    95         (short-float (number-case y                               
    96                        (short-float (,op (the short-float x) (the short-float y)))
    97                        (double-float (with-stack-double-floats ((dx x))
    98                                        (,op (the double-float dx) (the double-float y))))
    99                        (rational (sfloat-rat ,op x y))
    100                        (complex (complex (,op x (%realpart y))
    101                                          ,(if (eq op '-) `(- (%imagpart y)) `(%imagpart y))))))
    102         (bignum (number-case y
    103                   (bignum (,big-op x y))
    104                   (fixnum (with-small-bignum-buffers ((by y))
    105                             (,big-op x by)))
    106                   (double-float (rat-dfloat ,op x y))
    107                   (short-float (rat-sfloat ,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                      (%make-ratio n dy)))))
    114         (complex (number-case y
    115                    (complex (canonical-complex (,op (%realpart x) (%realpart y))
    116                                                (,op (%imagpart x) (%imagpart y))))
    117                    ((rational float) (complex (,op (%realpart x) y) (%imagpart x)))))
    118         (ratio (number-case 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                       (%make-ratio (,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) (%make-ratio 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 (%make-ratio nn nd)))))))))
    137                  (integer
    138                   (let* ((dx (%denominator x)) (n (,op (%numerator x) (* y dx))))
    139                     (%make-ratio n dx)))
    140                  (double-float (rat-dfloat ,op x y))
    141                  (short-float (rat-sfloat ,op x y))
    142                  (complex (complex (,op x (%realpart y))
    143                                    ,(if (eq op '-)`(- (%imagpart y)) `(%imagpart y)))))))))
     74
    14475
    14576  (declaim (inline  %make-complex %make-ratio))
     
    577508
    578509
    579 (two-arg-+/- +-2 + add-bignums)
    580 (two-arg-+/- --2 - subtract-bignum)
     510(defun +-2 (x y)     
     511  (number-case x
     512    (fixnum (number-case y
     513              (fixnum (+ (the fixnum x) (the fixnum y)))
     514              (double-float (rat-dfloat + x y))
     515              (short-float (rat-sfloat + x y))
     516              (bignum (add-bignum-and-fixnum y x))
     517              (complex (complex (+ x (%realpart y))
     518                                (%imagpart y)))
     519              (ratio (let* ((dy (%denominator y))
     520                            (n (+ (* x dy) (%numerator y))))
     521                       (%make-ratio n dy)))))
     522    (double-float (number-case y
     523                    (double-float (+ (the double-float x) (the double-float y)))
     524                    (short-float (with-stack-double-floats ((dy y))
     525                                   (+ (the double-float x) (the double-float dy))))
     526                    (rational (dfloat-rat + x y))
     527                    (complex (complex (+ x (%realpart y))
     528                                      (%imagpart y)))))
     529    (short-float (number-case y                               
     530                   (short-float (+ (the short-float x) (the short-float y)))
     531                   (double-float (with-stack-double-floats ((dx x))
     532                                   (+ (the double-float dx) (the double-float y))))
     533                   (rational (sfloat-rat + x y))
     534                   (complex (complex (+ x (%realpart y))
     535                                     (%imagpart y)))))
     536    (bignum (number-case y
     537              (bignum (add-bignums x y))
     538              (fixnum (add-bignum-and-fixnum x y))
     539              (double-float (rat-dfloat + x y))
     540              (short-float (rat-sfloat + 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                 (%make-ratio n dy)))))
     547    (complex (number-case y
     548               (complex (canonical-complex (+ (%realpart x) (%realpart y))
     549                                           (+ (%imagpart x) (%imagpart y))))
     550               ((rational float) (complex (+ (%realpart x) y) (%imagpart x)))))
     551    (ratio (number-case 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                  (%make-ratio (+ (* 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) (%make-ratio 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 (%make-ratio nn nd)))))))))
     570             (integer
     571              (let* ((dx (%denominator x)) (n (+ (%numerator x) (* y dx))))
     572                (%make-ratio n dx)))
     573             (double-float (rat-dfloat + x y))
     574             (short-float (rat-sfloat + x y))
     575             (complex (complex (+ x (%realpart y))
     576                               (%imagpart y)))))))
     577
     578(defun --2 (x y)     
     579  (number-case x
     580    (fixnum (number-case y
     581              (fixnum (- (the fixnum x) (the fixnum y)))
     582              (double-float (rat-dfloat - x y))
     583              (short-float (rat-sfloat - x y))
     584              (bignum
     585               (with-small-bignum-buffers ((bx x))
     586                        (subtract-bignum bx y)))
     587              (complex (complex (- x (%realpart y))
     588                                (- (%imagpart y))))
     589              (ratio (let* ((dy (%denominator y))
     590                            (n (- (* x dy) (%numerator y))))
     591                       (%make-ratio n dy)))))
     592    (double-float (number-case y
     593                    (double-float (- (the double-float x) (the double-float y)))
     594                    (short-float (with-stack-double-floats ((dy y))
     595                                   (- (the double-float x) (the double-float dy))))
     596                    (rational (dfloat-rat - x y))
     597                    (complex (complex (- x (%realpart y))
     598                                      (- (%imagpart y))))))
     599    (short-float (number-case y                               
     600                   (short-float (- (the short-float x) (the short-float y)))
     601                   (double-float (with-stack-double-floats ((dx x))
     602                                   (- (the double-float dx) (the double-float y))))
     603                   (rational (sfloat-rat - x y))
     604                   (complex (complex (- x (%realpart y))
     605                                     (- (%imagpart y))))))
     606    (bignum (number-case y
     607              (bignum (subtract-bignum x y))
     608              (fixnum (if (eql y target::target-most-negative-fixnum)
     609                        (with-small-bignum-buffers ((by y))
     610                          (subtract-bignum x by))
     611                        (add-bignum-and-fixnum x (- y))))
     612              (double-float (rat-dfloat - x y))
     613              (short-float (rat-sfloat - 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                 (%make-ratio n dy)))))
     620    (complex (number-case y
     621               (complex (canonical-complex (- (%realpart x) (%realpart y))
     622                                           (- (%imagpart x) (%imagpart y))))
     623               ((rational float) (complex (- (%realpart x) y) (%imagpart x)))))
     624    (ratio (number-case 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                  (%make-ratio (- (* 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) (%make-ratio 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 (%make-ratio nn nd)))))))))
     643             (integer
     644              (let* ((dx (%denominator x)) (n (- (%numerator x) (* y dx))))
     645                (%make-ratio n dx)))
     646             (double-float (rat-dfloat - x y))
     647             (short-float (rat-sfloat - x y))
     648             (complex (complex (- x (%realpart y))
     649                               (- (%imagpart y))))))))
    581650
    582651
Note: See TracChangeset for help on using the changeset viewer.