core: Throw an error when assigning a bignum to a fixnum tuple slot if the bignum doesn't fit. Fixes #594.

db4
Doug Coleman 2012-08-03 14:59:59 -07:00
parent 16de2794de
commit cd9dd9d752
6 changed files with 31 additions and 11 deletions

View File

@ -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? ;

View File

@ -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

View File

@ -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

View File

@ -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 ]

View File

@ -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?

View File

@ -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 )