enable-compiler
+: compile-uncompiled [ compiled? not ] filter compile ;
+
nl
"Compiling..." write flush
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
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 ;
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 ;
[ 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
! 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 ;
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 ;
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 ;
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
GENERIC: bitnot ( x -- y ) foldable
GENERIC# bit? 1 ( x n -- ? ) foldable
+GENERIC: abs ( x -- y ) foldable
+
<PRIVATE
GENERIC: (log2) ( x -- n ) 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
: ?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
-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 ;
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 ;