Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/tests/optimizer.factor

@@ -375,3 +375,9 @@ DEFER: loop-bbb
 : 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

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel effects accessors math math.private math.libm
+USING: kernel effects accessors math math.private
-math.partial-dispatch math.intervals math.parser math.order
+math.integers.private math.partial-dispatch math.intervals
-layouts words sequences sequences.private arrays assocs classes
+math.parser math.order layouts words sequences sequences.private
-classes.algebra combinators generic.math splitting fry locals
+arrays assocs classes classes.algebra combinators generic.math
-classes.tuple alien.accessors classes.tuple.private slots.private
+splitting fry locals classes.tuple alien.accessors
-definitions strings.private vectors hashtables
+classes.tuple.private slots.private definitions strings.private
+vectors hashtables
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ 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? [
@@ -230,7 +234,7 @@ generic-comparison-ops [
 } [
     [
         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
 
@@ -247,6 +251,15 @@ generic-comparison-ops [
     ] "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

basis/compiler/tree/propagation/propagation-tests.factor

@@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests
 
 [ 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 ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
-    [ { integer } declare bitnot ] final-classes
+
-] 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
 
@@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests
     [ { 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
@@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests
     ] 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
@@ -604,6 +624,22 @@ MIXIN: empty-mixin
     [ { 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

basis/math/intervals/intervals-docs.factor

@@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
 { $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? }
@@ -203,6 +204,10 @@ HELP: interval-abs
 { $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 } "." } ;

basis/math/intervals/intervals.factor

@@ -2,7 +2,7 @@
 ! 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
@@ -365,7 +365,7 @@ SYMBOL: incomparable
         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 ;
 
@@ -373,6 +373,18 @@ SYMBOL: incomparable
     #! 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

core/generic/math/math.factor

@@ -28,9 +28,6 @@ PREDICATE: math-class < class
 : 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 ;
 

core/math/integers/integers.factor

@@ -45,9 +45,6 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
 
 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 ;
 
@@ -76,7 +73,7 @@ M: bignum /mod bignum/mod ;
 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? ;

core/math/math.factor

@@ -103,9 +103,8 @@ M: float fp-infinity? ( float -- ? )
         drop f
     ] if ;
 
-GENERIC: next-power-of-2 ( m -- n ) foldable
+: next-power-of-2 ( m -- n )
-
+    dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
-M: real next-power-of-2 1+ >integer next-power-of-2 ;
 
 : power-of-2? ( n -- ? )
     dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable

extra/irc/messages/messages.factor

@@ -90,11 +90,11 @@ M: end-of-names >>command-parameters ( names-reply params -- names-reply )
     first2 [ >>who ] [ >>channel ] bi* ;
 
 M: mode >>command-parameters ( mode params -- mode )
-    dup length 3 = [
+    dup length {
-        first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
+        { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
-    ] [
+        { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
-        first2 [ >>name ] [ >>mode ] bi*
+        [ drop first >>name dup trailing>> >>mode ]
-    ] if ;
+    } case ;
 
 PRIVATE>
 
@@ -135,12 +135,12 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 
 : copy-message-in ( command irc-message -- command )
     {
-        [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
         [ line>>      >>line ]
         [ prefix>>    >>prefix ]
         [ command>>   >>command ]
         [ trailing>>  >>trailing ]
         [ timestamp>> >>timestamp ]
+        [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
     } cleave ;
 
 PRIVATE>

extra/irc/ui/ui.factor

@@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
        irc.client irc.client.private irc.messages
-       irc.ui.commandparser irc.ui.load vocabs.loader ;
+       irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;
 
 RENAME: join sequences => sjoin
 
@@ -30,6 +30,7 @@ TUPLE: irc-tab < frame chat client window ;
     foreground associate format ;
 : dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
 : dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
+: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;
 
 : dot-or-parens ( string -- string )
     [ "." ]
@@ -41,14 +42,14 @@ M: ping write-irc
     drop "* Ping" blue write-color ;
 
 M: privmsg write-irc
-    "<" blue write-color
+    "<" dark-blue write-color
     [ irc-message-sender write ] keep
-    "> " blue write-color
+    "> " dark-blue write-color
     trailing>> write ;
 
 M: notice write-irc
-    [ type>> blue write-color ] keep
+    [ type>> dark-blue write-color ] keep
-    ": " blue write-color
+    ": " dark-blue write-color
     trailing>> write ;
 
 TUPLE: own-message message nick timestamp ;
@@ -57,9 +58,9 @@ TUPLE: own-message message nick timestamp ;
     now own-message boa ;
 
 M: own-message write-irc
-    "<" blue write-color
+    "<" dark-blue write-color
     [ nick>> bold font-style associate format ] keep
-    "> " blue write-color
+    "> " dark-blue write-color
     message>> write ;
 
 M: join write-irc
@@ -87,26 +88,23 @@ M: kick write-irc
     " from the channel" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
-: full-mode ( message -- mode )
-    parameters>> rest " " sjoin ;
-
 M: mode write-irc
-    "* " blue write-color
+    "* " dark-blue write-color
-    [ irc-message-sender write ] keep
+    [ name>> write ] keep
-    " has applied mode " blue write-color
+    " has applied mode " dark-blue write-color
-    [ full-mode write ] keep
+    [ mode>> write ] keep
-    " to " blue write-color
+    " to " dark-blue write-color
-    channel>> write ;
+    parameter>> write ;
 
 M: nick write-irc
-    "* " blue write-color
+    "* " dark-blue write-color
     [ irc-message-sender write ] keep
     " is now known as " blue write-color
     trailing>> write ;
 
 M: unhandled write-irc
     "UNHANDLED: " write
-    line>> blue write-color ;
+    line>> dark-blue write-color ;
 
 M: irc-end write-irc
     drop "* You have left IRC" dark-red write-color ;
@@ -121,7 +119,10 @@ M: irc-chat-end write-irc
     drop ;
 
 M: irc-message write-irc
-    drop ; ! catch all unimplemented writes, THIS WILL CHANGE    
+    "UNIMPLEMENTED" write
+    [ class pprint ] keep
+    ": " write
+    line>> dark-blue write-color ;
 
 GENERIC: time-happened ( message -- timestamp )
 

vm/math.c

@@ -197,7 +197,7 @@ void primitive_bignum_xor(void)
 
 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)));
 }