- declared input type for bignum-shift was stricter than the runtime behavior, leading to bad propagation of type info if shift count was a bignum
- types inferred for type functions which used number-valued/integer-valued/real-valued were not always precise, eg bignum bignum bitxor => integer
- add interval-log2, type function for (log2)
- remove math-class-min, it was useless
: loop-ccc ( -- ) loop-bbb ;
[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
+
+! Type inference issue
+[ 4 3 ] [
+ 1 >bignum 2 >bignum
+ [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel effects accessors math math.private math.libm
-math.partial-dispatch math.intervals math.parser math.order
-layouts words sequences sequences.private arrays assocs classes
-classes.algebra combinators generic.math splitting fry locals
-classes.tuple alien.accessors classes.tuple.private slots.private
-definitions strings.private vectors hashtables
+USING: kernel effects accessors math math.private
+math.integers.private math.partial-dispatch math.intervals
+math.parser math.order layouts words sequences sequences.private
+arrays assocs classes classes.algebra combinators generic.math
+splitting fry locals classes.tuple alien.accessors
+classes.tuple.private slots.private definitions strings.private
+vectors hashtables
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
[ rational math-class-max ] dip
] unless ;
+: ensure-math-class ( class must-be -- class' )
+ [ class<= ] 2keep ? ;
+
: number-valued ( class interval -- class' interval' )
- [ number math-class-min ] dip ;
+ [ number ensure-math-class ] dip ;
: integer-valued ( class interval -- class' interval' )
- [ integer math-class-min ] dip ;
+ [ integer ensure-math-class ] dip ;
: real-valued ( class interval -- class' interval' )
- [ real math-class-min ] dip ;
+ [ real ensure-math-class ] dip ;
: float-valued ( class interval -- class' interval' )
over null-class? [
} [
[
in-d>> second value-info >literal<
- [ power-of-2? [ 1- bitand ] f ? ] when
+ [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
] "custom-inlining" set-word-prop
] each
] "custom-inlining" set-word-prop
] each
+{ numerator denominator }
+[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
+
+{ (log2) fixnum-log2 bignum-log2 } [
+ [
+ [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
+ ] "outputs" set-word-prop
+] each
+
\ string-nth [
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
] "outputs" set-word-prop
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
-[ V{ number } ] [ [ + ] final-classes ] unit-test
+! Test type propagation for math ops
+: cleanup-math-class ( obj -- class )
+ { null fixnum bignum integer ratio rational float real complex number }
+ [ class= ] with find nip ;
-[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+: final-math-class ( quot -- class )
+ final-classes first cleanup-math-class ;
-[ V{ float } ] [ [ /f ] final-classes ] unit-test
+[ number ] [ [ + ] final-math-class ] unit-test
-[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
-[ V{ integer } ] [
- [ { integer } declare bitnot ] final-classes
-] unit-test
+[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
+
+[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+
+[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ /f ] final-math-class ] unit-test
+
+[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
+
+[ integer ] [ [ /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
+
+[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
+
+[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
+
+[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
[ { fixnum } declare 615949 * ] final-classes
] unit-test
-[ V{ null } ] [
- [ { null null } declare + ] final-classes
-] unit-test
-
-[ V{ null } ] [
- [ { null fixnum } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { float fixnum } declare + ] final-classes
-] unit-test
-
[ V{ fixnum } ] [
[ 255 bitand >fixnum 3 bitor ] final-classes
] unit-test
] final-classes
] unit-test
-[ V{ float } ] [
- [ { real float } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { float real } declare + ] final-classes
-] unit-test
-
[ V{ fixnum } ] [
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test
[ { integer } declare 127 bitand ] final-info first interval>>
] unit-test
+[ V{ bignum } ] [
+ [ { bignum } declare dup 1- bitxor ] final-classes
+] unit-test
+
+[ V{ bignum integer } ] [
+ [ { bignum integer } declare [ shift ] keep ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ { fixnum } declare log2 ] final-classes
+] unit-test
+
+[ V{ word } ] [
+ [ { fixnum } declare log2 0 >= ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
{ $subsection interval-bitnot }
{ $subsection interval-recip }
{ $subsection interval-2/ }
-{ $subsection interval-abs } ;
+{ $subsection interval-abs }
+{ $subsection interval-log2 } ;
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
{ $subsection interval-contains? }
{ $values { "i1" interval } { "i2" interval } }
{ $description "Absolute value of an interval." } ;
+HELP: interval-log2
+{ $values { "i1" interval } { "i2" interval } }
+{ $description "Integer-valued Base-2 logarithm of an interval." } ;
+
HELP: interval-intersect
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
-combinators generic ;
+combinators generic layouts ;
IN: math.intervals
SYMBOL: empty-interval
2dup [ interval-nonnegative? ] both?
[
[ interval>points [ first ] bi@ ] bi@
- 4array supremum 0 swap next-power-of-2 [a,b]
+ 4array supremum 0 swap >integer next-power-of-2 [a,b]
] [ 2drop [-inf,inf] ] if
] do-empty-interval ;
#! Inaccurate.
interval-bitor ;
+: interval-log2 ( i1 -- i2 )
+ {
+ { empty-interval [ empty-interval ] }
+ { full-interval [ 0 [a,inf] ] }
+ [
+ to>> first 1 max dup most-positive-fixnum >
+ [ drop full-interval interval-log2 ]
+ [ 1+ >integer log2 0 swap [a,b] ]
+ if
+ ]
+ } case ;
+
: assume< ( i1 i2 -- i3 )
dup special-interval? [ drop ] [
to>> first [-inf,a) interval-intersect
: math-class-max ( class1 class2 -- class )
[ math-class<=> ] most ;
-: math-class-min ( class1 class2 -- class )
- [ swap math-class<=> ] most ;
-
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
M: fixnum (log2) fixnum-log2 ;
-M: integer next-power-of-2
- dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ;
-
M: bignum >fixnum bignum>fixnum ;
M: bignum >bignum ;
M: bignum bitand bignum-bitand ;
M: bignum bitor bignum-bitor ;
M: bignum bitxor bignum-bitxor ;
-M: bignum shift bignum-shift ;
+M: bignum shift >fixnum bignum-shift ;
M: bignum bitnot bignum-bitnot ;
M: bignum bit? bignum-bit? ;
drop f
] if ;
-GENERIC: next-power-of-2 ( m -- n ) foldable
-
-M: real next-power-of-2 1+ >integer next-power-of-2 ;
+: next-power-of-2 ( m -- n )
+ dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
: power-of-2? ( n -- ? )
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
void primitive_bignum_shift(void)
{
- F_FIXNUM y = to_fixnum(dpop());
+ F_FIXNUM y = untag_fixnum_fast(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}