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

2008-08-02 15:32:51 -05:00 · 2008-08-02 15:32:51 -05:00 · 49d17ecad4
parent d3e4070bb3 fb9f879aa6
commit 49d17ecad4
82 changed files with 1361 additions and 584 deletions
--- a/basis/concurrency/messaging/messaging-docs.factor
+++ b/basis/concurrency/messaging/messaging-docs.factor
@ -56,19 +56,19 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
    "USING: concurrency.messaging kernel threads ;"
    ": pong-server ( -- )"
    "    receive >r \"pong\" r> reply-synchronous ;"
-    "[ pong-server t ] spawn-server"
+    "[ pong-server t ] \"pong-server\" spawn-server"
    "\"ping\" swap send-synchronous ."
    "\"pong\""
 } ;

 ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" 
-{ $code "[ 1 0 / \"This will not print\" print ] spawn" } 
+{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } 
 "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
 { $subsection spawn-linked }
 "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
 { $code "["
-"  [ 1 0 / \"This will not print\" print ] spawn-linked drop"
+"  [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop"
 "  receive"
 "] [ \"Exception caught.\" print ] recover" } 
 "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
--- a/basis/help/stylesheet/stylesheet.factor
+++ b/basis/help/stylesheet/stylesheet.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.styles namespaces ;
+USING: io.styles namespaces colors ;
 IN: help.stylesheet

 SYMBOL: default-span-style
