From ce6ed41cbe1ac97e3a7f75b88f4aa71617b8e1c0 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Dec 2008 23:27:32 -0200 Subject: [PATCH 1/5] irc.messages: Fix parsing of MODE messages with the mode on the trailing part of the message --- extra/irc/messages/messages.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index bea9bf37b1..8054dc8075 100755 --- a/extra/irc/messages/messages.factor +++ b/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> From 68108818fd2a8d2b2f4bcd7bab4dd18d7ee1f4af Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sun, 7 Dec 2008 04:06:52 -0500 Subject: [PATCH 2/5] irc.ui: Fixed mode stuff --- extra/irc/ui/ui.factor | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index b96d3e1bdc..fd64e9a07e 100755 --- a/extra/irc/ui/ui.factor +++ b/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 ) From ce269c87335b75de94560f5932f1a52674f598a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 08:50:59 -0600 Subject: [PATCH 3/5] Fix grouping unit test --- basis/grouping/grouping-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index dc3d970fbf..cfcc653776 100644 --- a/basis/grouping/grouping-tests.factor +++ b/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 2 over set-length >array From d1744fd67a707bd8d603f34c7aabdd0adc668948 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 08:51:22 -0600 Subject: [PATCH 4/5] Remove cache-nth word, nobody was using it and the semantics were broken --- core/sequences/sequences-docs.factor | 6 ------ core/sequences/sequences-tests.factor | 10 ---------- core/sequences/sequences.factor | 7 ------- 3 files changed, 23 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 08831579bb..0b3e0003ac 100644 --- a/core/sequences/sequences-docs.factor +++ b/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 } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 0d795d453a..dcca525e2b 100644 --- a/core/sequences/sequences-tests.factor +++ b/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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 995a8bba4c..8c9eff94f5 100644 --- a/core/sequences/sequences.factor +++ b/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 From e4f8448eb140f2ab8e399675e74fb53e897cd152 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Dec 2008 19:44:49 -0600 Subject: [PATCH 5/5] Fix some problems with arithmetic type inference, exposed by recent changes to log2 word - 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 --- basis/compiler/tests/optimizer.factor | 6 ++ .../known-words/known-words.factor | 33 ++++--- .../tree/propagation/propagation-tests.factor | 90 +++++++++++++------ basis/math/intervals/intervals-docs.factor | 7 +- basis/math/intervals/intervals.factor | 16 +++- core/generic/math/math.factor | 3 - core/math/integers/integers.factor | 5 +- core/math/math.factor | 5 +- vm/math.c | 2 +- 9 files changed, 116 insertions(+), 51 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 41df6e7ae5..fa6a3c7b21 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 8242311287..4d8d935477 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/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 ] "outputs" set-word-prop ] each + +{ (log2) fixnum-log2 bignum-log2 } [ + [ + [ class>> ] [ interval>> interval-log2 ] bi + ] "outputs" set-word-prop +] each + \ string-nth [ 2drop fixnum 0 23 2^ [a,b] ] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aa04b58de7..d95245fe83 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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 diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 5a96c7aceb..d8a80340ba 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/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 } "." } ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4182d25524..ed76ccaedd 100644 --- a/basis/math/intervals/intervals.factor +++ b/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 diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 63043b50b9..66f2da7191 100644 --- a/core/generic/math/math.factor +++ b/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 ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 910d394c55..30903e3269 100644 --- a/core/math/integers/integers.factor +++ b/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? ; diff --git a/core/math/math.factor b/core/math/math.factor index 8b064725d3..2434bf8ec6 100644 --- a/core/math/math.factor +++ b/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 diff --git a/vm/math.c b/vm/math.c index dd01e852ad..f0aa874886 100644 --- a/vm/math.c +++ b/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))); }