ikarus/scheme/ikarus.numerics.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(library (ikarus flonums)
  (export $flonum->exact 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 $flround flround)
  (import 
    (ikarus system $bytevectors)
    (ikarus system $fx) 
    (only (ikarus system $flonums) $fl>= $flonum-sbe)
    (ikarus system $bignums)
    (except (ikarus system $flonums) $flonum-rational?
            $flonum-integer? $flround)
    (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? flround))
  
  (define (flonum-bytes f)
    (unless (flonum? f) 
      (die 'flonum-bytes "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) 
      (die 'flonum-parts "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-rational? x)
    (let ([be ($fxlogand ($flonum-sbe x) 
                ($fxsub1 ($fxsll 1 11)))])
      ($fx< be 2047)))

  (define ($flonum-integer? x)
    (let ([be ($fxlogand ($flonum-sbe x) 
                ($fxsub1 ($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 ($fl= x ($flround x))])))


  (define ($flround x) 
    (foreign-call "ikrt_fl_round" x ($make-flonum)))

  (define (flround x)
    (if (flonum? x)
        ($flround x)
        (die 'flround "not a flonum" x)))

  (module ($flonum->exact)
    (define ($flonum-signed-mantissa x)
      (let ([b0 ($flonum-u8-ref x 0)])
        (let ([m0 ($fx+ ($flonum-u8-ref x 7) 
                        ($fx+ ($fxsll ($flonum-u8-ref x 6) 8)
                              ($fxsll ($flonum-u8-ref x 5) 16)))]
              [m1 ($fx+ ($flonum-u8-ref x 4)
                        ($fx+ ($fxsll ($flonum-u8-ref x 3) 8)
                              ($fxsll ($flonum-u8-ref x 2) 16)))]
              [m2 (let ([b1 ($flonum-u8-ref x 1)])
                    (if (and ($fx= ($fxlogand b0 #x7F) 0)
                             ($fx= ($fxsra b1 4) 0))
                        ($fxlogand b1 #xF)
                        ($fxlogor ($fxlogand b1 #xF) #x10)))])
          (if ($fx= 0 ($fxlogand #x80 b0))
              (+ (bitwise-arithmetic-shift-left ($fxlogor m1 ($fxsll m2 24)) 24) m0)
              (+ (bitwise-arithmetic-shift-left 
                   ($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
                 ($fx- 0 m0))))))
    (define ($flonum->exact x)
      (import (ikarus))
      (let ([sbe ($flonum-sbe x)])
        (let ([be ($fxlogand sbe #x7FF)])
          (cond
            [($fx= be 2047) #f] ;;; nans/infs
            [($fx>= be 1075)    ;;; magnitude large enough to be an integer
             (bitwise-arithmetic-shift-left 
               ($flonum-signed-mantissa x)
               (- be 1075))]
            [else
             ;;; this really needs to get optimized.
             (let-values ([(pos? be m) (flonum-parts x)])
               (cond
                 [(= be 0) ;;; denormalized
                  (if (= m 0) 
                      0
                      (* (if pos? 1 -1) 
                         (/ m (expt 2 1074))))]
                 [else ; normalized flonum
                  (/ (+ m (expt 2 52))
                     (bitwise-arithmetic-shift-left 
                       (if pos? 1 -1) 
                       (- 1075 be)))]))])))))

  (define (flnumerator x) 
    (unless (flonum? x) 
      (die 'flnumerator "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) 
      (die 'fldenominator "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)
    ;;; FIXME: optimize
    (unless (flonum? x) 
      (die 'fleven? "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 (die 'fleven? "not an integer flonum" x)])))

  (define (flodd? x)
    (unless (flonum? x) 
      (die 'flodd? "not a flonum" x))
    ;;; FIXME: optimize
    (let ([v ($flonum->exact x)])
      (cond
        [(fixnum? v) ($fx= ($fxlogand v 1) 1)]
        [(bignum? v) 
         (not (foreign-call "ikrt_even_bn" v))]
        [else (die 'flodd? "not an integer flonum" x)])))

  (define (flinteger? x)
    (if (flonum? x)
        ($flonum-integer? x)
        (die 'flinteger? "not a flonum" x)))

  (define (flinfinite? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
          (and (fx= be 2047)  ;;; nans and infs
               ($zero-m? x)))
        (die 'flinfinite? "not a flonum" x)))

  (define (flnan? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
          (and (fx= be 2047)  ;;; nans and infs
               (not ($zero-m? x))))
        (die 'flnan? "not a flonum" x)))

  (define (flfinite? x) 
    (if (flonum? x) 
        (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
          (not (fx= be 2047)))
        (die 'flfinite? "not a flonum" x)))
  
  (define ($flzero? x)
    (let ([be (fxlogand ($flonum-sbe 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 (inexact->exact x)
    (cond
      [(flonum? x)
       (or ($flonum->exact x)
           (die 'inexact->exact "no real value" x))]
      [(or (fixnum? x) (ratnum? x) (bignum? x)) x]
      [else
       (die 'inexact->exact "not an inexact number" x)]))

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


  (define (flpositive? x)
    (if (flonum? x) 
        ($fl> x 0.0)
        (die 'flpositive? "not a flonum" x)))
  
  (define (flabs x)
    (if (flonum? x) 
        (if ($fx> ($flonum-u8-ref x 0) 127)
            ($fl* x -1.0)
            x)
        (die 'flabs "not a flonum" x)))

  (define (fixnum->flonum x)
    (if (fixnum? x) 
        ($fixnum->flonum x)
        (die 'fixnum->flonum "not a fixnum")))

  (define (flsin x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_sin" x)
        (die 'flsin "not a flonum" x)))

  (define (flcos x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_cos" x)
        (die 'flcos "not a flonum" x)))

  (define (fltan x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_tan" x)
        (die 'fltan "not a flonum" x)))

  (define (flasin x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_asin" x)
        (die 'flasin "not a flonum" x)))

  (define (flacos x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_acos" x)
        (die 'flacos "not a flonum" x)))

  (define flatan 
    (case-lambda
      [(x)
       (if (flonum? x) 
           (foreign-call "ikrt_fl_atan" x)
           (die 'flatan "not a flonum" x))]
      [(x y)
       (if (flonum? x)
           (if (flonum? y)
               (foreign-call "ikrt_atan2" x y)
               (die 'flatan "not a flonum" y))
           (die 'flatan "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) 
       ;;; optimize for integer flonums case
       (let ([e ($flonum->exact x)])
         (cond
           [(ratnum? e)
            (exact->inexact (ratnum-floor e))] 
           [else x]))]
      [else (die 'flfloor "not a flonum" x)]))

  (define (flceiling x)
    (cond
      [(flonum? x) 
       ;;; optimize for integer flonums case
       (let ([e ($flonum->exact x)])
         (cond
           [(ratnum? e)
            (exact->inexact (ceiling e))] 
           [else x]))]
      [else (die 'flceiling "not a flonum" x)]))

  (define (flexp x)
    (if (flonum? x) 
        (foreign-call "ikrt_fl_exp" x ($make-flonum))
        (die 'flexp "not a flonum" x)))

  (define fllog
    (case-lambda
      [(x)
       (if (flonum? x)
           (foreign-call "ikrt_fl_log" x)
           (die 'fllog "not a flonum" x))]
      [(x y)
       (if (flonum? x)
           (if (flonum? y)
               (fl/ (foreign-call "ikrt_fl_log" x)
                    (foreign-call "ikrt_fl_log" y))
               (die 'fllog "not a flonum" y))
           (die 'fllog "not a flonum" x))]))

  (define (flexpt x y)
    (if (flonum? x)
        (if (flonum? y)
            (let ([y^ ($flonum->exact y)]) 
              ;;; FIXME: performance bottleneck?
              (cond
                [(fixnum? y^) (inexact (expt x y^))]
                [(bignum? y^) (inexact (expt x y^))]
                [else
                 (foreign-call "ikrt_flfl_expt" x y ($make-flonum))]))
            (die 'flexpt "not a flonum" y))
        (die 'fllog "not a flonum" x)))
)


(library (ikarus generic-arithmetic)
  (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
          modulo even? odd? bitwise-and bitwise-not bitwise-ior
          bitwise-xor bitwise-if
          bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left 
          bitwise-arithmetic-shift 
          bitwise-length bitwise-copy-bit-field 
          bitwise-copy-bit bitwise-bit-field
          positive? negative? expt gcd lcm numerator denominator
          exact-integer-sqrt
          quotient+remainder number->string min max
          abs truncate fltruncate sra sll real->flonum
          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
          sinh cosh tanh asinh acosh atanh
          flmax random
          error@add1 error@sub1)
  (import 
    (ikarus system $fx)
    (ikarus system $flonums)
    (ikarus system $ratnums)
    (ikarus system $bignums)
    (ikarus system $compnums)
    (ikarus system $chars)
    (ikarus system $strings)
    (only (ikarus flonums) $flonum->exact $flzero? $flnegative?
          $flround)
    (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 
            bitwise-length bitwise-copy-bit-field 
            bitwise-copy-bit bitwise-bit-field
            positive? negative? bitwise-and bitwise-not bitwise-ior
            bitwise-xor bitwise-if
            expt gcd lcm numerator denominator
            exact->inexact inexact floor ceiling round log
            exact-integer-sqrt min max abs real->flonum
            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
            sinh cosh tanh asinh acosh atanh
            flmax random))

  (define (bignum->flonum x)
    (foreign-call "ikrt_bignum_to_flonum" x 0 ($make-flonum)))


  ;;; (define (ratnum->flonum x)
  ;;;   (define (->flonum n d)
  ;;;     (let-values ([(q r) (quotient+remainder n d)])
  ;;;       (if (= r 0) 
  ;;;           (inexact q)
  ;;;           (if (= q 0) 
  ;;;               (/ (->flonum d n))
  ;;;               (+ q (->flonum r d))))))
  ;;;   (let ([n (numerator x)] [d (denominator x)])
  ;;;     (let ([b (bitwise-first-bit-set n)])
  ;;;       (if (eqv? b 0)
  ;;;           (let ([b (bitwise-first-bit-set d)])
  ;;;             (if (eqv? b 0)
  ;;;                 (->flonum n d)
  ;;;                 (/ (->flonum n (bitwise-arithmetic-shift-right d b))
  ;;;                    (expt 2.0 b))))
  ;;;           (* (->flonum (bitwise-arithmetic-shift-right n b) d)
  ;;;              (expt 2.0 b))))))
  
  ;;; (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 (ratnum->flonum num)
    (define (rat n m)
      (let-values ([(q r) (quotient+remainder n m)])
         (if (= r 0) 
             (inexact q)
             (fl+ (inexact q) (fl/ 1.0 (rat  m r))))))
    (define (pos n d)
      (cond
        [(> n d) (rat n d)]
        [(even? n)
         (* (pos (sra n 1) d) 2.0)]
        [(even? d) 
         (/ (pos n (sra d 1)) 2.0)]
        [else 
         (/ (rat d n))]))
    (let ([n ($ratnum-n num)] [d ($ratnum-d num)])
      (if (> n 0) 
          (pos n d)
          (- (pos (- n) d)))))

  (define (err who x)
    (die who (if (number? x) "invalid argument" "not a number") x))


  (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))]
           [(compnum? y) 
            ($make-compnum 
              (binary+ x ($compnum-real y)) 
              ($compnum-imag y))]
           [(cflonum? y)
            ($make-cflonum
              (binary+ x ($cflonum-real y))
              ($cflonum-imag y))]
           [else (err '+ 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))] 
           [(compnum? y) 
            ($make-compnum 
              (binary+ x ($compnum-real y)) 
              ($compnum-imag y))] 
           [(cflonum? y)
            ($make-cflonum
              (binary+ x ($cflonum-real y))
              ($cflonum-imag y))]
           [else (err '+ 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))]
           [(cflonum? y)
            ($make-cflonum
              ($fl+ x ($cflonum-real y))
              ($cflonum-imag y))]
           [(compnum? y)
            ($make-cflonum
              (binary+ x ($compnum-real y))
              (inexact ($compnum-imag y)))]
           [else (err '+ 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)))]
           [(compnum? y) 
            ($make-compnum 
              (binary+ x ($compnum-real y)) 
              ($compnum-imag y))] 
           [(cflonum? y)
            ($make-cflonum
              (binary+ x ($cflonum-real y))
              ($cflonum-imag y))] 
           [else (err '+ y)])]
        [(compnum? x) 
         (cond
           [(or (fixnum? y) (bignum? y) (ratnum? y))
            ($make-compnum 
              (binary+ ($compnum-real x) y)
              ($compnum-imag x))]
           [(compnum? y) 
            ($make-rectangular 
              (binary+ ($compnum-real x) ($compnum-real y)) 
              (binary+ ($compnum-imag x) ($compnum-imag y)))]
           [(flonum? y)
            ($make-cflonum
              (binary+ y ($compnum-real x))
              (inexact ($compnum-imag x)))]
           [(cflonum? y)
            ($make-cflonum 
              (binary+ ($compnum-real x) ($cflonum-real y))
              (binary+ ($compnum-imag x) ($cflonum-imag y)))]
           [else (err '+ y)])]
        [(cflonum? x)
         (cond
           [(cflonum? y)
            ($make-cflonum 
              (binary+ ($cflonum-real x) ($cflonum-real y))
              (binary+ ($cflonum-imag x) ($cflonum-imag y)))]
           [(flonum? y) 
            ($make-cflonum
              ($fl+ ($cflonum-real x) y) 
              ($cflonum-imag x))]
           [(or (fixnum? y) (bignum? y) (ratnum? y))
            ($make-compnum 
              (binary+ ($compnum-real x) y)
              ($compnum-imag x))]
           [(compnum? y) 
            ($make-cflonum 
              (binary+ ($cflonum-real x) ($compnum-real y)) 
              (binary+ ($cflonum-imag x) ($compnum-imag y)))]
           [else (err '+ y)])]
        [else (err '+ x)])))

  (define binary-bitwise-and
    (lambda (x y)
      (cond
        [(fixnum? x)
         (cond
           [(fixnum? y) ($fxlogand x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnlogand" x y)]
           [else 
            (die 'bitwise-and "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
            (die 'bitwise-and "not an exact integer" y)])]
        [else (die 'bitwise-and "not an exact integer" x)])))

  (define binary-bitwise-ior
    (lambda (x y)
      (cond
        [(fixnum? x)
         (cond
           [(fixnum? y) ($fxlogor x y)]
           [(bignum? y)
            (foreign-call "ikrt_fxbnlogor" x y)]
           [else 
            (die 'bitwise-ior "not an exact integer" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y)
            (foreign-call "ikrt_fxbnlogor" y x)]
           [(bignum? y) 
            (foreign-call "ikrt_bnbnlogor" x y)]
           [else
            (die 'bitwise-ior "not an exact integer" y)])]
        [else (die 'bitwise-ior "not an exact integer" x)])))


  (define binary-bitwise-xor
    (lambda (x y)
      (define (fxbn x y)
        (let ([y0 (bitwise-and y (greatest-fixnum))]
              [y1 (bitwise-arithmetic-shift-right y (- (fixnum-width) 1))])
          (bitwise-ior
            ($fxlogand ($fxlogxor x y0) (greatest-fixnum))
            (bitwise-arithmetic-shift-left
              (bitwise-arithmetic-shift-right
                (if ($fx>= x 0) y (bitwise-not y))
                (- (fixnum-width) 1))
              (- (fixnum-width) 1)))))
      (define (bnbn x y)
        (let ([x0 (bitwise-and x (greatest-fixnum))]
              [x1 (bitwise-arithmetic-shift-right x (- (fixnum-width) 1))]
              [y0 (bitwise-and y (greatest-fixnum))]
              [y1 (bitwise-arithmetic-shift-right y (- (fixnum-width) 1))])
          (bitwise-ior
            ($fxlogand ($fxlogxor x0 y0) (greatest-fixnum))
            (bitwise-arithmetic-shift-left
              (binary-bitwise-xor x1 y1)
              (- (fixnum-width) 1)))))
      (cond
        [(fixnum? x)
         (cond
           [(fixnum? y) ($fxlogxor x y)]
           [(bignum? y) (fxbn x y)]
           [else 
            (die 'bitwise-xor "not an exact integer" y)])]
        [(bignum? x)
         (cond
           [(fixnum? y) (fxbn y x)]
           [(bignum? y) (bnbn x y)]
           [else
            (die 'bitwise-xor "not an exact integer" y)])]
        [else (die 'bitwise-xor "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))]
           [(compnum? y)
            ($make-compnum 
              (binary- x ($compnum-real y))
              (binary- 0 ($compnum-imag y)))]
           [(cflonum? y) 
            ($make-cflonum 
              (binary- x ($cflonum-real y))
              ($fl- 0.0 ($cflonum-imag y)))]
           [else (err '- 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))]
           [(compnum? y)
            ($make-compnum 
              (binary- x ($compnum-real y))
              (binary- 0 ($compnum-imag y)))] 
           [(cflonum? y) 
            ($make-cflonum 
              (binary- x ($cflonum-real y))
              ($fl- 0.0 ($cflonum-imag y)))] 
           [else (err '- y)])]
        [(flonum? x)
         (cond
           [(flonum? y)
            ($fl- x y)]
           [(cflonum? y)
            ($make-cflonum 
              ($fl- x ($cflonum-real y))