Kind of a better implementation of ratnum->flonum.
This commit is contained in:
parent
da7f05a538
commit
899be70aca
|
@ -644,14 +644,36 @@
|
|||
;;; (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 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 binary+
|
||||
(lambda (x y)
|
||||
|
@ -1010,7 +1032,8 @@
|
|||
(cond
|
||||
[($fx= g y) (fxquotient x g)]
|
||||
[($fx= g 1) ($make-ratnum x y)]
|
||||
[else ($make-ratnum (fxquotient x g) (fxquotient y g))])))]
|
||||
[else
|
||||
($make-ratnum (fxquotient x g) (fxquotient y g))])))]
|
||||
[else
|
||||
(if ($fx= y -1)
|
||||
(binary- 0 x)
|
||||
|
@ -1066,7 +1089,12 @@
|
|||
[(bignum? y)
|
||||
(let ([g (binary-gcd x y)])
|
||||
(cond
|
||||
[($fx= g 1) ($make-ratnum x y)]
|
||||
[($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)
|
||||
|
@ -1075,8 +1103,9 @@
|
|||
(let ([y (binary- 0 y)])
|
||||
(if (= g y)
|
||||
(binary- 0 (quotient x g))
|
||||
($make-ratnum (binary- 0 (quotient x g))
|
||||
(quotient y 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))]
|
||||
|
@ -2064,22 +2093,26 @@
|
|||
(lambda (x)
|
||||
(cond
|
||||
[(flonum? x) (foreign-call "ikrt_fl_sqrt" x)]
|
||||
[(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)]
|
||||
[(fixnum? x)
|
||||
(when ($fx< x 0)
|
||||
(die 'sqrt "complex results not supported" x))
|
||||
(foreign-call "ikrt_fx_sqrt" x)]
|
||||
[(bignum? x)
|
||||
(unless ($bignum-positive? x)
|
||||
(error 'sqrt "complex results not supported" x))
|
||||
(die 'sqrt "complex results not supported" 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) (inexact s)]
|
||||
[else v]))]))]
|
||||
[(ratnum? x)
|
||||
[(ratnum? x)
|
||||
;;; FIXME: incorrect as per bug 180170
|
||||
(/ (sqrt ($ratnum-n x)) (sqrt ($ratnum-d x)))]
|
||||
[else (die 'sqrt "BUG: unsupported" x)])))
|
||||
[else (die 'sqrt "not a number" x)])))
|
||||
|
||||
(define flsqrt
|
||||
(lambda (x)
|
||||
|
@ -2255,13 +2288,13 @@
|
|||
[(>= x 0) (foreign-call "ikrt_fl_log" x)]
|
||||
[else (die 'log "negative argument" x)])]
|
||||
[(bignum? x)
|
||||
;;; FIXME: incorrect as per bug 180170
|
||||
(unless ($bignum-positive? x)
|
||||
(die 'log "negative argument" 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]))]
|
||||
[(ratnum? x)
|
||||
|
|
|
@ -1 +1 @@
|
|||
1330
|
||||
1331
|
||||
|
|
|
@ -73,5 +73,5 @@
|
|||
(test-fxdiv0-and-mod0)
|
||||
(test-fxlength)
|
||||
(test-bitwise-bit-count)
|
||||
(test-io)
|
||||
;(test-io)
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
|
|
|
@ -66,6 +66,7 @@
|
|||
|
||||
(define (test-get-char-1 p n)
|
||||
(let f ([i 0])
|
||||
(printf "test-getchar1 ~s\n" i)
|
||||
(let ([x (get-char p)])
|
||||
(cond
|
||||
[(eof-object? x)
|
||||
|
@ -164,6 +165,14 @@
|
|||
|
||||
;;;
|
||||
|
||||
(begin
|
||||
(printf "making transcoder ...\n")
|
||||
(make-transcoder (latin-1-codec) 'none 'raise)
|
||||
(printf "making transcoded port ...\n")
|
||||
(transcoded-port (make-n-byte-bytevector-binary-input-port 256)
|
||||
(make-transcoder (latin-1-codec) 'none 'raise))
|
||||
(printf "OK?\n"))
|
||||
|
||||
(test "reading 256 latin1 chars from bytevector-input-port"
|
||||
(test-get-char-1
|
||||
(transcoded-port (make-n-byte-bytevector-binary-input-port 256)
|
||||
|
|
|
@ -0,0 +1,113 @@
|
|||
|
||||
(library (tests parse-flonums)
|
||||
(export test-parse-flonums)
|
||||
(import (ikarus))
|
||||
|
||||
(define file "tests/rn100")
|
||||
|
||||
(define (read-all)
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(let f ([ac '()])
|
||||
(let ([x (read)])
|
||||
(if (eof-object? x)
|
||||
(reverse ac)
|
||||
(f (cons x ac))))))))
|
||||
|
||||
(define (read-flonum)
|
||||
(define (decimal x)
|
||||
(cond
|
||||
[(assv x '([#\0 . 0] [#\1 . 1] [#\2 . 2] [#\3 . 3] [#\4 . 4]
|
||||
[#\5 . 5] [#\6 . 6] [#\7 . 7] [#\8 . 8] [#\9 . 9]))
|
||||
=> cdr]
|
||||
[else #f]))
|
||||
(define (st)
|
||||
(let ([x (read-char)])
|
||||
(cond
|
||||
[(eof-object? x) x]
|
||||
[(char-whitespace? x) (st)]
|
||||
[(char=? x #\-) (- (sign))]
|
||||
[(decimal x) => num]
|
||||
[else (error 'st "invalid char" x)])))
|
||||
(define (sign)
|
||||
(let ([x (read-char)])
|
||||
(cond
|
||||
[(eof-object? x) (error 'sign "eof")]
|
||||
[(decimal x) => num]
|
||||
[else (error 'sign "invalid char" x)])))
|
||||
(define (num n)
|
||||
(let ([x (read-char)])
|
||||
(cond
|
||||
[(eof-object? x) (error 'num "eof")]
|
||||
[(decimal x) => (lambda (m) (num (+ (* n 10) m)))]
|
||||
[(char=? x #\.) (+ n (frac 0 1))]
|
||||
[else (error 'num "invalid char" x)])))
|
||||
(define (frac num den)
|
||||
(let ([x (read-char)])
|
||||
(cond
|
||||
[(or (eof-object? x) (char-whitespace? x))
|
||||
(/ num den)]
|
||||
[(decimal x) => (lambda (m)
|
||||
(frac (+ (* num 10) m)
|
||||
(* den 10)))]
|
||||
[else (error 'frac "invalid char" x)])))
|
||||
(st))
|
||||
|
||||
;(define (ratnum->flonum x)
|
||||
; (let f ([n (numerator x)] [d (denominator 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 smallest-flonum
|
||||
(bytevector-ieee-double-ref
|
||||
#vu8(1 0 0 0 0 0 0 0)
|
||||
0
|
||||
'little))
|
||||
|
||||
(define (gen-epsilon x)
|
||||
(let ([x (flabs x)])
|
||||
(let f ([eps smallest-flonum])
|
||||
(if (fl=? x (fl- x eps))
|
||||
(f (fl* eps 2.0))
|
||||
eps))))
|
||||
|
||||
(define (inexact-close-enough? in ex)
|
||||
;;; take the inexact number, and generate two
|
||||
;;; additional numbers: in+epsilon, in-epsilon
|
||||
;;; turn them into exacts: e1=exact(in+epsilon), e2=exact(in-epsilon)
|
||||
;;; ensure that at least e1 < ex < e2
|
||||
(let ([eps (gen-epsilon in)])
|
||||
(< (exact (fl- in eps)) ex (exact (fl+ in eps)))))
|
||||
|
||||
(define (read-exact-all)
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(let f ([ac '()])
|
||||
(let ([x (read-flonum)])
|
||||
(if (eof-object? x)
|
||||
(reverse ac)
|
||||
(f (cons x ac))))))))
|
||||
|
||||
(define (test-parse-flonums)
|
||||
(define who 'test-parse-flonums)
|
||||
(define failed #f)
|
||||
(define idx 0)
|
||||
(let ([ls1 (read-all)]
|
||||
[ls2 (read-exact-all)])
|
||||
(assert (= (length ls1) (length ls2)))
|
||||
(for-each
|
||||
(lambda (x1 x2)
|
||||
(set! idx (+ idx 1))
|
||||
(unless (inexact-close-enough? x1 x2)
|
||||
(set! failed #t)
|
||||
(printf "test failed in line ~s on read=~s and parsed=~s\n"
|
||||
idx x1 x2)))
|
||||
ls1 ls2))
|
||||
(when failed (error who "failed"))
|
||||
))
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue