1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! Copyright (C) 2008, Doug Coleman.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: kernel kernel.private sequences
5 sequences.private math math.private combinators ;
6 IN: math.integers.private
9 M: integer denominator drop 1 ;
12 M: fixnum >bignum fixnum>bignum ;
15 M: fixnum hashcode* nip ;
16 M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
17 M: fixnum number= eq? ;
20 M: fixnum <= fixnum<= ;
22 M: fixnum >= fixnum>= ;
27 M: fixnum /i fixnum/i ;
28 M: fixnum /f [ >float ] dip >float float/f ;
30 M: fixnum mod fixnum-mod ;
32 M: fixnum /mod fixnum/mod ;
34 M: fixnum bitand fixnum-bitand ;
35 M: fixnum bitor fixnum-bitor ;
36 M: fixnum bitxor fixnum-bitxor ;
37 M: fixnum shift >fixnum fixnum-shift ;
39 M: fixnum bitnot fixnum-bitnot ;
41 M: fixnum bit? neg shift 1 bitand 0 > ;
43 : fixnum-log2 ( x -- n )
44 0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ;
46 M: fixnum (log2) fixnum-log2 ;
48 M: integer next-power-of-2
49 dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ;
51 M: bignum >fixnum bignum>fixnum ;
54 M: bignum hashcode* nip >fixnum ;
57 over bignum? [ bignum= ] [
58 swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
61 M: bignum number= bignum= ;
64 M: bignum <= bignum<= ;
66 M: bignum >= bignum>= ;
71 M: bignum /i bignum/i ;
72 M: bignum mod bignum-mod ;
74 M: bignum /mod bignum/mod ;
76 M: bignum bitand bignum-bitand ;
77 M: bignum bitor bignum-bitor ;
78 M: bignum bitxor bignum-bitxor ;
79 M: bignum shift bignum-shift ;
81 M: bignum bitnot bignum-bitnot ;
82 M: bignum bit? bignum-bit? ;
83 M: bignum (log2) bignum-log2 ;
85 ! Converting ratios to floats. Based on FLOAT-RATIO from
86 ! sbcl/src/code/float.lisp, which has the following license:
88 ! "The software is in the public domain and is
89 ! provided with absolutely no warranty."
91 ! First step: pre-scaling
92 : twos ( x -- y ) dup 1- bitxor log2 ; inline
94 : scale-denonimator ( den -- scaled-den scale' )
95 dup twos neg [ shift ] keep ; inline
97 : pre-scale ( num den -- scale shifted-num scaled-den )
99 tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
103 : shift-mantissa ( scale mantissa -- scale' mantissa' )
104 [ 1+ ] [ 2/ ] bi* ; inline
106 : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
107 [ 2dup /i log2 53 > ]
108 [ [ shift-mantissa ] dip ]
109 [ ] while /mod ; inline
111 ! Third step: post-scaling
112 : unscaled-float ( mantissa -- n )
113 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
115 : scale-float ( scale mantissa -- float' )
116 [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
118 : post-scale ( scale mantissa -- n )
119 2/ dup log2 52 > [ shift-mantissa ] when
120 unscaled-float scale-float ; inline
123 : /f-abs ( m n -- f )
132 [ zero? [ 1+ ] unless ] [ drop ] if
137 M: bignum /f ( m n -- f )
138 [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;