From 08af497255701566e75cc1ea35db58f55f3b9518 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Apr 2008 21:26:31 -0500 Subject: [PATCH] Fix /f for large integers --- core/bootstrap/compiler/compiler.factor | 18 ++++---- core/math/floats/floats.factor | 5 +- core/math/integers/integers-tests.factor | 26 +++++++++++ core/math/integers/integers.factor | 58 +++++++++++++++++++++++- core/math/math.factor | 10 ++-- extra/math/functions/functions.factor | 4 -- extra/math/ratios/ratios.factor | 1 + 7 files changed, 101 insertions(+), 21 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index a19ffe742e..7ad1c6978b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -18,6 +18,8 @@ IN: bootstrap.compiler enable-compiler +: compile-uncompiled [ compiled? not ] filter compile ; + nl "Compiling..." write flush @@ -42,38 +44,38 @@ nl find-pair-next namestack* bitand bitor bitxor bitnot -} compile +} compile-uncompiled "." write flush { - + 1+ 1- 2/ < <= > >= shift min -} compile + + 1+ 1- 2/ < <= > >= shift +} compile-uncompiled "." write flush { new-sequence nth push pop peek -} compile +} compile-uncompiled "." write flush { hashcode* = get set -} compile +} compile-uncompiled "." write flush { . lines -} compile +} compile-uncompiled "." write flush { malloc calloc free memcpy -} compile +} compile-uncompiled -vocabs [ words [ compiled? not ] filter compile "." write flush ] each +vocabs [ words compile-uncompiled "." write flush ] each " done" print flush diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 30abd9cad6..5cd6f067a9 100755 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -6,8 +6,6 @@ IN: math.floats.private M: fixnum >float fixnum>float ; M: bignum >float bignum>float ; -M: float zero? dup 0.0 float= swap -0.0 float= or ; - M: float >fixnum float>fixnum ; M: float >bignum float>bignum ; M: float >float ; @@ -22,4 +20,7 @@ M: float + float+ ; M: float - float- ; M: float * float* ; M: float / float/f ; +M: float /f float/f ; M: float mod float-mod ; + +M: real abs dup 0 < [ neg ] when ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index fe8e5bddc8..93567ee71a 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -191,3 +191,29 @@ unit-test [ f ] [ -128 power-of-2? ] unit-test [ f ] [ 0 power-of-2? ] unit-test [ t ] [ 1 power-of-2? ] unit-test + +[ 5. ] [ 5 1 ratio>float ] unit-test +[ 4. ] [ 4 1 ratio>float ] unit-test +[ 2. ] [ 2 1 ratio>float ] unit-test +[ .5 ] [ 1 2 ratio>float ] unit-test +[ .75 ] [ 3 4 ratio>float ] unit-test +[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test +[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test +[ 0.4 ] [ 6 15 ratio>float ] unit-test + +[ HEX: 3fe553522d230931 ] +[ 61967020039 92984792073 ratio>float double>bits ] unit-test + +: random-integer + 32 random-bits + 1 random zero? [ neg ] when + 1 random zero? [ >bignum ] when ; + +[ t ] [ + 1000 [ + drop + random-integer + random-integer + [ >float / ] [ ratio>float ] 2bi 0.1 ~ + ] all? +] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 70a6d2e087..60b32140f7 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -1,4 +1,5 @@ ! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2008, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math math.private combinators ; @@ -22,6 +23,8 @@ M: fixnum + fixnum+ ; M: fixnum - fixnum- ; M: fixnum * fixnum* ; M: fixnum /i fixnum/i ; +M: fixnum /f >r >float r> >float float/f ; + M: fixnum mod fixnum-mod ; M: fixnum /mod fixnum/mod ; @@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ; M: bignum bit? bignum-bit? ; M: bignum (log2) bignum-log2 ; -M: integer zero? 0 number= ; +! Converting ratios to floats. Based on FLOAT-RATIO from +! sbcl/src/code/float.lisp, which has the following license: + +! "The software is in the public domain and is +! provided with absolutely no warranty." + +! First step: pre-scaling +: twos ( x -- y ) dup 1- bitxor log2 ; inline + +: scale-denonimator ( den -- scaled-den scale' ) + dup twos neg [ shift ] keep ; inline + +: pre-scale ( num den -- scale shifted-num scaled-den ) + 2dup [ log2 ] bi@ - + tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi* + -rot ; inline + +! Second step: loop +: shift-mantissa ( scale mantissa -- scale' mantissa' ) + [ 1+ ] [ 2/ ] bi* ; inline + +: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) + [ 2dup /i log2 53 > ] + [ >r shift-mantissa r> ] + [ ] while /mod ; inline + +! Third step: post-scaling +: unscaled-float ( mantissa -- n ) + 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline + +: scale-float ( scale mantissa -- float' ) + >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline + +: post-scale ( scale mantissa -- n ) + 2/ dup log2 52 > [ shift-mantissa ] when + unscaled-float scale-float ; inline + +! Main word +: /f-abs ( m n -- f ) + over zero? [ + 2drop 0 >float + ] [ + dup zero? [ + 2drop 1 >float 0 >float / + ] [ + pre-scale + /f-loop over odd? + [ zero? [ 1+ ] unless ] [ drop ] if + post-scale + ] if + ] if ; inline + +M: bignum /f ( m n -- f ) + [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; diff --git a/core/math/math.factor b/core/math/math.factor index a35e4926bc..d5040757d4 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -21,6 +21,7 @@ MATH: + ( x y -- z ) foldable MATH: - ( x y -- z ) foldable MATH: * ( x y -- z ) foldable MATH: / ( x y -- z ) foldable +MATH: /f ( x y -- z ) foldable MATH: /i ( x y -- z ) foldable MATH: mod ( x y -- z ) foldable @@ -33,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable GENERIC: bitnot ( x -- y ) foldable GENERIC# bit? 1 ( x n -- ? ) foldable +GENERIC: abs ( x -- y ) foldable + (log2) ] if ; foldable -GENERIC: zero? ( x -- ? ) foldable - -M: object zero? drop f ; - +: zero? ( x -- ? ) 0 number= ; inline : 1+ ( x -- y ) 1 + ; inline : 1- ( x -- y ) 1 - ; inline : 2/ ( x -- y ) -1 shift ; inline @@ -60,8 +60,6 @@ M: object zero? drop f ; : ?1+ [ 1+ ] [ 0 ] if* ; inline -: /f ( x y -- z ) >r >float r> >float float/f ; inline - : rem ( x y -- z ) tuck mod over + swap mod ; foldable : 2^ ( n -- 2^n ) 1 swap shift ; inline diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 481b58bb92..bce93fbb11 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -80,10 +80,6 @@ M: integer (^) -rot (^mod) ] if ; foldable -GENERIC: abs ( x -- y ) foldable - -M: real abs dup 0 < [ neg ] when ; - GENERIC: absq ( x -- y ) foldable M: real absq sq ; diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 3c430111ff..43cbc3fc10 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -47,5 +47,6 @@ M: ratio - 2dup scale - -rot ratio+d / ; M: ratio * 2>fraction * >r * r> / ; M: ratio / scale / ; M: ratio /i scale /i ; +M: ratio /f scale /f ; M: ratio mod 2dup >r >r /i r> r> rot * - ; M: ratio /mod [ /i ] 2keep mod ;