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
-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
@@ -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 } 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
 
@@ -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/grouping/grouping-tests.factor

@@ -5,7 +5,7 @@ IN: grouping.tests
 
 [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
 
-[ { V{ "a" "b" } V{ f f } } ] [
+[ { V{ "a" "b" } V{ 0 0 } } ] [
     V{ "a" "b" } clone 2 <groups>
     2 over set-length
     >array

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

core/sequences/sequences-docs.factor

@@ -416,11 +416,6 @@ HELP: interleave
 { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
 { $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
 
-HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
-{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
-{ $side-effects "seq" } ;
-
 HELP: index
 { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
@@ -1497,7 +1492,6 @@ ARTICLE: "sequences-destructive" "Destructive operations"
 "Changing elements:"
 { $subsection change-each }
 { $subsection change-nth }
-{ $subsection cache-nth }
 "Deleting elements:"
 { $subsection delete }
 { $subsection delq }

core/sequences/sequences-tests.factor

@@ -190,16 +190,6 @@ unit-test
 
 [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
 
-[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
-    V{ } clone "cache-test" set
-    1 "cache-test" get [ sq ] cache-nth
-    2 "cache-test" get [ sq ] cache-nth
-    3 "cache-test" get [ sq ] cache-nth
-    4 "cache-test" get [ sq ] cache-nth
-    4 "cache-test" get [ "wrong" ] cache-nth
-    "cache-test" get
-] unit-test
-
 [ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
 
 ! Pathological case

core/sequences/sequences.factor

@@ -523,13 +523,6 @@ PRIVATE>
 : harvest ( seq -- newseq )
     [ empty? not ] filter ;
 
-: cache-nth ( i seq quot -- elt )
-    2over ?nth dup [
-        [ 3drop ] dip
-    ] [
-        drop swap [ over [ call dup ] dip ] dip set-nth
-    ] if ; inline
-
 : mismatch ( seq1 seq2 -- i )
     [ min-length ] 2keep
     [ 2nth-unsafe = not ] 2curry

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 = [
-        first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
-    ] [
-        first2 [ >>name ] [ >>mode ] bi*
-    ] if ;
+    dup length {
+        { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
+        { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
+        [ drop first >>name dup trailing>> >>mode ]
+    } 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
-    ": " blue write-color
+    [ type>> dark-blue write-color ] keep
+    ": " 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
-    [ irc-message-sender write ] keep
-    " has applied mode " blue write-color
-    [ full-mode write ] keep
-    " to " blue write-color
-    channel>> write ;
+    "* " dark-blue write-color
+    [ name>> write ] keep
+    " has applied mode " dark-blue write-color
+    [ mode>> write ] keep
+    " to " dark-blue write-color
+    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)));
 }