Merge branch 'master' of git://factorcode.org/git/factor
commit
f753742e99
|
@ -375,3 +375,9 @@ DEFER: loop-bbb
|
||||||
: loop-ccc ( -- ) loop-bbb ;
|
: loop-ccc ( -- ) loop-bbb ;
|
||||||
|
|
||||||
[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
|
[ 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
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
stack-checker.state
|
||||||
compiler.tree.comparisons
|
compiler.tree.comparisons
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
|
@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
||||||
[ rational math-class-max ] dip
|
[ rational math-class-max ] dip
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
: ensure-math-class ( class must-be -- class' )
|
||||||
|
[ class<= ] 2keep ? ;
|
||||||
|
|
||||||
: number-valued ( class interval -- class' interval' )
|
: number-valued ( class interval -- class' interval' )
|
||||||
[ number math-class-min ] dip ;
|
[ number ensure-math-class ] dip ;
|
||||||
|
|
||||||
: integer-valued ( class interval -- class' interval' )
|
: integer-valued ( class interval -- class' interval' )
|
||||||
[ integer math-class-min ] dip ;
|
[ integer ensure-math-class ] dip ;
|
||||||
|
|
||||||
: real-valued ( class interval -- class' interval' )
|
: real-valued ( class interval -- class' interval' )
|
||||||
[ real math-class-min ] dip ;
|
[ real ensure-math-class ] dip ;
|
||||||
|
|
||||||
: float-valued ( class interval -- class' interval' )
|
: float-valued ( class interval -- class' interval' )
|
||||||
over null-class? [
|
over null-class? [
|
||||||
|
@ -230,7 +234,7 @@ generic-comparison-ops [
|
||||||
} [
|
} [
|
||||||
[
|
[
|
||||||
in-d>> second value-info >literal<
|
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
|
] "custom-inlining" set-word-prop
|
||||||
] each
|
] each
|
||||||
|
|
||||||
|
@ -247,6 +251,15 @@ generic-comparison-ops [
|
||||||
] "custom-inlining" set-word-prop
|
] "custom-inlining" set-word-prop
|
||||||
] each
|
] 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 [
|
\ string-nth [
|
||||||
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
|
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
|
||||||
] "outputs" set-word-prop
|
] "outputs" set-word-prop
|
||||||
|
|
|
@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
|
[ 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
|
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||||
|
|
||||||
|
@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests
|
||||||
[ { fixnum } declare 615949 * ] final-classes
|
[ { fixnum } declare 615949 * ] final-classes
|
||||||
] unit-test
|
] 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 } ] [
|
[ V{ fixnum } ] [
|
||||||
[ 255 bitand >fixnum 3 bitor ] final-classes
|
[ 255 bitand >fixnum 3 bitor ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ float } ] [
|
|
||||||
[ { real float } declare + ] final-classes
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ V{ float } ] [
|
|
||||||
[ { float real } declare + ] final-classes
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ V{ fixnum } ] [
|
[ V{ fixnum } ] [
|
||||||
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -604,6 +624,22 @@ MIXIN: empty-mixin
|
||||||
[ { integer } declare 127 bitand ] final-info first interval>>
|
[ { integer } declare 127 bitand ] final-info first interval>>
|
||||||
] unit-test
|
] 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 } ] [
|
! [ V{ string } ] [
|
||||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||||
! ] unit-test
|
! ] unit-test
|
||||||
|
|
|
@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
|
||||||
{ $subsection interval-bitnot }
|
{ $subsection interval-bitnot }
|
||||||
{ $subsection interval-recip }
|
{ $subsection interval-recip }
|
||||||
{ $subsection interval-2/ }
|
{ $subsection interval-2/ }
|
||||||
{ $subsection interval-abs } ;
|
{ $subsection interval-abs }
|
||||||
|
{ $subsection interval-log2 } ;
|
||||||
|
|
||||||
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
||||||
{ $subsection interval-contains? }
|
{ $subsection interval-contains? }
|
||||||
|
@ -203,6 +204,10 @@ HELP: interval-abs
|
||||||
{ $values { "i1" interval } { "i2" interval } }
|
{ $values { "i1" interval } { "i2" interval } }
|
||||||
{ $description "Absolute value of an 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
|
HELP: interval-intersect
|
||||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
{ $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 } "." } ;
|
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
||||||
USING: accessors kernel sequences arrays math math.order
|
USING: accessors kernel sequences arrays math math.order
|
||||||
combinators generic ;
|
combinators generic layouts ;
|
||||||
IN: math.intervals
|
IN: math.intervals
|
||||||
|
|
||||||
SYMBOL: empty-interval
|
SYMBOL: empty-interval
|
||||||
|
@ -365,7 +365,7 @@ SYMBOL: incomparable
|
||||||
2dup [ interval-nonnegative? ] both?
|
2dup [ interval-nonnegative? ] both?
|
||||||
[
|
[
|
||||||
[ interval>points [ first ] bi@ ] bi@
|
[ 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
|
] [ 2drop [-inf,inf] ] if
|
||||||
] do-empty-interval ;
|
] do-empty-interval ;
|
||||||
|
|
||||||
|
@ -373,6 +373,18 @@ SYMBOL: incomparable
|
||||||
#! Inaccurate.
|
#! Inaccurate.
|
||||||
interval-bitor ;
|
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 )
|
: assume< ( i1 i2 -- i3 )
|
||||||
dup special-interval? [ drop ] [
|
dup special-interval? [ drop ] [
|
||||||
to>> first [-inf,a) interval-intersect
|
to>> first [-inf,a) interval-intersect
|
||||||
|
|
|
@ -28,9 +28,6 @@ PREDICATE: math-class < class
|
||||||
: math-class-max ( class1 class2 -- class )
|
: math-class-max ( class1 class2 -- class )
|
||||||
[ math-class<=> ] most ;
|
[ math-class<=> ] most ;
|
||||||
|
|
||||||
: math-class-min ( class1 class2 -- class )
|
|
||||||
[ swap math-class<=> ] most ;
|
|
||||||
|
|
||||||
: (math-upgrade) ( max class -- quot )
|
: (math-upgrade) ( max class -- quot )
|
||||||
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
|
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
|
||||||
|
|
||||||
|
|
|
@ -45,9 +45,6 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
|
||||||
|
|
||||||
M: fixnum (log2) fixnum-log2 ;
|
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 >fixnum bignum>fixnum ;
|
||||||
M: bignum >bignum ;
|
M: bignum >bignum ;
|
||||||
|
|
||||||
|
@ -76,7 +73,7 @@ M: bignum /mod bignum/mod ;
|
||||||
M: bignum bitand bignum-bitand ;
|
M: bignum bitand bignum-bitand ;
|
||||||
M: bignum bitor bignum-bitor ;
|
M: bignum bitor bignum-bitor ;
|
||||||
M: bignum bitxor bignum-bitxor ;
|
M: bignum bitxor bignum-bitxor ;
|
||||||
M: bignum shift bignum-shift ;
|
M: bignum shift >fixnum bignum-shift ;
|
||||||
|
|
||||||
M: bignum bitnot bignum-bitnot ;
|
M: bignum bitnot bignum-bitnot ;
|
||||||
M: bignum bit? bignum-bit? ;
|
M: bignum bit? bignum-bit? ;
|
||||||
|
|
|
@ -103,9 +103,8 @@ M: float fp-infinity? ( float -- ? )
|
||||||
drop f
|
drop f
|
||||||
] if ;
|
] 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 -- ? )
|
: power-of-2? ( n -- ? )
|
||||||
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
|
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
|
||||||
|
|
|
@ -90,11 +90,11 @@ M: end-of-names >>command-parameters ( names-reply params -- names-reply )
|
||||||
first2 [ >>who ] [ >>channel ] bi* ;
|
first2 [ >>who ] [ >>channel ] bi* ;
|
||||||
|
|
||||||
M: mode >>command-parameters ( mode params -- mode )
|
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>
|
PRIVATE>
|
||||||
|
|
||||||
|
@ -135,12 +135,12 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
||||||
|
|
||||||
: copy-message-in ( command irc-message -- command )
|
: copy-message-in ( command irc-message -- command )
|
||||||
{
|
{
|
||||||
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
|
|
||||||
[ line>> >>line ]
|
[ line>> >>line ]
|
||||||
[ prefix>> >>prefix ]
|
[ prefix>> >>prefix ]
|
||||||
[ command>> >>command ]
|
[ command>> >>command ]
|
||||||
[ trailing>> >>trailing ]
|
[ trailing>> >>trailing ]
|
||||||
[ timestamp>> >>timestamp ]
|
[ timestamp>> >>timestamp ]
|
||||||
|
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
|
@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
|
||||||
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
|
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
|
||||||
io io.styles namespaces calendar calendar.format models continuations
|
io io.styles namespaces calendar calendar.format models continuations
|
||||||
irc.client irc.client.private irc.messages
|
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
|
RENAME: join sequences => sjoin
|
||||||
|
|
||||||
|
@ -30,6 +30,7 @@ TUPLE: irc-tab < frame chat client window ;
|
||||||
foreground associate format ;
|
foreground associate format ;
|
||||||
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
|
: 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-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 )
|
: dot-or-parens ( string -- string )
|
||||||
[ "." ]
|
[ "." ]
|
||||||
|
@ -41,14 +42,14 @@ M: ping write-irc
|
||||||
drop "* Ping" blue write-color ;
|
drop "* Ping" blue write-color ;
|
||||||
|
|
||||||
M: privmsg write-irc
|
M: privmsg write-irc
|
||||||
"<" blue write-color
|
"<" dark-blue write-color
|
||||||
[ irc-message-sender write ] keep
|
[ irc-message-sender write ] keep
|
||||||
"> " blue write-color
|
"> " dark-blue write-color
|
||||||
trailing>> write ;
|
trailing>> write ;
|
||||||
|
|
||||||
M: notice write-irc
|
M: notice write-irc
|
||||||
[ type>> blue write-color ] keep
|
[ type>> dark-blue write-color ] keep
|
||||||
": " blue write-color
|
": " dark-blue write-color
|
||||||
trailing>> write ;
|
trailing>> write ;
|
||||||
|
|
||||||
TUPLE: own-message message nick timestamp ;
|
TUPLE: own-message message nick timestamp ;
|
||||||
|
@ -57,9 +58,9 @@ TUPLE: own-message message nick timestamp ;
|
||||||
now own-message boa ;
|
now own-message boa ;
|
||||||
|
|
||||||
M: own-message write-irc
|
M: own-message write-irc
|
||||||
"<" blue write-color
|
"<" dark-blue write-color
|
||||||
[ nick>> bold font-style associate format ] keep
|
[ nick>> bold font-style associate format ] keep
|
||||||
"> " blue write-color
|
"> " dark-blue write-color
|
||||||
message>> write ;
|
message>> write ;
|
||||||
|
|
||||||
M: join write-irc
|
M: join write-irc
|
||||||
|
@ -87,26 +88,23 @@ M: kick write-irc
|
||||||
" from the channel" dark-red write-color
|
" from the channel" dark-red write-color
|
||||||
trailing>> dot-or-parens dark-red write-color ;
|
trailing>> dot-or-parens dark-red write-color ;
|
||||||
|
|
||||||
: full-mode ( message -- mode )
|
|
||||||
parameters>> rest " " sjoin ;
|
|
||||||
|
|
||||||
M: mode write-irc
|
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
|
M: nick write-irc
|
||||||
"* " blue write-color
|
"* " dark-blue write-color
|
||||||
[ irc-message-sender write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" is now known as " blue write-color
|
" is now known as " blue write-color
|
||||||
trailing>> write ;
|
trailing>> write ;
|
||||||
|
|
||||||
M: unhandled write-irc
|
M: unhandled write-irc
|
||||||
"UNHANDLED: " write
|
"UNHANDLED: " write
|
||||||
line>> blue write-color ;
|
line>> dark-blue write-color ;
|
||||||
|
|
||||||
M: irc-end write-irc
|
M: irc-end write-irc
|
||||||
drop "* You have left IRC" dark-red write-color ;
|
drop "* You have left IRC" dark-red write-color ;
|
||||||
|
@ -121,7 +119,10 @@ M: irc-chat-end write-irc
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
M: irc-message write-irc
|
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 )
|
GENERIC: time-happened ( message -- timestamp )
|
||||||
|
|
||||||
|
|
|
@ -197,7 +197,7 @@ void primitive_bignum_xor(void)
|
||||||
|
|
||||||
void primitive_bignum_shift(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());
|
F_ARRAY* x = untag_object(dpop());
|
||||||
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
|
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in New Issue