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

* Added fldiv, flmod, and fldiv-and-mod

This commit is contained in:
Abdulaziz Ghuloum 2007-11-11 16:48:03 -05:00
parent 564908d55d
commit 05fef19307
7 changed files with 172 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -185,8 +185,6 @@ top_srcdir = .
AUTOMAKE_OPTIONS = foreign AUTOMAKE_OPTIONS = foreign
SUBDIRS = src scheme doc SUBDIRS = src scheme doc
EXTRA_DIST = README COPYING GPL-3 EXTRA_DIST = README COPYING GPL-3
#datarootdir=${prefix}/share
#docdir=${datarootdir}/doc/${PACKAGE}
dist_doc_DATA = README COPYING GPL-3 dist_doc_DATA = README COPYING GPL-3
all: config.h all: config.h
$(MAKE) $(AM_MAKEFLAGS) all-recursive $(MAKE) $(AM_MAKEFLAGS) all-recursive

2
Makefile.in
View File

@ -185,8 +185,6 @@ top_srcdir = @top_srcdir@
AUTOMAKE_OPTIONS = foreign AUTOMAKE_OPTIONS = foreign
SUBDIRS = src scheme doc SUBDIRS = src scheme doc
EXTRA_DIST = README COPYING GPL-3 EXTRA_DIST = README COPYING GPL-3
#datarootdir=${prefix}/share
#docdir=${datarootdir}/doc/${PACKAGE}
dist_doc_DATA = README COPYING GPL-3 dist_doc_DATA = README COPYING GPL-3
all: config.h all: config.h
$(MAKE) $(AM_MAKEFLAGS) all-recursive $(MAKE) $(AM_MAKEFLAGS) all-recursive

143
scheme/ikarus.numerics.ss
View File

