1185 lines
37 KiB
Scheme
1185 lines
37 KiB
Scheme
|
|
|
|
|
|
|
|
|
|
|
|
(library (ikarus flonums)
|
|
(export string->flonum flonum->string)
|
|
(import
|
|
(ikarus system $bytevectors)
|
|
(except (ikarus) flonum->string string->flonum))
|
|
|
|
(define (flonum->string x)
|
|
(utf8-bytevector->string
|
|
(or (foreign-call "ikrt_flonum_to_bytevector" x
|
|
($make-bytevector 80))
|
|
(error 'flonum->string "~s is not a flonum" x))))
|
|
|
|
(define (string->flonum x)
|
|
(cond
|
|
[(string? x)
|
|
(foreign-call "ikrt_bytevector_to_flonum"
|
|
(string->utf8-bytevector x))]
|
|
[else
|
|
(error 'string->flonum "~s is not a string" x)])))
|
|
|
|
|
|
|
|
(library (ikarus generic-arithmetic)
|
|
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder
|
|
positive? expt gcd lcm numerator denominator exact-integer-sqrt
|
|
quotient+remainder number->string string->number)
|
|
(import
|
|
(ikarus system $fx)
|
|
(ikarus system $ratnums)
|
|
(ikarus system $bignums)
|
|
(ikarus system $chars)
|
|
(ikarus system $strings)
|
|
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
|
|
remainder quotient+remainder number->string positive?
|
|
string->number expt gcd lcm numerator denominator
|
|
exact-integer-sqrt))
|
|
|
|
(define (fixnum->flonum x)
|
|
(foreign-call "ikrt_fixnum_to_flonum" x))
|
|
(define (bignum->flonum x)
|
|
(foreign-call "ikrt_bignum_to_flonum" x))
|
|
(define (ratnum->flonum x)
|
|
(binary/ (exact->inexact ($ratnum-n x))
|
|
(exact->inexact ($ratnum-d x))))
|
|
(define ($fl+ x y)
|
|
(foreign-call "ikrt_fl_plus" x y))
|
|
(define ($fl- x y)
|
|
(foreign-call "ikrt_fl_minus" x y))
|
|
(define ($fl* x y)
|
|
(foreign-call "ikrt_fl_times" x y))
|
|
(define ($fl/ x y)
|
|
(foreign-call "ikrt_fl_div" x y))
|
|
|
|
|
|
|
|
(define binary+
|
|
(lambda (x y)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_fxfxplus" x y)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_fxbnplus" x y)]
|
|
[(flonum? y)
|
|
($fl+ (fixnum->flonum x) y)]
|
|
[(ratnum? y)
|
|
($make-ratnum
|
|
(+ (* x ($ratnum-d y)) ($ratnum-n y))
|
|
($ratnum-d y))]
|
|
[else
|
|
(error '+ "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_fxbnplus" y x)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_bnbnplus" x y)]
|
|
[(flonum? y)
|
|
($fl+ (bignum->flonum x) y)]
|
|
[(ratnum? y)
|
|
($make-ratnum
|
|
(+ (* x ($ratnum-d y)) ($ratnum-n y))
|
|
($ratnum-d y))]
|
|
[else
|
|
(error '+ "~s is not a number" y)])]
|
|
[(flonum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
($fl+ x (fixnum->flonum y))]
|
|
[(bignum? y)
|
|
($fl+ x (bignum->flonum y))]
|
|
[(flonum? y)
|
|
($fl+ x y)]
|
|
[(ratnum? y)
|
|
($fl+ x (ratnum->flonum y))]
|
|
[else
|
|
(error '+ "~s is not a number" y)])]
|
|
[(ratnum? x)
|
|
(cond
|
|
[(or (fixnum? y) (bignum? y))
|
|
($make-ratnum
|
|
(+ (* y ($ratnum-d x)) ($ratnum-n x))
|
|
($ratnum-d x))]
|
|
[(flonum? y)
|
|
($fl+ y (ratnum->flonum x))]
|
|
[(ratnum? y)
|
|
(let ([n0 ($ratnum-n x)] [n1 ($ratnum-n y)]
|
|
[d0 ($ratnum-d x)] [d1 ($ratnum-d y)])
|
|
;;; FIXME: inefficient
|
|
(/ (+ (* n0 d1) (* n1 d0)) (* d0 d1)))]
|
|
[else
|
|
(error '+ "~s is not a number" y)])]
|
|
[else (error '+ "~s is not a number" x)])))
|
|
|
|
(define binary-logand
|
|
(lambda (x y)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y) ($fxlogand x y)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_fxbnlogand" x y)]
|
|
[else
|
|
(error 'logand "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_fxbnlogand" y x)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_bnbnlogand" x y)]
|
|
[else
|
|
(error 'logand "~s is not a number" y)])]
|
|
[else (error 'logand "~s is not a number" 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)
|
|
($fl- (fixnum->flonum x) y)]
|
|
[else
|
|
(error '- "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_bnfxminus" x y)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_bnbnminus" x y)]
|
|
[(flonum? y)
|
|
($fl- (bignum->flonum x) y)]
|
|
[else
|
|
(error '- "~s is not a number" y)])]
|
|
[(flonum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
($fl- x (fixnum->flonum y))]
|
|
[(bignum? y)
|
|
($fl- x (bignum->flonum y))]
|
|
[(flonum? y)
|
|
($fl- x y)]
|
|
[else
|
|
(error '- "~s is not a number" y)])]
|
|
[else (error '- "~s is not a number" x)])))
|
|
|
|
(define binary*
|
|
(lambda (x y)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_fxfxmult" x y)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_fxbnmult" x y)]
|
|
[(flonum? y)
|
|
($fl* (fixnum->flonum x) y)]
|
|
[else
|
|
(error '* "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(foreign-call "ikrt_fxbnmult" y x)]
|
|
[(bignum? y)
|
|
(foreign-call "ikrt_bnbnmult" x y)]
|
|
[(flonum? y)
|
|
($fl* (bignum->flonum x) y)]
|
|
[else
|
|
(error '* "~s is not a number" y)])]
|
|
[(flonum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
($fl* x (fixnum->flonum y))]
|
|
[(bignum? y)
|
|
($fl* x (bignum->flonum y))]
|
|
[(flonum? y)
|
|
($fl* x y)]
|
|
[else
|
|
(error '* "~s is not a number" y)])]
|
|
[else (error '* "~s is not a number" x)])))
|
|
|
|
(define +
|
|
(case-lambda
|
|
[(x y) (binary+ x y)]
|
|
[(x y z) (binary+ (binary+ x y) z)]
|
|
[(a)
|
|
(cond
|
|
[(fixnum? a) a]
|
|
[(bignum? a) a]
|
|
[else (error '+ "~s is not a number" a)])]
|
|
[() 0]
|
|
[(a b c d . e*)
|
|
(let f ([ac (binary+ (binary+ (binary+ a b) c) d)]
|
|
[e* e*])
|
|
(cond
|
|
[(null? e*) ac]
|
|
[else (f (binary+ ac (car e*)) (cdr e*))]))]))
|
|
|
|
(define logand
|
|
(case-lambda
|
|
[(x y) (binary-logand x y)]
|
|
[(x y z) (binary-logand (binary-logand x y) z)]
|
|
[(a)
|
|
(cond
|
|
[(fixnum? a) a]
|
|
[(bignum? a) a]
|
|
[else (error 'logand "~s is not a number" a)])]
|
|
[() -1]
|
|
[(a b c d . e*)
|
|
(let f ([ac (binary-logand (binary-logand (binary-logand a b) c) d)]
|
|
[e* e*])
|
|
(cond
|
|
[(null? e*) ac]
|
|
[else (f (binary-logand ac (car e*)) (cdr e*))]))]))
|
|
|
|
(define -
|
|
(case-lambda
|
|
[(x y) (binary- x y)]
|
|
[(x y z) (binary- (binary- x y) z)]
|
|
[(a) (binary- 0 a)]
|
|
[(a b c d . e*)
|
|
(let f ([ac (binary- (binary- (binary- a b) c) d)]
|
|
[e* e*])
|
|
(cond
|
|
[(null? e*) ac]
|
|
[else (f (binary- ac (car e*)) (cdr e*))]))]))
|
|
|
|
(define *
|
|
(case-lambda
|
|
[(x y) (binary* x y)]
|
|
[(x y z) (binary* (binary* x y) z)]
|
|
[(a)
|
|
(cond
|
|
[(fixnum? a) a]
|
|
[(bignum? a) a]
|
|
[else (error '* "~s is not a number" a)])]
|
|
[() 1]
|
|
[(a b c d . e*)
|
|
(let f ([ac (binary* (binary* (binary* a b) c) d)]
|
|
[e* e*])
|
|
(cond
|
|
[(null? e*) ac]
|
|
[else (f (binary* ac (car e*)) (cdr e*))]))]))
|
|
|
|
(define (binary-gcd x y)
|
|
(define (gcd x y)
|
|
(cond
|
|
[($fx= y 0) x]
|
|
[else (gcd y (remainder x y))]))
|
|
(let ([x (if (< x 0) (- x) x)]
|
|
[y (if (< y 0) (- y) y)])
|
|
(cond
|
|
[(> x y) (gcd x y)]
|
|
[(< x y) (gcd y x)]
|
|
[else x])))
|
|
|
|
(define gcd
|
|
(case-lambda
|
|
[(x y)
|
|
(cond
|
|
[(or (fixnum? x) (bignum? x))
|
|
(cond
|
|
[(or (fixnum? y) (bignum? y))
|
|
(binary-gcd x y)]
|
|
[(number? y)
|
|
(error 'gcd "~s is not an exact integer" y)]
|
|
[else
|
|
(error 'gcd "~s is not a number" y)])]
|
|
[(number? x)
|
|
(error 'gcd "~s is not an exact integer" x)]
|
|
[else
|
|
(error 'gcd "~s is not a number" x)])]
|
|
[(x)
|
|
(cond
|
|
[(or (fixnum? x) (bignum? x)) x]
|
|
[(number? x)
|
|
(error 'gcd "~s is not an exact integer" x)]
|
|
[else
|
|
(error 'gcd "~s is not a number" x)])]
|
|
[() 0]
|
|
[(x y z . ls)
|
|
(let f ([g (gcd (gcd x y) z)] [ls ls])
|
|
(cond
|
|
[(null? ls) g]
|
|
[else (f (gcd g (car ls)) (cdr ls))]))]))
|
|
|
|
|
|
(define lcm
|
|
(case-lambda
|
|
[(x y)
|
|
(cond
|
|
[(or (fixnum? x) (bignum? x))
|
|
(cond
|
|
[(or (fixnum? y) (bignum? y))
|
|
(let ([x (if (< x 0) (- x) x)]
|
|
[y (if (< y 0) (- y) y)])
|
|
(let ([g (binary-gcd x y)])
|
|
(binary* y (quotient x g))))]
|
|
[(number? y)
|
|
(error 'lcm "~s is not an exact integer" y)]
|
|
[else
|
|
(error 'lcm "~s is not a number" y)])]
|
|
[(number? x)
|
|
(error 'lcm "~s is not an exact integer" x)]
|
|
[else
|
|
(error 'lcm "~s is not a number" x)])]
|
|
[(x)
|
|
(cond
|
|
[(or (fixnum? x) (bignum? x)) x]
|
|
[(number? x)
|
|
(error 'lcm "~s is not an exact integer" x)]
|
|
[else
|
|
(error 'lcm "~s is not a number" x)])]
|
|
[() 1]
|
|
[(x y z . ls)
|
|
(let f ([g (lcm (lcm x y) z)] [ls ls])
|
|
(cond
|
|
[(null? ls) g]
|
|
[else (f (lcm g (car ls)) (cdr ls))]))]))
|
|
|
|
|
|
|
|
|
|
(define binary/ ;;; implements ratnums
|
|
(lambda (x y)
|
|
(cond
|
|
[(flonum? x)
|
|
(cond
|
|
[(flonum? y) ($fl/ x y)]
|
|
[(fixnum? y) ($fl/ x (fixnum->flonum y))]
|
|
[(bignum? y) ($fl/ x (bignum->flonum y))]
|
|
[(ratnum? y) ($fl/ x (ratnum->flonum y))]
|
|
[else (error '/ "unspported ~s ~s" x y)])]
|
|
[(fixnum? x)
|
|
(cond
|
|
[(flonum? y) ($fl/ (fixnum->flonum x) y)]
|
|
[(fixnum? y)
|
|
(cond
|
|
[($fx= y 0) (error '/ "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)
|
|
(let ([g (binary-gcd x y)])
|
|
(cond
|
|
[(= g y) (quotient x g)] ;;; should not happen
|
|
[($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))]
|
|
[else (error '/ "unsupported ~s ~s" x y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(cond
|
|
[($fx= y 0) (error '/ "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) ($make-ratnum x 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-n y)) ($ratnum-d y))]
|
|
[else (error '/ "~s is not a number" y)])]
|
|
[(ratnum? x)
|
|
(cond
|
|
[(ratnum? y)
|
|
(binary/
|
|
(binary* ($ratnum-n x) ($ratnum-d y))
|
|
(binary* ($ratnum-n y) ($ratnum-d x)))]
|
|
[else (binary/ 1 (binary/ y x))])]
|
|
[else (error '/ "~s is not a number" x)])))
|
|
|
|
(define /
|
|
(case-lambda
|
|
[(x y) (binary/ x y)]
|
|
[(x)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[($fxzero? x) (error '/ "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)]))]
|
|
[else (error '/ "unspported argument ~s" x)])]
|
|
[(x y z . rest)
|
|
(let f ([a (binary/ x y)] [b z] [ls rest])
|
|
(cond
|
|
[(null? rest) (binary/ a b)]
|
|
[else (f (binary/ a b) (car ls) (cdr ls))]))]))
|
|
|
|
|
|
(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)]
|
|
[else (error 'max "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(if (positive-bignum? x) x y)]
|
|
[(bignum? y)
|
|
(if (bnbn> x y) x y)]
|
|
[else (error 'max "~s is not a number" y)])]
|
|
[else (error 'max "~s is 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)
|
|
(if (number? x)
|
|
x
|
|
(error 'max "~s is 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)]
|
|
[else (error 'min "~s is not a number" y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(if (positive-bignum? x) y x)]
|
|
[(bignum? y)
|
|
(if (bnbn> x y) y x)]
|
|
[else (error 'min "~s is not a number" y)])]
|
|
[else (error 'min "~s is 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)
|
|
(if (number? x)
|
|
x
|
|
(error 'min "~s is not a number" x))]))
|
|
|
|
(define exact->inexact
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) (fixnum->flonum x)]
|
|
[(bignum? x) (bignum->flonum x)]
|
|
[else
|
|
(error 'exact->inexact
|
|
"~s is not an exact number" x)])))
|
|
|
|
(define inexact?
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) #f]
|
|
[(bignum? x) #f]
|
|
[(flonum? x) #t]
|
|
[else
|
|
(error 'inexact? "~s is not a 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)]
|
|
[else (error 'even? "~s is not an integer" x)]))
|
|
|
|
(define (odd? x)
|
|
(not
|
|
(cond
|
|
[(fixnum? x) ($fxeven? x)]
|
|
[(bignum? x) (even-bignum? x)]
|
|
[else (error 'odd? "~s is not an integer" x)])))
|
|
|
|
(define bignum->string
|
|
(lambda (x)
|
|
(utf8-bytevector->string
|
|
(foreign-call "ikrt_bignum_to_bytevector" x))))
|
|
|
|
(define ratnum->string
|
|
(lambda (x)
|
|
(string-append
|
|
(number->string ($ratnum-n x))
|
|
"/"
|
|
(number->string ($ratnum-d x)))))
|
|
|
|
(define number->string
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) (fixnum->string x)]
|
|
[(bignum? x) (bignum->string x)]
|
|
[(flonum? x) (flonum->string x)]
|
|
[(ratnum? x) (ratnum->string x)]
|
|
[else (error 'number->string "~s is not a number" x)])))
|
|
|
|
(define modulo
|
|
(lambda (n m)
|
|
(cond
|
|
[(fixnum? n)
|
|
(cond
|
|
[(fixnum? m) ($fxmodulo n m)]
|
|
[else (error 'modulo "unsupported ~s" m)])]
|
|
[else (error 'modulo "unsupported ~s" n)])))
|
|
|
|
(define-syntax mk<
|
|
(syntax-rules ()
|
|
[(_ name fxfx< fxbn< bnfx< bnbn<
|
|
fxfl< flfx< bnfl< flbn< flfl<)
|
|
(let ()
|
|
(define err
|
|
(lambda (x) (error 'name "~s is not a 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))))]
|
|
[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))))]
|
|
[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))))]
|
|
[else (err y)])))
|
|
(define loopf
|
|
(lambda (x ls)
|
|
(cond
|
|
[(number? x)
|
|
(or (null? ls) (loopf (car ls) (cdr ls)))]
|
|
[else (err x)])))
|
|
(case-lambda
|
|
[(x y)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y) (fxfx< x y)]
|
|
[(bignum? y) (fxbn< x y)]
|
|
[(flonum? y) (fxfl< x y)]
|
|
[else (err y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y) (bnfx< x y)]
|
|
[(bignum? y) (bnbn< x y)]
|
|
[(flonum? y) (bnfl< x y)]
|
|
[else (err y)])]
|
|
[(flonum? x)
|
|
(cond
|
|
[(fixnum? y) (flfx< x y)]
|
|
[(bignum? y) (flbn< x y)]
|
|
[(flonum? y) (flfl< x y)]
|
|
[else (err y)])]
|
|
[else (err x)])]
|
|
[(x y z)
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(cond
|
|
[(fixnum? z) (and (fxfx< x y) (fxfx< y z))]
|
|
[(bignum? z)
|
|
(and (fxfx< x y) (fxbn< y z))]
|
|
[(flonum? z)
|
|
(and (fxfx< x y) (fxfl< y z))]
|
|
[else (err z)])]
|
|
[(bignum? y)
|
|
(cond
|
|
[(fixnum? z) #f]
|
|
[(bignum? z)
|
|
(and (fxbn< x y) (bnbn< y z))]
|
|
[(flonum? z)
|
|
(and (fxbn< x y) (bnfl< y z))]
|
|
[else (err z)])]
|
|
[(flonum? y)
|
|
(cond
|
|
[(fixnum? z)
|
|
(and (fxfx< x z)
|
|
(fxfl< x y)
|
|
(flfx< y z))]
|
|
[(bignum? z)
|
|
(and (fxbn< x z)
|
|
(fxfl< x y)
|
|
(flbn< y z))]
|
|
[(flonum? z)
|
|
(and (flfl< y z)
|
|
(fxfl< x y))]
|
|
[else (err z)])]
|
|
[else (err y)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(cond
|
|
[(fixnum? z) (and (fxfx< y z) (bnfx< x y))]
|
|
[(bignum? z)
|
|
(and (bnfx< x y) (bnfx< y z))]
|
|
[(flonum? z)
|
|
(and (bnfx< x y) (fxfl< y z))]
|
|
[else (err z)])]
|
|
[(bignum? y)
|
|
(cond
|
|
[(fixnum? z) (and (bnfx< y z) (bnbn< x y))]
|
|
[(bignum? z) (and (bnbn< x y) (bnbn< y z))]
|
|
[(flonum? z) (and (bnfl< y z) (bnbn< x y))]
|
|
[else (err z)])]
|
|
[(flonum? y)
|
|
(cond
|
|
[(fixnum? z)
|
|
(and (flfx< y z) (bnfl< x y))]
|
|
[(bignum? z)
|
|
(and (bnfl< x y) (flbn< y z))]
|
|
[(flonum? z)
|
|
(and (flfl< y z) (bnfl< x y))]
|
|
[else (err z)])]
|
|
[else (err y)])]
|
|
[(flonum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(cond
|
|
[(fixnum? z)
|
|
(and (fxfx< y z) (flfx< x y))]
|
|
[(bignum? z)
|
|
(and (flfx< x y) (fxbn< y z))]
|
|
[(flonum? z)
|
|
(and (flfx< x y) (fxfl< y z))]
|
|
[else (err z)])]
|
|
[(bignum? y)
|
|
(cond
|
|
[(fixnum? z)
|
|
(and (bnfx< y z) (flbn< x y))]
|
|
[(bignum? z)
|
|
(and (bnbn< y z) (flbn< x y))]
|
|
[(flonum? z)
|
|
(and (flbn< x y) (bnfl< y z))]
|
|
[else (err z)])]
|
|
[(flonum? y)
|
|
(cond
|
|
[(fixnum? z)
|
|
(and (flfx< y z) (flfl< x y))]
|
|
[(bignum? z)
|
|
(and (flfl< x y) (flbn< y z))]
|
|
[(flonum? z)
|
|
(and (flfl< x y) (flfl< y z))]
|
|
[else (err z)])]
|
|
[else (err y)])]
|
|
[else (err x)])]
|
|
[(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)]
|
|
[else (err x)])]))]))
|
|
|
|
(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)])))]))
|
|
|
|
(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)]))
|
|
|
|
(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 =
|
|
(mk< = $fx= false false bnbn= fxfl= flfx= bnfl= flbn= flfl=))
|
|
(define <
|
|
(mk< < $fx< fxbn< bnfx< bnbn< fxfl< flfx< bnfl< flbn< flfl<))
|
|
(define >
|
|
(mk< > $fx> fxbn> bnfx> bnbn> fxfl> flfx> bnfl> flbn> flfl>))
|
|
(define <=
|
|
(mk< <= $fx<= fxbn< bnfx< bnbn<= fxfl<= flfx<= bnfl<= flbn<= flfl<=))
|
|
(define >=
|
|
(mk< >= $fx>= fxbn> bnfx> bnbn>= fxfl>= flfx>= bnfl>= flbn>= flfl>=))
|
|
|
|
(define add1
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x)
|
|
(foreign-call "ikrt_fxfxplus" x 1)]
|
|
[(bignum? x)
|
|
(foreign-call "ikrt_fxbnplus" 1 x)]
|
|
[else (error 'add1 "~s is not a number" x)])))
|
|
|
|
(define sub1
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x)
|
|
(foreign-call "ikrt_fxfxplus" x -1)]
|
|
[(bignum? x)
|
|
(foreign-call "ikrt_fxbnplus" -1 x)]
|
|
[else (error 'sub1 "~s is not a number" x)])))
|
|
|
|
(define zero?
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) (eq? x 0)]
|
|
[(bignum? x) #f]
|
|
[(flonum? x) (= x (exact->inexact 0))]
|
|
[else (error 'zero? "tag=~s / ~s is not a number"
|
|
($fxlogand 255
|
|
($fxsll x 2))
|
|
($fxlogand x -1)
|
|
)])))
|
|
|
|
(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)
|
|
(error 'expt "~s is not a numebr" n))
|
|
(cond
|
|
[(fixnum? m)
|
|
(if ($fx>= m 0)
|
|
(fxexpt n m)
|
|
(error 'expt "power should be positive, got ~s" m))]
|
|
[(bignum? m)
|
|
(cond
|
|
[(eq? n 0) 0]
|
|
[(eq? n 1) 1]
|
|
[(eq? n -1)
|
|
(if (positive-bignum? m)
|
|
(if (even-bignum? m)
|
|
1
|
|
-1)
|
|
(error 'expt "power should be positive, got ~s" m))]
|
|
[else
|
|
(if (positive-bignum? m)
|
|
(error 'expt "(expt ~s ~s) is too big to compute" n m)
|
|
(error 'expt "power should be positive, got ~s" m))])]
|
|
[else (error 'expt "~s is 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)
|
|
(error 'quotient+remainder
|
|
"second argument must be non-zero")]
|
|
[(fixnum? x)
|
|
(cond
|
|
[(fixnum? y)
|
|
(values (fxquotient x y)
|
|
(fxremainder x y))]
|
|
[(bignum? y) (values 0 x)]
|
|
[else (error 'quotient+remainder
|
|
"~s is 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)))]
|
|
[else (error 'quotient+remainder
|
|
"~s is not a number" y)])]
|
|
[else (error 'quotient+remainder
|
|
"~s is not a number" x)])))
|
|
|
|
(define positive?
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) ($fx> x 0)]
|
|
[(bignum? x) (positive-bignum? x)]
|
|
[else (error 'positive? "~s is not a number" x)])))
|
|
|
|
(define negative?
|
|
(lambda (x)
|
|
(cond
|
|
[(fixnum? x) ($fx< x 0)]
|
|
[(bignum? x) (not (positive-bignum? x))]
|
|
[else (error 'negative? "~s is not a number" x)])))
|
|
|
|
(define sin
|
|
(lambda (x)
|
|
(cond
|
|
[(flonum? x) (foreign-call "ikrt_fl_sin" x)]
|
|
[(fixnum? x) (foreign-call "ikrt_fx_sin" x)]
|
|
[else (error 'sin "unsupported ~s" x)])))
|
|
|
|
(define cos
|
|
(lambda (x)
|
|
(cond
|
|
[(flonum? x) (foreign-call "ikrt_fl_cos" x)]
|
|
[(fixnum? x) (foreign-call "ikrt_fx_cos" x)]
|
|
[else (error 'cos "unsupported ~s" x)])))
|
|
|
|
(define atan
|
|
(lambda (x)
|
|
(cond
|
|
[(flonum? x) (foreign-call "ikrt_fl_atan" x)]
|
|
[(fixnum? x) (foreign-call "ikrt_fx_atan" x)]
|
|
[else (error 'atan "unsupported ~s" x)])))
|
|
|
|
(define sqrt
|
|
(lambda (x)
|
|
(cond
|
|
[(flonum? x) (foreign-call "ikrt_fl_sqrt" x)]
|
|
[(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)]
|
|
[(bignum? x) (error 'sqrt "BUG: bignum sqrt not implemented")]
|
|
[(ratnum? x) (/ (sqrt ($ratnum-n x)) (sqrt ($ratnum-d x)))]
|
|
[else (error 'sqrt "unsupported ~s" x)])))
|
|
|
|
(define exact-integer-sqrt
|
|
(lambda (x)
|
|
(define who 'exact-integer-sqrt)
|
|
(define (fxsqrt x i k)
|
|
(let ([j ($fxsra ($fx+ i k) 1)])
|
|
(let ([j^2 ($fx* j j)])
|
|
(if ($fx> j^2 x)
|
|
(fxsqrt x i j)
|
|
(if ($fx= i j)
|
|
(values j ($fx- x j^2))
|
|
(fxsqrt x j k))))))
|
|
(define (bnsqrt x i k)
|
|
(let ([j (quotient (+ i k) 2)])
|
|
(let ([j^2 (* j j)])
|
|
(if (> j^2 x)
|
|
(bnsqrt x i j)
|
|
(if (= i j)
|
|
(values j (- x j^2))
|
|
(bnsqrt x j k))))))
|
|
(cond
|
|
[(fixnum? x)
|
|
(cond
|
|
[($fx< x 0) (error who "invalid argument ~s" x)]
|
|
[($fx= x 0) (values 0 0)]
|
|
[($fx< x 4) (values 1 ($fx- x 1))]
|
|
[($fx< x 9) (values 2 ($fx- x 4))]
|
|
[($fx< x 46340) (fxsqrt x 3 ($fxsra x 1))]
|
|
[else (fxsqrt x 215 23171)])]
|
|
[(bignum? x)
|
|
(cond
|
|
[($bignum-positive? x)
|
|
(bnsqrt x 23170 (quotient x 23170))]
|
|
[else (error who "invalid argument ~s" x)])]
|
|
[else (error who "invalid argument ~s" x)])))
|
|
|
|
|
|
(define numerator
|
|
(lambda (x)
|
|
(cond
|
|
[(ratnum? x) ($ratnum-n x)]
|
|
[(or (fixnum? x) (bignum? x)) x]
|
|
[else (error 'numerator "~s is not an exact integer" x)])))
|
|
|
|
(define denominator
|
|
(lambda (x)
|
|
(cond
|
|
[(ratnum? x) ($ratnum-d x)]
|
|
[(or (fixnum? x) (bignum? x)) 1]
|
|
[else (error 'denominator "~s is not an exact integer" x)])))
|
|
|
|
(define string->number
|
|
(lambda (x)
|
|
(define (convert-data str len pos? idx ac)
|
|
(cond
|
|
[($fx= idx len) (if pos? ac (- 0 ac))]
|
|
[else
|
|
(let ([c ($string-ref str idx)])
|
|
(cond
|
|
[(and ($char<= #\0 c) ($char<= c #\9))
|
|
(convert-data str len pos? ($fxadd1 idx)
|
|
(+ (* ac 10)
|
|
($fx- ($char->fixnum c) ($char->fixnum #\0))))]
|
|
[else #f]))]))
|
|
(define (convert-data-init str len pos? idx c)
|
|
(cond
|
|
[($char= c #\0)
|
|
(if ($fx= idx len)
|
|
0
|
|
(convert-data-init str len pos?
|
|
($fxadd1 idx)
|
|
($string-ref str idx)))]
|
|
[(and ($char<= #\1 c) ($char<= c #\9))
|
|
(convert-data str len pos? idx
|
|
($fx- ($char->fixnum c) ($char->fixnum #\0)))]
|
|
[else #f]))
|
|
(define (convert-num str len pos?)
|
|
(cond
|
|
[($fx> len 1)
|
|
(convert-data-init str len pos? 2 ($string-ref str 1))]
|
|
[else #f]))
|
|
(define (digit c radix)
|
|
(cond
|
|
[(and ($char<= #\0 c) ($char<= c #\9))
|
|
(let ([n ($fx- ($char->fixnum c) ($char->fixnum #\0))])
|
|
(and
|
|
(or ($fx>= radix 10)
|
|
(and ($fx= radix 8) ($char<= c #\7))
|
|
(and ($fx= radix 2) ($char<= c #\1)))
|
|
n))]
|
|
[(and ($char<= #\a c) ($char<= c #\f))
|
|
(let ([n ($fx+ 10 ($fx- ($char->fixnum c) ($char->fixnum #\a)))])
|
|
(and ($fx= radix 16) n))]
|
|
[(and ($char<= #\A c) ($char<= c #\F))
|
|
(let ([n ($fx+ 10 ($fx- ($char->fixnum c) ($char->fixnum #\A)))])
|
|
(and ($fx= radix 16) n))]
|
|
[else #f]))
|
|
(define (convert-subseq str idx len radix ac)
|
|
(cond
|
|
[($fx< idx len)
|
|
(let ([c (string-ref str idx)])
|
|
(cond
|
|
[(digit c radix) =>
|
|
(lambda (n)
|
|
(convert-subseq str ($fxadd1 idx) len radix
|
|
(+ (* ac radix) n)))]
|
|
[else #f]))]
|
|
[else ac]))
|
|
(define (convert-init str idx len radix)
|
|
(cond
|
|
[($fx< idx len)
|
|
(let ([c (string-ref str idx)])
|
|
(cond
|
|
[(digit c radix) =>
|
|
(lambda (n)
|
|
(convert-subseq str ($fxadd1 idx) len radix n))]
|
|
[else #f]))]
|
|
[else #f]))
|
|
(define (convert-init-sign str idx len radix)
|
|
(cond
|
|
[($fx< idx len)
|
|
(let ([c (string-ref str idx)])
|
|
(cond
|
|
[(char=? c #\+)
|
|
(convert-init str ($fxadd1 idx) len radix)]
|
|
[(char=? c #\-)
|
|
(let ([n (convert-init str ($fxadd1 idx) len radix)])
|
|
(and n (- n)))]
|
|
[else (convert-init str idx len radix)]))]
|
|
[else #f]))
|
|
(define (convert-radix str len)
|
|
(cond
|
|
[($fx>= len 2)
|
|
(let ([c (string-ref str 1)])
|
|
(case c
|
|
[(#\x #\X) (convert-init-sign str 2 len 16)]
|
|
[(#\b #\B) (convert-init-sign str 2 len 2)]
|
|
[(#\d #\D) (convert-init-sign str 2 len 10)]
|
|
[(#\o #\O) (convert-init-sign str 2 len 8)]
|
|
[else #f]))]
|
|
[else #f]))
|
|
(define (convert-sign str len)
|
|
(cond
|
|
[($fx> len 0)
|
|
(let ([c ($string-ref str 0)])
|
|
(case c
|
|
[(#\+) (convert-num str len #t)]
|
|
[(#\-) (convert-num str len #f)]
|
|
[(#\#) (convert-radix str len)]
|
|
[else
|
|
(convert-data-init str len #t 1 c)]))]
|
|
[else #f]))
|
|
(cond
|
|
[(string? x)
|
|
(convert-sign x ($string-length x))]
|
|
[else (error 'string->number "~s is not a string" x)])))
|
|
)
|