1020 lines
36 KiB
Racket
1020 lines
36 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base)
|
|
ffi/unsafe
|
|
ffi/unsafe/cvector
|
|
ffi/unsafe/custodian
|
|
ffi/unsafe/define
|
|
racket/math
|
|
racket/runtime-path
|
|
racket/promise
|
|
racket/serialize
|
|
(only-in rnrs/arithmetic/bitwise-6
|
|
bitwise-first-bit-set)
|
|
"gmp.rkt"
|
|
"utils.rkt")
|
|
|
|
(provide
|
|
;; Parameters
|
|
bf-rounding-mode
|
|
bf-min-precision
|
|
bf-max-precision
|
|
bf-precision
|
|
;; Type predicate
|
|
(rename-out [mpfr? bigfloat?])
|
|
bfcanonicalize
|
|
;; Accessors
|
|
bigfloat-precision
|
|
bigfloat-signbit
|
|
bigfloat-exponent
|
|
bigfloat-significand
|
|
;; Conversion to and from Real
|
|
sig+exp->bigfloat
|
|
flonum->bigfloat
|
|
integer->bigfloat
|
|
rational->bigfloat
|
|
real->bigfloat
|
|
bigfloat->sig+exp
|
|
bigfloat->flonum
|
|
bigfloat->integer
|
|
bigfloat->rational
|
|
bigfloat->real
|
|
;; String conversion
|
|
bigfloat->string
|
|
string->bigfloat
|
|
;; Main constructor
|
|
bf
|
|
bigfloat-deserialize-info
|
|
;; Low-level stuff
|
|
mpfr-lib
|
|
get-mpfr-fun
|
|
_rnd_t
|
|
_prec_t
|
|
_sign_t
|
|
_exp_t
|
|
_mpfr_size_limb_t
|
|
_mpfr
|
|
_mpfr-pointer
|
|
(struct-out mpfr))
|
|
|
|
;; Arithmetic, comparison, and other functions are provided by the macros that create them
|
|
|
|
;; ===================================================================================================
|
|
;; Setup/takedown
|
|
|
|
(define-runtime-path libmpfr-so
|
|
(case (system-type)
|
|
[(macosx) '(so "libmpfr.4.dylib")]
|
|
[(windows) '(so "libmpfr-4.dll")]
|
|
[else '(so "libmpfr")]))
|
|
|
|
(define mpfr-lib (ffi-lib libmpfr-so '("4" "1" "") #:fail (λ () #f)))
|
|
|
|
(define-syntax get-mpfr-fun
|
|
(syntax-rules ()
|
|
[(_ name type) (get-mpfr-fun name type (make-not-available name))]
|
|
[(_ name type fail-thunk) (get-ffi-obj name mpfr-lib type fail-thunk)]))
|
|
|
|
(define mpfr-free-cache (get-mpfr-fun 'mpfr_free_cache (_fun -> _void)))
|
|
|
|
(define mpfr-shutdown
|
|
(register-custodian-shutdown
|
|
mpfr-free-cache ; acts as a "random" object for a shutdown handle
|
|
(λ (free)
|
|
(when mpfr-lib
|
|
;; The direct reference here is important, since custodian holds only
|
|
;; a weak reference to shutdown handle:
|
|
(mpfr-free-cache)))))
|
|
|
|
;; ===================================================================================================
|
|
;; MPFR types
|
|
|
|
;; Rounding modes (not all of them, just the useful/well-supported ones)
|
|
(define _rnd_t (_enum '(nearest zero up down)))
|
|
|
|
(define _prec_t _long)
|
|
(define _sign_t _int)
|
|
(define _exp_t _long)
|
|
|
|
;; In mpfr-impl.h, this is a union of mp_size_t and mp_limb_t
|
|
(define _mpfr_size_limb_t
|
|
(if (sizeof-mp_limb_t . > . (ctype-sizeof _mp_size_t)) _mp_limb_t _mp_size_t))
|
|
|
|
(define sizeof-mpfr_size_limb_t (ctype-sizeof _mpfr_size_limb_t))
|
|
|
|
(define sizeof-exp_t (ctype-sizeof _exp_t))
|
|
|
|
;; ===================================================================================================
|
|
;; Parameters: rounding mode, precision
|
|
|
|
;; One of 'nearest 'zero 'up 'down
|
|
(define bf-rounding-mode (make-parameter 'nearest))
|
|
|
|
;; minimum precision (1 bit can't be rounded correctly)
|
|
(define bf-min-precision 2)
|
|
;; maximum precision (the number when longs are 64 bits is ridiculously large)
|
|
(define bf-max-precision _long-max)
|
|
|
|
(define bf-precision
|
|
(make-parameter 128 (λ (p) (cond [(p . < . bf-min-precision) bf-min-precision]
|
|
[(p . > . bf-max-precision) bf-max-precision]
|
|
[else p]))))
|
|
|
|
;; ===================================================================================================
|
|
;; _mpfr type (bigfloat)
|
|
|
|
(define (bigfloat-equal? x1 x2 _)
|
|
(or (and (bfnan? x1) (bfnan? x2))
|
|
(bf=? x1 x2)))
|
|
|
|
(define (canonicalize-sig+exp sig exp)
|
|
(cond [(zero? sig) (values 0 0)]
|
|
[else
|
|
(let-values ([(sgn sig) (cond [(sig . < . 0) (values -1 (- sig))]
|
|
[else (values 1 sig)])])
|
|
(define shift (bitwise-first-bit-set sig))
|
|
(cond [(shift . > . 0) (values (* sgn (arithmetic-shift sig (- shift)))
|
|
(+ exp shift))]
|
|
[else (values (* sgn sig) exp)]))]))
|
|
|
|
(define (bfcanonicalize x)
|
|
(cond [(bfzero? x) (if (zero? (bigfloat-signbit x)) (force 0.bf) (force -0.bf))]
|
|
[(bfnan? x) (force +nan.bf)]
|
|
[(bfinfinite? x) (if (zero? (bigfloat-signbit x)) (force +inf.bf) (force -inf.bf))]
|
|
[else
|
|
(let*-values ([(sig exp) (bigfloat->sig+exp x)]
|
|
[(sig exp) (canonicalize-sig+exp sig exp)])
|
|
(parameterize ([bf-precision (integer-length sig)])
|
|
(sig+exp->bigfloat sig exp)))]))
|
|
|
|
(define (bigfloat-hash x recur-hash)
|
|
(let*-values ([(x) (bfcanonicalize x)]
|
|
[(sig exp) (bigfloat->sig+exp x)])
|
|
(recur-hash (vector (bigfloat-signbit x) sig exp))))
|
|
|
|
(define bigfloat-deserialize
|
|
(case-lambda
|
|
[(p x)
|
|
(unless (exact-integer? p)
|
|
(raise-argument-error 'bigfloat-deserialize "Integer" 0 p x))
|
|
(unless (or (string? x) (real? x))
|
|
(raise-argument-error 'bigfloat-deserialize "(U String Real)" 1 p x))
|
|
(parameterize ([bf-precision p])
|
|
(bf x))]
|
|
[(p sig exp)
|
|
(unless (exact-integer? p)
|
|
(raise-argument-error 'bigfloat-deserialize "Integer" 0 p sig exp))
|
|
(unless (exact-integer? sig)
|
|
(raise-argument-error 'bigfloat-deserialize "Integer" 1 p sig exp))
|
|
(unless (exact-integer? exp)
|
|
(raise-argument-error 'bigfloat-deserialize "Integer" 2 p sig exp))
|
|
(parameterize ([bf-precision p])
|
|
(sig+exp->bigfloat sig exp))]))
|
|
|
|
(define bigfloat-deserialize-info
|
|
(make-deserialize-info
|
|
bigfloat-deserialize
|
|
#f))
|
|
|
|
(define bigfloat-serialize-info
|
|
(make-serialize-info
|
|
(λ (x)
|
|
(cond [(bfzero? x) (vector (bigfloat-precision x)
|
|
(if (zero? (bigfloat-signbit x)) 0.0 -0.0))]
|
|
[(bfnan? x) (vector (bigfloat-precision x)
|
|
+nan.0)]
|
|
[(bfinfinite? x) (vector (bigfloat-precision x)
|
|
(if (zero? (bigfloat-signbit x)) +inf.0 -inf.0))]
|
|
[else (define-values (sig exp) (bigfloat->sig+exp (bfcanonicalize x)))
|
|
(vector (bigfloat-precision x) sig exp)]))
|
|
#'bigfloat-deserialize-info
|
|
#f
|
|
(or (current-load-relative-directory)
|
|
(current-directory))))
|
|
|
|
;; _mpfr: a multi-precision float with rounding (the main data type)
|
|
(define-cstruct _mpfr ([prec _prec_t] [sign _sign_t] [exp _exp_t] [d _gcpointer])
|
|
#:property prop:custom-print-quotable 'never
|
|
#:property prop:custom-write (λ (b port mode) (bigfloat-custom-write b port mode))
|
|
#:property prop:equal+hash (list bigfloat-equal? bigfloat-hash bigfloat-hash)
|
|
#:property prop:serializable bigfloat-serialize-info)
|
|
|
|
;; ===================================================================================================
|
|
;; Foreign functions
|
|
|
|
(define mpfr-get-emin (get-mpfr-fun 'mpfr_get_emin (_fun -> _exp_t)))
|
|
(define mpfr-get-emax (get-mpfr-fun 'mpfr_get_emax (_fun -> _exp_t)))
|
|
|
|
;; Allocation/initialization
|
|
(define mpfr-set-nan (get-mpfr-fun 'mpfr_set_nan (_fun _mpfr-pointer -> _void)))
|
|
(define mpfr-init2 (get-mpfr-fun 'mpfr_init2 (_fun _mpfr-pointer _prec_t -> _void)))
|
|
(define mpfr-clear (get-mpfr-fun 'mpfr_clear (_fun _mpfr-pointer -> _void)))
|
|
;; A "special free" for strings allocated and returned by mpfr_get_str:
|
|
(define mpfr-free-str (get-mpfr-fun 'mpfr_free_str (_fun _pointer -> _void)))
|
|
|
|
;; Conversions from _mpfr to other types
|
|
(define mpfr-get-d (get-mpfr-fun 'mpfr_get_d (_fun _mpfr-pointer _rnd_t -> _double)))
|
|
(define mpfr-get-si (get-mpfr-fun 'mpfr_get_si (_fun _mpfr-pointer _rnd_t -> _long)))
|
|
(define mpfr-get-z (get-mpfr-fun 'mpfr_get_z (_fun _mpz-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define mpfr-get-z-2exp
|
|
(get-mpfr-fun 'mpfr_get_z_2exp (_fun _mpz-pointer _mpfr-pointer -> _exp_t)
|
|
(λ () (get-mpfr-fun 'mpfr_get_z_exp
|
|
(_fun _mpz-pointer _mpfr-pointer -> _exp_t)))))
|
|
(define mpfr-get-str
|
|
(get-mpfr-fun 'mpfr_get_str (_fun _pointer (_cpointer _exp_t) _int _ulong _mpfr-pointer _rnd_t
|
|
-> _bytes)))
|
|
|
|
;; Conversions from other types to _mpfr
|
|
(define mpfr-set (get-mpfr-fun 'mpfr_set (_fun _mpfr-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define mpfr-set-d (get-mpfr-fun 'mpfr_set_d (_fun _mpfr-pointer _double _rnd_t -> _void)))
|
|
(define mpfr-set-si (get-mpfr-fun 'mpfr_set_si (_fun _mpfr-pointer _long _rnd_t -> _void)))
|
|
(define mpfr-set-z (get-mpfr-fun 'mpfr_set_z (_fun _mpfr-pointer _mpz-pointer _rnd_t -> _void)))
|
|
(define mpfr-set-str (get-mpfr-fun 'mpfr_set_str (_fun _mpfr-pointer _string _int _rnd_t -> _int)))
|
|
|
|
;; Functions without simple or uniformly typed wrappers
|
|
(define mpfr-nextabove (get-mpfr-fun 'mpfr_nextabove (_fun _mpfr-pointer -> _void)))
|
|
(define mpfr-nextbelow (get-mpfr-fun 'mpfr_nextbelow (_fun _mpfr-pointer -> _void)))
|
|
(define mpfr-jn (get-mpfr-fun 'mpfr_jn (_fun _mpfr-pointer _long _mpfr-pointer _rnd_t -> _int)))
|
|
(define mpfr-yn (get-mpfr-fun 'mpfr_yn (_fun _mpfr-pointer _long _mpfr-pointer _rnd_t -> _int)))
|
|
(define mpfr-root (get-mpfr-fun 'mpfr_root (_fun _mpfr-pointer _mpfr-pointer _ulong _rnd_t -> _int)))
|
|
|
|
;; mpfr-set-z-exp : _mpfr _mpz integer _rnd_t -> _int
|
|
;; Reimplementation of mpfr_set_z_2exp in Racket, used for older versions of MPFR that don't have it
|
|
(define (mpfr-set-z-exp x z e rnd)
|
|
(define inex (mpfr-set-z x z rnd))
|
|
(cond
|
|
[(or (bfzero? x) (not (bfrational? x)))
|
|
;; Zeros and non-rational numbers have exponents outside the range [emin..emax], which MPFR
|
|
;; nevertheless recognizes as valid. Adding `e' to the exponent of one of those would result in
|
|
;; an invalid exponent, for which MPFR would raise an assertion failure that would crash Racket.
|
|
inex]
|
|
[else
|
|
;; Fix up the exponent
|
|
(let ([e (+ (mpfr-exp x) e)])
|
|
;; Check the exponent against its valid range; return sensible stuff if it's out of range
|
|
(cond [(e . > . (mpfr-get-emax))
|
|
(if ((mpfr-sign x) . >= . 0)
|
|
(mpfr-set-d x +inf.0 'zero)
|
|
(mpfr-set-d x -inf.0 'zero))
|
|
0]
|
|
[(e . < . (mpfr-get-emin))
|
|
(if ((mpfr-sign x) . >= . 0)
|
|
(mpfr-set-d x +0.0 'zero)
|
|
(mpfr-set-d x -0.0 'zero))
|
|
0]
|
|
[else
|
|
(set-mpfr-exp! x e)
|
|
inex]))]))
|
|
|
|
(define mpfr-set-z-2exp
|
|
(get-mpfr-fun 'mpfr_set_z_2exp (_fun _mpfr-pointer _mpz-pointer _exp_t _rnd_t -> _int)
|
|
(λ () mpfr-set-z-exp)))
|
|
|
|
;; ===================================================================================================
|
|
;; Construction
|
|
|
|
#|
|
|
We always create _mpfr instances using new-mpfr, which uses Racket's memory management for the limbs.
|
|
In doing so, we assume that no mpfr_* function will ever try to reallocate limbs. This is a good
|
|
assumption because an _mpfr's precision is fixed from when it's allocated to when it's deallocated.
|
|
There's no reason to allocate new limbs for an _mpfr without changing its precision.
|
|
|#
|
|
|
|
;; raw-mpfr : integer -> bigfloat
|
|
;; Creates and initializes an _mpfr instance using MPFR's memory management. This function exists
|
|
;; mostly for documentation purposes. It's a simpler version of `new-mpfr'.
|
|
;; It's a bad idea to use `raw-mpfr' for long-lived _mpfr objects. Racket can't track the memory used
|
|
;; by the limbs of an _mpfr object constructed using `mpfr-init2', meaning that it would think it
|
|
;; uses less memory than it actually does.
|
|
(define (raw-mpfr prec)
|
|
(define x (make-mpfr 0 0 0 #f))
|
|
(mpfr-init2 x prec)
|
|
(register-finalizer x (λ (x) (mpfr-clear x)))
|
|
x)
|
|
|
|
;; Reimplementation of `mpfr-init2' starts here
|
|
|
|
;; mpfr-prec->limbs : integer -> integer
|
|
;; Reimplementation of MPFR_PREC2LIMBS
|
|
(define (mpfr-prec->limbs prec)
|
|
(+ 1 (quotient (- prec 1) gmp-limb-bits)))
|
|
|
|
;; mpfr-malloc-size : integer -> integer
|
|
;; Reimplementation of MPFR_MALLOC_SIZE
|
|
(define (mpfr-malloc-size n)
|
|
(+ sizeof-mpfr_size_limb_t (* sizeof-mp_limb_t n)))
|
|
|
|
;; Reimplementation of MPFR_EXP_INVALID
|
|
(define mpfr-exp-invalid
|
|
(arithmetic-shift 1 (- (quotient (* gmp-limb-bits sizeof-exp_t) sizeof-mp_limb_t) 2)))
|
|
|
|
;; mpfr-set-alloc-size! : pointer integer -> void
|
|
;; Reimplementation of MPFR_SET_ALLOC_SIZE
|
|
(define (mpfr-set-alloc-size! d n)
|
|
(ptr-set! d _mp_size_t -1 n))
|
|
|
|
;; new-mpfr : integer -> bigfloat
|
|
;; Creates a new _mpfr instance and initializes it, mimicking `mpfr-init2'.
|
|
(define (new-mpfr prec)
|
|
(define n (mpfr-prec->limbs prec))
|
|
;; Allocate d so it won't be traced (atomic) or moved (interior)
|
|
(define orig-d (malloc (mpfr-malloc-size n) 'atomic-interior))
|
|
;; An _mpfr object points at the second element of its limbs array, and uses the first element
|
|
;; to store its size, so shift the pointer
|
|
(define d (ptr-add orig-d 1 _mpfr_size_limb_t))
|
|
;; Setting the size after shifting the pointer because that's what `mpfr-init2' does...
|
|
(mpfr-set-alloc-size! d n)
|
|
;; Make an _mpfr object managed by Racket
|
|
(define x (make-mpfr prec 0 mpfr-exp-invalid d))
|
|
;; Use a finalizer to keep a reference to orig-d as long as x is alive (equiv. to tracing x, if
|
|
;; the value of d pointed at a Racket object)
|
|
(register-finalizer x (λ (x) orig-d))
|
|
;; Set +nan.bf because that's what `mpfr-init2' does...
|
|
(mpfr-set-nan x)
|
|
x)
|
|
|
|
;; ===================================================================================================
|
|
;; Accessors
|
|
|
|
;; bigfloat-precision : bigfloat -> integer
|
|
;; Returns the maximum number of nonzero bits in the significand.
|
|
(define bigfloat-precision mpfr-prec)
|
|
|
|
;; bigfloat-signbit : bigfloat -> fixnum
|
|
;; Returns the sign bit of a bigfloat.
|
|
(define (bigfloat-signbit x)
|
|
(if ((mpfr-sign x) . < . 0) 1 0))
|
|
|
|
;; bigfloat-exponent : bigfloat -> integer
|
|
;; Returns the exponent part of a bigfloat.
|
|
(define (bigfloat-exponent x)
|
|
(- (mpfr-exp x) (bigfloat-precision x)))
|
|
|
|
;; bigfloat->sig+exp : bigfloat -> integer integer
|
|
;; Returns the signed significand and exponent of a bigfloat.
|
|
(define (bigfloat->sig+exp x)
|
|
(define z (new-mpz))
|
|
(define exp (mpfr-get-z-2exp z x))
|
|
(values (mpz->integer z) exp))
|
|
|
|
;; bigfloat-significand : bigfloat -> integer
|
|
;; Returns just the signed significand of a bigfloat.
|
|
(define (bigfloat-significand x)
|
|
(define-values (sig exp) (bigfloat->sig+exp x))
|
|
sig)
|
|
|
|
;; ===================================================================================================
|
|
;; Conversion from Racket data types to bigfloat
|
|
|
|
;; sig+exp->bigfloat : integer integer -> bigfloat
|
|
(define (sig+exp->bigfloat n e)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(mpfr-set-z-2exp y (integer->mpz n) e (bf-rounding-mode))
|
|
y)
|
|
|
|
;; flonum->bigfloat : float -> bigfloat
|
|
;; Converts a Racket inexact real to a bigfloat; rounds if bf-precision < 53.
|
|
(define (flonum->bigfloat value)
|
|
(define x (new-mpfr (bf-precision)))
|
|
(mpfr-set-d x value (bf-rounding-mode))
|
|
x)
|
|
|
|
;; integer->bigfloat : integer -> bigfloat
|
|
;; Converts a Racket integer to a bigfloat; rounds if necessary.
|
|
(define (integer->bigfloat value)
|
|
(define x (new-mpfr (bf-precision)))
|
|
(if (_long? value)
|
|
(mpfr-set-si x value (bf-rounding-mode))
|
|
(mpfr-set-z x (integer->mpz value) (bf-rounding-mode)))
|
|
x)
|
|
|
|
(define (round/mode q)
|
|
(case (bf-rounding-mode)
|
|
[(up) (ceiling q)]
|
|
[(down) (floor q)]
|
|
[(zero) (truncate q)]
|
|
[else (round q)]))
|
|
|
|
(define (floor-log2 n) (max 0 (sub1 (integer-length n))))
|
|
(define (ceiling-log2 n) (max 0 (integer-length (sub1 n))))
|
|
|
|
(define (log2-lower-bound q)
|
|
(- (floor-log2 (numerator q))
|
|
(ceiling-log2 (denominator q))))
|
|
|
|
(define (log2-upper-bound q)
|
|
(- (ceiling-log2 (numerator q))
|
|
(floor-log2 (denominator q))))
|
|
|
|
;; rational->bigfloat : rational -> bigfloat
|
|
;; Converts a Racket rational to a bigfloat; rounds if necessary.
|
|
(define (rational->bigfloat q)
|
|
(define prec (bf-precision))
|
|
(define sgn-q (sgn q))
|
|
(define abs-q (abs q))
|
|
(define ipart (floor abs-q))
|
|
(cond [(zero? sgn-q) (sig+exp->bigfloat 0 0)]
|
|
[(zero? ipart)
|
|
(define e-ub (- (log2-upper-bound abs-q) prec))
|
|
(define e-lb (- (log2-lower-bound abs-q) prec))
|
|
(let loop ([e e-ub])
|
|
(define 2^-e (arithmetic-shift 1 (- e)))
|
|
(define sig (round/mode (* sgn-q abs-q 2^-e)))
|
|
(cond [(or (= e e-lb) (= prec (integer-length (abs sig))))
|
|
(sig+exp->bigfloat sig e)]
|
|
[else
|
|
(loop (- e 1))]))]
|
|
[else
|
|
(define e (- (integer-length ipart) prec))
|
|
(define 2^-e (cond [(e . < . 0) (arithmetic-shift 1 (- e))]
|
|
[else (/ 1 (arithmetic-shift 1 e))]))
|
|
(define sig (round/mode (* sgn-q abs-q 2^-e)))
|
|
(sig+exp->bigfloat sig e)]))
|
|
|
|
;; real->bigfloat : real -> bigfloat
|
|
;; Converts any real Racket value to a bigfloat; rounds if necessary.
|
|
(define (real->bigfloat value)
|
|
(cond [(inexact? value) (flonum->bigfloat value)]
|
|
[(integer? value) (integer->bigfloat value)]
|
|
[else (rational->bigfloat value)]))
|
|
|
|
;; ===================================================================================================
|
|
;; Conversion from mpfr_t to Racket data types
|
|
|
|
;; bigfloat->flonum : bigfloat -> float
|
|
;; Converts a bigfloat to a Racket float; rounds if necessary.
|
|
(define (bigfloat->flonum x)
|
|
(mpfr-get-d x (bf-rounding-mode)))
|
|
|
|
;; bigfloat->integer : bigfloat -> integer
|
|
;; Converts a bigfloat to a Racket integer; rounds if necessary.
|
|
(define (bigfloat->integer x)
|
|
(unless (bfinteger? x) (raise-argument-error 'bigfloat->integer "bfinteger?" x))
|
|
(define z (new-mpz))
|
|
(mpfr-get-z z x (bf-rounding-mode))
|
|
(define res (mpz->integer z))
|
|
res)
|
|
|
|
;; bigfloat->rational : bigfloat -> rational
|
|
;; Converts a bigfloat to a Racket rational; does not round.
|
|
(define (bigfloat->rational x)
|
|
(unless (bfrational? x) (raise-argument-error 'bigfloat->rational "bfrational?" x))
|
|
(define-values (sig exp) (bigfloat->sig+exp x))
|
|
(cond [(zero? sig) 0] ; without this, (bigfloat->rational 0.bf) chews up half a gigabyte
|
|
[else (* sig (expt 2 exp))]))
|
|
|
|
; bigfloat->real : bigfloat -> (or exact-rational flonum)
|
|
(define (bigfloat->real x)
|
|
(cond [(bfrational? x) (bigfloat->rational x)]
|
|
[else (bigfloat->flonum x)]))
|
|
|
|
;; ===================================================================================================
|
|
;; String conversions
|
|
|
|
(define (mpfr-get-string x base rnd)
|
|
(define exp-ptr (cast (malloc _exp_t 'atomic-interior) _pointer (_cpointer _exp_t)))
|
|
(define bs (mpfr-get-str #f exp-ptr base 0 x rnd))
|
|
(define exp (ptr-ref exp-ptr _exp_t))
|
|
(define str (bytes->string/utf-8 bs))
|
|
(mpfr-free-str bs)
|
|
(values exp str))
|
|
|
|
(define (remove-trailing-zeros str)
|
|
(let loop ([i (string-length str)])
|
|
(cond [(zero? i) "0"]
|
|
[(char=? #\0 (string-ref str (sub1 i))) (loop (sub1 i))]
|
|
[(char=? #\. (string-ref str (sub1 i))) (substring str 0 (sub1 i))]
|
|
[else (substring str 0 i)])))
|
|
|
|
(define (scientific-string exp str)
|
|
(define n (string-length str))
|
|
(cond [(= n 0) "0"]
|
|
[else
|
|
(define sig (remove-trailing-zeros (format "~a.~a" (substring str 0 1) (substring str 1))))
|
|
(if (= exp 1) sig (format "~ae~a" sig (number->string (- exp 1))))]))
|
|
|
|
(define (decimal-string-length exp digs)
|
|
(cond [(exp . > . (string-length digs))
|
|
(+ (string-length digs) (- exp (string-length digs)))]
|
|
[(exp . <= . 0)
|
|
(let ([digs (remove-trailing-zeros digs)])
|
|
(cond [(equal? digs "0") 1]
|
|
[else (+ 2 (- exp) (string-length digs))]))]
|
|
[else
|
|
(string-length
|
|
(remove-trailing-zeros
|
|
(string-append (substring digs 0 exp) "." (substring digs exp))))]))
|
|
|
|
(define (decimal-string exp digs)
|
|
(cond [(exp . > . (string-length digs))
|
|
(string-append digs (make-string (- exp (string-length digs)) #\0))]
|
|
[(exp . <= . 0)
|
|
(remove-trailing-zeros
|
|
(string-append "0." (make-string (- exp) #\0) digs))]
|
|
[else
|
|
(remove-trailing-zeros
|
|
(string-append (substring digs 0 exp) "." (substring digs exp)))]))
|
|
|
|
;; Converts a bigfloat to a Racket string of digits, with a decimal point.
|
|
;; Outputs enough digits to exactly recreate the bigfloat using string->bigfloat.
|
|
(define (bigfloat->string x)
|
|
(cond
|
|
[(bfzero? x) (if (= 0 (bigfloat-signbit x)) "0.0" "-0.0")]
|
|
[(bfinfinite? x) (if (= 0 (bigfloat-signbit x)) "+inf.bf" "-inf.bf")]
|
|
[(bfnan? x) "+nan.bf"]
|
|
[else
|
|
(define-values (exp str) (mpfr-get-string x 10 'nearest))
|
|
(cond
|
|
[(not str) (error 'bigfloat->string "string conversion failed for ~e"
|
|
(number->string (bigfloat->rational x)))]
|
|
[else
|
|
(define-values (sign digs)
|
|
(if (char=? (string-ref str 0) #\-)
|
|
(values "-" (substring str 1))
|
|
(values "" str)))
|
|
(define sstr (scientific-string exp digs))
|
|
(define dlen (decimal-string-length exp digs))
|
|
(cond [((string-length sstr) . < . dlen) (string-append sign sstr)]
|
|
[else (string-append sign (decimal-string exp digs))])])]))
|
|
|
|
;; string->bigfloat : string [integer] -> bigfloat
|
|
;; Converts a Racket string to a bigfloat.
|
|
(define (string->bigfloat str)
|
|
(case str
|
|
[("-inf.bf" "-inf.0" "-inf.f") (force -inf.bf)]
|
|
[("-1.bf") (force -1.bf)]
|
|
[("-0.bf") (force -0.bf)]
|
|
[( "0.bf") (force 0.bf)]
|
|
[( "1.bf") (force 1.bf)]
|
|
[("+inf.bf" "+inf.0" "+inf.f") (force +inf.bf)]
|
|
[("+nan.bf" "+nan.0" "+nan.f") (force +nan.bf)]
|
|
[else
|
|
(define y (new-mpfr (bf-precision)))
|
|
(define bs (string->bytes/utf-8 str))
|
|
(if (zero? (mpfr-set-str y bs 10 'nearest)) y #f)]))
|
|
|
|
(define (bigfloat-custom-write x port mode)
|
|
(cond
|
|
[(and mpfr-lib gmp-lib)
|
|
;; Only try to print if libmpfr was loaded; otherwise, we get an infinite loop when the
|
|
;; `make-not-available' handler tries to print any _mpfr arguments
|
|
(write-string
|
|
(cond [(bfzero? x) (if (= 0 (bigfloat-signbit x)) "0.bf" "-0.bf")]
|
|
[(bfrational? x)
|
|
(define str (bigfloat->string x))
|
|
(cond [(regexp-match #rx"\\.|e" str)
|
|
(define exp (bigfloat-exponent x))
|
|
(define prec (bigfloat-precision x))
|
|
(if ((abs exp) . > . (* prec 2))
|
|
(format "(bf \"~a\")" str)
|
|
(format "(bf #e~a)" str))]
|
|
[else (format "(bf ~a)" str)])]
|
|
[(bfinfinite? x) (if (= 0 (bigfloat-signbit x)) "+inf.bf" "-inf.bf")]
|
|
[else "+nan.bf"])
|
|
port)]
|
|
[else
|
|
(write-string "#<_mpfr>" port)]))
|
|
|
|
;; ===================================================================================================
|
|
;; Main bigfloat constructor
|
|
|
|
;; bf : (or real string) -> bigfloat
|
|
;; : integer integer -> bigfloat
|
|
(define bf
|
|
(case-lambda
|
|
[(v) (cond [(string? v)
|
|
(define x (string->bigfloat v))
|
|
(if x x (error 'bf "expected well-formed decimal number; given ~e" v))]
|
|
[else
|
|
(real->bigfloat v)])]
|
|
[(n e) (sig+exp->bigfloat n e)]))
|
|
|
|
;; ===================================================================================================
|
|
;; Unary functions
|
|
|
|
(define-for-syntax 1ary-funs (list))
|
|
(provide (for-syntax 1ary-funs))
|
|
|
|
(define-syntax-rule (provide-1ary-fun name c-name)
|
|
(begin
|
|
(define cfun (get-mpfr-fun c-name (_fun _mpfr-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define (name x)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(cfun y x (bf-rounding-mode))
|
|
y)
|
|
(provide name)
|
|
(begin-for-syntax (set! 1ary-funs (cons #'name 1ary-funs)))))
|
|
|
|
(define-syntax-rule (provide-1ary-funs [name c-name] ...)
|
|
(begin (provide-1ary-fun name c-name) ...))
|
|
|
|
(provide-1ary-funs
|
|
[bfsqr 'mpfr_sqr]
|
|
[bfsqrt 'mpfr_sqrt]
|
|
[bf1/sqrt 'mpfr_rec_sqrt]
|
|
[bfcbrt 'mpfr_cbrt]
|
|
[bfneg 'mpfr_neg]
|
|
[bfabs 'mpfr_abs]
|
|
[bflog 'mpfr_log]
|
|
[bflog2 'mpfr_log2]
|
|
[bflog10 'mpfr_log10]
|
|
[bflog1p 'mpfr_log1p]
|
|
[bfexp 'mpfr_exp]
|
|
[bfexp2 'mpfr_exp2]
|
|
[bfexp10 'mpfr_exp10]
|
|
[bfexpm1 'mpfr_expm1]
|
|
[bfcos 'mpfr_cos]
|
|
[bfsin 'mpfr_sin]
|
|
[bftan 'mpfr_tan]
|
|
[bfsec 'mpfr_sec]
|
|
[bfcsc 'mpfr_csc]
|
|
[bfcot 'mpfr_cot]
|
|
[bfacos 'mpfr_acos]
|
|
[bfasin 'mpfr_asin]
|
|
[bfatan 'mpfr_atan]
|
|
[bfcosh 'mpfr_cosh]
|
|
[bfsinh 'mpfr_sinh]
|
|
[bftanh 'mpfr_tanh]
|
|
[bfsech 'mpfr_sech]
|
|
[bfcsch 'mpfr_csch]
|
|
[bfcoth 'mpfr_coth]
|
|
[bfacosh 'mpfr_acosh]
|
|
[bfasinh 'mpfr_asinh]
|
|
[bfatanh 'mpfr_atanh]
|
|
[bfeint 'mpfr_eint]
|
|
[bfli2 'mpfr_li2]
|
|
[bfgamma 'mpfr_gamma]
|
|
[bfpsi0 'mpfr_digamma]
|
|
[bfzeta 'mpfr_zeta]
|
|
[bferf 'mpfr_erf]
|
|
[bferfc 'mpfr_erfc]
|
|
[bfbesj0 'mpfr_j0]
|
|
[bfbesj1 'mpfr_j1]
|
|
[bfbesy0 'mpfr_y0]
|
|
[bfbesy1 'mpfr_y1]
|
|
[bfrint 'mpfr_rint]
|
|
[bffrac 'mpfr_frac]
|
|
[bfcopy 'mpfr_set])
|
|
|
|
(begin-for-syntax
|
|
(set! 1ary-funs (remove* (list #'bfneg) 1ary-funs free-identifier=?)))
|
|
|
|
(define (bfsgn x)
|
|
(cond [(bfzero? x) x]
|
|
[(= 0 (bigfloat-signbit x)) (force 1.bf)]
|
|
[else (force -1.bf)]))
|
|
|
|
(define (bfround x)
|
|
(parameterize ([bf-rounding-mode 'nearest])
|
|
(bfrint x)))
|
|
|
|
(provide bfsgn bfround)
|
|
(begin-for-syntax
|
|
(set! 1ary-funs (list* #'bfsgn #'bfround 1ary-funs)))
|
|
|
|
(define mpfr-fac-ui (get-mpfr-fun 'mpfr_fac_ui (_fun _mpfr-pointer _ulong _rnd_t -> _int)))
|
|
|
|
(define (bffactorial n)
|
|
(cond [(n . < . 0) (raise-argument-error 'bffactorial "Natural" n)]
|
|
[(n . > . 100000000) (force +inf.bf)]
|
|
[else (define y (new-mpfr (bf-precision)))
|
|
(mpfr-fac-ui y n (bf-rounding-mode))
|
|
y]))
|
|
|
|
(provide bffactorial)
|
|
|
|
(define mpfr-sum (get-mpfr-fun 'mpfr_sum (_fun _mpfr-pointer (_list i _mpfr-pointer) _ulong
|
|
_rnd_t -> _int)))
|
|
|
|
(define (bfsum xs)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(mpfr-sum y xs (length xs) (bf-rounding-mode))
|
|
y)
|
|
|
|
(provide bfsum)
|
|
|
|
(define-syntax-rule (provide-1ary-fun/noround name c-name)
|
|
(begin
|
|
(define cfun (get-mpfr-fun c-name (_fun _mpfr-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define (name x)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(cfun y x (bf-rounding-mode))
|
|
y)
|
|
(provide name)
|
|
(begin-for-syntax (set! 1ary-funs (cons #'name 1ary-funs)))))
|
|
|
|
(define-syntax-rule (provide-1ary-funs/noround [name c-name] ...)
|
|
(begin (provide-1ary-fun/noround name c-name) ...))
|
|
|
|
(provide-1ary-funs/noround
|
|
[bfceiling 'mpfr_ceil]
|
|
[bffloor 'mpfr_floor]
|
|
[bftruncate 'mpfr_trunc])
|
|
|
|
(define-for-syntax 1ary2-funs (list))
|
|
(provide (for-syntax 1ary2-funs))
|
|
|
|
(define-syntax-rule (provide-1ary2-fun name c-name)
|
|
(begin
|
|
(define cfun
|
|
(get-mpfr-fun c-name (_fun _mpfr-pointer _mpfr-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define (name x)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(define z (new-mpfr (bf-precision)))
|
|
(cfun y z x (bf-rounding-mode))
|
|
(values y z))
|
|
(provide name)
|
|
(begin-for-syntax (set! 1ary2-funs (cons #'name 1ary2-funs)))))
|
|
|
|
(define-syntax-rule (provide-1ary2-funs [name c-name] ...)
|
|
(begin (provide-1ary2-fun name c-name) ...))
|
|
|
|
(provide-1ary2-funs
|
|
[bfsin+cos 'mpfr_sin_cos]
|
|
[bfsinh+cosh 'mpfr_sinh_cosh]
|
|
[bfmodf 'mpfr_modf])
|
|
|
|
(define mpfr-lgamma
|
|
(get-mpfr-fun 'mpfr_lgamma (_fun _mpfr-pointer _pointer _mpfr-pointer _rnd_t -> _int)))
|
|
|
|
(define (bflog-gamma/sign x)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(define s (malloc _int 'atomic-interior))
|
|
(mpfr-lgamma y s x (bf-rounding-mode))
|
|
(values y (ptr-ref s _int)))
|
|
|
|
(define (bflog-gamma x)
|
|
(define-values (y _) (bflog-gamma/sign x))
|
|
y)
|
|
|
|
(provide bflog-gamma/sign bflog-gamma)
|
|
(begin-for-syntax
|
|
(set! 1ary-funs (list* #'bflog-gamma 1ary-funs)))
|
|
|
|
;; ===================================================================================================
|
|
;; Unary predicates
|
|
|
|
(define-for-syntax 1ary-preds (list))
|
|
(provide (for-syntax 1ary-preds))
|
|
|
|
(define-syntax-rule (provide-1ary-pred name c-name)
|
|
(begin
|
|
(define cfun (get-mpfr-fun c-name (_fun _mpfr-pointer -> _int)))
|
|
(define (name x) (not (zero? (cfun x))))
|
|
(provide name)
|
|
(begin-for-syntax (set! 1ary-preds (cons #'name 1ary-preds)))))
|
|
|
|
(define-syntax-rule (provide-1ary-preds [name c-name] ...)
|
|
(begin (provide-1ary-pred name c-name) ...))
|
|
|
|
(provide-1ary-preds
|
|
[bfnan? 'mpfr_nan_p]
|
|
[bfinfinite? 'mpfr_inf_p]
|
|
[bfrational? 'mpfr_number_p]
|
|
[bfinteger? 'mpfr_integer_p]
|
|
[bfzero? 'mpfr_zero_p])
|
|
|
|
(define (bfpositive? x)
|
|
(bfgt? x (force 0.bf)))
|
|
|
|
(define (bfnegative? x)
|
|
(bflt? x (force 0.bf)))
|
|
|
|
(define (bfeven? x)
|
|
(and (bfinteger? x) (even? (bigfloat->integer x))))
|
|
|
|
(define (bfodd? x)
|
|
(and (bfinteger? x) (odd? (bigfloat->integer x))))
|
|
|
|
(provide bfpositive? bfnegative? bfeven? bfodd?)
|
|
(begin-for-syntax
|
|
(set! 1ary-preds (append (list #'bfpositive? #'bfnegative? #'bfeven? #'bfodd?)
|
|
1ary-preds)))
|
|
|
|
;; ===================================================================================================
|
|
;; Binary functions
|
|
|
|
(define-for-syntax 2ary-funs (list))
|
|
(provide (for-syntax 2ary-funs))
|
|
|
|
(define-syntax-rule (provide-2ary-fun name c-name)
|
|
(begin
|
|
(define cfun
|
|
(get-mpfr-fun c-name (_fun _mpfr-pointer _mpfr-pointer _mpfr-pointer _rnd_t -> _int)))
|
|
(define (name x1 x2)
|
|
(define y (new-mpfr (bf-precision)))
|
|
(cfun y x1 x2 (bf-rounding-mode))
|
|
y)
|
|
(provide name)
|
|
(begin-for-syntax (set! 2ary-funs (cons #'name 2ary-funs)))))
|
|
|
|
(define-syntax-rule (provide-2ary-funs [name c-name] ...)
|
|
(begin (provide-2ary-fun name c-name) ...))
|
|
|
|
(provide-2ary-funs
|
|
[bfadd 'mpfr_add]
|
|
[bfsub 'mpfr_sub]
|
|
[bfmul 'mpfr_mul]
|
|
[bfdiv 'mpfr_div]
|
|
[bfremainder 'mpfr_fmod] ; this may not be right
|
|
[bfexpt 'mpfr_pow]
|
|
[bfmax2 'mpfr_max]
|
|
[bfmin2 'mpfr_min]
|
|
[bfatan2 'mpfr_atan2]
|
|
[bfhypot 'mpfr_hypot]
|
|
[bfagm 'mpfr_agm])
|
|
|
|
(begin-for-syntax
|
|
(set! 2ary-funs (remove* (list #'bfadd #'bfsub #'bfmul #'bfdiv #'bfmax2 #'bfmin2)
|
|
2ary-funs
|
|
free-identifier=?)))
|
|
|
|
(define (bfbesj n x)
|
|
(unless (_long? n) (raise-argument-error 'bfbesj "_long?" 0 n x))
|
|
(define y (new-mpfr (bf-precision)))
|
|
(mpfr-jn y n x (bf-rounding-mode))
|
|
y)
|
|
|
|
(define (bfbesy n x)
|
|
(unless (_long? n) (raise-argument-error 'bfbesy "_long?" 0 n x))
|
|
(define y (new-mpfr (bf-precision)))
|
|
(mpfr-yn y n x (bf-rounding-mode))
|
|
y)
|
|
|
|
(define (bfroot x n)
|
|
(unless (and (_ulong? n) (n . >= . 0)) (raise-argument-error 'bfroot "_ulong?" 1 x n))
|
|
(define y (new-mpfr (bf-precision)))
|
|
(mpfr-root y x n (bf-rounding-mode))
|
|
y)
|
|
|
|
(define (bfnext x)
|
|
(define y (bfcopy x))
|
|
(mpfr-nextabove y)
|
|
y)
|
|
|
|
(define (bfprev x)
|
|
(define y (bfcopy x))
|
|
(mpfr-nextbelow y)
|
|
y)
|
|
|
|
(define (bfshift x n)
|
|
(unless (fixnum? n) (raise-argument-error 'bfshift "Fixnum" 1 x n))
|
|
(cond [(bfzero? x) x]
|
|
[(not (bfrational? x)) x]
|
|
[else (define-values (sig exp) (bigfloat->sig+exp x))
|
|
(bf sig (+ n exp))]))
|
|
|
|
(define (infinite-ordinal p)
|
|
(+ 1 (arithmetic-shift #b1111111111111111111111111111111 (- p 1))))
|
|
|
|
(define (bigfloat->ordinal x)
|
|
(cond [(bfzero? x) 0]
|
|
[else
|
|
(define p (bf-precision))
|
|
(let loop ([x (bfcopy x)])
|
|
(cond [(bfnegative? x) (- (loop (bfneg x)))]
|
|
[(bfinfinite? x) (infinite-ordinal p)]
|
|
[(bfnan? x) (+ 1 (infinite-ordinal p))]
|
|
[else
|
|
(define-values (sig exp) (bigfloat->sig+exp x))
|
|
(+ 1 (bitwise-ior (arithmetic-shift (+ exp (- p (mpfr-get-emin))) (- p 1))
|
|
(bitwise-xor (arithmetic-shift 1 (- p 1)) sig)))]))]))
|
|
|
|
(define (ordinal->bigfloat n)
|
|
(define p (bf-precision))
|
|
(cond [(zero? n) (bf 0)]
|
|
[(negative? n) (bfneg (ordinal->bigfloat (- n)))]
|
|
[(n . > . (infinite-ordinal p)) (force +nan.bf)]
|
|
[else
|
|
(let ([n (- n 1)])
|
|
(define exp (- (arithmetic-shift n (- 1 p)) (- p (mpfr-get-emin))))
|
|
(define high-bit (arithmetic-shift 1 (- p 1)))
|
|
(define sig (bitwise-ior high-bit (bitwise-and n (- high-bit 1))))
|
|
(bf sig exp))]))
|
|
|
|
(define (bigfloats-between x y)
|
|
(- (bigfloat->ordinal y) (bigfloat->ordinal x)))
|
|
|
|
(define (bfstep x n)
|
|
(cond [(or (bfnan? x) (= n 0)) x]
|
|
[else
|
|
(let loop ([x (bfcopy x)] [n n])
|
|
(cond [(negative? n) (bfneg (loop (bfneg x) (- n)))]
|
|
[(bfinfinite? x)
|
|
(cond [(bfpositive? x) x]
|
|
[else (loop (bfnext x) (- n 1))])]
|
|
[else
|
|
(define p (bf-precision))
|
|
(define i (+ n (bigfloat->ordinal x)))
|
|
(cond [(and (i . > . 0) (i . > . (infinite-ordinal p))) (force +inf.bf)]
|
|
[else (ordinal->bigfloat i)])]))]))
|
|
|
|
(provide bfbesj bfbesy bfroot
|
|
bigfloat->ordinal ordinal->bigfloat bigfloats-between bfshift bfstep bfprev bfnext)
|
|
|
|
;; ===================================================================================================
|
|
;; Binary predicates
|
|
|
|
(define-syntax-rule (provide-2ary-pred name c-name)
|
|
(begin (define cfun (get-mpfr-fun c-name (_fun _mpfr-pointer _mpfr-pointer -> _int)))
|
|
(define (name x1 x2)
|
|
(not (zero? (cfun x1 x2))))
|
|
(provide name)))
|
|
|
|
(define-syntax-rule (provide-2ary-preds [name c-name] ...)
|
|
(begin (provide-2ary-pred name c-name) ...))
|
|
|
|
(provide-2ary-preds
|
|
[bf=? 'mpfr_equal_p]
|
|
[bflt? 'mpfr_less_p]
|
|
[bflte? 'mpfr_lessequal_p]
|
|
[bfgt? 'mpfr_greater_p]
|
|
[bfgte? 'mpfr_greaterequal_p])
|
|
|
|
;; ===================================================================================================
|
|
;; Constants and variable-precision constants (i.e. 0-ary functions)
|
|
|
|
(define-for-syntax consts (list))
|
|
(provide (for-syntax consts))
|
|
|
|
(define-syntax-rule (define-bf-constant name prec expr)
|
|
(begin
|
|
(define name (lazy (parameterize ([bf-precision prec]) expr)))
|
|
(provide name)
|
|
(begin-for-syntax
|
|
(set! consts (cons #'name consts)))))
|
|
|
|
(define-bf-constant -inf.bf 2 (flonum->bigfloat -inf.0))
|
|
(define-bf-constant -0.bf 2 (flonum->bigfloat -0.0))
|
|
(define-bf-constant 0.bf 2 (flonum->bigfloat 0.0))
|
|
(define-bf-constant +inf.bf 2 (flonum->bigfloat +inf.0))
|
|
(define-bf-constant +nan.bf 2 (flonum->bigfloat +nan.0))
|
|
|
|
(define-bf-constant 1.bf 4 (flonum->bigfloat 1.0))
|
|
(define-bf-constant 2.bf 4 (flonum->bigfloat 2.0))
|
|
(define-bf-constant 3.bf 4 (flonum->bigfloat 3.0))
|
|
(define-bf-constant 4.bf 4 (flonum->bigfloat 4.0))
|
|
(define-bf-constant 5.bf 4 (flonum->bigfloat 5.0))
|
|
(define-bf-constant 6.bf 4 (flonum->bigfloat 6.0))
|
|
(define-bf-constant 7.bf 4 (flonum->bigfloat 7.0))
|
|
(define-bf-constant 8.bf 4 (flonum->bigfloat 8.0))
|
|
(define-bf-constant 9.bf 4 (flonum->bigfloat 9.0))
|
|
(define-bf-constant 10.bf 4 (flonum->bigfloat 10.0))
|
|
|
|
(define-bf-constant -1.bf 4 (flonum->bigfloat -1.0))
|
|
(define-bf-constant -2.bf 4 (flonum->bigfloat -2.0))
|
|
(define-bf-constant -3.bf 4 (flonum->bigfloat -3.0))
|
|
(define-bf-constant -4.bf 4 (flonum->bigfloat -4.0))
|
|
(define-bf-constant -5.bf 4 (flonum->bigfloat -5.0))
|
|
(define-bf-constant -6.bf 4 (flonum->bigfloat -6.0))
|
|
(define-bf-constant -7.bf 4 (flonum->bigfloat -7.0))
|
|
(define-bf-constant -8.bf 4 (flonum->bigfloat -8.0))
|
|
(define-bf-constant -9.bf 4 (flonum->bigfloat -9.0))
|
|
(define-bf-constant -10.bf 4 (flonum->bigfloat -10.0))
|
|
|
|
(define-for-syntax 0ary-funs (list))
|
|
(provide (for-syntax 0ary-funs))
|
|
|
|
(define-syntax-rule (provide-0ary-fun name c-name)
|
|
(begin
|
|
(define cfun (get-mpfr-fun c-name (_fun _mpfr-pointer _rnd_t -> _int)))
|
|
(define (name)
|
|
(let ([y (new-mpfr (bf-precision))])
|
|
(cfun y (bf-rounding-mode))
|
|
y))
|
|
(provide name)
|
|
(begin-for-syntax (set! 0ary-funs (cons #'name 0ary-funs)))))
|
|
|
|
(define-syntax-rule (provide-0ary-funs [name c-name] ...)
|
|
(begin (provide-0ary-fun name c-name) ...))
|
|
|
|
(provide-0ary-funs
|
|
[log2.bf 'mpfr_const_log2]
|
|
[pi.bf 'mpfr_const_pi]
|
|
[gamma.bf 'mpfr_const_euler]
|
|
[catalan.bf 'mpfr_const_catalan])
|
|
|
|
(define constant-hash (make-hash))
|
|
|
|
(define (phi.bf)
|
|
(define p (bf-precision))
|
|
(hash-ref!
|
|
constant-hash (cons 'phi.bf p)
|
|
(λ () (bfcopy
|
|
(parameterize ([bf-precision (+ p 10)])
|
|
(bfdiv (bfadd (force 1.bf) (bfsqrt (force 5.bf))) (force 2.bf)))))))
|
|
|
|
(define (epsilon.bf)
|
|
(define p (bf-precision))
|
|
(hash-ref! constant-hash (cons 'epsilon.bf p) (λ () (bfexpt (force 2.bf) (bf (- 1 p))))))
|
|
|
|
(define (-max.bf) (bfnext (bf -inf.0)))
|
|
(define (-min.bf) (bfprev (bf -0.0)))
|
|
(define (+min.bf) (bfnext (bf 0.0)))
|
|
(define (+max.bf) (bfprev (bf +inf.0)))
|
|
|
|
(provide phi.bf epsilon.bf -max.bf -min.bf +min.bf +max.bf)
|
|
(begin-for-syntax
|
|
(set! 0ary-funs (list* #'phi.bf #'epsilon.bf #'-max.bf #'-min.bf #'+min.bf #'+max.bf
|
|
0ary-funs)))
|