ikarus/src/ikarus.numerics.ss

(library (ikarus flonums)
  (export $flonum->exact $flonum-signed-biased-exponent flonum-parts
          inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
          $flnegative? flpositive? flabs fixnum->flonum
          flsin flcos fltan flasin flacos flatan fleven? flodd?
          flfloor flceiling flnumerator fldenominator flexp fllog
          flinteger? flonum-bytes flnan? flfinite? flinfinite?
          flexpt)
  (import 
    (ikarus system $bytevectors)
    (ikarus system $fx) 
    (only (ikarus system $flonums) $fl>=)
    (ikarus system $bignums)
    (except (ikarus system $flonums) $flonum-signed-biased-exponent
            $flonum-rational? $flonum-integer?)
    (except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
            flsin flcos fltan flasin flacos flatan fleven? flodd?
            flfloor flceiling flnumerator fldenominator flexp fllog
            flexpt flinteger? flonum-parts flonum-bytes flnan? flfinite?
            flinfinite?))
  
  (define (flonum-bytes f)
    (unless (flonum? f) 
      (error 'flonum-bytes "~s is not a flonum" f))
    (values 
      ($flonum-u8-ref f 0)
      ($flonum-u8-ref f 1)
      ($flonum-u8-ref f 2)
      ($flonum-u8-ref f 3)
      ($flonum-u8-ref f 4)
      ($flonum-u8-ref f 5)
      ($flonum-u8-ref f 6)
      ($flonum-u8-ref f 7)))
  (define (flonum-parts x)
    (unless (flonum? x) 
      (error 'flonum-parts "~s is not a flonum" x))
    (let-values ([(b0 b1 b2 b3 b4 b5 b6 b7) (flonum-bytes x)])
      (values 
        (zero? (fxlogand b0 128)) 
        (+ (fxsll (fxlogand b0 127) 4)
           (fxsra b1 4))
        (+ (+ b7 (fxsll b6 8) (fxsll b5 16))
           (* (+ b4
                 (fxsll b3 8)
                 (fxsll b2 16)
                 (fxsll (fxlogand b1 #b1111) 24))
              (expt 2 24))))))
  (define ($zero-m? f) 
    (and ($fxzero? ($flonum-u8-ref f 7))
         ($fxzero? ($flonum-u8-ref f 6))
         ($fxzero? ($flonum-u8-ref f 5))
         ($fxzero? ($flonum-u8-ref f 4))
         ($fxzero? ($flonum-u8-ref f 3))
         ($fxzero? ($flonum-u8-ref f 2))
         ($fxzero? ($fxlogand ($flonum-u8-ref f 1) #b1111))))



  (define ($flonum-signed-biased-exponent x)
    (let ([b0 ($flonum-u8-ref x 0)]
          [b1 ($flonum-u8-ref x 1)])
      (fxlogor (fxsll b0 4) (fxsra b1 4))))

  (define ($flonum-rational? x)
    (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
      (fx< be 2047)))

  (define ($flonum-integer? x)
    (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
      (cond
        [(fx= be 2047)  ;;; nans and infs
         #f]
        [(fx>= be 1075) ;;; magnitue large enough
         #t]
        [(fx= be 0) ;;; denormalized double, only +/-0.0 is integer
         (and (fx= ($flonum-u8-ref x 7) 0)
              (fx= ($flonum-u8-ref x 6) 0) 
              (fx= ($flonum-u8-ref x 5) 0) 
              (fx= ($flonum-u8-ref x 4) 0) 
              (fx= ($flonum-u8-ref x 3) 0) 
              (fx= ($flonum-u8-ref x 2) 0) 
              (fx= ($flonum-u8-ref x 1) 0))]
        [(fx< be (fx+ 1075 -52)) ;;; too small to be an integer
         #f]
        [else
         (let ([v ($flonum->exact x)])
           (or (fixnum? v) (bignum? v)))])))

  (define (flnumerator x) 
    (unless (flonum? x) 
      (error 'flnumerator "~s is not a flonum" x))
    (cond
      [($flonum-integer? x) x]
      [($flonum-rational? x) 
       (exact->inexact (numerator ($flonum->exact x)))]
      [else x]))

  (define (fldenominator x) 
    (unless (flonum? x) 
      (error 'fldenominator "~s is not a flonum" x))
    (cond
      [($flonum-integer? x) 1.0]
      [($flonum-rational? x) 
       (exact->inexact (denominator ($flonum->exact x)))]
      [(flnan? x) x]
      [else 1.0]))

  (define (fleven? x)
    (unless (flonum? x) 
      (error 'fleven? "~s is not a flonum" x))
    (let ([v ($flonum->exact x)])
      (cond
        [(fixnum? v) ($fx= ($fxlogand v 1) 0)]
        [(bignum? v) 
         (foreign-call "ikrt_even_bn" v)]
        [else (error 'fleven? "~s is not an integer flonum" x)])))

  (define (flodd? x)
    (unless (flonum? x) 
      (error 'flodd? "~s is not a flonum" x))
    (let ([v ($flonum->exact x)])
      (cond
        [(fixnum? v) ($fx= ($fxlogand v 1) 1)]
        [(bignum? v) 
         (not (foreign-call "ikrt_even_bn" v))]
        [else (error 'flodd? "~s is not an integer flonum" x)])))

  (define (flinteger? x)
    (if (flonum? x)
        ($flonum-integer? x)
        (error 'flinteger? "~s is not a flonum" x)))

  (define (flinfinite? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
          (and (fx= be 2047)  ;;; nans and infs
               ($zero-m? x)))
        (error 'flinfinite? "~s is not a flonum" x)))

  (define (flnan? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
          (and (fx= be 2047)  ;;; nans and infs
               (not ($zero-m? x))))
        (error 'flnan? "~s is not a flonum" x)))

  (define (flfinite? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
          (not (fx= be 2047)))
        (error 'flfinite? "~s is not a flonum" x)))
  
  (define ($flzero? x)
    (let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))])
       (and 
         (fx= be 0) ;;; denormalized double, only +/-0.0 is integer
         (and (fx= ($flonum-u8-ref x 7) 0)
              (fx= ($flonum-u8-ref x 6) 0) 
              (fx= ($flonum-u8-ref x 5) 0) 
              (fx= ($flonum-u8-ref x 4) 0) 
              (fx= ($flonum-u8-ref x 3) 0) 
              (fx= ($flonum-u8-ref x 2) 0) 
              (fx= ($flonum-u8-ref x 1) 0)))))

  (define ($flnegative? x)
    (let ([b0 ($flonum-u8-ref x 0)])
      (fx> b0 127)))

  (define ($flonum->exact x)
    (let-values ([(pos? be m) (flonum-parts x)])
      (cond
        [(<= 1 be 2046) ; normalized flonum
         (* (if pos? 1 -1)
            (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
        [(= be 0) 
         (* (if pos? 1 -1) 
            (* m (expt 2 -1074)))]
        [else #f])))
  

  (define (inexact->exact x)
    (cond
      [(flonum? x)
       (or ($flonum->exact x)
           (error 'inexact->exact "~s has no real value" x))]
      [(or (fixnum? x) (ratnum? x) (bignum? x)) x]
      [else
       (error 'inexact->exact "~s is not an inexact number" x)]))

  (define (exact x)
    (cond
      [(flonum? x)
       (or ($flonum->exact x)
           (error 'exact "~s has no real value" x))]
      [(or (fixnum? x) (ratnum? x) (bignum? x)) x]
      [else
       (error 'exact "~s is not an inexact number" x)]))


  (define (flpositive? x)
    (if (flonum? x) 
        ($fl> x 0.0)
        (error 'flpositive? "~s is not a flonum" x)))
  
  (define (flabs x)
    (if (flonum? x) 
        (if ($fl> x 0.0) 
            ($fl* x -1.0)
            x)
        (error 'flabs "~s is not a flonum" x)))

  (define (fixnum->flonum x)
    (if (fixnum? x) 
        ($fixnum->flonum x)
        (error 'fixnum->flonum "~s is not a fixnum")))

  (define (flsin x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_sin" x)
        (error 'flsin "~s is not a flonum" x)))

  (define (flcos x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_cos" x)
        (error 'flcos "~s is not a flonum" x)))

  (define (fltan x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_tan" x)
        (error 'fltan "~s is not a flonum" x)))

  (define (flasin x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_asin" x)
        (error 'flasin "~s is not a flonum" x)))

  (define (flacos x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_acos" x)
        (error 'flacos "~s is not a flonum" x)))

  (define (flatan x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_atan" x)
        (error 'flatan "~s is not a flonum" x)))


  (define (flfloor x)
    (define (ratnum-floor x)
      (let ([n (numerator x)] [d (denominator x)])
        (let ([q (quotient n d)])
          (if (>= n 0) q (- q 1)))))
    (cond
      [(flonum? x) 
       (let ([e ($flonum->exact x)])
         (cond
           [(ratnum? e)
            (exact->inexact (ratnum-floor e))] 
           [else x]))]
      [else (error 'flfloor "~s is not a flonum" x)]))

  (define (flceiling x)
    (cond
      [(flonum? x) 
       (let ([e ($flonum->exact x)])
         (cond
           [(ratnum? e)
            (exact->inexact (ceiling e))] 
           [else x]))]
      [else (error 'flceiling "~s is not a flonum" x)]))

  (define (flexp x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_exp" x ($make-flonum))
        (error 'flexp "~s is not a flonum" x)))

  (define (fllog x)
    (if (flonum? x)
        (if ($fl>= x 0.0) 
            (foreign-call "ikrt_fl_log" x)
            (error 'fllog "argument ~s should not be negative" x))
        (error 'fllog "~s is not a flonum" x)))

  (define (flexpt x y)
    (if (flonum? x)
        (if (flonum? y)
            (let ([y^ ($flonum->exact y)])
              (cond
                [(fixnum? y^) (inexact (expt x y^))]
                [(bignum? y^) (inexact (expt x y^))]
                [else
                 (foreign-call "ikrt_flfl_expt" x y ($make-flonum))]))
            (error 'flexpt "~s is not a flonum" y))
        (error 'fllog "~s is not a flonum" x)))


  )





(library (ikarus generic-arithmetic)
  (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
          modulo even? odd? logand $two-bignums
          bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift 
          positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt
          quotient+remainder number->string string->number min max
          abs truncate fltruncate sra sll
          exact->inexact inexact floor ceiling round log fl=? fl<? fl<=? fl>?
          fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative?
          sin cos tan asin acos atan sqrt exp
          flround flmax random)
  (import 
    (ikarus system $fx)
    (ikarus system $flonums)
    (ikarus system $ratnums)
    (ikarus system $bignums)
    (ikarus system $chars)
    (ikarus system $strings)
    (only (ikarus flonums) $flonum->exact $flzero? $flnegative?)
    (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
            remainder modulo even? odd? quotient+remainder number->string 
            bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift 
            positive? negative? logand $two-bignums
            string->number expt gcd lcm numerator denominator
            exact->inexact inexact floor ceiling round log
            exact-integer-sqrt min max abs
            fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin
            flzero? flnegative? sra sll exp
            sin cos tan asin acos atan sqrt truncate fltruncate
            flround flmax random))

  (define ($two-bignums)
    (list 1234567890 -1234567890
          12345678901234567890
          -12345678901234567890
          1234567890123456789012345678901234567890
          -1234567890123456789012345678901234567890))
;    (foreign-call "ikrt_fixnum_to_flonum" x))

  (module (bignum->flonum)
    ;  sbe         f6     f5       f4       f3       f2       f1       f0
    ;SEEEEEEE|EEEEmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm 
    ;        |        |        |        |        |        |        |
    ;   v0       v1       v2       v3       v4       v5       v6       v7
    (define ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)
      (let ([be (fx+ e 1075)])
        (let ([v ($make-flonum)])
          (cond
            [(fx< be 2047)
             (let ([sbe (if pos? be (fxlogor be (fxsll 1 11)))])
               ($flonum-set! v 0 (fxsra sbe 4))
               ($flonum-set! v 1 (fxlogor (fxsll sbe 4) (fxlogand f6 #b1111)))
               ($flonum-set! v 2 f5)
               ($flonum-set! v 3 f4)
               ($flonum-set! v 4 f3)
               ($flonum-set! v 5 f2)
               ($flonum-set! v 6 f1)
               ($flonum-set! v 7 f0))]
            [else ;;; inf
             (let ([sbe (if pos? 2047 (fxlogor 2047 (fxsll 1 11)))])
               ($flonum-set! v 0 (fxsra sbe 4))
               ($flonum-set! v 1 (fxsll sbe 4))
               ($flonum-set! v 2 0)
               ($flonum-set! v 3 0)
               ($flonum-set! v 4 0)
               ($flonum-set! v 5 0)
               ($flonum-set! v 6 0)
               ($flonum-set! v 7 0))])
          v)))
    (define ($flonum/c0 pos? e f6 f5 f4 f3 f2 f1 f0 c)
      (define ($fxeven? x)
        (fxzero? (fxlogand x 1)))
      (define-syntax cond*
        (syntax-rules (else)
          [(_ [test conseq] [else val]) 
           (if test conseq val)]
          [(_ [test conseq] [var  val] rest ...)
           (if test conseq (let ([var val]) (cond* rest ...)))]))
      (cond*
        [($fxeven? c) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)]
        [f0 (fx+ (fxlogand f0 255) 1)]
        [(fx< f0 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)]
        [f1 (fx+ (fxlogand f1 255) 1)]
        [(fx< f1 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 0)]
        [f2 (fx+ (fxlogand f2 255) 1)]
        [(fx< f2 256) ($flonum pos? e f6 f5 f4 f3 f2 0 0)]
        [f3 (fx+ (fxlogand f3 255) 1)]
        [(fx< f3 256) ($flonum pos? e f6 f5 f4 f3 0 0 0)]
        [f4 (fx+ (fxlogand f4 255) 1)]
        [(fx< f4 256) ($flonum pos? e f6 f5 f4 0 0 0 0)]
        [f5 (fx+ (fxlogand f5 255) 1)]
        [(fx< f5 256) ($flonum pos? e f6 f5 0 0 0 0 0)]
        [f6 (fx+ (fxlogand f6 #b1111) 1)]
        [(fx< f6 16) ($flonum pos? e f6 0 0 0 0 0 0)]
        [else ($flonum pos? (+ e 1) 0 0 0 0 0 0 0)]))
    (define ($flonum/aux pos? e b7 b6 b5 b4 b3 b2 b1 b0)
      (cond
        [(fx>= b7 #x80) 
         ($flonum/c0 pos? (fx+ e 3)
                                  (fxsra b7 3)
            (fxlogor (fxsll b7 5) (fxsra b6 3))
            (fxlogor (fxsll b6 5) (fxsra b5 3))
            (fxlogor (fxsll b5 5) (fxsra b4 3))
            (fxlogor (fxsll b4 5) (fxsra b3 3))
            (fxlogor (fxsll b3 5) (fxsra b2 3))
            (fxlogor (fxsll b2 5) (fxsra b1 3))
            (fxsra b1 2))]
        [(fx>= b7 #x40) 
         ($flonum/c0 pos? (fx+ e 2)
                                  (fxsra b7 2)
            (fxlogor (fxsll b7 6) (fxsra b6 2))
            (fxlogor (fxsll b6 6) (fxsra b5 2))
            (fxlogor (fxsll b5 6) (fxsra b4 2))
            (fxlogor (fxsll b4 6) (fxsra b3 2))
            (fxlogor (fxsll b3 6) (fxsra b2 2))
            (fxlogor (fxsll b2 6) (fxsra b1 2))
            (fxsra b1 1))]
        [(fx>= b7 #x20) 
         ($flonum/c0 pos? (fx+ e 1)
                                  (fxsra b7 1)
            (fxlogor (fxsll b7 7) (fxsra b6 1))
            (fxlogor (fxsll b6 7) (fxsra b5 1))
            (fxlogor (fxsll b5 7) (fxsra b4 1))
            (fxlogor (fxsll b4 7) (fxsra b3 1))
            (fxlogor (fxsll b3 7) (fxsra b2 1))
            (fxlogor (fxsll b2 7) (fxsra b1 1))
            b1)]
        [(fx>= b7 #x10) 
         ($flonum/c0 pos? e b7 b6 b5 b4 b3 b2 b1
            (fxsra b0 7))]
        [(fx>= b7 #x08)
         ($flonum/c0 pos? (fx- e 1)
            (fxlogor (fxsll b7 1) (fxsra b6 7))
            (fxlogor (fxsll b6 1) (fxsra b5 7))
            (fxlogor (fxsll b5 1) (fxsra b4 7))
            (fxlogor (fxsll b4 1) (fxsra b3 7))
            (fxlogor (fxsll b3 1) (fxsra b2 7))
            (fxlogor (fxsll b2 1) (fxsra b1 7))
            (fxlogor (fxsll b1 1) (fxsra b0 7))
            (fxsra b0 6))]
        [(fx>= b7 #x04)
         ($flonum/c0 pos? (fx- e 2)
            (fxlogor (fxsll b7 2) (fxsra b6 6))
            (fxlogor (fxsll b6 2) (fxsra b5 6))
            (fxlogor (fxsll b5 2) (fxsra b4 6))
            (fxlogor (fxsll b4 2) (fxsra b3 6))
            (fxlogor (fxsll b3 2) (fxsra b2 6))
            (fxlogor (fxsll b2 2) (fxsra b1 6))
            (fxlogor (fxsll b1 2) (fxsra b0 6))
            (fxsra b0 5))]
        [(fx>= b7 #x02)
         ($flonum/c0 pos? (fx- e 3)
            (fxlogor (fxsll b7 3) (fxsra b6 5))
            (fxlogor (fxsll b6 3) (fxsra b5 5))
            (fxlogor (fxsll b5 3) (fxsra b4 5))
            (fxlogor (fxsll b4 3) (fxsra b3 5))
            (fxlogor (fxsll b3 3) (fxsra b2 5))
            (fxlogor (fxsll b2 3) (fxsra b1 5))
            (fxlogor (fxsll b1 3) (fxsra b0 5))
            (fxsra b0 4))]
        [(fx>= b7 #x01)
         ($flonum/c0 pos? (fx- e 4)
            (fxlogor (fxsll b7 4) (fxsra b6 4))
            (fxlogor (fxsll b6 4) (fxsra b5 4))
            (fxlogor (fxsll b5 4) (fxsra b4 4))
            (fxlogor (fxsll b4 4) (fxsra b3 4))
            (fxlogor (fxsll b3 4) (fxsra b2 4))
            (fxlogor (fxsll b2 4) (fxsra b1 4))
            (fxlogor (fxsll b1 4) (fxsra b0 4))
            (fxsra b0 3))]
        [else (error '$float/aux "invalid b7=~s" b7)]))
    (define (bignum->flonum x)
      (define (bignum/4->flonum x) 
        ($flonum/aux ($bignum-positive? x) -24 
            ($bignum-byte-ref x 3)
            ($bignum-byte-ref x 2)
            ($bignum-byte-ref x 1)
            ($bignum-byte-ref x 0)
            0 0 0 0))
      (define (bignum/8->flonum x)
        ;;; bignum:  [b0 b1 b2 b3 b4 b5 b6 b7]
        (let ([b0 ($bignum-byte-ref x 0)]
              [b1 ($bignum-byte-ref x 1)]
              [b2 ($bignum-byte-ref x 2)]
              [b3 ($bignum-byte-ref x 3)]
              [b4 ($bignum-byte-ref x 4)]
              [b5 ($bignum-byte-ref x 5)]
              [b6 ($bignum-byte-ref x 6)]
              [b7 ($bignum-byte-ref x 7)] 
              [pos? ($bignum-positive? x)])
          (if (fx= b7 0)
              (if (fx= b6 0)
                  (if (fx= b5 0)
                      (if (fx= b4 0)
                          (error 'bignum8->flonum "malformed bignum")
                          ($flonum/aux pos? -16 b4 b3 b2 b1 b0 0 0 0))
                      ($flonum/aux pos? -8 b5 b4 b3 b2 b1 b0 0 0))
                  ($flonum/aux pos? 0 b6 b5 b4 b3 b2 b1 b0 0))
              ($flonum/aux pos? 8 b7 b6 b5 b4 b3 b2 b1 b0))))
      (define (bignum/n->flonum x bytes) 
        (define (aux x b7 bytes)
          ($flonum/aux ($bignum-positive? x) (+ (* bytes 8) -48)
             b7
             ($bignum-byte-ref x (fx- bytes 1))
             ($bignum-byte-ref x (fx- bytes 2))
             ($bignum-byte-ref x (fx- bytes 3))
             ($bignum-byte-ref x (fx- bytes 4))
             ($bignum-byte-ref x (fx- bytes 5))
             ($bignum-byte-ref x (fx- bytes 6))
             ($bignum-byte-ref x (fx- bytes 7))))
        ;;; bignum: [b0 b1 b2 b3 ... b_{bytes-1}]
        (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
          (if (fx= bn 0)
              (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
                (if (fx= bn 0)
                    (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
                      (if (fx= bn 0)
                          (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
                            (if (fx= bn 0)
                                (error 'bignum/n->flonum "malformed bignum")
                                (aux x bn bytes)))
                          (aux x bn bytes)))
                    (aux x bn bytes)))
              (aux x bn bytes))))
              
      (unless (bignum? x)
        (error 'bignum->flonum "~s is not a bignum" x))
      (let ([bytes ($bignum-size x)])
        (case bytes
          [(4)  (bignum/4->flonum x)]
          [(8)  (bignum/8->flonum x)]
          [else (bignum/n->flonum x bytes)]))))
  
  (define (ratnum->flonum x) 
    (let f ([n ($ratnum-n x)] [d ($ratnum-d x)])
      (let-values ([(q r) (quotient+remainder n d)])
        (if (= q 0) 
            (/ 1.0 (f d n))
            (if (= r 0)
                (inexact q)
                (+ q (f r d)))))))

  (define binary+
    (lambda (x y)
      (cond
        [(fixnum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxfxplus" x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnplus" x y)]
           [(flonum? y)
            ($fl+ ($fixnum->flonum x) y)]
           [(ratnum? y)
            ($make-ratnum
              (+ (* x ($ratnum-d y)) ($ratnum-n y))
              ($ratnum-d y))]
           [else 
            (error '+ "~s is not a number" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxbnplus" y x)]
           [(bignum? y)
            (foreign-call "ikrt_bnbnplus" x y)]
           [(flonum? y)
            ($fl+ (bignum->flonum x) y)]
           [(ratnum? y)
            ($make-ratnum
              (+ (* x ($ratnum-d y)) ($ratnum-n y))
              ($ratnum-d y))] 
           [else 
            (error '+ "~s is not a number" y)])]
        [(flonum? x)
         (cond
           [(fixnum? y)
            ($fl+ x ($fixnum->flonum y))]
           [(bignum? y)
            ($fl+ x (bignum->flonum y))]
           [(flonum? y)
            ($fl+ x y)]
           [(ratnum? y)
            ($fl+ x (ratnum->flonum y))]
           [else 
            (error '+ "~s is not a number" y)])]
        [(ratnum? x)
         (cond
           [(or (fixnum? y) (bignum? y))
            ($make-ratnum
              (+ (* y ($ratnum-d x)) ($ratnum-n x))
              ($ratnum-d x))]
           [(flonum? y)
            ($fl+ y (ratnum->flonum x))]
           [(ratnum? y)
            (let ([n0 ($ratnum-n x)] [n1 ($ratnum-n y)]
                  [d0 ($ratnum-d x)] [d1 ($ratnum-d y)])
              ;;; FIXME: inefficient
              (/ (+ (* n0 d1) (* n1 d0)) (* d0 d1)))]
           [else 
            (error '+ "~s is not a number" y)])] 
        [else (error '+ "~s is not a number" x)])))

  (define binary-logand
    (lambda (x y)
      (cond
        [(fixnum? x)
         (cond
           [(fixnum? y) ($fxlogand x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnlogand" x y)]
           [else 
            (error 'logand "~s is not an exact integer" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxbnlogand" y x)]
           [(bignum? y) 
            (foreign-call "ikrt_bnbnlogand" x y)]
           [else
            (error 'logand "~s is not an exact integer" y)])]
        [else (error 'logand "~s is not an exact integer" x)])))


  (define binary-
    (lambda (x y)
      (cond
        [(fixnum? x) 
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxfxminus" x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnminus" x y)]
           [(flonum? y)
            (if ($fx= x 0)
                ($fl* y -1.0)
                ($fl- ($fixnum->flonum x) y))]
           [(ratnum? y) 
            (let ([n ($ratnum-n y)] [d ($ratnum-d y)])
              (binary/ (binary- (binary* d x) n) d))]
           [else 
            (error '- "~s is not a number" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_bnfxminus" x y)]
           [(bignum? y)
            (foreign-call "ikrt_bnbnminus" x y)]
           [(flonum? y)
            ($fl- (bignum->flonum x) y)]
           [(ratnum? y) 
            (let ([n ($ratnum-n y)] [d ($ratnum-d y)])
              (binary/ (binary- (binary* d x) n) d))]
           [else 
            (error '- "~s is not a number" y)])]
        [(flonum? x)
         (cond
           [(fixnum? y)
            ($fl- x ($fixnum->flonum y))]
           [(bignum? y)
            ($fl- x (bignum->flonum y))]
           [(flonum? y)
            ($fl- x y)]
           [(ratnum? y) 
            (let ([n ($ratnum-n y)] [d ($ratnum-d y)])
              (binary/ (binary- (binary* d x) n) d))]
           [else
            (error '- "~s is not a number" y)])]
        [(ratnum? x)
         (let ([nx ($ratnum-n x)] [dx ($ratnum-d x)])
           (cond
             [(or (fixnum? y) (bignum? y) (flonum? y))
              (binary/ (binary- nx (binary* dx y)) dx)]
             [(ratnum? y)
              (let ([ny ($ratnum-n y)] [dy ($ratnum-d y)])
                (binary/ (binary- (binary* nx dy) (binary* ny dx))
                         (binary* dx dy)))]
             [else
              (error '- "~s is not a number" y)]))]
        [else (error '- "~s is not a number" x)])))

  (define binary*
    (lambda (x y)
      (cond
        [(fixnum? x) 
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxfxmult" x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnmult" x y)]
           [(flonum? y)
            ($fl* ($fixnum->flonum x) y)]
           [(ratnum? y) 
            (binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
           [else 
            (error '* "~s is not a number" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxbnmult" y x)]
           [(bignum? y)
            (foreign-call "ikrt_bnbnmult" x y)]
           [(flonum? y)
            ($fl* (bignum->flonum x) y)]
           [(ratnum? y) 
            (binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
           [else 
            (error '* "~s is not a number" y)])]
        [(flonum? x)
         (cond
           [(fixnum? y)
            ($fl* x ($fixnum->flonum y))]
           [(bignum? y)
            ($fl* x (bignum->flonum y))]
           [(flonum? y)
            ($fl* x y)]
           [(ratnum? y) 
            (binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
           [else
            (error '* "~s is not a number" y)])]
        [(ratnum? x) 
         (if (ratnum? y) 
             (binary/ (binary* ($ratnum-n x) ($ratnum-n y))
                      (binary* ($ratnum-d x) ($ratnum-d y)))
             (binary* y x))]
        [else (error '* "~s is not a number" x)])))

  (define +
    (case-lambda
      [(x y) (binary+ x y)]
      [(x y z) (binary+ (binary+ x y) z)]
      [(a)
       (cond
         [(fixnum? a) a]
         [(bignum? a) a]
         [else (error '+ "~s is not a number" a)])]
      [() 0]
      [(a b c d . e*)
       (let f ([ac (binary+ (binary+ (binary+ a b) c) d)]
               [e* e*])
         (cond
           [(null? e*) ac]
           [else (f (binary+ ac (car e*)) (cdr e*))]))]))

  (define logand
    (case-lambda
      [(x y) (binary-logand x y)]
      [(x y z) (binary-logand (binary-logand x y) z)]
      [(a)
       (cond
         [(fixnum? a) a]
         [(bignum? a) a]
         [else (error 'logand "~s is not a number" a)])]
      [() -1]
      [(a b c d . e*)
       (let f ([ac (binary-logand (binary-logand (binary-logand a b) c) d)]
               [e* e*])
         (cond
           [(null? e*) ac]
           [else (f (binary-logand ac (car e*)) (cdr e*))]))]))

  (define -
    (case-lambda
      [(x y) (binary- x y)]
      [(x y z) (binary- (binary- x y) z)]
      [(a) (binary- 0 a)]
      [(a b c d . e*)
       (let f ([ac (binary- (binary- (binary- a b) c) d)]
               [e* e*])
         (cond
           [(null? e*) ac]
           [else (f (binary- ac (car e*)) (cdr e*))]))]))

  (define *
    (case-lambda
      [(x y) (binary* x y)]
      [(x y z) (binary* (binary* x y) z)]
      [(a)
       (cond
         [(fixnum? a) a]
         [(bignum? a) a]
         [else (error '* "~s is not a number" a)])]
      [() 1]
      [(a b c d . e*)
       (let f ([ac (binary* (binary* (binary* a b) c) d)]
               [e* e*])
         (cond
           [(null? e*) ac]
           [else (f (binary* ac (car e*)) (cdr e*))]))]))

  (define (binary-gcd x y) 
    (define (gcd x y)
      (cond
        [($fx= y 0) x]
        [else (gcd y (remainder x y))]))
    (let ([x (if (< x 0) (- x) x)]
          [y (if (< y 0) (- y) y)])
      (cond
        [(> x y) (gcd x y)]
        [(< x y) (gcd y x)]
        [else x])))

  (define gcd
    (case-lambda
      [(x y) 
       (cond
         [(or (fixnum? x) (bignum? x))
          (cond
            [(or (fixnum? y) (bignum? y)) 
             (binary-gcd x y)]
            [(number? y)
             (error 'gcd "~s is not an exact integer" y)]
            [else 
             (error 'gcd "~s is not a number" y)])]
         [(number? x)
          (error 'gcd "~s is not an exact integer" x)]
         [else 
          (error 'gcd "~s is not a number" x)])]
      [(x)
       (cond
         [(or (fixnum? x) (bignum? x)) x]
         [(number? x)
          (error 'gcd "~s is not an exact integer" x)]
         [else 
          (error 'gcd "~s is not a number" x)])]
      [() 0]
      [(x y z . ls) 
       (let f ([g (gcd (gcd x y) z)] [ls ls])
         (cond
           [(null? ls) g]
           [else (f (gcd g (car ls)) (cdr ls))]))]))


  (define lcm
    (case-lambda
      [(x y) 
       (cond
         [(or (fixnum? x) (bignum? x))
          (cond
            [(or (fixnum? y) (bignum? y)) 
             (let ([x (if (< x 0) (- x) x)]
                   [y (if (< y 0) (- y) y)])
               (let ([g (binary-gcd x y)])
                 (binary* y (quotient x g))))]
            [(number? y)
             (error 'lcm "~s is not an exact integer" y)]
            [else 
             (error 'lcm "~s is not a number" y)])]
         [(number? x)
          (error 'lcm "~s is not an exact integer" x)]
         [else 
          (error 'lcm "~s is not a number" x)])]
      [(x)
       (cond
         [(or (fixnum? x) (bignum? x)) x]
         [(number? x)
          (error 'lcm "~s is not an exact integer" x)]
         [else 
          (error 'lcm "~s is not a number" x)])]
      [() 1]
      [(x y z . ls) 
       (let f ([g (lcm (lcm x y) z)] [ls ls])
         (cond
           [(null? ls) g]
           [else (f (lcm g (car ls)) (cdr ls))]))]))




  (define binary/ ;;; implements ratnums
    (lambda (x y)
      (cond
        [(flonum? x)
         (cond
           [(flonum? y) ($fl/ x y)]
           [(fixnum? y) ($fl/ x ($fixnum->flonum y))]
           [(bignum? y) ($fl/ x (bignum->flonum y))]
           [(ratnum? y) ($fl/ x (