compiler: Fix bitand on ratios, floats. Fix shift on ratios, floats. Add integer...

diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
index 55669f06c179ca4f3f9a503eb1e96486aff01ac3..6a829cfa7f14a2f0dda752982c47343d45f145fd 100644 (file)
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@@ -39,7 +39,7 @@ IN: compiler.tree.modular-arithmetic
 ! is a modular arithmetic word, then the input can be converted into
 ! a form that is cheaper to compute.
 {
-    >fixnum bignum>fixnum float>fixnum
+    >fixnum bignum>fixnum integer>fixnum float>fixnum
     set-alien-unsigned-1 set-alien-signed-1
     set-alien-unsigned-2 set-alien-signed-2
 }
@@ -181,7 +181,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
     ] when ;
 
 : like->fixnum? ( #call -- ? )
-    word>> { >fixnum bignum>fixnum float>fixnum } member-eq? ;
+    word>> { >fixnum bignum>fixnum float>fixnum integer>fixnum } member-eq? ;
 
 : like->integer? ( #call -- ? )
     word>> { >integer >bignum fixnum>bignum } member-eq? ;

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 147eeec745cc93fa82f7ad15b867d96b3e5ff1b7..3d263b57547311915c054f51b3e95b437a788ab8 100644 (file)
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -224,6 +224,7 @@ generic-comparison-ops [
 {
     { >fixnum fixnum }
     { bignum>fixnum fixnum }
+    { integer>fixnum fixnum }
 
     { >bignum bignum }
     { fixnum>bignum bignum }

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index d56faf150ede4b8d8b6834b78925f4ba281bbe01..3021bb6398c79d8c693648f394963fc7e50370c2 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -9,7 +9,7 @@ compiler.tree.debugger compiler.tree.checker slots.private words
 hashtables classes assocs locals specialized-arrays system
 sorting math.libm math.floats.private math.integers.private
 math.intervals quotations effects alien alien.data sets
-strings.private vocabs ;
+strings.private vocabs generic.single ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
 SPECIALIZED-ARRAY: void*
@@ -1025,3 +1025,19 @@ M: f derp drop t ;
 [
     [ dup maybe{ integer } instance? [ derp ] when ] { instance? } inlined?
 ] unit-test
+
+! Type-check ratios with bitand operators
+
+: bitand-ratio0 ( x -- y )
+    1 bitand zero? ;
+
+: bitand-ratio1 ( x -- y )
+    1 swap bitand zero? ;
+
+[ 2+1/2 bitand-ratio0 ] [ no-method? ] must-fail-with 
+[ 2+1/2 bitand-ratio1 ] [ no-method? ] must-fail-with
+
+: shift-test0 ( x -- y )
+    4.3 shift ;
+
+[ 1 shift-test0 ] [ no-method? ] must-fail-with

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 5edbc617ff5546af7893f2f5b48b729d941dd47c..2ab4c1a4f7946b34e4fcf6000b71aca023dbf84a 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -95,11 +95,11 @@ IN: compiler.tree.propagation.transforms
             }
             {
                 [ 2dup simplify-bitand? ]
-                [ 2drop [ >fixnum fixnum-bitand ] ]
+                [ 2drop [ integer>fixnum fixnum-bitand ] ]
             }
             {
                 [ 2dup swap simplify-bitand? ]
-                [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
+                [ 2drop [ [ integer>fixnum ] dip fixnum-bitand ] ]
             }
             [ 2drop f ]
         } cond
@@ -114,7 +114,7 @@ IN: compiler.tree.propagation.transforms
     2^? [
         cell-bits tag-bits get - 1 -
         '[
-            >fixnum dup 0 < [ 2drop 0 ] [
+            integer>fixnum dup 0 < [ 2drop 0 ] [
                 dup _ < [ fixnum-shift ] [
                     fixnum-shift
                 ] if
@@ -309,10 +309,17 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
     [ \ push def>> ] [ f ] if
 ] "custom-inlining" set-word-prop
 
+: custom-inline-fixnum ( x -- y )
+    in-d>> first value-info class>> fixnum \ f class-or class<=
+    [ [ dup [ \ >fixnum no-method ] unless ] ] [ f ] if ;
+
 ! Speeds up fasta benchmark
 \ >fixnum [
-    in-d>> first value-info class>> fixnum \ f class-or class<=
-    [ [ dup [ \ >fixnum no-method ] unless ] ] [ f ] if
+    custom-inline-fixnum
+] "custom-inlining" set-word-prop
+
+\ integer>fixnum [
+    custom-inline-fixnum
 ] "custom-inlining" set-word-prop
 
 ! We want to constant-fold calls to heap-size, and recompile those

diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index 56d8fb5abab8a93331e2b0828c5c57fc20238d3c..18281bf88ca0463e2ebe33222fef61aa35b0f26a 100644 (file)
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -15,6 +15,7 @@ M: fixnum >fixnum ; inline
 M: fixnum >bignum fixnum>bignum ; inline
 M: fixnum >integer ; inline
 M: fixnum >float fixnum>float ; inline
+M: fixnum integer>fixnum ; inline
 
 M: fixnum hashcode* nip ; inline
 M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
@@ -45,7 +46,7 @@ M: fixnum /mod fixnum/mod ; inline
 M: fixnum bitand fixnum-bitand ; inline
 M: fixnum bitor fixnum-bitor ; inline
 M: fixnum bitxor fixnum-bitxor ; inline
-M: fixnum shift >fixnum fixnum-shift ; inline
+M: fixnum shift integer>fixnum fixnum-shift ; inline
 
 M: fixnum bitnot fixnum-bitnot ; inline
 
@@ -61,6 +62,7 @@ M: fixnum (log2) fixnum-log2 ; inline
 
 M: bignum >fixnum bignum>fixnum ; inline
 M: bignum >bignum ; inline
+M: bignum integer>fixnum bignum>fixnum ; inline
 
 M: bignum hashcode* nip >fixnum ;
 
@@ -92,7 +94,7 @@ M: bignum /mod bignum/mod ; inline
 M: bignum bitand bignum-bitand ; inline
 M: bignum bitor bignum-bitor ; inline
 M: bignum bitxor bignum-bitxor ; inline
-M: bignum shift >fixnum bignum-shift ; inline
+M: bignum shift integer>fixnum bignum-shift ; inline
 
 M: bignum bitnot bignum-bitnot ; inline
 M: bignum bit? bignum-bit? ; inline

diff --git a/core/math/math.factor b/core/math/math.factor
index 1810cc0ee25a1aae6875439d95890ee81abf61bd..33d58769f72bad0e59e1d695b68345533e683be2 100644 (file)
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -7,6 +7,7 @@ GENERIC: >fixnum ( x -- n ) foldable
 GENERIC: >bignum ( x -- n ) foldable
 GENERIC: >integer ( x -- n ) foldable
 GENERIC: >float ( x -- y ) foldable
+GENERIC: integer>fixnum ( x -- y ) foldable
 
 GENERIC: numerator ( a/b -- a )
 GENERIC: denominator ( a/b -- b )