@ -81,32 +81,76 @@
(define ($flonum-signed-biased-exponent x) (define ($flonum-signed-biased-exponent x)
(let ([b0 ($flonum-u8-ref x 0)] (let ([b0 ($flonum-u8-ref x 0)]
[b1 ($flonum-u8-ref x 1)]) [b1 ($flonum-u8-ref x 1)])
(fxlogor (fxsll b0 4) (fxsra b1 4)))) ($fxlogor ($fxsll b0 4) ($fxsra b1 4))))
(define ($flonum-rational? x) (define ($flonum-rational? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be ($fxlogand ($flonum-signed-biased-exponent x)
(fx< be 2047))) ($fxsub1 ($fxsll 1 11)))])
($fx< be 2047)))
(define ($flonum-integer? x) (define ($flonum-integer? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be ($fxlogand ($flonum-signed-biased-exponent x)
($fxsub1 ($fxsll 1 11)))])
(cond (cond
[(fx= be 2047) ;;; nans and infs [($fx= be 2047) ;;; nans and infs
#f] #f]
[(fx>= be 1075) ;;; magnitue large enough [($fx>= be 1075) ;;; magnitue large enough
#t] #t]
[(fx= be 0) ;;; denormalized double, only +/-0.0 is integer [($fx= be 0) ;;; denormalized double, only +/-0.0 is integer
(and (fx= ($flonum-u8-ref x 7) 0) (and ($fx= ($flonum-u8-ref x 7) 0)
(fx= ($flonum-u8-ref x 6) 0) ($fx= ($flonum-u8-ref x 6) 0)
(fx= ($flonum-u8-ref x 5) 0) ($fx= ($flonum-u8-ref x 5) 0)
(fx= ($flonum-u8-ref x 4) 0) ($fx= ($flonum-u8-ref x 4) 0)
(fx= ($flonum-u8-ref x 3) 0) ($fx= ($flonum-u8-ref x 3) 0)
(fx= ($flonum-u8-ref x 2) 0) ($fx= ($flonum-u8-ref x 2) 0)
(fx= ($flonum-u8-ref x 1) 0))] ($fx= ($flonum-u8-ref x 1) 0))]
[(fx< be (fx+ 1075 -52)) ;;; too small to be an integer [($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer
#f] #f]
[else [else
(let ([v ($flonum->exact x)]) (let ([v ($flonum->exact x)])
(or (fixnum? v) (bignum? v)))]))) (or (fixnum? v) (bignum? v)))])))
;;;X (define ($fltruncate x)
;;;X ;(define bv
;;;X ; '#vu8(127 255 255 255 63 255 255 255 31 255 255 255 15 255 255 255
;;;X ; 7 255 255 255 3 255 255 255 1 255 255 255 0 255 255 255
;;;X ; 0 127 255 255 0 63 255 255 0 31 255 255 0 15 255 255
;;;X ; 0 7 255 255 0 3 255 255 0 1 255 255 0 0 255 255
;;;X ; 0 0 127 255 0 0 63 255 0 0 31 255 0 0 15 255
;;;X ; 0 0 7 255 0 0 3 255 0 0 1 255 0 0 0 255
;;;X ; 0 0 0 127 0 0 0 63 0 0 0 31 0 0 0 15
;;;X ; 0 0 0 7 0 0 0 3 0 0 0 1 0 0 0 0))
;;;X ;(define bv
;;;X ; '#vu8(255 255 255 255 255 255 255 255 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 254 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 252 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 248 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 240 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 224 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 192 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 128 0 0 0 0 0 0 0 0
;;;X
;;;X (let ([sbe ($flonum-signed-biased-exponent x)])
;;;X (let ([be ($fxlogand sbe ($fxsub1 ($fxsll 1 11)))])
;;;X (cond
;;;X [($fx= be 2047) ;;; nans and infs
;;;X x]
;;;X [($fx>= be 1075) ;;; magnitue large enough
;;;X x]
;;;X [($fx= be 0) ;;; denormalized double
;;;X (if ($fxzero? sbe) 0.0 -0.0)]
;;;X [($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer
;;;X (if ($fxzero? ($fxlogand sbe ($fxsll 1 11))) 0.0 -0.0)]
;;;X [else
;;;X (let ([v ($make-flonum)])
;;;X
;;;X
;;;X (let ([v ($flonum->exact x)])
;;;X (or (fixnum? v) (bignum? v)))]))))
;;;X
(define (flnumerator x) (define (flnumerator x)
(unless (flonum? x) (unless (flonum? x)
@ -2036,21 +2080,12 @@
[else [else
(if (even? q) q (- q 1))]))))))) (if (even? q) q (- q 1))])))))))
(define ($ratnum-truncate x) (define ($ratnum-truncate x)
(let ([n ($ratnum-n x)] [d ($ratnum-d x)]) (let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(quotient n d))) (quotient n d)))
;(define ($flround x)
; (foreign-call "ikrt_fl_round" x ($make-flonum)))
; (let ([e ($flonum->exact x)])
; (cond
; [(not e) x] ;;; infs and nans round to themselves
; [(ratnum? e) (exact->inexact ($ratnum-round e))]
; [else (exact->inexact e)])))
(define (flround x) (define (flround x)
;;; FIXME: flround should preserve the sign of -0.0.
(if (flonum? x) (if (flonum? x)
(let ([e ($flonum->exact x)]) (let ([e ($flonum->exact x)])
(cond (cond
@ -2059,6 +2094,7 @@
(error 'flround "not a flonum" x))) (error 'flround "not a flonum" x)))
(define (round x) (define (round x)
;;; FIXME: flround should preserve the sign of -0.0.
(cond (cond
[(flonum? x) [(flonum? x)
(let ([e (or ($flonum->exact x) (let ([e (or ($flonum->exact x)
@ -2071,6 +2107,7 @@
[else (error 'round "not a number" x)])) [else (error 'round "not a number" x)]))
(define (truncate x) (define (truncate x)
;;; FIXME: fltruncate should preserve the sign of -0.0.
(cond (cond
[(flonum? x) [(flonum? x)
(let ([e (or ($flonum->exact x) (let ([e (or ($flonum->exact x)
@ -2082,7 +2119,9 @@
[(or (fixnum? x) (bignum? x)) x] [(or (fixnum? x) (bignum? x)) x]
[else (error 'truncate "not a number" x)])) [else (error 'truncate "not a number" x)]))
(define (fltruncate x) (define (fltruncate x)
;;; FIXME: fltruncate should preserve the sign of -0.0.
(unless (flonum? x) (unless (flonum? x)
(error 'fltruncate "not a flonum" x)) (error 'fltruncate "not a flonum" x))
(let ([v ($flonum->exact x)]) (let ([v ($flonum->exact x)])
@ -2698,3 +2737,57 @@
m))) m)))
(library (ikarus flonums div-and-mod)
(export fldiv flmod fldiv-and-mod)
(import
(ikarus system $flonums)
(ikarus system $fx)
(except (ikarus) fldiv flmod fldiv-and-mod))
(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)
(error 'fldiv "not a flonum" m))
(error 'fldiv "not a flonum" n)))
(define (flmod n m)
(if (flonum? n)
(if (flonum? m)
($flmod n m)
(error 'flmod "not a flonum" m))
(error 'flmod "not a flonum" n)))
(define (fldiv-and-mod n m)
(if (flonum? n)
(if (flonum? m)
($fldiv-and-mod n m)
(error 'fldiv-and-mod "not a flonum" m))
(error 'fldiv-and-mod "not a flonum" n))))

6
scheme/makefile.ss
View File

@ -826,8 +826,8 @@
[flceiling i r fl] [flceiling i r fl]
[flcos i r fl] [flcos i r fl]
[fldenominator i r fl] [fldenominator i r fl]
[fldiv r fl] [fldiv i r fl]
[fldiv-and-mod r fl] [fldiv-and-mod i r fl]
[fldiv0 r fl] [fldiv0 r fl]
[fldiv0-and-mod0 r fl] [fldiv0-and-mod0 r fl]
[fleven? i r fl] [fleven? i r fl]
@ -840,7 +840,7 @@
[fllog i r fl] [fllog i r fl]
[flmax i r fl] [flmax i r fl]
[flmin i r fl] [flmin i r fl]
[flmod r fl] [flmod i r fl]
[flmod0 r fl] [flmod0 r fl]
[flnan? i r fl] [flnan? i r fl]
[flnegative? i r fl] [flnegative? i r fl]

2
scheme/run-tests.ss
View File

@ -28,6 +28,7 @@
(tests bignum-to-flonum) (tests bignum-to-flonum)
(tests string-to-number) (tests string-to-number)
(tests input-ports) (tests input-ports)
(tests fldiv-and-mod)
) )
(define (test-exact-integer-sqrt) (define (test-exact-integer-sqrt)
@ -57,4 +58,5 @@
(test-hashtables) (test-hashtables)
(test-input-ports) (test-input-ports)
(test-bignum-conversion) (test-bignum-conversion)
(test-fldiv-and-mod)
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

46
scheme/tests/fldiv-and-mod.ss Executable file
View File

@ -0,0 +1,46 @@
(library (tests fldiv-and-mod)
(export test-fldiv-and-mod)
(import (ikarus))
(define (test x1 x2 verify?)
(let-values ([(d m) (fldiv-and-mod x1 x2)])
(printf "(fldiv-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(when verify?
(assert (= d (fldiv x1 x2)))
(assert (= m (flmod x1 x2)))
(assert (<= 0.0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m))))))
(define (test-fldiv-and-mod)
(test +17.0 +3.0 #t)
(test +17.0 -3.0 #t)
(test -17.0 +3.0 #t)
(test -17.0 -3.0 #t)
(test +16.0 +3.0 #t)
(test +16.0 -3.0 #t)
(test -16.0 +3.0 #t)
(test -16.0 -3.0 #t)
(test +15.0 +3.0 #t)
(test +15.0 -3.0 #t)
(test -15.0 +3.0 #t)
(test -15.0 -3.0 #t)
(test +17.0 +3.5 #t)
(test +17.0 -3.5 #t)
(test -17.0 +3.5 #t)
(test -17.0 -3.5 #t)
(test +16.0 +3.5 #t)
(test +16.0 -3.5 #t)
(test -16.0 +3.5 #t)
(test -16.0 -3.5 #t)
(test +15.0 +3.5 #t)
(test +15.0 -3.5 #t)
(test -15.0 +3.5 #t)
(test -15.0 -3.5 #t)
(test +17.0 +nan.0 #f)
(test -17.0 +nan.0 #f)
(test +17.0 +inf.0 #f)
(test +17.0 -inf.0 #f)
(test -17.0 +inf.0 #f)
(test -17.0 -inf.0 #f)))

6
scheme/todo-r6rs.ss
View File

@ -332,8 +332,8 @@
[flceiling C fl] [flceiling C fl]
[flcos C fl] [flcos C fl]
[fldenominator C fl] [fldenominator C fl]
[fldiv S fl] [fldiv C fl]
[fldiv-and-mod S fl] [fldiv-and-mod C fl]
[fldiv0 S fl] [fldiv0 S fl]
[fldiv0-and-mod0 S fl] [fldiv0-and-mod0 S fl]
[fleven? C fl] [fleven? C fl]
@ -346,7 +346,7 @@
[fllog C fl] [fllog C fl]
[flmax C fl] [flmax C fl]
[flmin C fl] [flmin C fl]
[flmod S fl] [flmod C fl]
[flmod0 S fl] [flmod0 S fl]
[flnan? C fl] [flnan? C fl]
[flnegative? C fl] [flnegative? C fl]