@ -17,7 +17,7 @@ H{

 SYMBOL: link-style
 H{
-    { foreground { 0 0 0.3 1 } }
+    { foreground T{ rgba f 0 0 0.3 1 } }
    { font-style bold }
 } link-style set-global

@ -33,7 +33,7 @@ H{
    { font-size 18 }
    { font-style bold }
    { wrap-margin 500 }
-    { page-color { 0.8 0.8 0.8 1 } }
+    { page-color T{ rgba f 0.8 0.8 0.8 1 } }
    { border-width 5 }
 } title-style set-global

@ -58,12 +58,12 @@ SYMBOL: snippet-style
 H{
    { font "monospace" }
    { font-size 12 }
-    { foreground { 0.1 0.1 0.4 1 } }
+    { foreground T{ rgba f 0.1 0.1 0.4 1 } }
 } snippet-style set-global

 SYMBOL: code-style
 H{
-    { page-color { 0.8 0.8 0.8 0.5 } }
+    { page-color T{ rgba f 0.8 0.8 0.8 0.5 } }
    { border-width 5 }
    { wrap-margin f }
 } code-style set-global
@ -74,13 +74,13 @@ H{ { font-style bold } } input-style set-global
 SYMBOL: url-style
 H{
    { font "monospace" }
-    { foreground { 0.0 0.0 1.0 1.0 } }
+    { foreground T{ rgba f 0.0 0.0 1.0 1.0 } }
 } url-style set-global

 SYMBOL: warning-style
 H{
-    { page-color { 0.95 0.95 0.95 1 } }
-    { border-color { 1 0 0 1 } }
+    { page-color T{ rgba f 0.95 0.95 0.95 1 } }
+    { border-color T{ rgba f 1 0 0 1 } }
    { border-width 5 }
    { wrap-margin 500 }
 } warning-style set-global
@ -93,7 +93,7 @@ H{
 SYMBOL: table-style
 H{
    { table-gap { 5 5 } }
-    { table-border { 0.8 0.8 0.8 1.0 } }
+    { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
 } table-style set-global

 SYMBOL: list-style
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@ -1,6 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io ;
+
+USING: hashtables io colors ;
+
 IN: io.styles

 SYMBOL: plain
@ -33,7 +35,7 @@ SYMBOL: table-border
 : standard-table-style ( -- style )
    H{
        { table-gap { 5 5 } }
-        { table-border { 0.8 0.8 0.8 1.0 } }
+        { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
    } ;

 ! Input history
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@ -3,7 +3,8 @@
 USING: arrays hashtables io kernel math math.parser memory
 namespaces parser lexer sequences strings io.styles
 vectors words generic system combinators continuations debugger
-definitions compiler.units accessors ;
+definitions compiler.units accessors colors ;
+
 IN: listener

 SYMBOL: quit-flag
@ -41,7 +42,7 @@ M: object stream-read-quot

 : prompt. ( -- )
    "( " in get " )" 3append
-    H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
+    H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;

 SYMBOL: error-hook

--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@ -5,7 +5,7 @@ hashtables io assocs kernel math namespaces sequences strings
 sbufs io.styles vectors words prettyprint.config
 prettyprint.sections quotations io io.files math.parser effects
 classes.tuple math.order classes.tuple.private classes
-combinators ;
+combinators colors ;
 IN: prettyprint.backend

 GENERIC: pprint* ( obj -- )
@ -89,7 +89,7 @@ M: f pprint* drop \ f pprint-word ;
 : string-style ( obj -- hash )
    [
        presented set
-        { 0.3 0.3 0.3 1.0 } foreground set
+        T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
    ] H{ } make-assoc ;

 : unparse-string ( str prefix suffix -- str )
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: prettyprint
+
 USING: arrays generic generic.standard assocs io kernel
 math namespaces sequences strings io.styles io.streams.string
 vectors words prettyprint.backend prettyprint.sections
@ -8,7 +8,9 @@ prettyprint.config sorting splitting grouping math.parser vocabs
 definitions effects classes.builtin classes.tuple io.files
 classes continuations hashtables classes.mixin classes.union
 classes.intersection classes.predicate classes.singleton
-combinators quotations sets accessors ;
+combinators quotations sets accessors colors ;
+
+IN: prettyprint

 : make-pprint ( obj quot -- block in use )
    [
@ -95,7 +97,7 @@ combinators quotations sets accessors ;
 SYMBOL: ->

 \ ->
-{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
+{ { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
 "word-style" set-word-prop

 : remove-step-into ( word -- )
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@ -437,7 +437,7 @@ HELP: or

 HELP: xor
 { $values { "obj1" "a generalized boolean" } { "obj2" "a generalized boolean" } { "?" "a generalized boolean" } }
-{ $description "Tests if at exactly one object is not " { $link f } "." }
+{ $description "If exactly one input is false, outputs the other input. Otherwise outputs " { $link f } "." }
 { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;

 HELP: both?
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@ -50,6 +50,10 @@ IN: kernel.tests
 [ f ] [ 3 f and ] unit-test
 [ 4 ] [ 4 6 or ] unit-test
 [ 6 ] [ f 6 or ] unit-test
+[ f ] [ 1 2 xor ] unit-test
+[ 1 ] [ 1 f xor ] unit-test
+[ 2 ] [ f 2 xor ] unit-test
+[ f ] [ f f xor ] unit-test

 [ slip ] must-fail
 [ ] [ :c ] unit-test
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@ -173,7 +173,7 @@ GENERIC: boa ( ... class -- tuple )

 : or ( obj1 obj2 -- ? ) dupd ? ; inline

-: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
+: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline

 : both? ( x y quot -- ? ) bi@ and ; inline

--- a/extra/automata/tags.txt
+++ b/extra/automata/tags.txt
--- a/extra/automata/ui/tags.txt
+++ b/extra/automata/ui/tags.txt
--- a/extra/balloon-bomber/tags.txt
+++ b/extra/balloon-bomber/tags.txt
@ -1,2 +1,3 @@
+demos
 games
 applications
--- a/extra/boids/ui/tags.txt
+++ b/extra/boids/ui/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/bubble-chamber/tags.txt
+++ b/extra/bubble-chamber/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@ -3,40 +3,16 @@ USING: kernel alien.c-types combinators namespaces arrays
       sequences sequences.lib namespaces.lib splitting
       math math.functions math.vectors math.trig
       opengl.gl opengl.glu opengl ui ui.gadgets.slate
-       vars
-       random-weighted colors.hsv cfdg.gl ;
+       vars colors self self.slots
+       random-weighted colors.hsv cfdg.gl accessors ;

 IN: cfdg

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-! hsba { hue saturation brightness alpha }
+SELF-SLOTS: hsva

-: <hsba> 4array ;
-
-VAR: color
-
-! ( -- val )
-
-: hue>>        0 color> nth ;
-: saturation>> 1 color> nth ;
-: brightness>> 2 color> nth ;
-: alpha>>      3 color> nth ;
-
-! ( val -- )
-
-: >>hue        0 color> set-nth ;
-: >>saturation 1 color> set-nth ;
-: >>brightness 2 color> set-nth ;
-: >>alpha      3 color> set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
-
-: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
-
-: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ;
+: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -50,18 +26,18 @@ VAR: color

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: hue ( num -- ) hue>> + 360 mod >>hue ;
+: hue ( num -- ) hue-> + 360 mod ->hue ;

-: saturation ( num -- ) saturation>> swap adjust >>saturation ;
-: brightness ( num -- ) brightness>> swap adjust >>brightness ;
-: alpha      ( num -- ) alpha>>      swap adjust >>alpha ;
+: saturation ( num -- ) saturation-> swap adjust ->saturation ;
+: brightness ( num -- ) value->      swap adjust ->value ;
+: alpha      ( num -- ) alpha->      swap adjust ->alpha ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: h   hue ;
-: sat saturation ;
-: b   brightness ;
-: a   alpha ;
+: h   ( num -- ) hue ;
+: sat ( num -- ) saturation ;
+: b   ( num -- ) brightness ;
+: a   ( num -- ) alpha ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -69,9 +45,9 @@ VAR: color-stack

 : init-color-stack ( -- ) V{ } clone >color-stack ;

-: push-color ( -- ) color> color-stack> push   color> clone >color ;
+: push-color ( -- ) self> color-stack> push   self> clone >self ;

-: pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ;
+: pop-color ( -- ) color-stack> pop dup >self set-color ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -102,11 +78,11 @@ VAR: threshold
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 : circle ( -- )
-  color> gl-set-hsba
+  self> set-color
  gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;

 : triangle ( -- )
-  color> gl-set-hsba
+  self> set-color
  GL_POLYGON glBegin
    0    0.577 glVertex2d
    0.5 -0.289 glVertex2d
@ -114,7 +90,7 @@ VAR: threshold
  glEnd ;

 : square ( -- )
-  color> gl-set-hsba
+  self> set-color
  GL_POLYGON glBegin
    -0.5  0.5 glVertex2d
     0.5  0.5 glVertex2d
@ -138,10 +114,10 @@ VAR: threshold

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: s  size ;
-: s* size* ;
-: r  rotate ;
-: f  flip ;
+: s  ( scale -- ) size ;
+: s* ( scale-x scale-y -- ) size* ;
+: r  ( angle -- ) rotate ;
+: f  ( angle -- ) flip ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -162,12 +138,12 @@ VAR: threshold

 VAR: background

-: set-initial-background ( -- ) { 0 0 1 1 } clone >color ;
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;

 : set-background ( -- )
  set-initial-background
  background> call
-  color> gl-clear-hsba ;
+  self> clear-color ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -177,7 +153,7 @@ VAR: viewport ! { left width bottom height }

 VAR: start-shape

-: set-initial-color ( -- ) { 0 0 0 1 } clone >color ;
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;

 : display ( -- )

@ -198,7 +174,7 @@ VAR: start-shape

  set-initial-color

-  color> gl-set-hsba
+  self> set-color

  start-shape> call ;

--- a/extra/cfdg/models/aqua-star/tags.txt
+++ b/extra/cfdg/models/aqua-star/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/chiaroscuro/tags.txt
+++ b/extra/cfdg/models/chiaroscuro/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/flower6/tags.txt
+++ b/extra/cfdg/models/flower6/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/game1-turn6/tags.txt
+++ b/extra/cfdg/models/game1-turn6/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/lesson/tags.txt
+++ b/extra/cfdg/models/lesson/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/rules08/rules08.factor
+++ b/extra/cfdg/models/rules08/rules08.factor
@ -0,0 +1,63 @@
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.rules08
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insct ( -- )
+  [ 1.5 5.5 size* -1 brightness triangle ] do
+  10
+    [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
+  each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: line
+
+: ligne ( -- )
+  {
+    { 1   [ 4.5 y 1.15 0.8 size* -0.3 b line ] do }
+    { 0.5 [ ] }
+  }
+  call-random-weighted ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line ( -- ) [ insct ligne ] recursive ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sole ( -- )
+  [
+    {
+      {
+        1 [
+            [ 1 brightness 0.5 saturation ligne ] do
+            [ 140 r 1 hue                 sole  ] do
+          ]
+      }
+      { 0.01 [ ] }
+    }
+    call-random-weighted
+  ]
+  recursive ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: centre ( -- )
+  [ 1 b 5 s circle ] do
+  [ sole ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run ( -- )
+  [ -1 b ] >background
+  { -20 40 -20 40 } viewport set
+  [ centre ] >start-shape
+  0.0001 >threshold
+  cfdg-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
--- a/extra/cfdg/models/rules08/tags.txt
+++ b/extra/cfdg/models/rules08/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/sierpinski/tags.txt
+++ b/extra/cfdg/models/sierpinski/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/cfdg/models/snowflake/tags.txt
+++ b/extra/cfdg/models/snowflake/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@ -4,7 +4,7 @@ USING: kernel math math.functions math.parser models
       models.filter models.range models.compose sequences ui
       ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
       ui.gadgets.sliders ui.render math.geometry.rect accessors
-       ui.gadgets.grids ;
+       ui.gadgets.grids colors ;
 IN: color-picker

 ! Simple example demonstrating the use of models.
@ -23,7 +23,7 @@ M: color-preview model-changed
    swap model-value over set-gadget-interior relayout-1 ;

 : <color-model> ( model -- model )
-    [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
+    [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;

 : <color-sliders> ( -- model gadget )
    3 [ 0 0 0 255 <range> ] replicate
--- a/extra/colors/colors.factor
+++ b/extra/colors/colors.factor
@ -27,8 +27,6 @@ M: hsva >rgba ( hsva -- rgba )

 M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;

-M: array >rgba ( array -- rgba ) first4 rgba boa ;
-
 M: color red>>   ( color -- red   ) >rgba red>>   ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>>  ( color -- blue  ) >rgba blue>>  ;
--- a/extra/demos/demos.factor
+++ b/extra/demos/demos.factor
@ -0,0 +1,22 @@
+
+USING: kernel fry sequences
+       vocabs.loader tools.vocabs.browser
+       ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
+       ui.tools.listener
+       accessors ;
+
+IN: demos
+
+: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
+
+: <run-vocab-button> ( vocab-name -- button )
+  dup '[ drop [ , run ] call-listener ] <bevel-button> ;
+
+: <demo-runner> ( -- gadget )
+  <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
+
+: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: demos
--- a/extra/golden-section/golden-section.factor
+++ b/extra/golden-section/golden-section.factor
@ -39,16 +39,15 @@ IN: golden-section

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

+: <golden-section> ( -- gadget )
+  <cartesian>
+    {  600 600 }       >>pdim
+    { -400 400 }       x-range
+    { -400 400 }       y-range
+    [ golden-section ] >>action ;
+
 : golden-section-window ( -- )
-    [
-      <cartesian>
-        {  600 600 }       >>pdim
-        { -400 400 }       x-range
-        { -400 400 }       y-range
-        [ golden-section ] >>action
-      "Golden Section" open-window
-    ]
-  with-ui ;
+  [ <golden-section> "Golden Section" open-window ] with-ui ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@ -1,7 +1,7 @@
 USING: kernel tools.test accessors arrays sequences qualified
       io.streams.string io.streams.duplex namespaces threads
       calendar irc.client.private irc.client irc.messages.private
-       concurrency.mailboxes classes assocs ;
+       concurrency.mailboxes classes assocs combinators ;
 EXCLUDE: irc.messages => join ;
 RENAME: join irc.messages => join_
 IN: irc.client.tests
@ -11,16 +11,16 @@ IN: irc.client.tests
  "\n" join <string-reader> <string-writer> <duplex-stream> ;

 : make-client ( lines -- irc-client )
-   "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
-   swap [ 2nip <test-stream> f ] curry >>connect ;
+    "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+    swap [ 2nip <test-stream> f ] curry >>connect ;

 : set-nick ( irc-client nickname -- )
-     swap profile>> (>>nickname) ;
+    swap profile>> (>>nickname) ;

-: with-dummy-client ( quot -- )
-     rot with-variable ; inline
+: with-dummy-client ( irc-client quot -- )
+    [ current-irc-client ] dip with-variable ; inline

-{ "" } make-client dup "factorbot" set-nick current-irc-client [
+{ "" } make-client dup "factorbot" set-nick [
    { t } [ irc> profile>> nickname>> me? ] unit-test

    { "factorbot" } [ irc> profile>> nickname>> ] unit-test
@ -32,39 +32,144 @@ IN: irc.client.tests

    { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
                     parse-irc-line irc-message-origin ] unit-test
-] with-variable
+] with-dummy-client

 ! Test login and nickname set
-{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..."
-                    "NOTICE AUTH :*** Checking ident"
-                    "NOTICE AUTH :*** Found your hostname"
-                    "NOTICE AUTH :*** No identd (auth) response"
-                    ":some.where 001 factorbot :Welcome factorbot"
-                  } make-client
-                  [ connect-irc ] keep 1 seconds sleep
-                  profile>> nickname>> ] unit-test
+{ "factorbot" } [
+    { "NOTICE AUTH :*** Looking up your hostname..."
+      "NOTICE AUTH :*** Checking ident"
+      "NOTICE AUTH :*** Found your hostname"
+      "NOTICE AUTH :*** No identd (auth) response"
+      ":some.where 001 factorbot :Welcome factorbot"
+    } make-client
+    { [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ profile>> nickname>> ]
+      [ terminate-irc ]
+    } cleave ] unit-test

 { join_ "#factortest" } [
-           { ":factorbot!n=factorbo@some.where JOIN :#factortest"
-             ":ircserver.net MODE #factortest +ns"
-             ":ircserver.net 353 factorbot @ #factortest :@factorbot "
-             ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
-             ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
-             } make-client dup "factorbot" set-nick
-             [ connect-irc ] keep 1 seconds sleep
-             join-messages>> 1 seconds mailbox-get-timeout
-             [ class ] [ trailing>> ] bi ] unit-test
+    { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+      ":ircserver.net MODE #factortest +ns"
+      ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+      ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+      ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+    } make-client
+    { [ "factorbot" set-nick ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ join-messages>> 0.1 seconds mailbox-get-timeout ]
+      [ terminate-irc ]
+    } cleave
+    [ class ] [ trailing>> ] bi ] unit-test

 { +join+ "somebody" } [
-           { ":somebody!n=somebody@some.where JOIN :#factortest"
-             } make-client dup "factorbot" set-nick
-             [ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
-             [ connect-irc ]
-             [ listeners>> [ "#factortest" ] dip at
-               [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
-             [ action>> ] [ nick>> ] bi
-             ] unit-test
-! TODO: channel message
-! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
-! TODO: direct private message
-! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
+    { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+      [ connect-irc ]
+      [ listeners>> [ "#factortest" ] dip at
+        [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
+      [ terminate-irc ]
+    } cleave
+    [ action>> ] [ nick>> ] bi
+    ] unit-test
+
+{ privmsg "#factortest" "hello" } [
+    { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+      [ connect-irc ]
+      [ listeners>> [ "#factortest" ] dip at
+        [ read-message drop ] [ read-message ] bi ]
+      [ terminate-irc ]
+    } cleave
+    [ class ] [ name>> ] [ trailing>> ] tri
+    ] unit-test
+
+{ privmsg "factorbot" "hello" } [
+    { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
+      [ connect-irc ]
+      [ listeners>> [ "somedude" ] dip at
+        [ read-message drop ] [ read-message ] bi ]
+      [ terminate-irc ]
+    } cleave
+    [ class ] [ name>> ] [ trailing>> ] tri
+    ] unit-test
+
+! Participants lists tests
+{ H{ { "somedude" +normal+ } } } [
+    { ":somedude!n=user@isp.net JOIN :#factortest" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ listeners>> [ "#factortest" ] dip at participants>> ]
+      [ terminate-irc ]
+    } cleave
+    ] unit-test
+
+{ H{ { "somedude2" +normal+ } } } [
+    { ":somedude!n=user@isp.net PART #factortest" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener>
+                          H{ { "somedude2" +normal+ }
+                             { "somedude" +normal+ } } clone >>participants ] keep
+        ] dip set-at ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ listeners>> [ "#factortest" ] dip at participants>> ]
+      [ terminate-irc ]
+    } cleave
+    ] unit-test
+
+{ H{ { "somedude2" +normal+ } } } [
+    { ":somedude!n=user@isp.net QUIT" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener>
+                          H{ { "somedude2" +normal+ }
+                             { "somedude" +normal+ } } clone >>participants ] keep
+        ] dip set-at ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ listeners>> [ "#factortest" ] dip at participants>> ]
+      [ terminate-irc ]
+    } cleave
+    ] unit-test
+
+{ H{ { "somedude2" +normal+ } } } [
+    { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener>
+                          H{ { "somedude2" +normal+ }
+                             { "somedude" +normal+ } } clone >>participants ] keep
+        ] dip set-at ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ listeners>> [ "#factortest" ] dip at participants>> ]
+      [ terminate-irc ]
+    } cleave
+    ] unit-test
+
+! Namelist notification
+{ T{ participant-changed f f f } } [
+    { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+      ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
+    { [ "factorbot" set-nick ]
+      [ listeners>>
+        [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+      [ connect-irc ]
+      [ drop 0.1 seconds sleep ]
+      [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
+      [ terminate-irc ]
+    } cleave
+    ] unit-test
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@ -12,8 +12,6 @@ IN: irc.client
 ! Setup and running objects
 ! ======================================

-SYMBOL: current-irc-client
-
 : irc-port 6667 ; ! Default irc port

 TUPLE: irc-profile server port nickname password ;
@ -51,7 +49,8 @@ SYMBOL: +mode+
     <mailbox> <mailbox> irc-server-listener boa ;

 : <irc-channel-listener> ( name -- irc-channel-listener )
-     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
+     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
+     irc-channel-listener boa ;

 : <irc-nick-listener> ( name -- irc-nick-listener )
     [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
@ -63,19 +62,24 @@ SYMBOL: +mode+
 TUPLE: participant-changed nick action ;
 C: <participant-changed> participant-changed

+SINGLETON: irc-listener-end ! send to a listener to stop its execution
 SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;

 : terminate-irc ( irc-client -- )
-    [ [ irc-end ] dip in-messages>> mailbox-put ]
-    [ [ f ] dip (>>is-running) ]
-    [ stream>> dispose ]
-    tri ;
+    [ is-running>> ] keep and [
+        [ [ irc-end ] dip in-messages>> mailbox-put ]
+        [ [ f ] dip (>>is-running) ]
+        [ stream>> dispose ]
+        tri
+    ] when* ;

 <PRIVATE

+SYMBOL: current-irc-client
+
 ! ======================================
 ! Utils
 ! ======================================
@ -85,7 +89,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 : irc-write ( s -- ) irc-stream> stream-write ;
 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
-: unregister-listener ( name -- ) irc> listeners>> delete-at ;
+
+: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
+    [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline

 GENERIC: to-listener ( message obj -- )

@ -93,6 +99,12 @@ M: string to-listener ( message string -- )
    listener> [ +server-listener+ listener> ] unless*
    [ to-listener ] [ drop ] if* ;

+: unregister-listener ( name -- )
+    irc> listeners>>
+        [ at [ irc-listener-end ] dip to-listener ]
+        [ delete-at ]
+    2bi ;
+
 M: irc-listener to-listener ( message irc-listener -- )
    in-messages>> mailbox-put ;

@ -105,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- )
    with filter ;

 : remove-participant-from-all ( nick -- )
-    dup listeners-with-participant [ delete-at ] with each ;
+    dup listeners-with-participant [ participants>> delete-at ] with each ;

 : add-participant ( mode nick channel -- )
    listener> [ participants>> set-at ] [ 2drop ] if* ;
@ -206,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- )
    dup irc-message-origin to-listener ;

 M: join handle-incoming-irc ( join -- )
-    { [ maybe-forward-join ] ! keep
+    { [ maybe-forward-join ]
      [ dup trailing>> to-listener ]
-      [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+      [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
      [ handle-participant-change ]
    } cleave ;

@ -219,19 +231,18 @@ M: part handle-incoming-irc ( part -- )
    tri ;

 M: kick handle-incoming-irc ( kick -- )
-    { [ dup channel>>  to-listener ]
+    { [ dup channel>> to-listener ]
      [ [ who>> ] [ channel>> ] bi remove-participant ]
      [ handle-participant-change ]
      [ dup who>> me? [ unregister-listener ] [ drop ] if ]
    } cleave ;

 M: quit handle-incoming-irc ( quit -- )
-    { [ dup prefix>> parse-name listeners-with-participant
-        [ to-listener ] with each ]
-      [ handle-participant-change ]
-      [ prefix>> parse-name remove-participant-from-all ]
-      [ ]
-    } cleave call-next-method ;
+    [ dup prefix>> parse-name listeners-with-participant
+      [ to-listener ] with each ]
+    [ prefix>> parse-name remove-participant-from-all ]
+    [ handle-participant-change ]
+    tri ;

 : >nick/mode ( string -- nick mode )
    dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -241,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- )
    [ >nick/mode 2array ] map >hashtable ;

 M: names-reply handle-incoming-irc ( names-reply -- )
-    [ names-reply>participants ] [ channel>> listener> ] bi
-    [ (>>participants) ] [ drop ] if* ;
+    [ names-reply>participants ] [ channel>> listener> ] bi [
+        [ (>>participants) ]
+        [ [ f f <participant-changed> ] dip name>> to-listener ] bi
+    ] [ drop ] if* ;

 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
    broadcast-message-to-listeners ;
@ -256,12 +269,6 @@ GENERIC: handle-outgoing-irc ( obj -- )
 M: irc-message handle-outgoing-irc ( irc-message -- )
    irc-message>client-line irc-print ;

-M: privmsg handle-outgoing-irc ( privmsg -- )
-    [ name>> ] [ trailing>> ] bi /PRIVMSG ;
-
-M: part handle-outgoing-irc ( part -- )
-    [ channel>> ] [ trailing>> "" or ] bi /PART ;
-
 ! ======================================
 ! Reader/Writer
 ! ======================================
@ -273,7 +280,7 @@ DEFER: (connect-irc)

 : (handle-disconnect) ( -- )
    irc>
-        [ [ irc-disconnected ] dip to-listener ]
+        [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
        [ dup reconnect-time>> sleep (connect-irc) ]
        [ profile>> nickname>> /LOGIN ]
    tri ;
@ -291,35 +298,37 @@ DEFER: (connect-irc)
        ] if*
    ] with-destructors ;

-: reader-loop ( -- )
-    [ (reader-loop) ] [ handle-disconnect ] recover ;
+: reader-loop ( -- ? )
+    [ (reader-loop) ] [ handle-disconnect ] recover t ;

-: writer-loop ( -- )
-    irc> out-messages>> mailbox-get handle-outgoing-irc ;
+: writer-loop ( -- ? )
+    irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;

 ! ======================================
 ! Processing loops
 ! ======================================

-: in-multiplexer-loop ( -- )
-    irc> in-messages>> mailbox-get handle-incoming-irc ;
+: in-multiplexer-loop ( -- ? )
+    irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;

 : strings>privmsg ( name string -- privmsg )
    privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;

 : maybe-annotate-with-name ( name obj -- obj )
-    {
-        { [ dup string? ] [ strings>privmsg ] }
-        { [ dup privmsg instance? ] [ swap >>name ] }
-        [ nip ]
+    { { [ dup string? ] [ strings>privmsg ] }
+      { [ dup privmsg instance? ] [ swap >>name ] }
+      [ nip ]
    } cond ;

-: listener-loop ( name listener -- )
-    out-messages>> mailbox-get maybe-annotate-with-name
-    irc> out-messages>> mailbox-put ;
+: listener-loop ( name -- ? )
+    dup listener> [
+        out-messages>> [ maybe-annotate-with-name
+                         irc> out-messages>> mailbox-put ] with
+        maybe-mailbox-get t
+    ] [ drop f ] if* ;

-: spawn-irc-loop ( quot name -- )
-    [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
+: spawn-irc-loop ( quot: ( -- ? ) name -- )
+    [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
    spawn-server drop ;

 : spawn-irc ( -- )
@ -332,9 +341,8 @@ DEFER: (connect-irc)
 ! ======================================

 : set+run-listener ( name irc-listener -- )
-    [ '[ , , listener-loop ] "listener" spawn-irc-loop ]
-    [ swap irc> listeners>> set-at ]
-    2bi ;
+    over irc> listeners>> set-at
+    '[ , listener-loop ] "listener" spawn-irc-loop ;

 GENERIC: (add-listener) ( irc-listener -- )

@ -371,16 +379,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
        t >>is-running
    in-messages>> [ irc-connected ] dip mailbox-put ;

-: with-irc-client ( irc-client quot -- )
+: with-irc-client ( irc-client quot: ( -- ) -- )
    [ current-irc-client ] dip with-variable ; inline

 PRIVATE>

 : connect-irc ( irc-client -- )
-    dup [
-        [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
-        spawn-irc
-    ] with-irc-client ;
+    [ irc>
+      [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
+      spawn-irc ] with-irc-client ;

 : add-listener ( irc-listener irc-client -- )
    swap '[ , (add-listener) ] with-irc-client ;
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@ -35,3 +35,23 @@ join new
 [ ":someuser!n=user@some.where JOIN :#factortest"
  parse-irc-line f >>timestamp ] unit-test

+mode new
+    ":ircserver.net MODE #factortest +ns" >>line
+                          "ircserver.net" >>prefix
+                                   "MODE" >>command
+                  { "#factortest" "+ns" } >>parameters
+                            "#factortest" >>channel
+                                    "+ns" >>mode
+1array
+[ ":ircserver.net MODE #factortest +ns"
+  parse-irc-line f >>timestamp ] unit-test
+
+nick new
+    ":someuser!n=user@some.where NICK :someuser2" >>line
+                     "someuser!n=user@some.where" >>prefix
+                                           "NICK" >>command
+                                              { } >>parameters
+                                      "someuser2" >>trailing
+1array
+[ ":someuser!n=user@some.where NICK :someuser2"
+  parse-irc-line f >>timestamp ] unit-test
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry splitting ascii calendar accessors combinators qualified
-       arrays classes.tuple math.order ;
+       arrays classes.tuple math.order quotations ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.messages
@ -12,12 +12,13 @@ TUPLE: ping < irc-message ;
 TUPLE: join < irc-message ;
 TUPLE: part < irc-message channel ;
 TUPLE: quit < irc-message ;
+TUPLE: nick < irc-message ;
 TUPLE: privmsg < irc-message name ;
 TUPLE: kick < irc-message channel who ;
 TUPLE: roomlist < irc-message channel names ;
 TUPLE: nick-in-use < irc-message asterisk name ;
 TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message name channel mode ;
+TUPLE: mode < irc-message channel mode ;
 TUPLE: names-reply < irc-message who = channel ;
 TUPLE: unhandled < irc-message ;

@ -25,12 +26,44 @@ TUPLE: unhandled < irc-message ;
    irc-message new now >>timestamp
    [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;

+<PRIVATE
+
+GENERIC: irc-command-string ( irc-message -- string )
+
+M: irc-message irc-command-string ( irc-message -- string ) command>> ;
+M: ping        irc-command-string ( ping -- string )    drop "PING" ;
+M: join        irc-command-string ( join -- string )    drop "JOIN" ;
+M: part        irc-command-string ( part -- string )    drop "PART" ;
+M: quit        irc-command-string ( quit -- string )    drop "QUIT" ;
+M: nick        irc-command-string ( nick -- string )    drop "NICK" ;
+M: privmsg     irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
+M: notice      irc-command-string ( notice -- string )  drop "NOTICE" ;
+M: mode        irc-command-string ( mode -- string )    drop "MODE" ;
+M: kick        irc-command-string ( kick -- string )    drop "KICK" ;
+
+GENERIC: irc-command-parameters ( irc-message -- seq )
+
+M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
+M: ping        irc-command-parameters ( ping -- seq )    drop { } ;
+M: join        irc-command-parameters ( join -- seq )    drop { } ;
+M: part        irc-command-parameters ( part -- seq )    name>> 1array ;
+M: quit        irc-command-parameters ( quit -- seq )    drop { } ;
+M: nick        irc-command-parameters ( nick -- seq )    drop { } ;
+M: privmsg     irc-command-parameters ( privmsg -- seq ) name>> 1array ;
+M: notice      irc-command-parameters ( norice -- seq )  type>> 1array ;
+M: kick irc-command-parameters ( kick -- seq )
+    [ channel>> ] [ who>> ] bi 2array ;
+M: mode irc-command-parameters ( mode -- seq )
+    [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
+
+PRIVATE>
+
 GENERIC: irc-message>client-line ( irc-message -- string )

 M: irc-message irc-message>client-line ( irc-message -- string )
-    [ command>> ]
-    [ parameters>> " " sjoin ]
-    [ trailing>> dup [ CHAR: : prefix ] when ]
+    [ irc-command-string ]
+    [ irc-command-parameters " " sjoin ]
+    [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
    tri 3array " " sjoin ;

 GENERIC: irc-message>server-line ( irc-message -- string )
@ -73,19 +106,20 @@ PRIVATE>
 : parse-irc-line ( string -- message )
    string>irc-message
    dup command>> {
-        { "PING" [ \ ping ] }
-        { "NOTICE" [ \ notice ] }
-        { "001" [ \ logged-in ] }
-        { "433" [ \ nick-in-use ] }
-        { "353" [ \ names-reply ] }
-        { "JOIN" [ \ join ] }
-        { "PART" [ \ part ] }
-        { "PRIVMSG" [ \ privmsg ] }
-        { "QUIT" [ \ quit ] }
-        { "MODE" [ \ mode ] }
-        { "KICK" [ \ kick ] }
-        [ drop \ unhandled ]
+        { "PING" [ ping ] }
+        { "NOTICE" [ notice ] }
+        { "001" [ logged-in ] }
+        { "433" [ nick-in-use ] }
+        { "353" [ names-reply ] }
+        { "JOIN" [ join ] }
+        { "PART" [ part ] }
+        { "NICK" [ nick ] }
+        { "PRIVMSG" [ privmsg ] }
+        { "QUIT" [ quit ] }
+        { "MODE" [ mode ] }
+        { "KICK" [ kick ] }
+        [ drop unhandled ]
    } case
    [ [ tuple-slots ] [ parameters>> ] bi append ] dip
-    [ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
-
+    [ all-slots over [ length ] bi@ min head >quotation ] keep
+    '[ @ , boa nip ] call ;
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@ -5,10 +5,12 @@ USING: accessors kernel threads combinators concurrency.mailboxes
       sequences strings hashtables splitting fry assocs hashtables
       ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
       ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
-       ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
-       io io.styles namespaces calendar calendar.format models
+       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.messages.private
-       irc.ui.commandparser irc.ui.load ;
+       irc.ui.commandparser irc.ui.load qualified ;
+
+RENAME: join sequences => sjoin

 IN: irc.ui

@ -18,7 +20,7 @@ SYMBOL: client

 TUPLE: ui-window client tabs ;

-TUPLE: irc-tab < frame listener client listmodel ;
+TUPLE: irc-tab < frame listener client userlist ;

 : write-color ( str color -- )
    foreground associate format ;
@ -37,12 +39,20 @@ TUPLE: irc-tab < frame listener client listmodel ;

 GENERIC: write-irc ( irc-message -- )

+M: ping write-irc
+    drop "* Ping" blue write-color ;
+
 M: privmsg write-irc
    "<" blue write-color
    [ prefix>> parse-name write ] keep
    "> " blue write-color
    trailing>> write ;

+M: notice write-irc
+    [ type>> blue write-color ] keep
+    ": " blue write-color
+    trailing>> write ;
+
 TUPLE: own-message message nick timestamp ;

 : <own-message> ( message nick -- own-message )
@ -71,14 +81,21 @@ M: quit write-irc
    " has left IRC" red write-color
    trailing>> dot-or-parens red write-color ;

+: full-mode ( message -- mode )
+    parameters>> rest " " sjoin ;
+
 M: mode write-irc
    "* " blue write-color
-    [ name>> write ] keep
+    [ prefix>> parse-name write ] keep
    " has applied mode " blue write-color
-    [ mode>> write ] keep
+    [ full-mode write ] keep
    " to " blue write-color
    channel>> write ;

+M: unhandled write-irc
+    "UNHANDLED: " write
+    line>> blue write-color ;
+
 M: irc-end write-irc
    drop "* You have left IRC" red write-color ;

@ -88,11 +105,17 @@ M: irc-disconnected write-irc
 M: irc-connected write-irc
    drop "* Connected" green write-color ;

+M: irc-listener-end write-irc
+    drop ;
+
 M: irc-message write-irc
    drop ; ! catch all unimplemented writes, THIS WILL CHANGE    

+: time-happened ( irc-message -- timestamp )
+    [ timestamp>> ] [ 2drop now ] recover ;
+
 : print-irc ( irc-message -- )
-    [ timestamp>> timestamp>hms write " " write ]
+    [ time-happened timestamp>hms write " " write ]
    [ write-irc nl ] bi ;

 : send-message ( message -- )
@ -101,16 +124,15 @@ M: irc-message write-irc

 GENERIC: handle-inbox ( tab message -- )

-: filter-participants ( assoc val -- alist )
-    [ >alist ] dip
-   '[ second , = ] filter ;
+: filter-participants ( pack alist val color -- pack )
+   '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;

 : update-participants ( tab -- )
-    [ listmodel>> ] [ listener>> participants>> ] bi
-    [ +operator+ filter-participants ]
-    [ +voice+ filter-participants ]
-    [ +normal+ filter-participants ] tri
-    append append swap set-model ;
+    [ userlist>> [ clear-gadget ] keep ]
+    [ listener>> participants>> ] bi
+    [ +operator+ green filter-participants ]
+    [ +voice+ blue filter-participants ]
+    [ +normal+ black filter-participants ] tri drop ;

 M: participant-changed handle-inbox
    drop update-participants ;
@ -147,11 +169,6 @@ irc-editor "general" f {
    { T{ key-down f f "ENTER" } editor-send }
 } define-command-map

-: <irc-list> ( -- gadget model )
-    [ drop ]
-    [ first2 [ <label> ] dip >>color ]
-    { } <model> [ <list> ] keep ;
-
 : <irc-tab> ( listener client -- irc-tab )
    irc-tab new-frame
    swap client>> >>client swap >>listener
@ -160,19 +177,19 @@ irc-editor "general" f {

 : <irc-channel-tab> ( listener client -- irc-tab )
    <irc-tab>
-    <irc-list> [ <scroller> @right grid-add ] dip >>listmodel
-    [ update-participants ] keep ;
+    <pile> [ <scroller> @right grid-add ] keep >>userlist ;

 : <irc-server-tab> ( listener client -- irc-tab )
    <irc-tab> ;

 M: irc-tab graft*
-    [ listener>> ] [ client>> ] bi
-    add-listener ;
+    [ listener>> ] [ client>> ] bi add-listener ;

 M: irc-tab ungraft*
-    [ listener>> ] [ client>> ] bi
-    remove-listener ;
+    [ listener>> ] [ client>> ] bi remove-listener ;
+
+M: irc-tab pref-dim*
+    drop { 480 480 } ;

 : join-channel ( name ui-window -- )
    [ dup <irc-channel-listener> ] dip
@ -187,8 +204,9 @@ M: irc-tab ungraft*
 : ui-connect ( profile -- ui-window )
    <irc-client> ui-window new over >>client swap
    [ connect-irc ]
+    [ [ <irc-server-listener> ] dip add-listener ]
    [ listeners>> +server-listener+ swap at over <irc-tab>
-      "Server" associate <tabbed> >>tabs ] bi ;
+      "Server" associate <tabbed> >>tabs ] tri ;

 : server-open ( server port nick password channels -- )
    [ <irc-profile> ui-connect [ irc-window ] keep ] dip
--- a/extra/lsys/ui/tags.txt
+++ b/extra/lsys/ui/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/processing/color/color.factor
+++ b/extra/processing/color/color.factor
@ -1,22 +0,0 @@
-
-USING: kernel sequences ;
-
-IN: processing.color
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: rgba red green blue alpha ;
-
-C: <rgba> rgba
-
-: <rgb> ( r g b -- rgba ) 1 <rgba> ;
-
-: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
-
-: {rgb} ( seq -- rgba ) first3 <rgb> ;
-
-! : hex>rgba ( hex -- rgba )
-
-! : set-gl-color ( color -- )
-!   { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
-
--- a/extra/space-invaders/tags.txt
+++ b/extra/space-invaders/tags.txt
@ -1,2 +1,3 @@
+demos
 games
 applications
--- a/extra/springies/models/2snake/tags.txt
+++ b/extra/springies/models/2snake/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/2x2snake/tags.txt
+++ b/extra/springies/models/2x2snake/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/3snake/tags.txt
+++ b/extra/springies/models/3snake/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/ball/tags.txt
+++ b/extra/springies/models/ball/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/belt-tire/tags.txt
+++ b/extra/springies/models/belt-tire/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/nifty/tags.txt
+++ b/extra/springies/models/nifty/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/models/urchin/tags.txt
+++ b/extra/springies/models/urchin/tags.txt
@ -0,0 +1 @@
+demos
--- a/extra/springies/ui/ui.factor
+++ b/extra/springies/ui/ui.factor
@ -23,7 +23,9 @@ IN: springies.ui
  GL_MODELVIEW glMatrixMode
  glLoadIdentity ;

-: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+
+: display ( -- ) set-projection black set-color draw-nodes draw-springs ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/tetris/tags.txt
+++ b/extra/tetris/tags.txt
@ -1,2 +1,3 @@
+demos
 applications
 games
--- a/extra/ui/gadgets/cartesian/cartesian.factor
+++ b/extra/ui/gadgets/cartesian/cartesian.factor
@ -22,20 +22,15 @@ TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-M: cartesian draw-gadget* ( cartesian -- )
-   GL_PROJECTION glMatrixMode
-   glLoadIdentity
+M: cartesian establish-coordinate-system ( cartesian -- cartesian )
   dup
-       {
-         [ x-min>> ] [ x-max>> ]
-         [ y-min>> ] [ y-max>> ]
-         [ z-min>> ] [ z-max>> ]
-       }
-     cleave
-     glOrtho
-   GL_MODELVIEW glMatrixMode
-   glLoadIdentity
-   call-next-method ;
+   {
+     [ x-min>> ] [ x-max>> ]
+     [ y-min>> ] [ y-max>> ]
+     [ z-min>> ] [ z-max>> ]
+   }
+   cleave
+   glOrtho ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/ui/gadgets/plot/plot.factor
+++ b/extra/ui/gadgets/plot/plot.factor
@ -47,16 +47,91 @@ M: function plot-function ( plot function -- plot )
    [ [ drop 0  ] [ y-min>> ] bi 2array ]
    [ [ drop 0  ] [ y-max>> ] bi 2array ] bi line* ;

-M: plot draw-gadget* ( plot -- )
-   dup call-next-method
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gadgets.slate ;
+
+M: plot draw-slate ( plot -- plot )
   2 glLineWidth
   draw-axis
   plot-functions
-   drop
   fill-mode
   1 glLineWidth ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 : add-function ( plot function -- plot )
-  over functions>> swap suffix >>functions ;
+  over functions>> swap suffix >>functions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
+: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gestures ui.gadgets ;
+
+: left ( plot -- plot )
+  dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+  dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
+  dup relayout-1 ;
+
+: right ( plot -- plot )
+  dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+  dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
+  dup relayout-1 ;
+
+: down ( plot -- plot )
+  dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+  dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
+  dup relayout-1 ;
+
+: up ( plot -- plot )
+  dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+  dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
+  dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-in-horizontal ( plot -- plot )
+  dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+  dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
+
+: zoom-in-vertical ( plot -- plot )
+  dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+  dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
+
+: zoom-in ( plot -- plot )
+  zoom-in-horizontal
+  zoom-in-vertical
+  dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-out-horizontal ( plot -- plot )
+  dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+  dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
+
+: zoom-out-vertical ( plot -- plot )
+  dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+  dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
+
+: zoom-out ( plot -- plot )
+  zoom-out-horizontal
+  zoom-out-vertical
+  dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+plot
+  H{
+    { T{ mouse-enter } [ request-focus ] }
+    { T{ key-down f f "LEFT"  } [ left drop  ] }
+    { T{ key-down f f "RIGHT" } [ right drop ] }
+    { T{ key-down f f "DOWN"  } [ down drop  ] }
+    { T{ key-down f f "UP"    } [ up drop    ] }
+    { T{ key-down f f "a"     } [ zoom-in  drop ] }
+    { T{ key-down f f "z"     } [ zoom-out drop ] }
+  }
+set-gestures
--- a/extra/ui/gadgets/slate/slate.factor
+++ b/extra/ui/gadgets/slate/slate.factor
@ -21,8 +21,96 @@ TUPLE: slate < gadget action pdim graft ungraft ;

 M: slate pref-dim* ( slate -- dim ) pdim>> ;

-M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+       opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+  {
+    [ find-world height ]
+    [ screen-loc second ]
+    [ height ]
+  }
+  cleave
+  + - ;
+
+: screen-loc* ( gadget -- loc )
+  {
+    [ screen-loc first ]
+    [ screen-y* ]
+  }
+  cleave
+  2array ;
+
+: setup-viewport ( gadget -- gadget )
+  dup
+  {
+    [ screen-loc* ]
+    [ dim>>       ]
+  }
+  cleave
+  gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+  dup
+  {
+    [ drop 0 ]
+    [ width 1 - ]
+    [ height 1 - ]
+    [ drop 0 ]
+  }
+  cleave
+  -1 1
+  glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 M: slate graft*   ( slate -- ) graft>>   call ;
 M: slate ungraft* ( slate -- ) ungraft>> call ;

+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+   default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+   GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+   establish-coordinate-system
+
+   GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity 
+
+   setup-viewport
+
+   draw-slate
+
+   GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+   GL_MODELVIEW  glMatrixMode glPopMatrix glLoadIdentity
+
+   dup
+   find-world
+   ! The world coordinate system is a little wacky:
+   dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+   setup-viewport
+   drop
+   drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor
@ -166,19 +166,6 @@ M: object xyz ;
    \ +-integer-fixnum inlined?
 ] unit-test

-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-] unit-test
-
 [ t ] [
    [ { array-capacity } declare 0 < ] \ < inlined?
 ] unit-test
@ -208,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- )

 M: fixnum annotate-entry-test-1 drop ;

-: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
-    2over >= [
-        3drop
+: (annotate-entry-test-2) ( from to -- )
+    2dup >= [
+        2drop
    ] [
-        [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
+        >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
    ] if ; inline recursive

 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline

 [ f ] [
-    [ { bignum } declare [ ] annotate-entry-test-2 ]
+    [ { bignum } declare annotate-entry-test-2 ]
    \ annotate-entry-test-1 inlined?
 ] unit-test

@ -277,11 +264,6 @@ cell-bits 32 = [
    ] unit-test
 ] when

-[ f ] [
-    [ { integer } declare -63 shift 4095 bitand ]
-    \ shift inlined?
-] unit-test
-
 [ t ] [
    [ B{ 1 0 } *short 0 number= ]
    \ number= inlined?
@ -328,36 +310,6 @@ cell-bits 32 = [
    ] \ + inlined?
 ] unit-test

-[ f ] [
-    [
-        256 mod
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ f ] [
-    [
-        dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare 256 rem
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare [ 256 rem ] map
-    ] { mod fixnum-mod rem } inlined?
-] unit-test
-
 [ t ] [
    [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
 ] unit-test
@ -393,21 +345,6 @@ cell-bits 32 = [
    [ 27/2 fib ] { < - } inlined?
 ] unit-test

-: hang-regression ( m n -- x )
-    over 0 number= [
-        nip
-    ] [
-        dup [
-            drop 1 hang-regression
-        ] [
-            dupd hang-regression hang-regression
-        ] if
-    ] if ; inline recursive
-
-[ t ] [
-    [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
-] { } inlined? ] unit-test
-
 [ t ] [
    [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
 ] unit-test
@ -421,16 +358,6 @@ cell-bits 32 = [
    \ fixnum-bitand inlined?
 ] unit-test

-[ t ] [
-    [ { integer } declare 127 bitand 3 + ]
-    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
-] unit-test
-
-[ f ] [
-    [ { integer } declare 127 bitand 3 + ]
-    { >fixnum } inlined?
-] unit-test
-
 [ t ] [
    [ { fixnum } declare [ drop ] each-integer ]
    { < <-integer-fixnum +-integer-fixnum + } inlined?
@ -448,7 +375,7 @@ cell-bits 32 = [

 [ t ] [
    [ { fixnum } declare 0 [ + ] reduce ]
-    { < <-integer-fixnum } inlined?
+    { < <-integer-fixnum nth-unsafe } inlined?
 ] unit-test

 [ f ] [
@ -456,22 +383,6 @@ cell-bits 32 = [
    \ +-integer-fixnum inlined?
 ] unit-test

-[ t ] [
-    [
-        { integer } declare
-        dup 0 >= [
-            615949 * 797807 + 20 2^ mod dup 19 2^ -
-        ] [ dup ] if
-    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { fixnum } declare
-        615949 * 797807 + 20 2^ mod dup 19 2^ -
-    ] { >fixnum } inlined?
-] unit-test
-
 [ f ] [
    [
        { integer } declare [ ] map
@ -490,56 +401,6 @@ cell-bits 32 = [
    ] \ >fixnum inlined?
 ] unit-test

-[ t ] [
-    [
-        { integer } declare 0 swap
-        [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { fixnum } declare 0 swap
-        [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
-] unit-test
-
-[ t ] [
-    [ hashtable new ] \ new inlined?
-] unit-test
-
-[ t ] [
-    [ dup hashtable eq? [ new ] when ] \ new inlined?
-] unit-test
-
-[ t ] [
-    [ { hashtable } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-[ t ] [
-    [ { vector } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-[ f ] [
-    [ { assoc } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-TUPLE: declared-fixnum { x fixnum } ;
-
-[ t ] [
-    [ { declared-fixnum } declare [ 1 + ] change-x ]
-    { + fixnum+ >fixnum } inlined?
-] unit-test
-
-[ t ] [
-    [ { declared-fixnum } declare x>> drop ]
-    { slot } inlined?
-] unit-test
-
 [ t ] [
    [
        { array } declare length
@ -565,12 +426,6 @@ TUPLE: declared-fixnum { x fixnum } ;

 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test

-[ t ] [
-    [
-        { integer } declare [ 256 mod ] map
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
 [ t ] [
    [
        { integer } declare [ 0 >= ] map
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-namespaces
+classes.algebra namespaces assocs math math.private
+math.partial-dispatch
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@ -20,7 +21,13 @@ GENERIC: cleanup* ( node -- node/nodes )
    #! do it since the logic is a bit more involved
    [ cleanup* ] map flatten ;

-: cleanup-constant-folding ( #call -- nodes )
+: cleanup-folding? ( #call -- ? )
+    node-output-infos dup empty?
+    [ drop f ] [ [ literal?>> ] all? ] if ;
+
+: cleanup-folding ( #call -- nodes )
+    #! Replace a #call having a known result with a #drop of its
+    #! inputs followed by #push nodes for the outputs.
    [
        [ node-output-infos ] [ out-d>> ] bi
        [ [ literal>> ] dip #push ] 2map
@ -30,10 +37,27 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup-inlining ( #call -- nodes )
    body>> cleanup ;

+! Removing overflow checks
+: no-overflow-variant ( op -- fast-op )
+    H{
+        { fixnum+ fixnum+fast }
+        { fixnum- fixnum-fast }
+        { fixnum* fixnum*fast }
+        { fixnum-shift fixnum-shift-fast }
+    } at ;
+
+: remove-overflow-check? ( #call -- ? )
+    dup word>> no-overflow-variant
+    [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+
+: remove-overflow-check ( #call -- #call )
+    [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+
 M: #call cleanup*
    {
-        { [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
        { [ dup body>> ] [ cleanup-inlining ] }
+        { [ dup cleanup-folding? ] [ cleanup-folding ] }
+        { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
        [ ]
    } cond ;

--- a/unfinished/compiler/tree/combinators/combinators.factor
+++ b/unfinished/compiler/tree/combinators/combinators.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel accessors sequences sequences.deep
-compiler.tree ;
+USING: fry kernel accessors sequences sequences.deep arrays
+stack-checker.inlining namespaces compiler.tree ;
 IN: compiler.tree.combinators

 : each-node ( nodes quot: ( node -- ) -- )
@ -44,3 +44,14 @@ IN: compiler.tree.combinators

 : select-children ( seq flags -- seq' )
    [ [ drop f ] unless ] 2map ;
+
+: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
+
+: until-fixed-point ( #recursive quot -- )
+    over label>> t >>fixed-point drop
+    [ with-scope ] 2keep
+    over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; inline
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
@ -0,0 +1,25 @@
+IN: compiler.tree.copy-equiv.tests
+USING: compiler.tree.copy-equiv tools.test namespaces kernel
+assocs ;
+
+H{ } clone copies set
+
+[ ] [ 0 introduce-value ] unit-test
+[ ] [ 1 introduce-value ] unit-test
+[ ] [ 1 2 is-copy-of ] unit-test
+[ ] [ 2 3 is-copy-of ] unit-test
+[ ] [ 2 4 is-copy-of ] unit-test
+[ ] [ 4 5 is-copy-of ] unit-test
+[ ] [ 0 6 is-copy-of ] unit-test
+
+[ 0 ] [ 0 resolve-copy ] unit-test
+[ 1 ] [ 5 resolve-copy ] unit-test
+
+! Make sure that we did path compression
+[ 1 ] [ 5 copies get at ] unit-test
+
+[ 1 ] [ 1 resolve-copy ] unit-test
+[ 1 ] [ 2 resolve-copy ] unit-test
+[ 1 ] [ 3 resolve-copy ] unit-test
+[ 1 ] [ 4 resolve-copy ] unit-test
+[ 0 ] [ 6 resolve-copy ] unit-test
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
@ -1,23 +1,37 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces disjoint-sets sequences assocs math
-kernel accessors fry
-compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+USING: namespaces sequences assocs math kernel accessors fry
+combinators sets locals
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv

 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation).

-! Disjoint set of copy equivalence
+! Mapping from values to their canonical leader
 SYMBOL: copies

-: is-copy-of ( val copy -- ) copies get equate ;
+:: compress-path ( source assoc -- destination )
+    [let | destination [ source assoc at ] |
+        source destination = [ source ] [
+            [let | destination' [ destination assoc compress-path ] |
+                destination' destination = [
+                    destination' source assoc set-at
+                ] unless
+                destination'
+            ]
+        ] if
+    ] ;
+
+: resolve-copy ( copy -- val ) copies get compress-path ;
+
+: is-copy-of ( val copy -- ) copies get set-at ;

 : are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;

-: resolve-copy ( copy -- val ) copies get representative ;
-
-: introduce-value ( val -- ) copies get add-atom ;
+: introduce-value ( val -- ) copies get conjoin ;

 GENERIC: compute-copy-equiv* ( node -- )

@ -60,5 +74,5 @@ M: node compute-copy-equiv* drop ;
    ] each-node ;

 : compute-copy-equiv ( node -- node )
-    <disjoint-set> copies set
+    H{ } clone copies set
    dup amend-copy-equiv ;
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@ -0,0 +1,28 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs namespaces sequences kernel math
+stack-checker.state compiler.tree.copy-equiv ;
+IN: compiler.tree.escape-analysis.allocations
+
+SYMBOL: escaping
+
+! A map from values to sequences of values or 'escaping'
+SYMBOL: allocations
+
+: allocation ( value -- allocation )
+    resolve-copy allocations get at ;
+
+: record-allocation ( allocation value -- )
+    allocations get set-at ;
+
+: record-allocations ( allocations values -- )
+    [ record-allocation ] 2each ;
+
+: record-slot-access ( out slot# in -- )
+    over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
+
+! A map from values to sequences of values
+SYMBOL: slot-merging
+
+: merge-slots ( values -- value )
+    <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@ -0,0 +1,32 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences
+compiler.tree
+compiler.tree.propagation.branches
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.branches
+
+SYMBOL: children-escape-data
+
+M: #branch escape-analysis*
+    live-children sift [ (escape-analysis) ] each ;
+
+: (merge-allocations) ( values -- allocation )
+    [
+        [ allocation ] map dup [ ] all? [
+            dup [ length ] map all-equal? [
+                flip
+                [ (merge-allocations) ] [ [ merge-slots ] map ] bi
+                [ record-allocations ] keep
+            ] [ drop f ] if
+        ] [ drop f ] if
+    ] map ;
+
+: merge-allocations ( in-values out-values -- )
+    [ (merge-allocations) ] dip record-allocations ;
+
+M: #phi escape-analysis*
+    [ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]
+    [ [ phi-in-r>> ] [ out-r>> ] bi merge-allocations ]
+    bi ;
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces search-dequeues
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations
+compiler.tree.escape-analysis.recursive
+compiler.tree.escape-analysis.branches
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.work-list ;
+IN: compiler.tree.escape-analysis
+
+: escape-analysis ( node -- node )
+    H{ } clone slot-merging set
+    H{ } clone allocations set
+    <hashed-dlist> work-list set
+    dup (escape-analysis) ;
--- a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
+++ b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
@ -0,0 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences compiler.tree ;
+IN: compiler.tree.escape-analysis.nodes
+
+GENERIC: escape-analysis* ( node -- )
+
+M: node escape-analysis* drop ;
+
+: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
@ -0,0 +1,16 @@
+IN: compiler.tree.escape-analysis.recursive.tests
+USING: kernel tools.test namespaces sequences
+compiler.tree.copy-equiv
+compiler.tree.escape-analysis.recursive
+compiler.tree.escape-analysis.allocations ;
+
+H{ } clone allocations set
+H{ } clone copies set
+
+[ ] [ 8 [ introduce-value ] each ] unit-test
+
+[ ] [ { 1 2 } 3 record-allocation ] unit-test
+
+[ t ] [ { 1 2 } { 6 7 } congruent? ] unit-test
+[ f ] [ { 3 4 } { 6 7 } congruent? ] unit-test
+[ f ] [ { 3 4 5 } { 6 7 } congruent? ] unit-test
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@ -0,0 +1,56 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math combinators accessors namespaces
+compiler.tree
+compiler.tree.copy-equiv
+compiler.tree.combinators
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.branches
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.recursive
+
+: congruent? ( alloc1 alloc2 -- ? )
+    2dup [ length ] bi@ = [
+        [ [ allocation ] bi@ congruent? ] 2all?
+    ] [ 2drop f ] if ;
+
+: check-fixed-point ( node alloc1 alloc2 -- node )
+    congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
+
+: node-input-allocations ( node -- allocations )
+    in-d>> [ allocation ] map ;
+
+: node-output-allocations ( node -- allocations )
+    out-d>> [ allocation ] map ;
+
+: recursive-stacks ( #enter-recursive -- stacks )
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+
+: analyze-recursive-phi ( #enter-recursive -- )
+    [ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri
+    [ [ allocation ] map check-fixed-point drop ] 2keep
+    record-allocations ;
+
+M: #recursive escape-analysis* ( #recursive -- )
+    [
+        copies [ clone ] change
+
+        child>>
+        [ first analyze-recursive-phi ]
+        [ (escape-analysis) ]
+        bi
+    ] until-fixed-point ;
+
+M: #call-recursive escape-analysis* ( #call-label -- )
+    dup
+    [ node-output-allocations ]
+    [ label>> return>> node-input-allocations ] bi
+    [ check-fixed-point ] keep
+    swap out-d>> record-allocations ;
+
+! M: #return-recursive escape-analysis* ( #return-recursive -- )
+!     dup dup label>> calls>> dup empty? [ 3drop ] [
+!         [ node-input-allocations ]
+!         [ first node-output-allocations ] bi*
+!         check-fixed-point drop
+!     ] if ;
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences classes.tuple
+classes.tuple.private math math.private slots.private
+combinators dequeues search-dequeues namespaces fry
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.work-list
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.simple
+
+: record-tuple-allocation ( #call -- )
+    #! Delegation.
+    dup dup in-d>> peek node-value-info literal>>
+    class>> all-slots rest-slice [ read-only>> ] all? [
+        [ in-d>> but-last ] [ out-d>> first ] bi
+        record-allocation
+    ] [ drop ] if ;
+
+: record-slot-call ( #call -- )
+    [ out-d>> first ]
+    [ dup in-d>> second node-value-info literal>> ]
+    [ in-d>> first ] tri
+    over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
+
+M: #call escape-analysis*
+    dup word>> {
+        { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ slot [ record-slot-call ] }
+        [ drop in-d>> add-escaping-values ]
+    } case ;
+
+M: #return escape-analysis*
+    in-d>> add-escaping-values ;
--- a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
+++ b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dequeues namespaces sequences fry ;
+IN: compiler.tree.escape-analysis.work-list
+
+SYMBOL: work-list
+
+: add-escaping-values ( values -- )
+    work-list get '[ , push-front ] each ;
--- a/unfinished/compiler/tree/normalization/normalization.factor
+++ b/unfinished/compiler/tree/normalization/normalization.factor
@ -9,8 +9,9 @@ IN: compiler.tree.normalization
 ! fix up some oddities in the tree output by the stack checker:
 !
 ! - We rewrite the code is that #introduce nodes only appear
-! at the top level, and not inside #recursive. This enables more
-! accurate type inference for 'row polymorphic' combinators.
+! at the beginning of a program, never having #introduce follow
+! any other type of node or appear inside a #branch or
+! #recursive. This simplifies some types of analysis.
 !
 ! - We collect #return-recursive and #call-recursive nodes and
 ! store them in the #recursive's label slot.
@ -46,6 +47,10 @@ M: #branch count-introductions*
    [ count-introductions ] map supremum
    introductions [ + ] change ;

+M: #recursive count-introductions*
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions drop ;
+
 M: node count-introductions* drop ;

 ! Collect label info
@ -58,18 +63,16 @@ M: #call-recursive collect-label-info
    dup label>> calls>> push ;

 M: #recursive collect-label-info
-    [ label>> V{ } clone >>calls ]
-    [ child>> count-introductions ]
-    bi >>introductions drop ;
+    label>> V{ } clone >>calls drop ;

 M: node collect-label-info drop ;

 ! Eliminate introductions
 SYMBOL: introduction-stack

-: fixup-enter-recursive ( recursive -- )
+: fixup-enter-recursive ( introductions recursive -- )
    [ child>> first ] [ in-d>> ] bi >>in-d
-    [ introduction-stack get prepend ] change-out-d
+    [ append ] change-out-d
    drop ;

 GENERIC: eliminate-introductions* ( node -- node' )
@ -93,23 +96,37 @@ M: #branch eliminate-introductions*
    [ [ length ] map infimum introduction-stack [ swap head ] change ]
    bi ;

+: eliminate-phi-introductions ( introductions seq terminated -- seq' )
+    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+
 M: #phi eliminate-introductions*
-    remaining-introductions get swap
-    [ flip [ over length tail append ] 2map flip ] change-phi-in-d ;
+    remaining-introductions get swap dup terminated>>
+    '[ , eliminate-phi-introductions ] change-phi-in-d ;

 M: node eliminate-introductions* ;

-: eliminate-introductions ( recursive n -- )
-    make-values introduction-stack [
-        [ fixup-enter-recursive ]
-        [ child>> [ eliminate-introductions* ] change-each ] bi
+: eliminate-introductions ( nodes introductions -- nodes )
+    introduction-stack [
+        [ eliminate-introductions* ] map
    ] with-variable ;

+: eliminate-toplevel-introductions ( nodes -- nodes' )
+    dup count-introductions make-values
+    [ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi
+    append ;
+
+: eliminate-recursive-introductions ( recursive n -- )
+    make-values
+    [ swap fixup-enter-recursive ]
+    [ '[ , eliminate-introductions ] change-child drop ]
+    2bi ;
+
 ! Normalize
 GENERIC: normalize* ( node -- node' )

 M: #recursive normalize*
-    dup dup label>> introductions>> eliminate-introductions ;
+    dup dup label>> introductions>>
+    eliminate-recursive-introductions ;

 : unchanged-underneath ( #call-recursive -- n )
    [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
@ -123,6 +140,6 @@ M: #call-recursive normalize*
 M: node normalize* ;

 : normalize ( nodes -- nodes' )
-    [ [ collect-label-info ] each-node ]
-    [ [ normalize* ] map-nodes ]
-    bi ;
+    dup [ collect-label-info ] each-node
+    eliminate-toplevel-introductions
+    [ normalize* ] map-nodes ;
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@ -24,7 +24,7 @@ GENERIC: live-branches ( #branch -- indices )

 M: #if live-branches
    in-d>> first value-info class>> {
-        { [ dup null class<= ] [ { f f } ] }
+        { [ dup null-class? ] [ { f f } ] }
        { [ dup true-class? ] [ { t f } ] }
        { [ dup false-class? ] [ { f t } ] }
        [ { t t } ]
@ -43,18 +43,17 @@ SYMBOL: infer-children-data
    value-infos [ clone ] change
    constraints [ clone ] change ;

+: no-value-info ( -- )
+    value-infos off
+    constraints off ;
+
 : infer-children ( node -- )
    [ live-children ] [ child-constraints ] bi [
        [
-            over [
-                copy-value-info
-                assume
-                (propagate)
-            ] [
-                2drop
-                value-infos off
-                constraints off
-            ] if
+            over
+            [ copy-value-info assume (propagate) ]
+            [ 2drop no-value-info ]
+            if
        ] H{ } make-assoc
    ] 2map infer-children-data set ;

--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
-sequences namespaces disjoint-sets classes classes.algebra
+sequences namespaces classes classes.algebra
 combinators words
 compiler.tree compiler.tree.propagation.info
 compiler.tree.copy-equiv ;
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@ -68,6 +68,5 @@ TUPLE: test-tuple { x read-only } ;

 [ t ] [
    f f 3 <literal-info> 3array test-tuple <tuple-info> dup
-    object <class-info>
-    value-info-intersect =
+    object-info value-info-intersect =
 ] unit-test
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@ -5,6 +5,12 @@ accessors math math.intervals namespaces sequences words
 combinators arrays compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info

+: false-class? ( class -- ? ) \ f class<= ;
+
+: true-class? ( class -- ? ) \ f class-not class<= ;
+
+: null-class? ( class -- ? ) null class<= ;
+
 SYMBOL: +interval+

 GENERIC: eql? ( obj1 obj2 -- ? )
@ -29,6 +35,8 @@ slots ;

 : null-info T{ value-info f null empty-interval } ; inline

+: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+
 : class-interval ( class -- interval )
    dup real class<=
    [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@ -57,7 +65,7 @@ slots ;
        dup literal>> class >>class
        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
    ] [
-        dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
+        dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
            null >>class
            empty-interval >>interval
        ] [
@ -154,8 +162,8 @@ DEFER: (value-info-intersect)

 : value-info-intersect ( info1 info2 -- info )
    {
-        { [ dup class>> null class<= ] [ nip ] }
-        { [ over class>> null class<= ] [ drop ] }
+        { [ dup class>> null-class? ] [ nip ] }
+        { [ over class>> null-class? ] [ drop ] }
        [ (value-info-intersect) ]
    } cond ;

@ -200,8 +208,8 @@ DEFER: (value-info-union)

 : value-info-union ( info1 info2 -- info )
    {
-        { [ dup class>> null class<= ] [ drop ] }
-        { [ over class>> null class<= ] [ nip ] }
+        { [ dup class>> null-class? ] [ drop ] }
+        { [ over class>> null-class? ] [ nip ] }
        [ (value-info-union) ]
    } cond ;

@ -225,16 +233,12 @@ SYMBOL: value-infos
 : value-literal ( value -- obj ? )
    value-info >literal< ;

-: false-class? ( class -- ? ) \ f class<= ;
-
-: true-class? ( class -- ? ) \ f class-not class<= ;
-
 : possible-boolean-values ( info -- values )
    dup literal?>> [
        literal>> 1array
    ] [
        class>> {
-            { [ dup null class<= ] [ { } ] }
+            { [ dup null-class? ] [ { } ] }
            { [ dup true-class? ] [ { t } ] }
            { [ dup false-class? ] [ { f } ] }
            [ { t f } ]
--- a/unfinished/compiler/tree/propagation/inlining/inlining.factor
+++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor
@ -142,3 +142,8 @@ SYMBOL: history

 : inline-method-body ( #call word -- ? )
    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+
+: always-inline-word? ( word -- ? )
+    { curry compose } memq? ;
+
+: always-inline-word ( #call word -- ? ) inline-word t ;
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@ -5,10 +5,12 @@ 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
-compiler.tree.propagation.info compiler.tree.propagation.nodes
-compiler.tree.propagation.constraints
+compiler.tree.comparisons
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.slots
-compiler.tree.comparisons ;
+compiler.tree.propagation.simple
+compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.known-words

 \ fixnum
@ -76,7 +78,7 @@ most-negative-fixnum most-positive-fixnum [a,b]

 : binary-op-class ( info1 info2 -- newclass )
    [ class>> ] bi@
-    2dup [ null class<= ] either? [ 2drop null ] [
+    2dup [ null-class? ] either? [ 2drop null ] [
        [ math-closure ] bi@ math-class-max
    ] if ;

@ -87,13 +89,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
    [ fixnum class<= ] [ fixnum fits? ] bi* and ;

 : may-overflow ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
        2dup won't-overflow?
        [ [ integer math-class-max ] dip ] unless
    ] unless ;

 : may-be-rational ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
        [ rational math-class-max ] dip
    ] unless ;

@ -107,7 +109,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
    [ real math-class-min ] dip ;

 : float-valued ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
        [ drop float ] dip
    ] unless ;

@ -167,7 +169,7 @@ generic-comparison-ops [
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
    [ [ interval>> ] bi@ ] dip interval-comparison {
-        { incomparable [ object <class-info> ] }
+        { incomparable [ object-info ] }
        { t [ t <literal-info> ] }
        { f [ f <literal-info> ] }
    } case ;
@ -184,7 +186,7 @@ generic-comparison-ops [
 ] each

 : maybe-or-never ( ? -- info )
-    [ object <class-info> ] [ \ f <class-info> ] if ;
+    [ object-info ] [ f <literal-info> ] if ;

 : info-intervals-intersect? ( info1 info2 -- ? )
    [ interval>> ] bi@ intervals-intersect? ;
@ -198,6 +200,12 @@ generic-comparison-ops [
 : info-classes-intersect? ( info1 info2 -- ? )
    [ class>> ] bi@ classes-intersect? ;

+\ eq? [
+    over value-info literal>> fixnum? [
+        [ value-info literal>> is-equal-to ] dip t-->
+    ] [ 3drop f ] if
+] +constraints+ set-word-prop
+
 \ eq? [
    [ info-intervals-intersect? ]
    [ info-classes-intersect? ]
@ -259,5 +267,16 @@ generic-comparison-ops [

 \ slot [
    dup literal?>>
-    [ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
+    [ literal>> swap value-info-slot ] [ 2drop object-info ] if
+] +outputs+ set-word-prop
+
+\ instance? [
+    [ value-info ] dip over literal>> class? [
+        [ literal>> ] dip predicate-constraints
+    ] [ 2drop f ] if
+] +constraints+ set-word-prop
+
+\ instance? [
+    dup literal>> class?
+    [ literal>> predicate-output-infos ] [ 2drop f ] if
 ] +outputs+ set-word-prop
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@ -5,7 +5,8 @@ accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
 byte-arrays classes.algebra classes.tuple.private
 math.functions math.private strings layouts
-compiler.tree.propagation.info slots.private ;
+compiler.tree.propagation.info slots.private words hashtables
+classes assocs ;
 IN: compiler.tree.propagation.tests

 \ propagate must-infer
@ -323,6 +324,10 @@ cell-bits 32 = [

 [ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test

+[ V{ 10 } ] [
+    [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
+] unit-test
+
 ! Slot propagation
 TUPLE: prop-test-tuple { x integer } ;

@ -475,3 +480,59 @@ M: array iterate first t ;
    iterate [ dead-loop ] when ; inline recursive

 [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
+
+: hang-1 ( m -- x )
+    dup 0 number= [ hang-1 ] unless ; inline recursive
+
+[ ] [ [ 3 hang-1 ] final-info drop ] unit-test
+
+: hang-2 ( m n -- x )
+    over 0 number= [
+        nip
+    ] [
+        dup [
+            drop 1 hang-2
+        ] [
+            dupd hang-2 hang-2
+        ] if
+    ] if ; inline recursive
+
+[ ] [ [ 3 over hang-2 ] final-info drop ] unit-test
+
+[ ] [
+    [
+        dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
+    ] final-info drop
+] unit-test
+
+[ V{ word } ] [
+    [ { hashtable } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ { vector } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ object } ] [
+    [ { assoc } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ word } ] [
+    [ { string } declare string? ] final-classes
+] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ 3 string? ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare [ ] curry obj>> ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ 10 eq? [ drop 3 ] unless ] final-literals
+] unit-test
--- a/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor
@ -0,0 +1,19 @@
+IN: compiler.tree.propagation.recursive.tests
+USING: tools.test compiler.tree.propagation.recursive
+math.intervals kernel ;
+
+[ T{ interval f { 0 t } { 1/0. t } } ] [
+    T{ interval f { 1 t } { 1 t } }
+    T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+] unit-test
+
+[ T{ interval f { -1/0. t } { 10 t } } ] [
+    T{ interval f { -1 t } { -1 t } }
+    T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+] unit-test
+
+[ t ] [
+    T{ interval f { 1 t } { 268435455 t } }
+    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    generalize-counter-interval =
+] unit-test
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors arrays fry math.intervals
-combinators
+combinators namespaces
 stack-checker.inlining
 compiler.tree
 compiler.tree.copy-equiv
+compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@ -21,16 +22,18 @@ IN: compiler.tree.propagation.recursive

 : generalize-counter-interval ( interval initial-interval -- interval' )
    {
-        { [ 2dup = ] [ empty-interval ] }
+        { [ 2dup interval-subset? ] [ empty-interval ] }
        { [ over empty-interval eq? ] [ empty-interval ] }
        { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
        { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
        [ [-inf,inf] ]
-    } cond nip interval-union ;
+    } cond interval-union nip ;

 : generalize-counter ( info' initial -- info )
-    [ drop clone ] [ [ interval>> ] bi@ ] 2bi
-    generalize-counter-interval >>interval ;
+    2dup [ class>> null-class? ] either? [ drop ] [
+        [ drop clone ] [ [ interval>> ] bi@ ] 2bi
+        generalize-counter-interval >>interval
+    ] if ;

 : unify-recursive-stacks ( stacks initial -- infos )
    over empty? [ nip ] [
@ -46,28 +49,20 @@ IN: compiler.tree.propagation.recursive
    [ node-output-infos check-fixed-point drop ] 2keep
    out-d>> set-value-infos ;

-USING: namespaces math ;
-SYMBOL: iter-counter
-0 iter-counter set-global
 M: #recursive propagate-around ( #recursive -- )
-    iter-counter inc
-    iter-counter get 10 > [ "Oops" throw ] when
-    dup label>> t >>fixed-point drop [
-        [
-            copies [ clone ] change
-            constraints [ clone ] change
+    [
+        copies [ clone ] change
+        constraints [ clone ] change

-            child>>
-            [ first propagate-recursive-phi ]
-            [ (propagate) ]
-            bi
-        ] with-scope
-    ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
+        child>>
+        [ first propagate-recursive-phi ]
+        [ (propagate) ]
+        bi
+    ] until-fixed-point ;

 : generalize-return-interval ( info -- info' )
-    dup literal?>> [
-        clone [-inf,inf] >>interval
-    ] unless ;
+    dup [ literal?>> ] [ class>> null-class? ] bi or
+    [ clone [-inf,inf] >>interval ] unless ;

 : generalize-return ( infos -- infos' )
    [ generalize-return-interval ] map ;
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@ -17,7 +17,7 @@ IN: compiler.tree.propagation.simple
 ! Propagation for straight-line code.

 M: #introduce propagate-before
-    value>> object <class-info> swap set-value-info ;
+    value>> object-info swap set-value-info ;

 M: #push propagate-before
    [ literal>> <literal-info> ] [ out-d>> first ] bi
@ -67,21 +67,34 @@ M: #declare propagate-before
    bi* with-datastack
    [ <literal-info> ] map ;

+: predicate-output-infos ( info class -- info )
+    [ class>> ] dip {
+        { [ 2dup class<= ] [ t <literal-info> ] }
+        { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
+        [ object-info ]
+    } cond 2nip ;
+
+: propagate-predicate ( #call word -- infos )
+    [ in-d>> first value-info ] [ "predicating" word-prop ] bi*
+    predicate-output-infos 1array ;
+
 : default-output-value-infos ( #call word -- infos )
    "default-output-classes" word-prop
-    [ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
+    [ class-infos ] [ out-d>> length object-info <repetition> ] ?if ;

 : output-value-infos ( #call word -- infos )
    {
        { [ 2dup foldable-call? ] [ fold-call ] }
        { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
        { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
+        { [ dup predicate? ] [ propagate-predicate ] }
        { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
        [ default-output-value-infos ]
    } cond ;

 : do-inlining ( #call word -- ? )
    {
+        { [ dup always-inline-word? ] [ always-inline-word ] }
        { [ dup standard-generic? ] [ inline-standard-method ] }
        { [ dup math-generic? ] [ inline-math-method ] }
        { [ dup math-partial? ] [ inline-math-partial ] }
--- a/unfinished/compiler/tree/propagation/slots/slots.factor
+++ b/unfinished/compiler/tree/propagation/slots/slots.factor
@ -3,7 +3,7 @@
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
 words math math.private combinators sequences.private namespaces
-classes compiler.tree.propagation.info ;
+slots.private classes compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.slots

 ! Propagation of immutable slots and array lengths
@ -41,16 +41,19 @@ UNION: fixed-length-sequence array byte-array string ;
    [ , f , [ literal>> ] map % ] { } make >tuple
    <literal-info> ;

-: propagate-<tuple-boa> ( #call -- info )
-    #! Delegation
-    in-d>> [ value-info ] map unclip-last
-    literal>> class>> [ read-only-slots ] keep
+: (propagate-tuple-constructor) ( values class -- info )
+    [ [ value-info ] map ] dip [ read-only-slots ] keep
    over 2 tail-slice [ dup [ literal?>> ] when ] all? [
        [ 2 tail-slice ] dip fold-<tuple-boa>
    ] [
        <tuple-info>
    ] if ;

+: propagate-<tuple-boa> ( #call -- info )
+    #! Delegation
+    in-d>> unclip-last
+    value-info literal>> class>> (propagate-tuple-constructor) ;
+
 : propagate-<complex> ( #call -- info )
    in-d>> [ value-info ] map complex <tuple-info> ;

@ -60,27 +63,13 @@ UNION: fixed-length-sequence array byte-array string ;
        { \ <complex> [ propagate-<complex> ] }
    } case 1array ;

-: tuple>array* ( tuple -- array )
-    prepare-tuple>array
-    >r copy-tuple-slots r>
-    prefix ;
-
 : read-only-slot? ( n class -- ? )
    all-slots [ offset>> = ] with find nip
    dup [ read-only>> ] when ;

 : literal-info-slot ( slot object -- info/f )
-    2dup class read-only-slot? [
-        {
-            { [ dup tuple? ] [
-                [ 1- ] [ tuple>array* ] bi* nth <literal-info>
-            ] }
-            { [ dup complex? ] [
-                [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
-                2array nth <literal-info>
-            ] }
-        } cond
-    ] [ 2drop f ] if ;
+    2dup class read-only-slot?
+    [ swap slot <literal-info> ] [ 2drop f ] if ;

 : length-accessor? ( slot info -- ? )
    [ 1 = ] [ length>> ] bi* and ;
@ -92,4 +81,4 @@ UNION: fixed-length-sequence array byte-array string ;
        { [ 2dup length-accessor? ] [ nip length>> ] }
        { [ dup literal?>> ] [ literal>> literal-info-slot ] }
        [ [ 1- ] [ slots>> ] bi* ?nth ]
-    } cond [ object <class-info> ] unless* ;
+    } cond [ object-info ] unless* ;
--- a/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor
+++ b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor
@ -0,0 +1,119 @@
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+    [ { declared-fixnum } declare [ 1 + ] change-x ]
+    { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { declared-fixnum } declare x>> drop ]
+    { slot } inlined?
+] unit-test
+
+[ t ] [
+    [ hashtable new ] \ new inlined?
+] unit-test
+
+[ t ] [
+    [ dup hashtable eq? [ new ] when ] \ new inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare -63 shift 4095 bitand ]
+    \ shift inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare
+        dup 0 >= [
+            615949 * 797807 + 20 2^ mod dup 19 2^ -
+        ] [ dup ] if
+    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare
+        615949 * 797807 + 20 2^ mod dup 19 2^ -
+    ] { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+] unit-test
+
+
+
+[ t ] [
+    [
+        { integer } declare [ 256 mod ] map
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+
+[ f ] [
+    [
+        256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+    [
+        dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 256 rem
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 rem ] map
+    ] { mod fixnum-mod rem } inlined?
+] unit-test
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@ -87,10 +87,11 @@ TUPLE: #dispatch < #branch ;
 : #dispatch ( n branches -- node )
    \ #dispatch new-branch ;

-TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ;
+TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r terminated ;

-: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
+: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- node )
    \ #phi new
+        swap >>terminated
        swap >>out-r
        swap >>phi-in-r
        swap >>out-d
--- a/unfinished/math/partial-dispatch/partial-dispatch.factor
+++ b/unfinished/math/partial-dispatch/partial-dispatch.factor
@ -44,28 +44,23 @@ PREDICATE: math-partial < word
        bi
    ] "" make "math.partial-dispatch" lookup ;

-: integer-op-word ( triple fix-word big-word -- word )
-    [
-        drop
-        name>> "fast" tail? >r
-        [ "-" % ] [ name>> % ] interleave
-        r> [ "-fast" % ] when
-    ] "" make "math.partial-dispatch" create ;
+: integer-op-word ( triple -- word )
+    [ name>> ] map "-" join "math.partial-dispatch" create ;

-: integer-op-quot ( word fix-word big-word -- quot )
+: integer-op-quot ( triple fix-word big-word -- quot )
    rot integer-op-combinator 1quotation 2curry ;

-: define-integer-op-word ( word fix-word big-word -- )
+: define-integer-op-word ( triple fix-word big-word -- )
    [
-        [ integer-op-word ] [ integer-op-quot ] 3bi
+        [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
        (( x y -- z )) define-declared
-    ]
-    [
-        [ integer-op-word ] [ 2drop ] 3bi
+    ] [
+        2drop
+        [ integer-op-word ] keep
        "derived-from" set-word-prop
    ] 3bi ;

-: define-integer-op-words ( words fix-word big-word -- )
+: define-integer-op-words ( triples fix-word big-word -- )
    [ define-integer-op-word ] 2curry each ;

 : integer-op-triples ( word -- triples )
@ -78,7 +73,7 @@ PREDICATE: math-partial < word
 : define-integer-ops ( word fix-word big-word -- )
    >r >r integer-op-triples r> r>
    [ define-integer-op-words ]
-    [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+    [ 2drop [ dup integer-op-word ] { } map>assoc % ]
    3bi ;

 : define-math-ops ( op -- )
@ -160,15 +155,10 @@ SYMBOL: fast-math-ops
        \ number= \ eq? \ bignum= define-integer-ops
    ] { } make >hashtable math-ops set-global

-    [
-        { { + fixnum fixnum } fixnum+fast } ,
-        { { - fixnum fixnum } fixnum-fast } ,
-        { { * fixnum fixnum } fixnum*fast } ,
-        { { shift fixnum fixnum } fixnum-shift-fast } ,
-
-        \ + \ fixnum+fast \ bignum+ define-integer-ops
-        \ - \ fixnum-fast \ bignum- define-integer-ops
-        \ * \ fixnum*fast \ bignum* define-integer-ops
-        \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
-    ] { } make >hashtable fast-math-ops set-global
+    H{
+        { { + fixnum fixnum } fixnum+fast }
+        { { - fixnum fixnum } fixnum-fast }
+        { { * fixnum fixnum } fixnum*fast }
+        { { shift fixnum fixnum } fixnum-shift-fast }
+    } fast-math-ops set-global
 ] with-compilation-unit
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@ -58,9 +58,17 @@ SYMBOL: quotations
    unify-branches
    [ drop ] [ ] [ dup >vector meta-r set ] tri* ;

+: terminated-phi ( seq -- terminated )
+    terminated? branch-variable ;
+
 : compute-phi-function ( seq -- )
    [ quotation active-variable sift quotations set ]
-    [ [ datastack-phi ] [ retainstack-phi ] bi #phi, ]
+    [
+        [ datastack-phi ]
+        [ retainstack-phi ]
+        [ terminated-phi ]
+        tri #phi,
+    ]
    [ [ terminated? swap at ] all? terminated? set ]
    tri ;

--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@ -106,17 +106,12 @@ SYMBOL: enter-out
    '[ , prepend ] bi@
    <effect> ;

-: insert-copy ( effect -- )
-    in>> [ consume-d dup ] keep make-copies
-    [ nip output-d ] [ #copy, ] 2bi ;
-
 : call-recursive-inline-word ( word -- )
    dup "recursive" word-prop [
        [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
-        [ 2drop insert-copy ]
        [ add-call drop ]
        [ nip '[ , #call-recursive, ] consume/produce ]
-        3tri
+        3bi
    ] [ undeclared-recursion-error inference-error ] if ;

 : inline-word ( word -- )
--- a/unfinished/stack-checker/stack-checker-tests.factor
+++ b/unfinished/stack-checker/stack-checker-tests.factor
@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
 sorting assocs definitions prettyprint io inspector
 classes.tuple classes.union classes.predicate debugger
 threads.private io.streams.string io.timeouts io.thread
-sequences.private destructors combinators ;
+sequences.private destructors combinators eval ;
 IN: stack-checker.tests

 : short-effect ( effect -- pair )
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@ -17,7 +17,7 @@ M: f #return-recursive, 3drop ;
 M: f #terminate, drop ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
-M: f #phi, 2drop 2drop ;
+M: f #phi, drop drop drop drop drop ;
 M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@ -20,7 +20,7 @@ HOOK: #r>, stack-visitor ( inputs outputs -- )
 HOOK: #terminate, stack-visitor ( stack -- )
 HOOK: #if, stack-visitor ( ? true false -- )
 HOOK: #dispatch, stack-visitor ( n branches -- )
-HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- )
 HOOK: #declare, stack-visitor ( declaration -- )
 HOOK: #return, stack-visitor ( stack -- )
 HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
--- a/unmaintained/lint/lint.factor
+++ b/unmaintained/lint/lint.factor
@ -1,8 +1,9 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
+USING: accessors alien alien.accessors arrays assocs
+combinators.lib io kernel macros math namespaces prettyprint
+quotations sequences vectors vocabs words html.elements sets
+slots.private combinators.short-circuit ;
 IN: lint

 SYMBOL: def-hash
@ -18,7 +19,7 @@ SYMBOL: def-hash-keys
        2drop
    ] if ;

-: more-defs
+: more-defs ( -- )
    {
        { [ swap >r swap r> ] -rot }
        { [ swap swapd ] -rot }
@ -33,6 +34,7 @@ SYMBOL: def-hash-keys
        { [ 0 = ] zero? }
        { [ pop drop ] pop* }
        { [ [ ] if ] when }
+        { [ f = not ] >boolean }
    } [ first2 swap add-word-def ] each ;

 : accessor-words ( -- seq )
@ -51,33 +53,32 @@ SYMBOL: def-hash-keys
    {
        [ get ] [ t ] [ { } ] [ . ] [ drop f ]
        [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
-        [ ">" write-html ] [ <unimplemented-typeflag> throw ]
-        [ "/>" write-html ]
+        [ ">" write-html ] [ "/>" write-html ]
    } ;

 H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
+all-words [ dup def>> add-word-def ] each
 more-defs

 ! Remove empty word defs
 def-hash get-global [
    drop empty? not
-] assoc-subset
+] assoc-filter

 ! Remove constants [ 1 ]
 [
    drop dup length 1 = swap first number? and not
-] assoc-subset
+] assoc-filter

 ! Remove set-alien-cell, etc.
 [
-    drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
-] assoc-subset
+    drop [ accessor-words diff ] keep [ length ] bi@ =
+] assoc-filter

 ! Remove trivial defs
 [
    drop trivial-defs member? not
-] assoc-subset
+] assoc-filter

 ! Remove n m shift defs
 [
@ -85,19 +86,19 @@ def-hash get-global [
        dup first2 [ number? ] both?
        swap third \ shift = and not
    ] [ drop t ] if
-] assoc-subset 
+] assoc-filter 

 ! Remove [ n slot ]
 [
    drop dup length 2 = [
        first2 \ slot = swap number? and not
    ] [ drop t ] if
-] assoc-subset def-hash set-global
+] assoc-filter def-hash set-global

-: find-duplicates
+: find-duplicates ( -- seq )
    def-hash get-global [
        nip length 1 >
-    ] assoc-subset ;
+    ] assoc-filter ;

 def-hash get-global keys def-hash-keys set-global

@ -107,18 +108,18 @@ M: object lint ( obj -- seq )
    drop f ;

 : subseq/member? ( subseq/member seq -- ? )
-    { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+    { [ start ] [ member? ] } 2|| ;

 M: callable lint ( quot -- seq )
    def-hash-keys get [
        swap subseq/member?
-    ] with subset ;
+    ] with filter ;

 M: word lint ( word -- seq )
-    word-def dup callable? [ lint ] [ drop f ] if ;
+    def>> dup callable? [ lint ] [ drop f ] if ;

 : word-path. ( word -- )
-    [ word-vocabulary ":" ] keep unparse 3append write nl ;
+    [ vocabulary>> ":" ] keep unparse 3append write nl ;

 : (lint.) ( pair -- )
    first2 >r word-path. r> [
@ -135,7 +136,7 @@ M: word lint ( word -- seq )

 GENERIC: run-lint ( obj -- obj )

-: (trim-self)
+: (trim-self) ( val key -- obj ? )
    def-hash get-global at* [
        dupd remove empty? not
    ] [
@ -143,13 +144,13 @@ GENERIC: run-lint ( obj -- obj )
    ] if ;

 : trim-self ( seq -- newseq )
-    [ [ (trim-self) ] subset ] assoc-map ;
+    [ [ (trim-self) ] filter ] assoc-map ;

 : filter-symbols ( alist -- alist )
    [
        nip first dup def-hash get at
        [ first ] bi@ literalize = not
-    ] assoc-subset ;
+    ] assoc-filter ;

 M: sequence run-lint ( seq -- seq )
    [
@ -157,7 +158,7 @@ M: sequence run-lint ( seq -- seq )
        dup lint
    ] { } map>assoc
    trim-self
-    [ second empty? not ] subset
+    [ second empty? not ] filter
    filter-symbols ;

 M: word run-lint ( word -- seq )