conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added rationalize

This commit is contained in:
Abdulaziz Ghuloum 2007-09-12 00:57:04 -04:00
parent 2eaaa77615
commit 9d8ceef99f
7 changed files with 130 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

2
src/ikarus.intel-assembler.ss
View File

@ -763,6 +763,8 @@
[(jnle dst) (conditional-jump #x8F dst ac)]
[(jne dst) (conditional-jump #x85 dst ac)]
[(jo dst) (conditional-jump #x80 dst ac)]
[(jp dst) (conditional-jump #x8A dst ac)]
[(jnp dst) (conditional-jump #x8B dst ac)]
[(byte x)
(unless (byte? x) (error who "~s is not a byte" x))
(cons (byte x) ac)]

61
src/ikarus.numerics.ss
View File

@ -2307,14 +2307,67 @@
;;; Gee! nans have no sign!
"+nan.0")]
[else (error 'flonum->string "cannot happen")]))))
;;;
(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)]))
(error 'string->flonum "~s is 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 1]))
(define (simplest^ n d n^ d^)
(let-values ([(q r) (quotient+remainder n d)])
(if (= r 0)
q
(let-values ([(q^ r^) (quotient+remainder 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) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])
(cond
[(flonum? eps)
(if (flfinite? eps) x +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
x]
[else (error who "~s is not a number" eps)]))]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])]
[else (error who "~s is not a number" x)])))

17
src/libaltcogen.ss
View File

@ -2604,8 +2604,10 @@
(cond
[(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]
[u< u>=] [u<= u>] [u> u<=] [u>= u<]
[fl:= fl:!=] [fl:!= fl:=]
[fl:< fl:>=] [fl:<= fl:>] [fl:> fl:<=] [fl:>= fl:<]))
[fl:= fl:o!=] [fl:!= fl:o=]
[fl:< fl:o>=] [fl:<= fl:o>]
[fl:> fl:o<=] [fl:>= fl:o<]
))
=> cadr]
[else (error who "invalid notop ~s" x)]))
(define (jmpname x)
@ -2613,7 +2615,10 @@
[(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
[u< jb] [u<= jbe] [u> ja] [u>= jae]
[fl:= je] [fl:!= jne]
[fl:< jb] [fl:> ja] [fl:<= jbe] [fl:>= jae]))
[fl:< jb] [fl:> ja] [fl:<= jbe] [fl:>= jae]
[fl:o= je] [fl:o!= jne]
[fl:o< jb] [fl:o> ja] [fl:o<= jbe] [fl:o>= jae]
))
=> cadr]
[else (error who "invalid jmpname ~s" x)]))
(define (revjmpname x)
@ -2626,6 +2631,12 @@
(cond
[(memq op '(fl:= fl:!= fl:< fl:<= fl:> fl:>=))
(cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
`(,(jmpname op) ,lab)
;;; BOGUS!
ac)]
[(memq op '(fl:o= fl:o!= fl:o< fl:o<= fl:o> fl:o>=))
(cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
`(jp ,lab)
`(,(jmpname op) ,lab)
ac)]
[(or (symbol? a0) (constant? a1))

1
src/makefile.ss
View File

@ -551,6 +551,7 @@
[fixnum->flonum i r]
[exact i r]
[inexact i r]
[rationalize i]
[random i]
[symbol? i r symbols]
[symbol=? i r symbols]

87
src/rationalize.ss
View File

@ -4,46 +4,69 @@
#;
(define (rationalize x eps)
(simplest (- x eps) (+ x eps)))
(define (simplest x y)
(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 1]))
(define (simplest^ n d n^ d^)
(let-values ([(q r) (quotient+remainder n d)])
(if (= r 0)
q
(let-values ([(q^ r^) (quotient+remainder 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
[(< 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 1]))
[(flonum? x)
(if (flfinite? x)
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])
(cond
[(flonum? eps)
(if (flfinite? eps) x +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
x]
[else (error who "~s is not a number" eps)]))]
[(or (fixnum? x) (bignum? x) (ratnum? x))
(cond
[(flonum? eps)
(if (flfinite? eps) (go x eps) +nan.0)]
[(or (fixnum? eps) (bignum? eps) (ratnum? eps))
(go x eps)]
[else (error who "~s is not a number" eps)])]
[else (error who "~s is not a number" x)]))
(define (simplest^ n d n^ d^)
(let-values ([(q r) (quotient+remainder n d)])
(if (= r 0)
q
(let-values ([(q^ r^) (quotient+remainder 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 (test v0 v1 r)
(let ([s (rationalize v0 v1)])
(unless (= s r)
(let ([s (time (rationalize v0 v1))])
(unless (or (= s r) (and (flnan? s) (flnan? r)))
(error 'test "failed in ~s ~s => ~s, should be ~s"
v0 v1 s r))))
(test 314/100 1/100 22/7)
(test (exact 0.3) 1/10 1/3)
(test 0.3 1/10 #i1/3)
(test (/ 1.0 0.0) 3 (/ 1.0 0.0))
;;; dead
(test (/ 1.0 0.0) (/ 1.0 0.0) (/ (/ 0.0 0.0) (/ 1.0 0.0)))
(test #e0.3 1/10 1/3)
(test 0.3 1/10 #i1/3)
(test +inf.0 3 +inf.0)
(test +inf.0 +inf.0 +nan.0)

2
src/todo-r6rs.ss
View File

@ -192,7 +192,7 @@
[procedure? C ba se]
[rational-valued? S ba]
[rational? C ba se]
[rationalize S ba se]
[rationalize C ba se]
[real-part D ba se]
[real-valued? S ba]
[real? C ba se]