conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/scheme/ikarus.numerics.ss

4065 lines
133 KiB
Scheme
Raw Blame History

;;; 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)
;;; optimize for integer flonums case
(define (ratnum-round n nbe)
(let ([d (sll 1 nbe)])
(let ([q (sra n nbe)]
[r (bitwise-and n (sub1 d))])
(let ([r2 (+ r r)])
(cond
[(< r2 d) q]
[(> r2 d) (+ q 1)]
[else (if (even? q) q (+ q 1))])))))
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
;;; nans/infs/magnitude large enough to be an integer
[($fx>= be 1075) x]
[else
;;; this really needs to get optimized.
(let-values ([(pos? be m) (flonum-parts x)])
(cond
[(= be 0) ;;; denormalized
(if pos? +0.0 -0.0)]
[else ; normalized flonum
(let ([r
(inexact
(ratnum-round (+ m (expt 2 52)) (- 1075 be)))])
(if pos? r ($fl* r -1.0)))]))]))))
(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 ($exact x who)
(import (ikarus system $compnums))
(cond
[(flonum? x)
(or ($flonum->exact x)
(die who "number has no real value" x))]
[(cflonum? x)
(make-rectangular
(or ($flonum->exact ($cflonum-real x))
(die who "number has no real value" x))
(or ($flonum->exact ($cflonum-imag x))
(die who "number has no real value" x)))]
[(or (fixnum? x) (ratnum? x) (bignum? x) (compnum? x)) x]
[else (die who "not a number" x)]))
(define (inexact->exact x) ($exact x 'inexact->exact))
(define (exact x) ($exact x 'exact))
(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))
($fl- 0.0 ($cflonum-imag y)))]
[(fixnum? y)
($fl- x ($fixnum->flonum y))]
[(bignum? y)
($fl- x (bignum->flonum y))]
[(ratnum? y)
(let ([n ($ratnum-n y)] [d ($ratnum-d y)])
(binary/ (binary- (binary* d x) n) d))]
[(compnum? y)
($make-cflonum
(binary- x ($compnum-real y))
(binary- 0.0 ($compnum-imag y)))]
[else (err '- 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)))]
[(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)]))]
[(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)))]
[(cflonum? y)
($make-cflonum
(binary- ($compnum-real x) ($cflonum-real y))
(binary- ($compnum-imag x) ($cflonum-imag y)))]
[else
(err '- y)])]
[(cflonum? x)
(cond
[(flonum? y)
($make-cflonum
($fl- ($cflonum-real x) y)
($cflonum-imag x))]
[(cflonum? y)
($make-cflonum
(binary- ($cflonum-real x) ($cflonum-real y))
(binary- ($cflonum-imag x) ($cflonum-imag y)))]
[(or (fixnum? y) (bignum? y) (ratnum? y))
($make-cflonum
(binary- ($cflonum-real x) y)
($cflonum-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*
(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))]
[(compnum? y)
($make-rectangular
(binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))]
[(cflonum? y)
($make-cflonum
(binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))]
[else (err '* 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))]
[(compnum? y)
($make-rectangular
(binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))]
[(cflonum? y)
($make-cflonum
(binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))]
[else (err '* y)])]
[(flonum? x)
(cond
[(flonum? y)
($fl* x y)]
[(cflonum? y)
($make-cflonum
($fl* x ($cflonum-real y))
($fl* x ($cflonum-imag y)))]
[(fixnum? y)
($fl* x ($fixnum->flonum y))]
[(bignum? y)
($fl* x (bignum->flonum y))]
[(ratnum? y)
(binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
[(compnum? y)
($make-cflonum
(binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))]
[else (err '* y)])]
[(ratnum? x)
(cond
[(ratnum? y)
(binary/ (binary* ($ratnum-n x) ($ratnum-n y))
(binary* ($ratnum-d x) ($ratnum-d y)))]
[(compnum? y)
($make-rectangular
(binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))]
[(cflonum? y)
($make-cflonum
(binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))]
[else (binary* y x)])]
[(compnum? x)
(cond
[(or (fixnum? y) (bignum? y) (ratnum? y))
($make-rectangular
(binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))]
[(flonum? y)
($make-cflonum
(binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))]
[(compnum? y)
(let ([r0 ($compnum-real x)]
[r1 ($compnum-real y)]
[i0 ($compnum-imag x)]
[i1 ($compnum-imag y)])
(make-rectangular
(- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))]
[(cflonum? y)
(let ([r0 ($compnum-real x)]
[r1 ($cflonum-real y)]
[i0 ($compnum-imag x)]
[i1 ($cflonum-imag y)])
(make-rectangular
(- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))]
[else (err '* y)])]
[(cflonum? x)
(cond
[(flonum? y)
($make-cflonum
($fl* ($cflonum-real x) y)
($fl* ($cflonum-imag x) y))]
[(cflonum? y)
(let ([r0 ($cflonum-real x)]
[r1 ($cflonum-real y)]
[i0 ($cflonum-imag x)]
[i1 ($cflonum-imag y)])
($make-cflonum
($fl- ($fl* r0 r1) ($fl* i0 i1))
($fl+ ($fl* r0 i1) ($fl* i0 r1))))]
[(or (fixnum? y) (bignum? y) (ratnum? y))
($make-cflonum
(binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))]
[(compnum? y)
(let ([r0 ($compnum-real x)]
[r1 ($compnum-real y)]
[i0 ($compnum-imag x)]
[i1 ($compnum-imag y)])
(make-rectangular
(- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))]
[else (err '* y)])]
[else (err '* x)])))
(define +
(case-lambda
[(x y) (binary+ x y)]
[(x y z) (binary+ (binary+ x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(number? a) a]
[else (die '+ "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 bitwise-and
(case-lambda
[(x y) (binary-bitwise-and x y)]
[(x y z) (binary-bitwise-and (binary-bitwise-and x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (die 'bitwise-and "not a number" a)])]
[() -1]
[(a b c d . e*)
(let f ([ac (binary-bitwise-and a
(binary-bitwise-and b
(binary-bitwise-and c d)))]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary-bitwise-and ac (car e*)) (cdr e*))]))]))
(define bitwise-ior
(case-lambda
[(x y) (binary-bitwise-ior x y)]
[(x y z) (binary-bitwise-ior (binary-bitwise-ior x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (die 'bitwise-ior "not a number" a)])]
[() 0]
[(a b c d . e*)
(let f ([ac (binary-bitwise-ior a
(binary-bitwise-ior b
(binary-bitwise-ior c d)))]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary-bitwise-ior ac (car e*)) (cdr e*))]))]))
(define bitwise-xor
(case-lambda
[(x y) (binary-bitwise-xor x y)]
[(x y z) (binary-bitwise-xor (binary-bitwise-xor x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (die 'bitwise-xor "not a number" a)])]
[() 0]
[(a b c d . e*)
(let f ([ac (binary-bitwise-xor a
(binary-bitwise-xor b
(binary-bitwise-xor c d)))]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary-bitwise-xor ac (car e*)) (cdr e*))]))]))
(define (bitwise-not x)
(cond
[(fixnum? x) ($fxlognot x)]
[(bignum? x) (foreign-call "ikrt_bnlognot" x)]
[else (die 'bitwise-not "invalid argument" x)]))
(define (bitwise-if x y z)
(define who 'bitwise-if)
(define (err x) (die who "not an exact integer" x))
(unless (or (fixnum? x) (bignum? x)) (err x))
(unless (or (fixnum? y) (bignum? y)) (err y))
(unless (or (fixnum? z) (bignum? z)) (err z))
(bitwise-ior
(bitwise-and x y)
(bitwise-and (bitwise-not x) z)))
(define (bitwise-copy-bit-field x i j n)
(define who 'bitwise-copy-bit-field)
(define (err x) (die who "not an exact integer" x))
(define (err2 x) (die who "index must be nonnegative" x))
(define (err3 x y) (die who "indices must be in nondescending order" x y))
(unless (or (fixnum? x) (bignum? x)) (err x))
(unless (or (fixnum? i) (bignum? i)) (err i))
(unless (or (fixnum? j) (bignum? j)) (err j))
(unless (or (fixnum? n) (bignum? n)) (err n))
(when (< i 0) (err2 i))
(when (< j i) (err3 i j))
(bitwise-if (sll (sub1 (sll 1 (- j i))) i) (sll n i) x))
(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]
[(number? a) a]
[else (die '* "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)
(die 'gcd "not an exact integer" y)]
[else
(die 'gcd "not a number" y)])]
[(number? x)
(die 'gcd "not an exact integer" x)]
[else
(die 'gcd "not a number" x)])]
[(x)
(cond
[(or (fixnum? x) (bignum? x)) x]
[(number? x)
(die 'gcd "not an exact integer" x)]
[else
(die 'gcd "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))))]
[(flonum? y)
(let ([v ($flonum->exact y)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (lcm x v))]
[else (die 'lcm "not an integer" y)]))]
[else
(die 'lcm "not an integer" y)])]
[(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (lcm v y))]
[else (die 'lcm "not an integer" x)]))]
[else
(die 'lcm "not an integer" x)])]
[(x)
(cond
[(or (fixnum? x) (bignum? x)) x]
[(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(or (fixnum? v) (bignum? v)) x]
[else (die 'lcm "not an integer" x)]))]
[else
(die 'lcm "not an integer" x)])]
[() 1]
[(x y z . ls)
;;; FIXME: incorrect for multiple roundings
(let f ([g (lcm (lcm x y) z)] [ls ls])
(cond
[(null? ls) g]
[else (f (lcm g (car ls)) (cdr ls))]))]))
(define binary/
(lambda (x y)
(define (x/compy x y)
(let ([yr (real-part y)]
[yi (imag-part y)])
(let ([denom (+ (* yr yr) (* yi yi))])
(make-rectangular
(binary/ (* x yr) denom)
(binary/ (* (- x) yi) denom)))))
(define (compx/y x y)
(let ([xr (real-part x)]
[xi (imag-part x)])
(make-rectangular
(binary/ xr y)
(binary/ xi y))))
(define (compx/compy x y)
(let ([xr (real-part x)]
[xi (imag-part x)]
[yr (real-part y)]
[yi (imag-part y)])
(let ([denom (+ (* yr yr) (* yi yi))])
(make-rectangular
(binary/ (+ (* xr yr) (* xi yi)) denom)
(binary/ (- (* xi yr) (* xr yi)) denom)))))
(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 (ratnum->flonum y))]
[(or (cflonum? y) (compnum? y)) (x/compy x y)]
[else (err '/ y)])]
[(fixnum? x)
(cond
[(flonum? y) ($fl/ ($fixnum->flonum x) y)]
[(fixnum? y)
(cond
[($fx= y 0) (die '/ "division by 0")]
[($fx> y 0)
(if ($fx= y 1)
x
(let ([g (binary-gcd x y)])
(cond
[($fx= g y) (fxquotient x g)]
[($fx= g 1) ($make-ratnum x y)]
[else
($make-ratnum (fxquotient x g) (fxquotient y g))])))]
[else
(if ($fx= y -1)
(binary- 0 x)
(let ([g (binary-gcd x y)])
(cond
[($fx= ($fx- 0 g) y) (binary- 0 (fxquotient x g))]
[($fx= g 1) ($make-ratnum (binary- 0 x) (binary- 0 y))]
[else
($make-ratnum
(binary- 0 (fxquotient x g))
(binary- 0 (fxquotient y g)))])))])]
[(bignum? y)
(if ($fx= x 0)
0
(let ([g (binary-gcd x y)])
(cond
[(= g y) (quotient x g)]
[($bignum-positive? y)
(if ($fx= g 1)
($make-ratnum x y)
($make-ratnum (fxquotient x g) (quotient y g)))]
[else
(if ($fx= g 1)
($make-ratnum (binary- 0 x) (binary- 0 y))
($make-ratnum
(binary- 0 (fxquotient x g))
(binary- 0 (quotient y g))))])))]
[(ratnum? y)
(/ (* x ($ratnum-d y)) ($ratnum-n y))]
[(or (compnum? y) (cflonum? y)) (x/compy x y)]
[else (err '/ y)])]
[(bignum? x)
(cond
[(fixnum? y)
(cond
[($fx= y 0) (die '/ "division by 0")]
[($fx> y 0)
(if ($fx= y 1)
x
(let ([g (binary-gcd x y)])
(cond
[($fx= g 1) ($make-ratnum x y)]
[($fx= g y) (quotient x g)]
[else
($make-ratnum (quotient x g) (quotient y g))])))]
[else
(if ($fx= y -1)
(- x)
(let ([g (binary-gcd x y)])
(cond
[(= (- g) y) (- (quotient x g))]
[else
($make-ratnum
(- (quotient x g))
(- (quotient y g)))])))])]
[(bignum? y)
(let ([g (binary-gcd x y)])
(cond
[($fx= g 1)
(if ($bignum-positive? y)
($make-ratnum x y)
($make-ratnum
(binary- 0 x)
(binary- 0 y)))]
[($bignum-positive? y)
(if (= g y)
(quotient x g)
($make-ratnum (quotient x g) (quotient y g)))]
[else
(let ([y (binary- 0 y)])
(if (= g y)
(binary- 0 (quotient x g))
($make-ratnum
(binary- 0 (quotient x g))
(quotient y g))))]))]
[(flonum? y) ($fl/ (bignum->flonum x) y)]
[(ratnum? y)
(binary/ (binary* x ($ratnum-d y)) ($ratnum-n y))]
[(or (compnum? y) (cflonum? y)) (x/compy x y)]
[else (err '/ y)])]
[(ratnum? x)
(cond
[(ratnum? y)
(binary/
(binary* ($ratnum-n x) ($ratnum-d y))
(binary* ($ratnum-n y) ($ratnum-d x)))]
[(or (compnum? y) (cflonum? y)) (x/compy x y)]
[else (binary/ 1 (binary/ y x))])]
[(or (compnum? x) (cflonum? x))
(cond
[(or (compnum? y) (cflonum? y)) (compx/compy x y)]
[(or (fixnum? y) (bignum? y) (ratnum? y) (flonum? y)) (compx/y x y)]
[else (err '/ y)])]
[else (err '/ x)])))
(define /
(case-lambda
[(x y) (binary/ x y)]
[(x)
(cond
[(fixnum? x)
(cond
[($fxzero? x) (die '/ "division by 0")]
[($fx> x 0)
(if ($fx= x 1)
1
($make-ratnum 1 x))]
[else
(if ($fx= x -1)
-1
($make-ratnum -1 (- x)))])]
[(bignum? x)
(if ($bignum-positive? x)
($make-ratnum 1 x)
($make-ratnum -1 (- x)))]
[(flonum? x) (foreign-call "ikrt_fl_invert" x)]
[(ratnum? x)
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(cond
[($fx= n 1) d]
[($fx= n -1) (- d)]
[else ($make-ratnum d n)]))]
[(compnum? x) (binary/ 1 x)]
[else (die '/ "not a number" x)])]
[(x y z . ls)
(let f ([a (binary/ x y)] [b z] [ls ls])
(cond
[(null? ls) (binary/ a b)]
[else (f (binary/ a b) (car ls) (cdr ls))]))]))
(define flmax
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
(if ($fl< x y)
y
x)
(die 'flmax "not a flonum" y))
(die 'flmax "not a flonum" x))]
[(x y z . rest)
(let f ([a (flmax x y)] [b z] [ls rest])
(cond
[(null? ls) (flmax a b)]
[else
(f (flmax a b) (car ls) (cdr ls))]))]
[(x)
(if (flonum? x)
x
(die 'flmax "not a number" x))]))
(define max
(case-lambda
[(x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(if ($fx> x y) x y)]
[(bignum? y)
(if (positive-bignum? y) y x)]
[(flonum? y)
(let ([x ($fixnum->flonum x)])
(if ($fl>= y x) y x))]
[(ratnum? y) ;;; FIXME: optimize
(if (>= x y) x y)]
[else (die 'max "not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(if (positive-bignum? x) x y)]
[(bignum? y)
(if (bnbn> x y) x y)]
[(flonum? y)
(let ([x (bignum->flonum x)])
(if ($fl>= y x) y x))]
[(ratnum? y) ;;; FIXME: optimize
(if (>= x y) x y)]
[else (die 'max "not a number" y)])]
[(flonum? x)
(cond
[(flonum? y)
(if ($fl>= x y) x y)]
[(fixnum? y)
(let ([y ($fixnum->flonum y)])
(if ($fl>= y x) y x))]
[(bignum? y)
(let ([y (bignum->flonum y)])
(if ($fl>= y x) y x))]
[(ratnum? y)
;;; FIXME: may be incorrect
(let ([y (ratnum->flonum y)])
(if ($fl>= y x) y x))]
[else (die 'max "not a number" y)])]
[(ratnum? x)
(cond
[(or (fixnum? y) (bignum? y) (ratnum? y))
(if (>= x y) x y)]
[(flonum? y)
(let ([x (ratnum->flonum x)])
(if ($fl>= x y) x y))]
[else (die 'max "not a number" y)])]
[else (die 'max "not a number" x)])]
[(x y z . rest)
(let f ([a (max x y)] [b z] [ls rest])
(cond
[(null? ls) (max a b)]
[else
(f (max a b) (car ls) (cdr ls))]))]
[(x)
(cond
[(or (fixnum? x) (bignum? x) (ratnum? x) (flonum? x)) x]
[else (die 'max "not a number" x)])]))
(define min
(case-lambda
[(x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(if ($fx> x y) y x)]
[(bignum? y)
(if (positive-bignum? y) x y)]
[(flonum? y)
(let ([x ($fixnum->flonum x)])
(if ($fl>= y x) x y))]
[(ratnum? y) ;;; FIXME: optimize
(if (>= x y) y x)]
[else (die 'min "not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(if (positive-bignum? x) y x)]
[(bignum? y)
(if (bnbn> x y) y x)]
[(flonum? y)
(let ([x (bignum->flonum x)])
(if ($fl>= y x) x y))]
[(ratnum? y) ;;; FIXME: optimize
(if (>= x y) y x)]
[else (die 'min "not a number" y)])]
[(flonum? x)
(cond
[(flonum? y)
(if ($fl>= x y) y x)]
[(fixnum? y)
(let ([y ($fixnum->flonum y)])
(if ($fl>= y x) x y))]
[(bignum? y)
(let ([y (bignum->flonum y)])
(if ($fl>= y x) x y))]
[(ratnum? y)
;;; FIXME: may be incorrect
(let ([y (ratnum->flonum y)])
(if ($fl>= y x) x y))]
[else (die 'min "not a number" y)])]
[(ratnum? x)
(cond
[(or (fixnum? y) (bignum? y) (ratnum? y))
(if (>= x y) y x)]
[(flonum? y)
(let ([x (ratnum->flonum x)])
(if ($fl>= x y) y x))]
[else (die 'min "not a number" y)])]
[else (die 'min "not a number" x)])]
[(x y z . rest)
(let f ([a (min x y)] [b z] [ls rest])
(cond
[(null? ls) (min a b)]
[else
(f (min a b) (car ls) (cdr ls))]))]
[(x)
(cond
[(or (fixnum? x) (bignum? x) (ratnum? x) (flonum? x)) x]
[else (die 'min "not a number" x)])]))
(define (abs x)
(cond
[(fixnum? x)
(if ($fx< x 0) (- x) x)]
[(bignum? x)
(if ($bignum-positive? x) x (- x))]
[(flonum? x)
(if ($fx> ($flonum-u8-ref x 0) 127)
($fl* x -1.0)
x)]
[(ratnum? x)
(let ([n ($ratnum-n x)])
(if (< n 0)
($make-ratnum (- n) ($ratnum-d x))
x))]
[else (die 'abs "not a number" x)]))
(define flmin
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
(if ($fl< x y) x y)
(die 'flmin "not a flonum" y))
(die 'flmin "not a flonum" x))]
[(x y z . rest)
(let f ([a (flmin x y)] [b z] [ls rest])
(cond
[(null? ls) (flmin a b)]
[else
(f (flmin a b) (car ls) (cdr ls))]))]
[(x)
(if (flonum? x)
x
(die 'flmin "not a flonum" x))]))
(define (->inexact x who)
(cond
[(fixnum? x) ($fixnum->flonum x)]
[(bignum? x) (bignum->flonum x)]
[(ratnum? x) (ratnum->flonum x)]
[(flonum? x) x]
[(compnum? x)
(make-rectangular
(->inexact (real-part x) who)
(->inexact (imag-part x) who))]
[(cflonum? x) x]
[else
(die who "not a number" x)]))
(define (exact->inexact x)
(->inexact x 'exact->inexact))
(define (inexact x)
(->inexact x 'inexact))
(define real->flonum
(lambda (x)
(cond
[(fixnum? x) ($fixnum->flonum x)]
[(bignum? x) (bignum->flonum x)]
[(ratnum? x) (ratnum->flonum x)]
[(flonum? x) x]
[else
(die 'real->flonum "not a real number" x)])))
(define positive-bignum?
(lambda (x)
(foreign-call "ikrt_positive_bn" x)))
(define even-bignum?
(lambda (x)
(foreign-call "ikrt_even_bn" x)))
(define ($fxeven? x)
($fxzero? ($fxlogand x 1)))
(define (even? x)
(cond
[(fixnum? x) ($fxeven? x)]
[(bignum? x) (even-bignum? x)]
[(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(fixnum? v) ($fxeven? v)]
[(bignum? v) (even-bignum? v)]
[else (die 'even? "not an integer" x)]))]
[else (die 'even? "not an integer" x)]))
(define (odd? x)
(cond
[(fixnum? x) (not ($fxeven? x))]
[(bignum? x) (not (even-bignum? x))]
[(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(fixnum? v) (not ($fxeven? v))]
[(bignum? v) (not (even-bignum? v))]
[else (die 'odd? "not an integer" x)]))]
[else (die 'odd? "not an integer" x)]))
(module (number->string)
(module (bignum->string)
(define (bignum->decimal-string x)
(utf8->string (foreign-call "ikrt_bignum_to_bytevector" x)))
(module (bignum->power-string)
(define string-map "0123456789ABCDEF")
(define (init-string x chars)
(if ($bignum-positive? x)
(make-string chars)
(let ([s (make-string ($fxadd1 chars))])
(string-set! s 0 #\-)
s)))
(define (bignum-bits x)
(define (add-bits b n)
(cond
[($fxzero? b) n]
[else (add-bits ($fxsra b 1) ($fx+ n 1))]))
(let f ([i ($fxsub1 ($bignum-size x))])
(let ([b ($bignum-byte-ref x i)])
(cond
[($fxzero? b) (f ($fxsub1 i))]
[else (add-bits b ($fxsll i 3))]))))
(define (bignum->power-string x mask shift)
(let ([bits (bignum-bits x)])
(let ([chars (fxquotient (fx+ bits (fx- shift 1)) shift)])
(let* ([s (init-string x chars)]
[n ($fx- (string-length s) 1)])
(let f ([i 0] [j 0] [k 0] [b 0])
(cond
[($fx= i chars) s]
[($fx< k 8)
(f i ($fxadd1 j) ($fx+ k 8)
($fxlogor b
($fxsll ($bignum-byte-ref x j) k)))]
[else
(string-set! s ($fx- n i)
(string-ref string-map
($fxlogand mask b)))
(f ($fxadd1 i) j ($fx- k shift) ($fxsra b shift))])))))))
(define (bignum->string x r)
(case r
[(10) (bignum->decimal-string x)]
[(2) (bignum->power-string x 1 1)]
[(8) (bignum->power-string x 7 3)]
[(16) (bignum->power-string x 15 4)]
[else (die 'number->string "BUG")])))
(define ratnum->string
(lambda (x r)
(string-append
($number->string ($ratnum-n x) r)
"/"
($number->string ($ratnum-d x) r))))
(define (imag x r)
(cond
[(eqv? x 1) "+"]
[(eqv? x -1) "-"]
[(or (< x 0) (eqv? x -0.0))
($number->string x r)]
[else (string-append "+" ($number->string x r))]))
(define $number->string
(lambda (x r)
(import (ikarus system $compnums))
(cond
[(fixnum? x) (fixnum->string x r)]
[(bignum? x) (bignum->string x r)]
[(flonum? x)
(unless (eqv? r 10)
(die 'number->string
"invalid radix for inexact number"
r x))
(flonum->string x)]
[(ratnum? x) (ratnum->string x r)]
[(compnum? x)
(let ([xr ($compnum-real x)]
[xi ($compnum-imag x)])
(if (eqv? xr 0)
(string-append (imag xi r) "i")
(string-append
($number->string xr r)
(imag xi r)
"i")))]
[(cflonum? x)
(let ([xr ($cflonum-real x)]
[xi ($cflonum-imag x)])
(cond
[(flnan? xi)
(string-append ($number->string xr r) "+nan.0i")]
[(flinfinite? xi)
(string-append ($number->string xr r)
(if ($fl> xi 0.0) "+inf.0i" "-inf.0i"))]
[else
(string-append
($number->string xr r) (imag xi r) "i")]))]
[else (die 'number->string "not a number" x)])))
(define do-warn
(lambda ()
(set! do-warn values)
(raise-continuable
(condition
(make-warning)
(make-who-condition 'number->string)
(make-message-condition
"precision argument is not supported")))))
(define number->string
(case-lambda
[(x) ($number->string x 10)]
[(x r)
(unless (memv r '(2 8 10 16))
(die 'number->string "invalid radix" r))
($number->string x r)]
[(x r precision)
;(do-warn)
(number->string x r)])))
(define modulo
(lambda (n m)
(cond
[(fixnum? n)
(cond
[(fixnum? m) ($fxmodulo n m)]
[(bignum? m)
(if ($fx< n 0)
(if ($bignum-positive? m)
(foreign-call "ikrt_fxbnplus" n m)
n)
(if ($bignum-positive? m)
n
(foreign-call "ikrt_fxbnplus" n m)))]
[(flonum? m)
(let ([v ($flonum->exact m)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (modulo n v))]
[else
(die 'modulo "not an integer" m)]))]
[(ratnum? m) (die 'modulo "not an integer" m)]
[else (die 'modulo "not a number" m)])]
[(bignum? n)
(cond
[(fixnum? m)
(foreign-call "ikrt_bnfx_modulo" n m)]
[(bignum? m)
(if ($bignum-positive? n)
(if ($bignum-positive? m)
(remainder n m)
(+ m (remainder n m)))
(if ($bignum-positive? m)
(+ m (remainder n m))
(remainder n m)))]
[(flonum? m)
(let ([v ($flonum->exact m)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (modulo n v))]
[else
(die 'modulo "not an integer" m)]))]
[(ratnum? m) (die 'modulo "not an integer" m)]
[else (die 'modulo "not a number" m)])]
[(flonum? n)
(let ([v ($flonum->exact n)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (modulo v m))]
[else
(die 'modulo "not an integer" n)]))]
[(ratnum? n) (die 'modulo "not an integer" n)]
[else (die 'modulo "not a number" n)])))
(define-syntax mk<
(syntax-rules ()
[(_ name fxfx< fxbn< bnfx< bnbn<
fxfl< flfx< bnfl< flbn< flfl<
fxrt< rtfx< bnrt< rtbn< flrt< rtfl< rtrt<)
(let ()
(define err
(lambda (x) (die 'name "not a real number" x)))
(define fxloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(fxfx< x y)
(if (fxfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(fxbn< x y)
(if (fxbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(fxfl< x y)
(if (fxfl< x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(fxrt< x y)
(if (fxrt< x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define bnloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(bnfx< x y)
(if (bnfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(bnbn< x y)
(if (bnbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(bnfl< x y)
(if (bnfl< x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(bnrt< x y)
(if (bnrt< x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define flloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(flfx< x y)
(if (flfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(flbn< x y)
(if (flbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(flfl< x y)
(if (flfl< x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(flrt< x y)
(if (flrt< x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define rtloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(rtfx< x y)
(if (rtfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(rtbn< x y)
(if (rtbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(rtfl< x y)
(if (rtfl< x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(rtrt< x y)
(if (rtrt< x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define loopf
(lambda (x ls)
(cond
[(number? x)
(if (null? ls)
#f
(loopf (car ls) (cdr ls)))]
[else (err x)])))
(define name
(case-lambda
[(x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y) (fxfx< x y)]
[(bignum? y) (fxbn< x y)]
[(flonum? y) (fxfl< x y)]
[(ratnum? y) (fxrt< x y)]
[else (err y)])]
[(bignum? x)
(cond
[(fixnum? y) (bnfx< x y)]
[(bignum? y) (bnbn< x y)]
[(flonum? y) (bnfl< x y)]
[(ratnum? y) (bnrt< x y)]
[else (err y)])]
[(flonum? x)
(cond
[(fixnum? y) (flfx< x y)]
[(bignum? y) (flbn< x y)]
[(flonum? y) (flfl< x y)]
[(ratnum? y) (flrt< x y)]
[else (err y)])]
[(ratnum? x)
(cond
[(fixnum? y) (rtfx< x y)]
[(bignum? y) (rtbn< x y)]
[(flonum? y) (rtfl< x y)]
[(ratnum? y) (rtrt< x y)]
[else (err y)])]
[else (err x)])]
[(x y z) (and (name x y) (name y z))]
[(x) (if (number? x) #t (err x))]
[(x y . ls)
(cond
[(fixnum? x) (fxloopt x y ls)]
[(bignum? x) (bnloopt x y ls)]
[(flonum? x) (flloopt x y ls)]
[(ratnum? x) (rtloopt x y ls)]
[else (err x)])]))
name)]))
(define-syntax false (syntax-rules () [(_ x y) #f]))
(define-syntax bnbncmp
(syntax-rules ()
[(_ x y cmp)
(cmp (foreign-call "ikrt_bnbncomp" x y) 0)]))
(define-syntax bnbn= (syntax-rules () [(_ x y) (bnbncmp x y $fx=)]))
(define-syntax bnbn< (syntax-rules () [(_ x y) (bnbncmp x y $fx<)]))
(define-syntax bnbn> (syntax-rules () [(_ x y) (bnbncmp x y $fx>)]))
(define-syntax bnbn<= (syntax-rules () [(_ x y) (bnbncmp x y $fx<=)]))
(define-syntax bnbn>= (syntax-rules () [(_ x y) (bnbncmp x y $fx>=)]))
(define-syntax fxbn< (syntax-rules () [(_ x y) (positive-bignum? y)]))
(define-syntax bnfx< (syntax-rules () [(_ x y) (not (positive-bignum? x))]))
(define-syntax fxbn> (syntax-rules () [(_ x y) (not (positive-bignum? y))]))
(define-syntax bnfx> (syntax-rules () [(_ x y) (positive-bignum? x)]))
(define-syntax flcmp
(syntax-rules ()
[(_ flfl? flfx? fxfl? flbn? bnfl? fl?)
(begin
(define-syntax flfl?
(syntax-rules () [(_ x y) (fl? x y)]))
(define-syntax flfx?
(syntax-rules () [(_ x y) (fl? x ($fixnum->flonum y))]))
(define-syntax flbn?
(syntax-rules () [(_ x y) (fl? x (bignum->flonum y))]))
(define-syntax fxfl?
(syntax-rules () [(_ x y) (fl? ($fixnum->flonum x) y)]))
(define-syntax bnfl?
(syntax-rules () [(_ x y) (fl? (bignum->flonum x) y)])))]))
;;; #;
;;; (begin
;;; (define-syntax $fl=
;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_equal" x y)]))
;;; (define-syntax $fl<
;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)]))
;;; (define-syntax $fl<=
;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)]))
;;; (define-syntax $fl>
;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" y x)]))
;;; (define-syntax $fl>=
;;; (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)])))
(define-syntax define-flcmp
(syntax-rules ()
[(_ fl<? $fl<)
(define fl<?
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl< x y)
(die 'fl<? "not a flonum" y))
(die 'fl<? "not a flonum" x))]
[(x y z)
(if (flonum? x)
(if (flonum? y)
(if (flonum? z)
(and ($fl< x y) ($fl< y z))
(die 'fl<? "not a flonum" z))
(die 'fl<? "not a flonum" y))
(die 'fl<? "not a flonum" x))]
[(x)
(or (flonum? x)
(die 'fl<? "not a flonum" x))]
[(x y . rest)
(let ()
(define (loopf a ls)
(unless (flonum? a)
(die 'fl<? "not a flonum" a))
(if (null? ls)
#f
(loopf (car ls) (cdr ls))))
(if (flonum? x)
(if (flonum? y)
(if ($fl< x y)
(let f ([x y] [y (car rest)] [ls (cdr rest)])
(if (flonum? y)
(if (null? ls)
($fl< x y)
(if ($fl< x y)
(f y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))
(die 'fl<? "not a flonum" y)))
(loopf (car rest) (cdr rest)))
(die 'fl<? "not a flonum" y))
(die 'fl<? "not a flonum" x)))]))]))
(define-flcmp fl=? $fl=)
(define-flcmp fl<? $fl<)
(define-flcmp fl<=? $fl<=)
(define-flcmp fl>? $fl>)
(define-flcmp fl>=? $fl>=)
(define fl+
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl+ x y)
(die 'fl+ "not a flonum" y))
(die 'fl+ "not a flonum" x))]
[(x y z)
(fl+ (fl+ x y) z)]
[(x y z q . rest)
(let f ([ac (fl+ (fl+ (fl+ x y) z) q)] [rest rest])
(if (null? rest)
ac
(f (fl+ ac (car rest)) (cdr rest))))]
[(x)
(if (flonum? x)
x
(die 'fl+ "not a flonum" x))]
[() (exact->inexact 0)]))
(define fl-
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl- x y)
(die 'fl- "not a flonum" y))
(die 'fl- "not a flonum" x))]
[(x y z)
(fl- (fl- x y) z)]
[(x y z q . rest)
(let f ([ac (fl- (fl- (fl- x y) z) q)] [rest rest])
(if (null? rest)
ac
(f (fl- ac (car rest)) (cdr rest))))]
[(x)
(if (flonum? x)
($fl* -1.0 x)
(die 'fl+ "not a flonum" x))]))
(define fl*
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl* x y)
(die 'fl* "not a flonum" y))
(die 'fl* "not a flonum" x))]
[(x y z)
(fl* (fl* x y) z)]
[(x y z q . rest)
(let f ([ac (fl* (fl* (fl* x y) z) q)] [rest rest])
(if (null? rest)
ac
(f (fl* ac (car rest)) (cdr rest))))]
[(x)
(if (flonum? x)
x
(die 'fl* "not a flonum" x))]
[() 1.0]))
(define fl/
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl/ x y)
(die 'fl/ "not a flonum" y))
(die 'fl/ "not a flonum" x))]
[(x y z)
(fl/ (fl/ x y) z)]
[(x y z q . rest)
(let f ([ac (fl/ (fl/ (fl/ x y) z) q)] [rest rest])
(if (null? rest)
ac
(f (fl/ ac (car rest)) (cdr rest))))]
[(x)
(if (flonum? x)
($fl/ 1.0 x)
(die 'fl/ "not a flonum" x))]))
(flcmp flfl= flfx= fxfl= flbn= bnfl= $fl=)
(flcmp flfl< flfx< fxfl< flbn< bnfl< $fl<)
(flcmp flfl> flfx> fxfl> flbn> bnfl> $fl>)
(flcmp flfl<= flfx<= fxfl<= flbn<= bnfl<= $fl<=)
(flcmp flfl>= flfx>= fxfl>= flbn>= bnfl>= $fl>=)
(define-syntax cmp-ex/in
(syntax-rules ()
[(_ pred)
(syntax-rules ()
[(_ ex in)
(let ([x ex] [y in])
(if ($flonum-rational? y)
(pred x (exact y))
(pred (inexact x) y)))])]))
(define-syntax cmp-in/ex
(syntax-rules ()
[(_ pred)
(syntax-rules ()
[(_ in ex)
(let ([x in] [y ex])
(if ($flonum-rational? x)
(pred (exact x) y)
(pred x (inexact y))))])]))
(define-syntax flrt= (cmp-in/ex =))
(define-syntax rtfl= (cmp-ex/in =))
(define-syntax flrt< (cmp-in/ex <))
(define-syntax rtfl< (cmp-ex/in <))
(define-syntax flrt<= (cmp-in/ex <=))
(define-syntax rtfl<= (cmp-ex/in <=))
(define-syntax flrt> (cmp-in/ex >))
(define-syntax rtfl> (cmp-ex/in >))
(define-syntax flrt>= (cmp-in/ex >=))
(define-syntax rtfl>= (cmp-ex/in >=))
(define (exrt< x y) (< (* x ($ratnum-d y)) ($ratnum-n y)))
(define (rtex< x y) (< ($ratnum-n x) (* y ($ratnum-d x))))
(define (rtrt< x y) (< (* ($ratnum-n x) ($ratnum-d y)) (* ($ratnum-n y) ($ratnum-d x))))
(define (rtrt<= x y) (<= (* ($ratnum-n x) ($ratnum-d y)) (* ($ratnum-n y) ($ratnum-d x))))
(define (exrt> x y) (> (* x ($ratnum-d y)) ($ratnum-n y)))
(define (rtex> x y) (> ($ratnum-n x) (* y ($ratnum-d x))))
(define (rtrt> x y) (> (* ($ratnum-n x) ($ratnum-d y)) (* ($ratnum-n y) ($ratnum-d x))))
(define (rtrt>= x y) (>= (* ($ratnum-n x) ($ratnum-d y)) (* ($ratnum-n y) ($ratnum-d x))))
(define (rtrt= x y)
(and (= ($ratnum-n x) ($ratnum-n y)) (= ($ratnum-d x) ($ratnum-d y))))
(define =
(let ()
(define err
(lambda (x) (die '= "not a number" x)))
(define fxloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
($fx= x y)
(if ($fx= x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y) (loopf (car ls) (cdr ls))]
[(flonum? y)
(if (null? ls)
(fxfl= x y)
(if (fxfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (ratnum? y) (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define bnloopt
(lambda (x y ls)
(cond
[(fixnum? y) (loopf (car ls) (cdr ls))]
[(bignum? y)
(if (null? ls)
(bnbn= x y)
(if (bnbn= x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(bnfl= x y)
(if (bnfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (ratnum? y) (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define flloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(flfx= x y)
(if (flfx= x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(flbn= x y)
(if (flbn= x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(flonum? y)
(if (null? ls)
(flfl= x y)
(if (flfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(flrt= x y)
(if (flrt= x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define rtloopt
(lambda (x y ls)
(cond
[(flonum? y)
(if (null? ls)
(rtfl= x y)
(if (rtfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(rtrt= x y)
(if (rtrt= x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define cnloopt
(lambda (x y ls)
(cond
[(compnum? y)
(if (null? ls)
(cncn= x y)
(if (cncn= x y)
(cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(cflonum? y)
(if (null? ls)
(cncf= x y)
(if (cncf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define cfloopt
(lambda (x y ls)
(cond
[(cflonum? y)
(if (null? ls)
(cfcf= x y)
(if (cfcf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(compnum? y)
(if (null? ls)
(cncf= y x)
(if (cncf= y x)
(cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define loopf
(lambda (x ls)
(cond
[(number? x)
(if (null? ls)
#f
(loopf (car ls) (cdr ls)))]
[else (err x)])))
(define (cncn= x y)
(and
(= ($compnum-real x) ($compnum-real y))
(= ($compnum-imag x) ($compnum-imag y))))
(define (cncf= x y)
(and
(= ($compnum-real x) ($cflonum-real y))
(= ($compnum-imag x) ($cflonum-imag y))))
(define (cfcf= x y)
(and
(= ($cflonum-real x) ($cflonum-real y))
(= ($cflonum-imag x) ($cflonum-imag y))))
(define =
(case-lambda
[(x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y) ($fx= x y)]
[(flonum? y) (fxfl= x y)]
[(or (bignum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(bignum? x)
(cond
[(bignum? y) (bnbn= x y)]
[(flonum? y) (bnfl= x y)]
[(or (fixnum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(flonum? x)
(cond
[(fixnum? y) (flfx= x y)]
[(bignum? y) (flbn= x y)]
[(flonum? y) (flfl= x y)]
[(ratnum? y) (flrt= x y)]
[(or (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(ratnum? x)
(cond
[(flonum? y) (rtfl= x y)]
[(ratnum? y) (rtrt= x y)]
[(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(compnum? x)
(cond
[(compnum? y) (cncn= x y)]
[(cflonum? y) (cncf= x y)]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[else (err y)])]
[(cflonum? x)
(cond
[(cflonum? y) (cfcf= x y)]
[(compnum? y) (cncf= y x)]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[else (err y)])]
[else (err x)])]
[(x y z) (and (= x y) (= y z))]
[(x) (if (number? x) #t (err x))]
[(x y . ls)
(cond
[(fixnum? x) (fxloopt x y ls)]
[(bignum? x) (bnloopt x y ls)]
[(flonum? x) (flloopt x y ls)]
[(ratnum? x) (rtloopt x y ls)]
[(compnum? x) (cnloopt x y ls)]
[(cflonum? x) (cfloopt x y ls)]
[else (err x)])]))
=))
;(define =
; (mk< = $fx= false false bnbn= fxfl= flfx= bnfl= flbn= flfl=
; false false false false flrt= rtfl= rtrt=))
(define <
(mk< < $fx< fxbn< bnfx< bnbn< fxfl< flfx< bnfl< flbn< flfl<
exrt< rtex< exrt< rtex< flrt< rtfl< rtrt<))
(define >
(mk< > $fx> fxbn> bnfx> bnbn> fxfl> flfx> bnfl> flbn> flfl>
exrt> rtex> exrt> rtex> flrt> rtfl> rtrt>))
(define <=
(mk< <= $fx<= fxbn< bnfx< bnbn<= fxfl<= flfx<= bnfl<= flbn<= flfl<=
exrt< rtex< exrt< rtex< flrt<= rtfl<= rtrt<=))
(define >=
(mk< >= $fx>= fxbn> bnfx> bnbn>= fxfl>= flfx>= bnfl>= flbn>= flfl>=
exrt> rtex> exrt> rtex> flrt>= rtfl>= rtrt>=))
(define error@add1
(lambda (x)
(import (ikarus))
(cond
[(fixnum? x) (+ (greatest-fixnum) 1)]
[(number? x) (+ x 1)]
[else (die 'add1 "not a number" x)])))
(define add1
(lambda (x)
(import (ikarus))
(add1 x)))
(define error@sub1
(lambda (x)
(import (ikarus))
(cond
[(fixnum? x) (- (least-fixnum) 1)]
[(number? x) (- x 1)]
[else (die 'sub1 "not a number" x)])))
(define sub1
(lambda (x)
(import (ikarus))
(sub1 x)))
(define zero?
(lambda (x)
(cond
[(fixnum? x) (eq? x 0)]
[(bignum? x) #f]
[(ratnum? x) #f]
[(flonum? x)
(or ($fl= x 0.0) ($fl= x -0.0))]
[(cflonum? x)
(and ($fl= ($cflonum-real x) 0.0) ($fl= ($cflonum-imag x) 0.0))]
[(compnum? x) #f]
[else
(die 'zero? "not a number" x)])))
(define expt
(lambda (n m)
(define fxexpt
(lambda (n m)
(cond
[($fxzero? m) 1]
[($fxzero? ($fxlogand m 1))
(fxexpt (binary* n n) ($fxsra m 1))]
[else
(binary* n (fxexpt (binary* n n) ($fxsra m 1)))])))
(unless (number? n)
(die 'expt "not a numebr" n))
(cond
[(fixnum? m)
(if ($fx>= m 0)
(cond
[(ratnum? n)
($make-ratnum (expt ($ratnum-n n) m) (expt ($ratnum-d n) m))]
[else (fxexpt n m)])
(let ([v (expt n (- m))])
(if (eq? v 0)
0
(/ 1 v))))]
[(bignum? m)
(cond
[(eq? n 0) 0]
[(eq? n 1) 1]
[(eq? n -1)
(if (positive-bignum? m)
(if (even-bignum? m)
1
-1)
(/ 1 (expt n (- m))))]
[else
(die 'expt "result is too big to compute" n m)])]
[(flonum? m) (flexpt (inexact n) m)]
[(ratnum? m) (flexpt (inexact n) (inexact m))]
[(or (compnum? m) (cflonum? m))
(if (eq? n 0)
0
(let ([e 2.718281828459045])
(define (ln x) (/ (log x) (log e)))
(exp (* m (ln n)))))]
[else (die 'expt "not a number" m)])))
(define quotient
(lambda (x y)
(let-values ([(q r) (quotient+remainder x y)])
q)))
(define remainder
(lambda (x y)
(let-values ([(q r) (quotient+remainder x y)])
r)))
(define quotient+remainder
(lambda (x y)
(cond
[(eq? y 0)
(die 'quotient+remainder
"second argument must be non-zero")]
[(fixnum? x)
(cond
[(fixnum? y)
(if (eq? y -1)
(values (- x) 0)
(values (fxquotient x y) (fxremainder x y)))]
[(bignum? y) (values 0 x)]
[(flonum? y)
(let ([v ($flonum->exact y)])
(cond
[(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))]
[else
(die 'quotient+remainder "not an integer" y)]))]
[else (die 'quotient+remainder "not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(let ([p (foreign-call "ikrt_bnfxdivrem" x y)])
(values (car p) (cdr p)))]
[(bignum? y)
(let ([p (foreign-call "ikrt_bnbndivrem" x y)])
(values (car p) (cdr p)))]
[(flonum? y)
(let ([v ($flonum->exact y)])
(cond
[(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))]
[else
(die 'quotient+remainder "not an integer" y)]))]
[else (die 'quotient+remainder "not a number" y)])]
[(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder v y)])
(values (inexact q) (inexact r)))]
[else (die 'quotient+remainder "not an integer" x)]))]
[else (die 'quotient+remainder "not a number" x)])))
(define positive?
(lambda (x)
(cond
[(fixnum? x) ($fx> x 0)]
[(flonum? x) ($fl> x 0.0)]
[(bignum? x) (positive-bignum? x)]
[(ratnum? x) (positive? ($ratnum-n x))]
[else (die 'positive? "not a number" x)])))
(define negative?
(lambda (x)
(cond
[(fixnum? x) ($fx< x 0)]
[(flonum? x) ($fl< x 0.0)]
[(bignum? x) (not (positive-bignum? x))]
[(ratnum? x) (negative? ($ratnum-n x))]
[else (die 'negative? "not a number" x)])))
(define sinh
(lambda (x)
(define who 'sinh)
(cond
[(flonum? x) (foreign-call "ikrt_fl_sinh" x)]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(sinh (inexact x))]
[(or (compnum? x) (cflonum? x))
(let ([r (real-part x)] [i (imag-part x)])
(make-rectangular
(* (sinh r) (cos i))
(* (cosh r) (sin i))))]
[else (die who "not a number" x)])))
(define cosh
(lambda (x)
(define who 'cosh)
(cond
[(flonum? x) (foreign-call "ikrt_fl_cosh" x)]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(cosh (inexact x))]
[(or (compnum? x) (cflonum? x))
(let ([r (real-part x)] [i (imag-part x)])
(make-rectangular
(* (cosh r) (cos i))
(* (sinh r) (sin i))))]
[else (die who "not a number" x)])))
(define tanh
(lambda (x)
(define who 'tanh)
(cond
[(flonum? x) (foreign-call "ikrt_fl_tanh" x)]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(tanh (inexact x))]
[(or (compnum? x) (cflonum? x))
(let ([r (real-part x)] [i (imag-part x)])
(let ([rr (* 2 r)] [ii (* 2 i)])
(let ([cos2i (cos ii)] [cosh2r (cosh rr)])
(make-rectangular
(/ (tanh rr) (+ 1 (/ cos2i cosh2r)))
(/ (sin ii) (+ cosh2r cos2i))))))]
[else (die who "not a number" x)])))
(define asinh
(lambda (x)
(define who 'asinh)
(cond
[(flonum? x) (foreign-call "ikrt_fl_asinh" x)]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(asinh (inexact x))]
[(or (cflonum? x) (compnum? x))
(let ([x (real-part x)] [y (imag-part x)])
(cond
[(= x 0)
(let ([v (asin y)])
(make-rectangular (imag-part v) (real-part v)))]
[else
(let* ([z^2 (+ (* x x) (* y y))]
[z^2-1 (- z^2 1)]
[z^2-1^2 (* z^2-1 z^2-1)]
[y^2 (* y y)]
[q (sqrt (+ z^2-1^2 (* 4 y^2)))])
(define (sgn x) (if (< x 0) -1 1))
(make-rectangular
(* 0.5 (sgn x) (acosh (+ q z^2)))
(* 0.5 (sgn y) (acos (- q z^2)))))]))]
[else (die who "not a number" x)])))
(define acosh
(lambda (x)
(define who 'acosh)
(cond
[(flonum? x)
(cond
[($fl>= x 1.0) (foreign-call "ikrt_fl_acosh" x)]
[($fl>= x -1.0)
(make-rectangular 0 (atan (sqrt (- 1 (* x x))) x))]
[($fl< x -1.0)
(make-rectangular (acosh (- x)) PI)]
[else +nan.0])]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(acosh (inexact x))]
[(or (cflonum? x) (compnum? x))
(let ([x (real-part x)] [y (imag-part x)])
(cond
[(= x 0) (+ (asinh y) (make-rectangular 0 PI/2))]
[else
(let* ([z^2 (+ (* x x) (* y y))]
[z^2-1 (- z^2 1)]
[z^2-1^2 (* z^2-1 z^2-1)]
[y^2 (* y y)]
[q (sqrt (+ z^2-1^2 (* 4 y^2)))])
(define (sgn x) (if (< x 0) -1 1))
(+ (* 0.5 (sgn x) (acosh (+ q z^2)))
(* 0.5i (sgn y)
(- PI (* (sgn x) (acos (- q z^2)))))))]))]
[else (die who "not a number" x)])))
(define atanh
(lambda (x)
(define who 'atanh)
(cond
[(flonum? x)
(cond
[(and (fl<=? x 1.0) (fl>=? x -1.0))
(foreign-call "ikrt_fl_atanh" x)]
[else
(- (atanh (fl/ 1.0 x))
(if (fl<? x 0.0) (* -i PI/2) (* +i PI/2)))])]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(atanh (inexact x))]
[(number? x) (error who "not implemented" x)]
[else (die who "not a number" x)])))
(define sin
(lambda (x)
(cond
[(flonum? x) (foreign-call "ikrt_fl_sin" x)]
[(fixnum? x)
(if (fx=? x 0)
0
(foreign-call "ikrt_fx_sin" x))]
[(or (cflonum? x) (compnum? x))
(let ([r (real-part x)] [i (imag-part x)])
(make-rectangular
(* (sin r) (cosh i))
(* (cos r) (sinh i))))]
[(number? x) (sin (inexact x))]
[else (die 'sin "not a number" x)])))
(define cos
(lambda (x)
(cond
[(flonum? x) (foreign-call "ikrt_fl_cos" x)]
[(fixnum? x)
(if (fx=? x 0)
1
(foreign-call "ikrt_fx_cos" x))]
[(or (cflonum? x) (compnum? x))
(let ([r (real-part x)] [i (imag-part x)])
(make-rectangular
(* (cos r) (cosh i))
(* (sin r) (sinh i))))]
[(number? x) (cos (inexact x))]
[else (die 'cos "not a number" x)])))
(define tan
(lambda (x)
(cond
[(flonum? x) (foreign-call "ikrt_fl_tan" x)]
[(fixnum? x)
(if (fx=? x 0)
0
(foreign-call "ikrt_fx_tan" x))]
[(or (cflonum? x) (compnum? x))
(let ([r (real-part x)] [i (imag-part x)])
(make-rectangular
(/ (sin (* 2 r))
(+ (cos (* 2 r)) (cosh (* 2 i))))
(/ (tanh (* 2 i))
(+ 1 (/ (cos (* 2 r)) (cosh (* 2 i)))))))]
[(number? x) (tan (inexact x))]
[else (die 'tan "not a number" x)])))
(module (PI PI/2)
(import (ikarus))
(define PI (acos -1))
(define PI/2 (/ PI 2)))
(define asin
(lambda (x)
(cond
[(flonum? x)
(cond
[($fl> x 1.0)
(make-rectangular PI/2 (acosh x))]
[($fl< x -1.0)
(make-rectangular (- PI/2) (- (acosh (- x))))]
[else
(foreign-call "ikrt_fl_asin" x)])]
[(or (cflonum? x) (compnum? x))
(let ([x (real-part x)] [y (imag-part x)])
(cond
[(= x 0) (make-rectangular 0 (asinh y))]
[else
(let* ([z^2 (+ (* x x) (* y y))]
[z^2-1 (- z^2 1.0)]
[z^2-1^2 (* z^2-1 z^2-1)]
[y^2 (* y y)]
[q (sqrt (+ z^2-1^2 (* 4.0 y^2)))])
(define (sgn x) (if (< x 0) -1.0 1.0))
(make-rectangular
(* 0.5 (sgn x) (acos (- q z^2)))
(* 0.5 (sgn y) (acosh (+ q z^2)))))]))]
[(number? x) (asin (inexact x))]
[else (die 'asin "not a number" x)])))
(define acos
(lambda (x)
(cond
[(flonum? x)
(cond
[($fl> x 1.0)
(make-rectangular 0 (acosh x))]
[($fl< x -1.0)
(make-rectangular PI (- (acosh (- x))))]
[else
(foreign-call "ikrt_fl_acos" x)])]
[(or (cflonum? x) (compnum? x))
(- PI/2 (asin x))]
[(number? x) (acos (inexact x))]
[else (die 'acos "not a number" x)])))
(define atan
(case-lambda
[(x)
(cond
[(flonum? x) (foreign-call "ikrt_fl_atan" x)]
[(fixnum? x) (foreign-call "ikrt_fx_atan" x)]
[(or (ratnum? x) (bignum? x)) (atan (inexact x))]
[else (die 'atan "not a number" x)])]
[(y x)
(unless (real? x) (die 'atan "not a real number" x))
(unless (real? y) (die 'atan "not a real number" y))
(foreign-call "ikrt_atan2" (inexact y) (inexact x))]))
(define sqrt
(lambda (x)
(cond
[(flonum? x)
(if ($fl< x 0.0)
(make-rectangular 0.0
(foreign-call "ikrt_fl_sqrt" ($fl- 0.0 x)))
(foreign-call "ikrt_fl_sqrt" x))]
[(fixnum? x)
(cond
[($fx< x 0)
(make-rectangular 0 (sqrt (- x)))]
[else
(let-values ([(s r) (exact-integer-sqrt x)])
(cond
[(eq? r 0) s]
[else (foreign-call "ikrt_fx_sqrt" x)]))])]
[(bignum? x)
(cond
[($bignum-positive? x)
(let-values ([(s r) (exact-integer-sqrt x)])
(cond
[(eq? r 0) s]
[else
(let ([v (sqrt (inexact x))])
;;; could the [dropped] residual ever affect the answer?
(cond
[(infinite? v)
(if (bignum? s)
(foreign-call "ikrt_bignum_to_flonum"
s
1 ;;; round up in case of a tie
($make-flonum))
(inexact s))]
[else v]))]))]
[else
(make-rectangular 0 (sqrt (- x)))])]
[(ratnum? x)
;;; FIXME: incorrect as per bug 180170
(/ (sqrt ($ratnum-n x)) (sqrt ($ratnum-d x)))]
[(or (compnum? x) (cflonum? x))
(let ([xr (real-part x)] [xi (imag-part x)])
(let ([m (sqrt (+ (* xr xr) (* xi xi)))]
[s (if (> xi 0) 1 -1)])
(make-rectangular
(sqrt (/ (+ m xr) 2))
(* s (sqrt (/ (- m xr) 2))))))]
[else (die 'sqrt "not a number" x)])))
(define flsqrt
(lambda (x)
(if (flonum? x)
(foreign-call "ikrt_fl_sqrt" x)
(die 'flsqrt "not a flonum" x))))
(define flzero?
(lambda (x)
(if (flonum? x)
($flzero? x)
(die 'flzero? "not a flonum" x))))
(define flnegative?
(lambda (x)
(if (flonum? x)
($fl< x 0.0)
(die 'flnegative? "not a flonum" x))))
(define exact-integer-sqrt
(lambda (x)
(define who 'exact-integer-sqrt)
(cond
[(fixnum? x)
(cond
[($fx= x 0) (values 0 0)]
[($fx< x 0) (die who "invalid argument" x)]
[else
(let ([s (foreign-call "ikrt_exact_fixnum_sqrt" x)])
(values s ($fx- x ($fx* s s))))])]
[(bignum? x)
(cond
[($bignum-positive? x)
(let ([r (foreign-call "ikrt_exact_bignum_sqrt" x)])
(values (car r) (cdr r)))]
[else (die who "invalid argument" x)])]
[else (die who "invalid argument" x)])))
(define numerator
(lambda (x)
(cond
[(ratnum? x) ($ratnum-n x)]
[(or (fixnum? x) (bignum? x)) x]
[(flonum? x) (flnumerator x)]
[else (die 'numerator "not an exact integer" x)])))
(define denominator
(lambda (x)
(cond
[(ratnum? x) ($ratnum-d x)]
[(or (fixnum? x) (bignum? x)) 1]
[(flonum? x) (fldenominator x)]
[else (die 'denominator "not an exact integer" x)])))
(define (floor 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
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e)
(exact->inexact (ratnum-floor e))]
[else x]))]
[(ratnum? x) (ratnum-floor x)]
[(or (fixnum? x) (bignum? x)) x]
[else (die 'floor "not a number" x)]))
(define (ceiling x)
(define (ratnum-ceiling 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
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e) (exact->inexact (ratnum-ceiling e))]
[else x]))]
[(ratnum? x) (ratnum-ceiling x)]
[(or (fixnum? x) (bignum? x)) x]
[else (die 'ceiling "not a number" x)]))
(define ($ratnum-round x)
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(let-values ([(q r) (div-and-mod n d)])
(let ([r2 (+ r r)])
(cond
[(< r2 d) q]
[(> r2 d) (+ q 1)]
[else (if (even? q) q (+ q 1))])))))
(define ($ratnum-truncate x)
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(quotient n d)))
(define (round x)
(cond
[(flonum? x) ($flround x)]
[(ratnum? x) ($ratnum-round x)]
[(or (fixnum? x) (bignum? x)) x]
[else (die 'round "not a number" x)]))
(define (truncate x)
;;; FIXME: fltruncate should preserve the sign of -0.0.
;;;
(cond
[(flonum? x)
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e) (exact->inexact ($ratnum-truncate e))]
[else x]))]
[(ratnum? x) ($ratnum-truncate x)]
[(or (fixnum? x) (bignum? x)) x]
[else (die 'truncate "not a number" x)]))
(define (fltruncate x)
;;; FIXME: fltruncate should preserve the sign of -0.0.
(unless (flonum? x)
(die 'fltruncate "not a flonum" x))
(let ([v ($flonum->exact x)])
(cond
[(ratnum? v) (exact->inexact ($ratnum-truncate v))]
[else x])))
(define log
(case-lambda
[(x)
(cond
[(fixnum? x)
(cond
[($fx= x 1) 0]
[($fx= x 0) (die 'log "undefined around 0")]
[($fx> x 0) (foreign-call "ikrt_fx_log" x)]
[else (make-rectangular (log (- x)) (acos -1))])]
[(flonum? x)
(cond
[(fl>=? x 0.0) (foreign-call "ikrt_fl_log" x)]
[else
(make-rectangular
(log (fl- 0.0 x))
(acos -1))])]
[(bignum? x)
(if ($bignum-positive? x)
(let ([v (log (inexact x))])
(cond
[(infinite? v)
(let-values ([(s r) (exact-integer-sqrt x)])
;;; could the [dropped] residual ever affect the answer?
(fl* 2.0 (log s)))]
[else v]))
(make-rectangular (log (- x)) (acos -1)))]
[(ratnum? x)
;;; FIXME: incorrect as per bug 180170
(- (log (numerator x)) (log (denominator x)))]
[(or (compnum? x) (cflonum? x))
(let ([e 2.718281828459045])
(define (ln x) (/ (log x) (log e)))
(let ([xr (real-part x)] [xi (imag-part x)])
(make-rectangular
(/ (ln (+ (* xr xr) (* xi xi))) 2)
(atan xi xr))))]
[else (die 'log "not a number" x)])]
[(x y)
(let ([ly (log y)])
(if (eqv? ly 0)
(die 'log "invalid arguments" x y)
(/ (log x) ly)))]))
(define (random n)
(if (fixnum? n)
(if (fx> n 1)
(foreign-call "ikrt_fxrandom" n)
(if (fx= n 1)
0
(die 'random "incorrect argument" n)))
(die 'random "not a fixnum" n)))
(define (shift-right-arithmetic n m who)
(cond
[(fixnum? m)
(cond
[(fixnum? n)
(cond
[($fx>= m 0) ($fxsra n m)]
[else (die who "offset must be non-negative" m)])]
[(bignum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_bignum_shift_right" n m)]
[($fx= m 0) n]
[else (die who "offset must be non-negative" m)])]
[else (die who "not an exact integer" n)])]
[(bignum? m)
(cond
[(fixnum? n) (if ($fx>= n 0) 0 -1)]
[(bignum? n) (if ($bignum-positive? n) 0 -1)]
[else (die who "not an exact integer" n)])]
[else (die who "not an exact integer offset" m)]))
(define (sra n m)
(shift-right-arithmetic n m 'sra))
(define (shift-left-logical n m who)
(unless (fixnum? m)
(die who "shift amount is not a fixnum"))
(cond
[(fixnum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_fixnum_shift_left" n m)]
[($fx= m 0) n]
[else (die who "offset must be non-negative" m)])]
[(bignum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_bignum_shift_left" n m)]
[($fx= m 0) n]
[else (die who "offset must be non-negative" m)])]
[else (die who "not an exact integer" n)]))
(define (sll n m)
(shift-left-logical n m 'sll))
(define (bitwise-arithmetic-shift-right n m)
(shift-right-arithmetic n m 'bitwise-arithmetic-shift-right))
(define (bitwise-arithmetic-shift-left n m)
(shift-left-logical n m 'bitwise-arithmetic-shift-left))
(define (bitwise-arithmetic-shift n m)
(define who 'bitwise-arithmetic-shift)
(unless (fixnum? m)
(die who "shift amount is not a fixnum"))
(cond
[(fixnum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_fixnum_shift_left" n m)]
[($fx= m 0) n]
[else
(let ([m^ (- m)])
(unless (fixnum? m^)
(die who "shift amount is too big" m))
($fxsra n m^))])]
[(bignum? n)
(cond
[($fx> m 0)
(foreign-call "ikrt_bignum_shift_left" n m)]
[($fx= m 0) n]
[else
(let ([m^ (- m)])
(unless (fixnum? m^)
(die who "shift amount is too big" m))
(foreign-call "ikrt_bignum_shift_right" n m^))])]
[else (die who "not an exact integer" n)]))
(define (exp x)
(cond
[(flonum? x) (flexp x)]
[(fixnum? x)
(if ($fx= x 0) 1 (flexp (fixnum->flonum x)))]
[(bignum? x) (flexp (bignum->flonum x))]
[(ratnum? x) (flexp (ratnum->flonum x))]
[(or (compnum? x) (cflonum? x))
;; e^x = e^(xr + xi i)
;; = e^xr cos(xi) + e^xr sin(xi) i
(let ([xr (real-part x)] [xi (imag-part x)])
(let ([e^xr (exp xr)])
(make-rectangular
(* e^xr (cos xi))
(* e^xr (sin xi)))))]
[else (die 'exp "not a number" x)]))
(define (bitwise-length n)
(cond
[(fixnum? n) (fxlength n)]
[(bignum? n) (foreign-call "ikrt_bignum_length" n)]
[else (die 'bitwise-length "not an exact integer" n)]))
(define (bitwise-copy-bit n idx bit)
(define who 'bitwise-copy-bit)
(define (do-copy-bit n idx bit)
(case bit
[(0)
(cond
[(bitwise-bit-set? n idx)
(bitwise-and n (bitwise-not (sll 1 idx)))]
[else n])]
[(1)
(cond
[(bitwise-bit-set? n idx) n]
[(>= n 0) (+ n (sll 1 idx))]
[else
(bitwise-not
(bitwise-and
(bitwise-not n)
(bitwise-not (sll 1 idx))))])]
[else (die who "bit must be either 0 or 1" bit)]))
(cond
[(fixnum? idx)
(cond
[(fx< idx 0)
(die who "negative bit index" idx)]
[(or (fixnum? n) (bignum? n))
(do-copy-bit n idx bit)]
[else (die who "not an exact integer" n)])]
[(bignum? idx)
(unless (or (fixnum? n) (bignum? n))
(die who "not an exact integer" n))
(if ($bignum-positive? idx)
(case bit
[(0)
(if (>= n 0)
n
(die who "unrepresentable result"))]
[(1)
(if (< n 0)
n
(die who "unrepresentable result"))]
[else (die who "bit must be either 0 or 1" bit)])
(die who "negative bit index" idx))]
[else (die who "index is not an exact integer" idx)]))
(define (bitwise-bit-field n idx1 idx2)
(define who 'bitwise-bit-field)
(cond
[(and (fixnum? idx1) (fx>= idx1 0))
(cond
[(and (fixnum? idx2) (fx>= idx2 0))
(cond
[(fx<= idx1 idx2)
(cond
[(or (fixnum? n) (bignum? n))
(bitwise-and
(sra n idx1)
(- (sll 1 (- idx2 idx1)) 1))]
[else (die who "not an exact integer" n)])]
[else (die who "invalid order for indices" idx1 idx2)])]
[else
(if (not (fixnum? idx2))
(die who "invalid index" idx2)
(die who "negative index" idx2))])]
[else
(if (not (fixnum? idx1))
(die who "invalid index" idx1)
(die who "negative index" idx1))]))
)
(library (ikarus flonum-conversion)
(export string->flonum flonum->string)
(import
(rnrs bytevectors)
(ikarus system $bytevectors)
(ikarus system $flonums)
(except (ikarus) flonum->string string->flonum ))
(module (flonum->string)
(module (flonum->digits)
(define flonum->digits
(lambda (f e min-e p b B)
;;; flonum v = f * b^e
;;; p = precision (p >= 1)
(let ([round? (even? f)])
(if (>= e 0)
(if (not (= f (expt b (- p 1))))
(let ([be (expt b e)])
(scale (* f be 2) 2 be be 0 B round? f e))
(let* ([be (expt b e)] [be1 (* be b)])
(scale (* f be1 2) (* b 2) be1 be 0 B round? f e)))
(if (or (= e min-e) (not (= f (expt b (- p 1)))))
(scale (* f 2) (* (expt b (- e)) 2) 1 1 0 B round? f e)
(scale (* f b 2) (* (expt b (- 1 e)) 2) b 1 0 B round? f e))))))
(define (len n)
(let f ([n n] [i 0])
(cond
[(zero? n) i]
[else (f (quotient n 2) (+ i 1))])))
(define scale
(lambda (r s m+ m- k B round? f e)
(let ([est (inexact->exact
(ceiling
(- (* (+ e (len f) -1) (invlog2of B))
1e-10)))])
(if (>= est 0)
(fixup r (* s (exptt B est)) m+ m- est B round?)
(let ([scale (exptt B (- est))])
(fixup (* r scale) s (* m+ scale) (* m- scale) est B round?))))))
(define fixup
(lambda (r s m+ m- k B round?)
(if ((if round? >= >) (+ r m+) s) ; too low?
(values (+ k 1) (generate r s m+ m- B round?))
(values k (generate (* r B) s (* m+ B) (* m- B) B round?)))))
(define (chr x)
(vector-ref '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) x))
(define generate
(lambda (r s m+ m- B round?)
(let-values ([(q r) (quotient+remainder r s)])
(let ([tc1 ((if round? <= <) r m-)]
[tc2 ((if round? >= >) (+ r m+) s)])
(if (not tc1)
(if (not tc2)
(cons (chr q) (generate (* r B) s (* m+ B) (* m- B) B round?))
(list (chr (+ q 1))))
(if (not tc2)
(list (chr q))
(if (< (* r 2) s)
(list (chr q))
(list (chr (+ q 1))))))))))
(define invlog2of
(let ([table (make-vector 37)]
[log2 (log 2)])
(do ([B 2 (+ B 1)])
((= B 37))
(vector-set! table B (/ log2 (log B))))
(lambda (B)
(if (<= 2 B 36)
(vector-ref table B)
(/ log2 (log B))))))
(define exptt
(let ([table (make-vector 326)])
(do ([k 0 (+ k 1)] [v 1 (* v 10)])
((= k 326))
(vector-set! table k v))
(lambda (B k)
(if (and (= B 10) (<= 0 k 325))
(vector-ref table k)
(expt B k))))))
(define (format-flonum pos? expt digits)
(define (next x)
(if (null? x)
(values #\0 '())
(values (car x) (cdr x))))
(define (format-flonum-no-expt expt d0 d*)
(cond
[(= expt 1)
(cons d0 (if (null? d*) '(#\. #\0) (cons #\. d*)))]
[else
(cons d0
(let-values ([(d0 d*) (next d*)])
(format-flonum-no-expt (- expt 1) d0 d*)))]))
(define (format-flonum-no-expt/neg expt d*)
(cond
[(= expt 0) d*]
[else (cons #\0 (format-flonum-no-expt/neg (+ expt 1) d*))]))
(define (sign pos? ls)
(if pos?
(list->string ls)
(list->string (cons #\- ls))))
(let ([d0 (car digits)] [d* (cdr digits)])
(cond
[(null? d*)
(if (char=? d0 #\0)
(if pos? "0.0" "-0.0")
(if (= expt 1)
(if pos?
(string d0 #\. #\0)
(string #\- d0 #\. #\0))
(if (= expt 0)
(if pos?
(string #\0 #\. d0)
(string #\- #\0 #\. d0))
(string-append
(if pos? "" "-")
(string d0) "e" (fixnum->string (- expt 1))))))]
[(and (null? d*) (char=? d0 #\0)) (if pos? "0.0" "-0.0")]
[(<= 1 expt 9)
(sign pos? (format-flonum-no-expt expt d0 d*))]
[(<= -3 expt 0)
(sign pos? (cons* #\0 #\. (format-flonum-no-expt/neg expt digits)))]
[else
(string-append
(if pos? "" "-")
(string d0) "." (list->string d*)
"e" (fixnum->string (- expt 1)))])))
(define (flo->string pos? m e p)
(let-values ([(expt digits) (flonum->digits m e 10 p 2 10)])
(format-flonum pos? expt digits)))
(define (flonum->string x)
(let-values ([(pos? be m) (flonum-parts x)])
(cond
[(<= 1 be 2046) ; normalized flonum
(flo->string pos? (+ m (expt 2 52)) (- be 1075) 53)]
[(= be 0)
(flo->string pos? m -1074 52)]
[(= be 2047)
(if (= m 0)
(if pos? "+inf.0" "-inf.0")
;;; Gee! nans have no sign!
"+nan.0")]
[else (die 'flonum->string "cannot happen")]))))
;;;
(define (string->flonum x)
(cond
[(string? x)
(foreign-call "ikrt_bytevector_to_flonum"
(string->utf8 x))]
[else
(die 'string->flonum "not a string" x)])) )
(library (ikarus rationalize)
(export rationalize)
(import
(except (ikarus) rationalize))
(define (rationalize x eps)
(define who 'rationalize)
(define (simplest x y)
(cond
[(< y x) (simplest y x)]
[(= x y) x]
[(> x 0)
(let ([n (numerator x)] [d (denominator x)]
[n^ (numerator y)] [d^ (denominator y)])
(simplest^ n d n^ d^))]
[(< y 0)
(let ([n (numerator x)] [d (denominator x)]
[n^ (numerator y)] [d^ (denominator y)])
(- (simplest^ (- n^) d^ (- n) d)))]
[else 0]))
(define (simplest^ n d n^ d^)
(let-values ([(q r) (div-and-mod n d)])
(if (= r 0)
q
(let-values ([(q^ r^) (div-and-mod n^ d^)])
(if (= q q^)
(let ([v (simplest^ d^ r^ d r)])
(let ([n^^ (numerator v)] [d^^ (denominator v)])
(/ (+ (* q n^^) d^^) n^^)))
(+ q 1))))))
(define (go x eps)
(simplest (- x eps) (+ x eps)))
(cond
[(flonum? x)
(if (flfinite? x)
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +0.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (die who "not a number" eps)])
(cond
[(flonum? eps)
(if (flfinite? eps) x +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
x]
[else (die who "not a number" eps)]))]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +0.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (die who "not a number" eps)])]
[else (die who "not a number" x)])))
(library (ikarus r6rs-fu div/mod)
(export div mod div-and-mod div0 mod0 div0-and-mod0)
(import
(except (ikarus)
div mod div-and-mod div0 mod0 div0-and-mod0))
(define (div-and-mod* n m who)
(import (ikarus system $fx)
(only (ikarus system $flonums) $fl=)
(ikarus flonums))
(define (int-div-and-mod n m)
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m0 0)
(values d0 m0)
(if (>= m 0)
(values (- d0 1) (+ m0 m))
(values (+ d0 1) (- m0 m)))))))
(define (rat-div-and-mod n m)
(let ([x (/ n m)])
(cond
[(or (fixnum? x) (bignum? x))
(values x 0)]
[else
(let ([n0 (numerator x)] [d0 (denominator x)])
(let ([q (quotient n0 d0)])
(let ([r (- n (* q m))])
(if (>= r 0)
(values q r)
(if (> m 0)
(values (- q 1) (+ r m))
(values (+ q 1) (- r m)))))))])))
(cond
[(fixnum? m)
(cond
[($fx= m 0)
(die who "division by 0")]
[(or (fixnum? n) (bignum? n))
(int-div-and-mod n m)]
[(flonum? n)
(fldiv-and-mod n (fixnum->flonum m))]
[(ratnum? n)
(rat-div-and-mod n m)]
[else (die who "not a number" n)])]
[(bignum? m)
(cond
[(or (fixnum? n) (bignum? n))
(int-div-and-mod n m)]
[(flonum? n)
(let ([v ($flonum->exact n)])
(unless v
(die who "invalid argument" n))
(let-values ([(a b) (div-and-mod* v m who)])
(values (inexact a) (inexact b))))]
[(ratnum? n)
(rat-div-and-mod n m)]
[else (die who "not a number" n)])]
[(ratnum? m)
(cond
[(or (fixnum? n) (bignum? n) (ratnum? n))
(rat-div-and-mod n m)]
[(flonum? n)
(let ([v ($flonum->exact n)])
(unless v
(die who "invalid argument" n))
(let-values ([(a b) (div-and-mod* v m who)])
(values (inexact a) (inexact b))))]
[else (die who "not a number" n)])]
[(flonum? m)
(cond
[($fl= m 0.0)
(die who "division by 0.0")]
[(flonum? n) (fldiv-and-mod n m)]
[(fixnum? n)
(fldiv-and-mod (fixnum->flonum n) m)]
[(or (bignum? n) (ratnum? n))
(let ([v ($flonum->exact m)])
(unless v
(die who "invalid argument" m))
(let-values ([(a b) (div-and-mod* n v who)])
(values (inexact a) (inexact b))))]
[else (die who "not a number" n)])]
[else (die who "not a number" m)]))
(define (div-and-mod n m)
(div-and-mod* n m 'div-and-mod))
(define (div n m)
(import (ikarus system $fx))
(cond
[(and (fixnum? n) (fixnum? m))
(cond
[(eq? m 0) (error 'div "division by 0")]
[(eq? m -1) (- n)]
[else
(let ([d0 ($fxquotient n m)])
(if ($fx>= n ($fx* d0 m))
d0
(if ($fx>= m 0)
($fx- d0 1)
($fx+ d0 1))))])]
[else
(let-values ([(a b) (div-and-mod* n m 'div)])
a)]))
(define (mod n m)
(import (ikarus system $fx))
(cond
[(and (fixnum? n) (fixnum? m))
(cond
[(eq? m 0) (error 'mod "division by 0")]
[else
(let ([d0 ($fxquotient n m)])
(let ([m0 ($fx- n ($fx* d0 m))])
(if ($fx>= m0 0)
m0
(if ($fx>= m 0)
($fx+ m0 m)
($fx- m0 m)))))])]
[else
(let-values ([(a b) (div-and-mod* n m 'mod)])
b)]))
(define (div0-and-mod0 x y)
(let-values ([(d m) (div-and-mod* x y 'div0-and-mod0)])
(if (> y 0)
(if (< m (/ y 2))
(values d m)
(values (+ d 1) (- m y)))
(if (>= m (/ y -2))
(values (- d 1) (+ m y))
(values d m)))))
(define (div0 x y)
(let-values ([(d m) (div-and-mod* x y 'div0)])
(if (> y 0)
(if (< m (/ y 2))
d
(+ d 1))
(if (>= m (/ y -2))
(- d 1)
d))))
(define (mod0 x y)
(let-values ([(d m) (div-and-mod* x y 'mod0)])
(if (> y 0)
(if (< m (/ y 2))
m
(- m y))
(if (>= m (/ y -2))
(+ m y)
m))))
)
(library (ikarus flonums div-and-mod)
(export fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0)
(import
(ikarus system $flonums)
(ikarus system $fx)
(except (ikarus)
fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0))
(define ($flmod n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m0 0.0)
m0
(if ($fl>= m 0.0)
($fl+ m0 m)
($fl- m0 m))))))
(define ($fldiv n m)
(let ([d0 (fltruncate ($fl/ n m))])
(if ($fl>= n ($fl* d0 m))
d0
(if ($fl>= m 0.0)
($fl- d0 1.0)
($fl+ d0 1.0)))))
(define ($fldiv-and-mod n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m0 0.0)
(values d0 m0)
(if ($fl>= m 0.0)
(values ($fl- d0 1.0) ($fl+ m0 m))
(values ($fl+ d0 1.0) ($fl- m0 m)))))))
(define (fldiv n m)
(if (flonum? n)
(if (flonum? m)
($fldiv n m)
(die 'fldiv "not a flonum" m))
(die 'fldiv "not a flonum" n)))
(define (flmod n m)
(if (flonum? n)
(if (flonum? m)
($flmod n m)
(die 'flmod "not a flonum" m))
(die 'flmod "not a flonum" n)))
(define (fldiv-and-mod n m)
(if (flonum? n)
(if (flonum? m)
($fldiv-and-mod n m)
(die 'fldiv-and-mod "not a flonum" m))
(die 'fldiv-and-mod "not a flonum" n)))
(define ($fldiv0-and-mod0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
(values d0 m0)
(values ($fl- d0 1.0) ($fl+ m0 m)))
(values ($fl+ d0 1.0) ($fl- m0 m)))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
(values d0 m0)
(values ($fl+ d0 1.0) ($fl- m0 m)))
(values ($fl- d0 1.0) ($fl+ m0 m)))))))
(define ($fldiv0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
d0
($fl- d0 1.0))
($fl+ d0 1.0))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
d0
($fl+ d0 1.0))
($fl- d0 1.0))))))
(define ($flmod0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
m0
($fl+ m0 m))
($fl- m0 m))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
m0
($fl- m0 m))
($fl+ m0 m))))))
(define (fldiv0 n m)
(if (flonum? n)
(if (flonum? m)
($fldiv0 n m)
(die 'fldiv0 "not a flonum" m))
(die 'fldiv0 "not a flonum" n)))
(define (flmod0 n m)
(if (flonum? n)
(if (flonum? m)
($flmod0 n m)
(die 'flmod0 "not a flonum" m))
(die 'flmod0 "not a flonum" n)))
(define (fldiv0-and-mod0 n m)
(if (flonum? n)
(if (flonum? m)
($fldiv0-and-mod0 n m)
(die 'fldiv0-and-mod0 "not a flonum" m))
(die 'fldiv0-and-mod0 "not a flonum" n))))
(library (ikarus bitwise misc)
(export fxfirst-bit-set bitwise-bit-set? bitwise-first-bit-set
fxbit-count bitwise-bit-count
fxlength
fxbit-set?
fxcopy-bit
fxcopy-bit-field fxrotate-bit-field
fxbit-field)
(import
(ikarus system $fx)
(ikarus system $bignums)
(ikarus system $flonums)
(except (ikarus)
fxfirst-bit-set bitwise-bit-set? bitwise-first-bit-set
fxbit-count bitwise-bit-count
fxlength
fxbit-set?
fxcopy-bit
fxcopy-bit-field fxrotate-bit-field
fxbit-field))
(module (bitwise-first-bit-set fxfirst-bit-set)
(define (byte-first-bit-set x i)
(import (ikarus system $bytevectors))
(define-syntax make-first-bit-set-bytevector
(lambda (x)
(define (fst n)
(cond
[(odd? n) 0]
[else (+ 1 (fst (bitwise-arithmetic-shift-right n 1)))]))
(u8-list->bytevector
(cons 0 #| not used |#
(let f ([i 1])
(cond
[(= i 256) '()]
[else (cons (fst i) (f (+ i 1)))]))))))
(define bv (make-first-bit-set-bytevector))
($fx+ i ($bytevector-u8-ref bv x)))
(define ($fxloop x i)
(let ([y ($fxlogand x 255)])
(if ($fx= y 0)
($fxloop ($fxsra x 8) ($fx+ i 8))
(byte-first-bit-set y i))))
(define ($bnloop x i idx)
(let ([b ($bignum-byte-ref x idx)])
(if ($fxzero? b)
($bnloop x ($fx+ i 8) ($fx+ idx 1))
(byte-first-bit-set b i))))
(define ($fxfirst-bit-set x)
(if ($fx> x 0)
($fxloop x 0)
(if ($fx= x 0)
-1
(if ($fx> x (least-fixnum))
($fxloop ($fx- 0 x) 0)
($bnloop (- x) 0 0)))))
(define (fxfirst-bit-set x)
(cond
[(fixnum? x)
($fxfirst-bit-set x)]
[else (die 'fxfirst-bit-set "not a fixnum" x)]))
(define (bitwise-first-bit-set x)
(cond
[(fixnum? x)
($fxfirst-bit-set x)]
[(bignum? x) ($bnloop x 0 0)]
[else (die 'bitwise-first-bit-set "not an exact integer" x)])))
(module (fxbit-count bitwise-bit-count)
(define (pos-fxbitcount n)
;;; nifty parrallel count from:
;;; http://infolab.stanford.edu/~manku/bitcount/bitcount.html
(case (fixnum-width)
[(30)
(let ([m0 #x15555555]
[m1 #x13333333]
[m2 #x0f0f0f0f])
(let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))]
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))])
($fxmodulo n 255)))]
[else
(let ([m0 #x0555555555555555]
[m1 #x0333333333333333]
[m2 #x0f0f0f0f0f0f0f0f]
[m3 #x00ff00ff00ff00ff])
(let* ([n ($fx+ ($fxlogand n m0) ($fxlogand ($fxsra n 1) m0))]
[n ($fx+ ($fxlogand n m1) ($fxlogand ($fxsra n 2) m1))]
[n ($fx+ ($fxlogand n m2) ($fxlogand ($fxsra n 4) m2))]
[n ($fx+ ($fxlogand n m3) ($fxlogand ($fxsra n 8) m3))])
($fxmodulo n 255)))]))
(define ($fxbitcount n)
(if ($fx< n 0)
(fxlognot (pos-fxbitcount (fxlognot n)))
(pos-fxbitcount n)))
(define (bnbitcount n)
(define (poscount x idx c)
(let ([c (+ c
($fx+ (pos-fxbitcount
($fxlogor
($fxsll ($bignum-byte-ref x ($fx+ idx 3)) 8)
($bignum-byte-ref x ($fx+ idx 2))))
(pos-fxbitcount
($fxlogor
($fxsll ($bignum-byte-ref x ($fxadd1 idx)) 8)
($bignum-byte-ref x idx)))))])
(if ($fx= idx 0)
c
(poscount x ($fx- idx 4) c))))
(if ($bignum-positive? n)
(poscount n ($fx- ($bignum-size n) 4) 0)
(let ([n (bitwise-not n)])
(bitwise-not (poscount n ($fx- ($bignum-size n) 4) 0)))))
(define (fxbit-count n)
(cond
[(fixnum? n) ($fxbitcount n)]
[else (die 'fxbit-count "not a fixnum" n)]))
(define (bitwise-bit-count n)
(cond
[(fixnum? n) ($fxbitcount n)]
[(bignum? n) (bnbitcount n)]
[else (die 'bitwise-bit-count "not an exact integer" n)])))
(define (fxlength x)
(define (fxlength32 x)
(let ([fl ($fixnum->flonum x)])
(let ([sbe ($fxlogor
($fxsll ($flonum-u8-ref fl 0) 4)
($fxsra ($flonum-u8-ref fl 1) 4))])
(cond
[($fx= sbe 0) 0]
[else ($fx- sbe 1022)]))))
(define (fxlength64 x)
(if ($fx> x #x7FFFFFFF)
($fx+ 31 (fxlength32 ($fxsra x 31)))
(fxlength32 x)))
(if (fixnum? x)
(case (fixnum-width)
[(30)
(fxlength32 (if ($fx< x 0) ($fxlognot x) x))]
[else
(fxlength64 (if ($fx< x 0) ($fxlognot x) x))])
(die 'fxlength "not a fixnum" x)))
(define (fxbit-set? x i)
(define who 'fxbit-set?)
(if (fixnum? x)
(if (fixnum? i)
(if (and ($fx<= 0 i) ($fx< i (fixnum-width)))
(not ($fxzero? ($fxlogand ($fxsra x i) 1)))
(die who "index out of range" i))
(die who "index is not a fixnum" i))
(die who "not a fixnum" x)))
(define (bitwise-bit-set? x i)
(define who 'bitwise-bit-set?)
(cond
[(fixnum? i)
(when ($fx< i 0)
(die who "index must be non-negative" i))
(cond
[(fixnum? x)
(if ($fx< i (fixnum-width))
($fx= ($fxlogand ($fxsra x i) 1) 1)
($fx< x 0))]
[(bignum? x)
(let ([n ($bignum-size x)])
(let ([m ($fx* n 8)])
(if ($fx< m i)
(not ($bignum-positive? x))
(if ($bignum-positive? x)
(let ([b ($bignum-byte-ref x ($fxsra i 3))])
($fx= ($fxlogand ($fxsra b ($fxlogand i 7)) 1) 1))
(= 1 (bitwise-and
(bitwise-arithmetic-shift-right x i)
1))))))]
[else (die who "not an exact integer" x)])]
[(bignum? i)
(unless ($bignum-positive? i)
(die who "index must be non-negative"))
(cond
[(fixnum? x) ($fx< x 0)]
[(bignum? x)
(= 1 (bitwise-and (bitwise-arithmetic-shift-right x i) 1))]
[else (die who "not an exact integer" x)])]
[else
(die who "index is not an exact integer" i)]))
(define (fxcopy-bit x i b)
(define who 'fxcopy-bit)
(if (fixnum? x)
(if (fixnum? i)
(if (and ($fx<= 0 i) ($fx< i (fixnum-width)))
(case b
[(0) ($fxlogand x ($fxlognot ($fxsll 1 i)))]
[(1) ($fxlogor x ($fxsll 1 i))]
[else (die who "invalid bit value" b)])
(die who "index out of range" i))
(die who "index is not a fixnum" i))
(die who "not a fixnum" x)))
(define (fxcopy-bit-field x i j b)
(define who 'fxcopy-bit-field)
(if (fixnum? x)
(if (fixnum? i)
(if ($fx<= 0 i)
(if (fixnum? j)
(if ($fx< j (fixnum-width))
(if ($fx<= i j)
(if (fixnum? b)
(let ([m
($fxlogxor
($fxsub1 ($fxsll 1 i))
($fxsub1 ($fxsll 1 j)))])
($fxlogor
($fxlogand m ($fxsll b i))
($fxlogand ($fxlognot m) x)))
(die who "not a fixnum" b))
(if ($fx<= 0 j)
(die who "index out of range" j)
(die who "indices not in order" i j)))
(die who "index out of range" j))
(die who "not a fixnum" j))
(die who "index out of range" i))
(die who "not a fixnum" i))
(die who "not a fixnum" x)))
(define ($fxrotate-bit-field x i j c w)
(let ([m ($fxsll ($fxsub1 ($fxsll 1 w)) i)])
(let ([x0 ($fxlogand x m)])
(let ([lt ($fxsll x0 c)] [rt ($fxsra x0 ($fx- w c))])
(let ([x0 ($fxlogand ($fxlogor lt rt) m)])
($fxlogor x0 ($fxlogand x ($fxlognot m))))))))
(define (fxrotate-bit-field x i j c)
(define who 'fxrotate-bit-field)
(if (fixnum? x)
(if (fixnum? i)
(if ($fx>= i 0)
(if (fixnum? j)
(if ($fx< j (fixnum-width))
(let ([w ($fx- j i)])
(if ($fx>= w 0)
(if (fixnum? c)
(if (and ($fx>= c 0) ($fx< c w))
($fxrotate-bit-field x i j c w)
(die who "count is invalid" c))
(die who "count is not a fixnum" c))
(die who "field width is negative" i j)))
(die who "end index is out of range" j))
(die who "end index is not a fixnum" j))
(die who "start index is out of range" i))
(die who "start index is not a fixnum" i))
(die who "not a fixnum" x)))
(define (fxbit-field x i j)
(define who 'fxbit-field)
(if (fixnum? x)
(if (fixnum? i)
(if ($fx<= 0 i)
(if (fixnum? j)
(if ($fx< j (fixnum-width))
(if ($fx<= i j)
($fxsra
($fxlogand x ($fxsub1 ($fxsll 1 j)))
i)
(if ($fx<= 0 j)
(die who "index out of range" j)
(die who "indices not in order" i j)))
(die who "index out of range" j))
(die who "not a fixnum" j))
(die who "index out of range" i))
(die who "not a fixnum" i))
(die who "not a fixnum" x)))
)
(library (ikarus complex-numbers)
(export make-rectangular $make-rectangular make-polar
real-part imag-part angle magnitude)
(import
(except (ikarus) make-rectangular make-polar
real-part imag-part angle magnitude)
(except (ikarus system $compnums) $make-rectangular))
(define ($make-rectangular r i)
;;; should be called with 2 exacts
(if (eqv? i 0)
r
($make-compnum r i)))
(define (make-rectangular r i)
(define who 'make-rectangular)
(define (err x)
(die who "invalid argument" x))
(cond
[(flonum? i)
(cond
[(flonum? r) ($make-cflonum r i)]
[(or (fixnum? r) (bignum? r) (ratnum? r))
($make-cflonum (inexact r) i)]
[else (err r)])]
[(eqv? i 0) (if (number? r) r (err r))]
[(or (fixnum? i) (bignum? i) (ratnum? i))
(cond
[(or (fixnum? r) (bignum? r) (ratnum? r))
($make-rectangular r i)]
[(flonum? r)
($make-cflonum r (inexact i))]
[else (err r)])]
[else (err i)]))
(define (make-polar mag angle)
(define who 'make-polar)
(unless (real? mag)
(die who "not a real number" mag))
(unless (real? angle)
(die who "not a real number" angle))
(make-rectangular
(* mag (cos angle))
(* mag (sin angle))))
(define magnitude
(lambda (x)
(cond
[(or (fixnum? x) (bignum? x) (ratnum? x) (flonum? x))
(abs x)]
[(compnum? x)
(let ([r ($compnum-real x)]
[i ($compnum-imag x)])
(sqrt (+ (* r r) (* i i))))]
[(cflonum? x)
(let ([r ($cflonum-real x)]
[i ($cflonum-imag x)])
(sqrt (+ (* r r) (* i i))))]
[else
(die 'magnitude "not a number" x)])))
(define angle
(lambda (x)
(import (ikarus system $bignums) (ikarus system $ratnums))
(define PI (acos -1))
(cond
[(fixnum? x)
(if (fx>? x 0)
0
(if (fx<? x 0)
PI
(die 'angle "undefined for 0")))]
[(bignum? x)
(if ($bignum-positive? x) 0 PI)]
[(ratnum? x)
(let ([n ($ratnum-n x)])
(if (> n 0) 0 PI))]
[(flonum? x)
(atan 0.0 x)]
[(compnum? x)
(let ([r ($compnum-real x)]
[i ($compnum-imag x)])
(atan i r))]
[(cflonum? x)
(let ([r ($cflonum-real x)]
[i ($cflonum-imag x)])
(atan i r))]
[else
(die 'angle "not a number" x)])))
(define real-part
(lambda (x)
(cond
[(fixnum? x) x]
[(bignum? x) x]
[(ratnum? x) x]
[(flonum? x) x]
[(compnum? x) ($compnum-real x)]
[(cflonum? x) ($cflonum-real x)]
[else
(die 'real-part "not a number" x)])))
(define imag-part
(lambda (x)
(cond
[(fixnum? x) 0]
[(bignum? x) 0]
[(ratnum? x) 0]
[(flonum? x) 0]
[(compnum? x) ($compnum-imag x)]
[(cflonum? x) ($cflonum-imag x)]
[else
(die 'imag-part "not a number" x)])))
)
(library (ikarus system flonums)
(export $fixnum->flonum)
(import (ikarus))
(define $fixnum->flonum fixnum->flonum))
Reference in New Issue View Git Blame Copy Permalink