core: Throw an error when assigning a bignum to a fixnum tuple slot if the bignum...

diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
index 6a829cfa7f14a2f0dda752982c47343d45f145fd..41f1949a661fe28d2b1bb44f33aa306644ee5678 100644 (file)
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@@ -39,7 +39,8 @@ 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 integer>fixnum float>fixnum
+    >fixnum bignum>fixnum integer>fixnum integer>fixnum-strict
+    float>fixnum
     set-alien-unsigned-1 set-alien-signed-1
     set-alien-unsigned-2 set-alien-signed-2
 }
@@ -181,7 +182,10 @@ MEMO: fixnum-coercion ( flags -- nodes )
     ] when ;
 
 : like->fixnum? ( #call -- ? )
-    word>> { >fixnum bignum>fixnum float>fixnum integer>fixnum } member-eq? ;
+    word>> {
+        >fixnum bignum>fixnum float>fixnum
+        integer>fixnum integer>fixnum-strict
+    } member-eq? ;
 
 : like->integer? ( #call -- ? )
     word>> { >integer >bignum fixnum>bignum } member-eq? ;

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 2ab4c1a4f7946b34e4fcf6000b71aca023dbf84a..d1793208aef7409217c1d788d1711d554302d281 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -318,9 +318,9 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
     custom-inline-fixnum
 ] "custom-inlining" set-word-prop
 
-\ integer>fixnum [
-    custom-inline-fixnum
-] "custom-inlining" set-word-prop
+{ integer>fixnum integer>fixnum-strict } [
+    [ custom-inline-fixnum ] "custom-inlining" set-word-prop
+] each
 
 ! We want to constant-fold calls to heap-size, and recompile those
 ! calls when a C type is redefined

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index acbe1a34e9e561c63ef0abad8e16c448fb8d53f7..111b7d9631effb19259c02a6c8bbed9b7a57d780 100755 (executable)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -197,7 +197,7 @@ bi
 "null?" "kernel" vocab-words delete-at
 
 "fixnum" "math" create { } define-builtin
-"fixnum" "math" create "integer>fixnum" "math" create 1quotation "coercer" set-word-prop
+"fixnum" "math" create "integer>fixnum-strict" "math" create 1quotation "coercer" set-word-prop
 
 "bignum" "math" create { } define-builtin
 "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 48a7e8cf0da1798755cf72aa3654a77358409b5e..cc6710993625b4b9a3babe60a6acb95dfa3b1cbf 100644 (file)
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -533,9 +533,17 @@ unit-test
 must-fail-with
 
 ! Check fixnum coercer
-[ 0.0 "hi" declared-types boa n>> ] [ T{ no-method f 0.0 integer>fixnum } = ] must-fail-with
+[ 0.0 "hi" declared-types boa n>> ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
 
-[ declared-types new 0.0 >>n n>> ] [ T{ no-method f 0.0 integer>fixnum } = ] must-fail-with
+[ declared-types new 0.0 >>n n>> ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
+
+[ T{ declared-types f 33333 "asdf" } ]
+[ 33333 >bignum "asdf" declared-types boa ] unit-test
+
+[ 444444444444444444444444444444444444444444444444433333 >bignum "asdf" declared-types boa ]
+[
+    T{ out-of-fixnum-range f 444444444444444444444444444444444444444444444444433333 }
+] must-fail-with
 
 ! Check bignum coercer
 TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
@@ -562,10 +570,10 @@ TUPLE: integer-coercer { n integer } ;
 
 \ foo def>> must-infer
 
-[ 0.0 "hi" foo ] [ T{ no-method f 0.0 integer>fixnum } = ] must-fail-with
+[ 0.0 "hi" foo ] [ T{ no-method f 0.0 integer>fixnum-strict } = ] must-fail-with
 
 [ "hi" 0.0 declared-types boa ]
-[ T{ no-method f "hi" integer>fixnum } = ]
+[ T{ no-method f "hi" integer>fixnum-strict } = ]
 must-fail-with
 
 [ 0 { } declared-types boa ]
@@ -573,7 +581,7 @@ must-fail-with
 must-fail-with
 
 [ "hi" 0.0 foo ]
-[ T{ no-method f "hi" integer>fixnum } = ]
+[ T{ no-method f "hi" integer>fixnum-strict } = ]
 must-fail-with
 
 [ 0 { } foo ]

diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index fa5d9745d688e4b97c98970dfdfb208ad3c43933..8e1aaba22864a3f38a021c20a9088accc11d83be 100644 (file)
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -16,6 +16,7 @@ M: fixnum >bignum fixnum>bignum ; inline
 M: fixnum >integer ; inline
 M: fixnum >float fixnum>float ; inline
 M: fixnum integer>fixnum ; inline
+M: fixnum integer>fixnum-strict ; inline
 
 M: fixnum hashcode* nip ; inline
 M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
@@ -64,6 +65,10 @@ M: bignum >fixnum bignum>fixnum ; inline
 M: bignum >bignum ; inline
 M: bignum integer>fixnum bignum>fixnum ; inline
 
+M: bignum integer>fixnum-strict
+    dup bignum>fixnum
+    2dup number= [ nip ] [ drop out-of-fixnum-range ] if ; inline
+
 M: bignum hashcode* nip bignum>fixnum ;
 
 M: bignum equal?

diff --git a/core/math/math.factor b/core/math/math.factor
index 33d58769f72bad0e59e1d695b68345533e683be2..b86cc9565ce33e80a50e8f1cc6a0f73562cac1e3 100644 (file)
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -8,6 +8,7 @@ GENERIC: >bignum ( x -- n ) foldable
 GENERIC: >integer ( x -- n ) foldable
 GENERIC: >float ( x -- y ) foldable
 GENERIC: integer>fixnum ( x -- y ) foldable
+GENERIC: integer>fixnum-strict ( x -- y ) foldable
 
 GENERIC: numerator ( a/b -- a )
 GENERIC: denominator ( a/b -- b )
@@ -57,6 +58,8 @@ GENERIC: (log2) ( x -- n ) foldable
 
 PRIVATE>
 
+ERROR: out-of-fixnum-range n ;
+
 ERROR: log2-expects-positive x ;
 
 : log2 ( x -- n )