From 470c66c851cf37b1062e35b4f70eb7584b16d33e Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Wed, 6 Aug 2008 01:07:10 -0500
Subject: [PATCH 01/42] adding docs for 24 game

---
 extra/24-game/24-game-docs.factor | 67 +++++++++++++++++++++++++++++++
 1 file changed, 67 insertions(+)
 create mode 100644 extra/24-game/24-game-docs.factor

diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor
new file mode 100644
index 0000000000..12a558b2d2
--- /dev/null
+++ b/extra/24-game/24-game-docs.factor
@@ -0,0 +1,67 @@
+USING: help.markup help.syntax math kernel ;
+IN: 24-game
+
+HELP: play-game ( -- )
+{ $description "Starts the game!" }
+{ $examples
+    { $unchecked-example
+        "USE: 24-game"
+        "play-game"
+        "{ 8 2 1 2 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "swap\n"
+        "{ 8 2 2 1 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "-\n"
+        "{ 8 2 1 }\n"
+        "Commands: { + - * / rot swap q }\n"
+        "+\n"
+        "{ 8 3 }\n"
+        "Commands: { + - * / swap q }\n"
+        "*\n"
+        "You WON!"
+    }
+} ;
+
+HELP: 24-able ( -- vector )
+{ $values { "vector" "vector of 4 integers" } }
+{ $description
+    "Produces a vector with 4 integers. With the following condition: "
+    "If these integers were directly on the stack, one can process them into 24, "
+    "just using the provided commands and the 4 numbers. The Following are the "
+    "provided commands: "
+    { $link + } ", " { $link - } ", " { $link * } ", "
+    { $link / } ", and " { $link swap } "."
+}
+{ $examples
+    { $example
+        "USE: 24-game"
+        "24-able vector-24-able?"
+        "t"
+    }
+    { $notes { $link 24-able? } " is used in " { $link 24-able } "." }
+} ;
+
+HELP: 24-able? ( quad -- t/f )
+{ $values
+    { "quad" "vector of 4 integers" }
+    { "t/f" "a boolean" }
+}
+{ $description
+    "Tells if it is possible to win 24-game if it was initiated "
+    "with this sequence."
+} ;
+
+HELP: build-quad ( -- array )
+{ $values
+    { "vector" "an array of 4 numbers" }
+}
+{ $description "Builds an array of 4 random numbers." } ;
+ARTICLE: "24-game" "The Game of 24"
+"A classic math game, where one attempts to create 24, by applying "
+"arithmetical operations and some shuffle words to a stack of 4 numbers. "
+{ $subsection play-game }
+{ $subsection 24-able }
+{ $subsection 24-able? }
+{ $subsection build-quad } ;
+ABOUT: "24-game"
\ No newline at end of file

From 6087776341313633647d8708d0d598634e71125e Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Wed, 6 Aug 2008 01:08:01 -0500
Subject: [PATCH 02/42] that would be me

---
 extra/24-game/authors.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/24-game/authors.txt

diff --git a/extra/24-game/authors.txt b/extra/24-game/authors.txt
new file mode 100644
index 0000000000..137b1605da
--- /dev/null
+++ b/extra/24-game/authors.txt
@@ -0,0 +1 @@
+Reginald Ford
\ No newline at end of file

From e1f8e318bd07befa9968c9c9e2e37addde0c4227 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Wed, 6 Aug 2008 01:08:40 -0500
Subject: [PATCH 03/42] that's me

---
 extra/math/derivatives/authors.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/math/derivatives/authors.txt

diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt
new file mode 100644
index 0000000000..137b1605da
--- /dev/null
+++ b/extra/math/derivatives/authors.txt
@@ -0,0 +1 @@
+Reginald Ford
\ No newline at end of file

From 5a9f05e2273b1a48a113455804a8cd5e6aacc072 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Wed, 6 Aug 2008 01:09:36 -0500
Subject: [PATCH 04/42] it's all me, baby

---
 extra/math/function-tools/authors.txt | 1 +
 extra/math/newtons-method/authors.txt | 1 +
 extra/math/secant-method/authors.txt  | 1 +
 3 files changed, 3 insertions(+)
 create mode 100644 extra/math/function-tools/authors.txt
 create mode 100644 extra/math/newtons-method/authors.txt
 create mode 100644 extra/math/secant-method/authors.txt

diff --git a/extra/math/function-tools/authors.txt b/extra/math/function-tools/authors.txt
new file mode 100644
index 0000000000..137b1605da
--- /dev/null
+++ b/extra/math/function-tools/authors.txt
@@ -0,0 +1 @@
+Reginald Ford
\ No newline at end of file
diff --git a/extra/math/newtons-method/authors.txt b/extra/math/newtons-method/authors.txt
new file mode 100644
index 0000000000..137b1605da
--- /dev/null
+++ b/extra/math/newtons-method/authors.txt
@@ -0,0 +1 @@
+Reginald Ford
\ No newline at end of file
diff --git a/extra/math/secant-method/authors.txt b/extra/math/secant-method/authors.txt
new file mode 100644
index 0000000000..137b1605da
--- /dev/null
+++ b/extra/math/secant-method/authors.txt
@@ -0,0 +1 @@
+Reginald Ford
\ No newline at end of file

From 10448f809798c6941b525e114bab98065c2430bd Mon Sep 17 00:00:00 2001
From: Joe Groff <jcg@dhcp-177-191.(none)>
Date: Wed, 6 Aug 2008 11:38:09 -0700
Subject: [PATCH 05/42] game-input.backend: follow eval to its new home

---
 extra/game-input/backend/backend.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor
index a31b9d6649..cfba0a52f5 100644
--- a/extra/game-input/backend/backend.factor
+++ b/extra/game-input/backend/backend.factor
@@ -1,4 +1,4 @@
-USING: multiline system parser combinators ;
+USING: eval multiline system combinators ;
 IN: game-input.backend
 
 STRING: set-backend-for-macosx

From bbcc4c238418536ac16be369173d4ded33b9a509 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 6 Aug 2008 17:51:01 -0500
Subject: [PATCH 06/42] Builder fixes

---
 basis/persistent/hashtables/hashtables-tests.factor | 6 ++++++
 basis/persistent/sequences/sequences-docs.factor    | 6 +++---
 basis/persistent/vectors/vectors-docs.factor        | 6 +++---
 3 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor
index accebfd778..ac6aa240cc 100644
--- a/basis/persistent/hashtables/hashtables-tests.factor
+++ b/basis/persistent/hashtables/hashtables-tests.factor
@@ -10,6 +10,10 @@ tools.test kernel namespaces random math.ranges sequences fry ;
 
 [ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
 
+! We have to define these first so that they're compiled before
+! the below hashtables are parsed...
+<<
+
 TUPLE: hash-0-a ;
 
 M: hash-0-a hashcode* 2drop 0 ;
@@ -18,6 +22,8 @@ TUPLE: hash-0-b ;
 
 M: hash-0-b hashcode* 2drop 0 ;
 
+>>
+
 [ ] [
     PH{ }
     "a" T{ hash-0-a } rot new-at
diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor
index beacf58966..53d15efeec 100644
--- a/basis/persistent/sequences/sequences-docs.factor
+++ b/basis/persistent/sequences/sequences-docs.factor
@@ -4,14 +4,14 @@ USING: help.markup help.syntax math sequences kernel ;
 HELP: new-nth
 { $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
 { $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
-{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
 
 HELP: ppush
 { $values { "val" object } { "seq" sequence } { "seq'" sequence } }
 { $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
 
 HELP: ppop
 { $values { "seq" sequence } { "seq'" sequence } }
 { $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor
index f17fca1ded..c49e56d2c5 100644
--- a/basis/persistent/vectors/vectors-docs.factor
+++ b/basis/persistent/vectors/vectors-docs.factor
@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel math sequences ;
-IN: persistent-vectors
+IN: persistent.vectors
 
 HELP: PV{
 { $syntax "elements... }" }
@@ -12,7 +12,7 @@ HELP: >persistent-vector
 HELP: persistent-vector
 { $class-description "The class of persistent vectors." } ;
 
-ARTICLE: "persistent-vectors" "Persistent vectors"
+ARTICLE: "persistent.vectors" "Persistent vectors"
 "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
 $nl
 "The class of persistent vectors:"
@@ -31,4 +31,4 @@ $nl
 $nl
 "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
 
-ABOUT: "persistent-vectors"
+ABOUT: "persistent.vectors"

From 52f586877fb56f6c5fb0958d578fd9b1c42c551f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 6 Aug 2008 19:01:17 -0500
Subject: [PATCH 07/42] More data structure cleanups

---
 basis/disjoint-sets/disjoint-sets.factor       |  5 +++--
 basis/persistent/hashtables/hashtables.factor  |  7 +++++++
 .../persistent/sequences/sequences-docs.factor | 18 ++++++++++++------
 basis/persistent/vectors/vectors-docs.factor   |  6 ------
 4 files changed, 22 insertions(+), 14 deletions(-)

diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index a885e333c5..680103f188 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hints kernel locals math hashtables
-assocs fry ;
-
+assocs fry sequences ;
 IN: disjoint-sets
 
 TUPLE: disjoint-set
@@ -65,6 +64,8 @@ M: disjoint-set add-atom
     [ 1 -rot counts>> set-at ]
     2tri ;
 
+: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;
diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor
index a68fa7c365..ae60aba50e 100644
--- a/basis/persistent/hashtables/hashtables.factor
+++ b/basis/persistent/hashtables/hashtables.factor
@@ -41,6 +41,13 @@ M: persistent-hash >alist [ root>> >alist% ] { } make ;
 : >persistent-hash ( assoc -- phash )
     T{ persistent-hash } swap [ spin new-at ] assoc-each ;
 
+M: persistent-hash equal?
+    over persistent-hash? [ assoc= ] [ 2drop f ] if ;
+
+M: persistent-hash hashcode* nip assoc-size ;
+
+M: persistent-hash clone ;
+
 : PH{ \ } [ >persistent-hash ] parse-literal ; parsing
 
 M: persistent-hash pprint-delims drop \ PH{ \ } ;
diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor
index 53d15efeec..986b16c737 100644
--- a/basis/persistent/sequences/sequences-docs.factor
+++ b/basis/persistent/sequences/sequences-docs.factor
@@ -3,15 +3,21 @@ USING: help.markup help.syntax math sequences kernel ;
 
 HELP: new-nth
 { $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
-{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } ;
 
 HELP: ppush
 { $values { "val" object } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } ;
 
 HELP: ppop
 { $values { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $vocab-link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ;
+
+ARTICLE: "persistent.sequences" "Persistent sequence protocol"
+"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as  " { $link length } " and " { $link nth } ", together with the following operations:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ;
+
+ABOUT: "persistent.sequences"
diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor
index c49e56d2c5..4816877a35 100644
--- a/basis/persistent/vectors/vectors-docs.factor
+++ b/basis/persistent/vectors/vectors-docs.factor
@@ -17,12 +17,6 @@ ARTICLE: "persistent.vectors" "Persistent vectors"
 $nl
 "The class of persistent vectors:"
 { $subsection persistent-vector }
-"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
-$nl
-"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
-{ $subsection new-nth }
-{ $subsection ppush }
-{ $subsection ppop }
 "Converting a sequence into a persistent vector:"
 { $subsection >persistent-vector }
 "Persistent vectors have a literal syntax:"

From b26aba48e3693b869e8b56a3fec2470cfcb63581 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 6 Aug 2008 19:04:18 -0500
Subject: [PATCH 08/42] cfdg.models.game1-turn6: Use new macros

---
 .../models/game1-turn6/game1-turn6.factor     | 44 +++++++++++--------
 1 file changed, 25 insertions(+), 19 deletions(-)

diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor
index 3e0994112a..5e512cd74a 100644
--- a/extra/cfdg/models/game1-turn6/game1-turn6.factor
+++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor
@@ -6,29 +6,35 @@ IN: cfdg.models.game1-turn6
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: f-triangles ( -- ) iterate? [
-[ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.8 b triangle ] do
-[ 10 hue 0.9 sat 0.33 b triangle ] do
-[ 0.9 s 10 hue 0.5 sat 1 b triangle ] do
-[ 0.8 s 5 r f-triangles ] do
-] when ;
+: f-triangles ( -- )
+  {
+    [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
+    [                         10 hue 0.9 sat 0.33 b triangle ]
+    [ 0.9 s                   10 hue 0.5 sat 1.00 b triangle ]
+    [ 0.8 s 5 r f-triangles ]
+  }
+  rule ;
 
-: f-squares ( -- ) iterate? [
-[ 0.1 x 0.1 y -0.33 alpha 250 hue 0.7 sat 0.8 b square ] do
-[ 220 hue 0.9 sat 0.33 b square ] do
-[ 0.9 s 220 hue 0.25 sat 1 b square ] do
-[ 0.8 s 5 r f-squares ] do
-] when ;
+: f-squares ( -- )
+  {
+    [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
+    [                         220 hue 0.90 sat 0.33 b square ]
+    [ 0.9 s                   220 hue 0.25 sat 1.00 b square ]
+    [ 0.8 s 5 r f-squares ]
+  }
+  rule ;
 
 DEFER: start
 
-: spiral ( -- ) iterate? [
-  { { 1 [ f-squares
-          [ 0.5 x 0.5 y 45 r f-triangles ] do
-          [ 1 y 25 r 0.9 s spiral ] do ] }
-    { 0.022 [ [ 90 flip 50 hue start ] do ] } }
-  call-random-weighted
-] when ;
+: spiral ( -- )
+  {
+    { 1 [ f-squares ]
+        [ 0.5 x 0.5 y 45 r f-triangles ]
+        [ 1 y 25 r 0.9 s spiral ] }
+            
+    { 0.022 [ 90 flip 50 hue start ] }
+  }
+  rules ;
 
 : start ( -- )
   [       spiral ] do

From 8aef8fda256199626a534946ef1bf3db4f9e7148 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 6 Aug 2008 19:12:57 -0500
Subject: [PATCH 09/42] cfdg.models.spirales: Use new macros

---
 extra/cfdg/models/spirales/spirales.factor | 28 ++++++----------------
 1 file changed, 7 insertions(+), 21 deletions(-)

diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor
index 985c21643e..f804b6ba83 100644
--- a/extra/cfdg/models/spirales/spirales.factor
+++ b/extra/cfdg/models/spirales/spirales.factor
@@ -7,33 +7,19 @@ DEFER: line
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: block ( -- )
-  [
-    [ circle ] do
-    [ 0.3 s 60 flip line ] do
-  ]
-  recursive ;
+: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
 
-: a1 ( -- )
-  [
-    [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do
-    [ block ] do
-  ]
-  recursive ;
+: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
 
-: line ( -- )
-  -0.3 a
-  [   0 rotate a1 ] do
-  [ 120 rotate a1 ] do
-  [ 240 rotate a1 ] do ;
+: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : init ( -- )
-  [ -1 b ] >background
-  { -20 40 -20 40 } viewport set
-  [ line ] >start-shape
-  0.03 >threshold ;
+  [ -1 b ]          >background
+  { -20 40 -20 40 } >viewport
+  [ line ]          >start-shape
+  0.04              >threshold ;
 
 : run ( -- ) [ init ] cfdg-window. ;
 

From c6b310228eaf94e311ce80af1310b2d8cfcfb0bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 7 Aug 2008 01:08:11 -0500
Subject: [PATCH 10/42] Finishing up with propagation and escape analysis

---
 .../tree/cleanup/cleanup-tests.factor         |   3 +-
 .../tree/copy-equiv/copy-equiv.factor         |  20 ++--
 .../allocations/allocations.factor            |  16 ++-
 .../escape-analysis-tests.factor              | 100 +++++++++++++++++-
 .../escape-analysis/escape-analysis.factor    |   1 -
 .../recursive/recursive.factor                |  34 +++---
 .../tree/normalization/normalization.factor   |   4 +
 .../compiler/tree/optimizer/optimizer.factor  |   1 -
 .../tree/propagation/branches/branches.factor |  36 +++++--
 .../tree/propagation/info/info.factor         |  25 ++++-
 .../tree/propagation/inlining/inlining.factor |   3 +-
 .../tree/propagation/nodes/nodes.factor       |   4 +-
 .../tree/propagation/propagation-tests.factor |  13 ++-
 .../tree/propagation/propagation.factor       |  10 +-
 .../propagation/recursive/recursive.factor    |  31 +++---
 .../stack-checker/inlining/inlining.factor    |   7 +-
 16 files changed, 232 insertions(+), 76 deletions(-)

diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor
index c483b8bdc6..4d2b312e9c 100644
--- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor
@@ -9,12 +9,11 @@ compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize compute-copy-equiv propagate cleanup ;
+    build-tree normalize propagate cleanup ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 
diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
index a96fe8eb22..6a4cca7ff4 100644
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
@@ -7,6 +7,9 @@ compiler.tree.def-use
 compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
+! This is not really a compiler pass; its invoked as part of
+! propagation.
+
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation). This is just a weak form of
 ! value numbering.
@@ -26,8 +29,7 @@ SYMBOL: copies
         ] if
     ] ;
 
-: resolve-copy ( copy -- val )
-    copies get compress-path [ "Unknown value" throw ] unless* ;
+: resolve-copy ( copy -- val ) copies get compress-path ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
@@ -68,13 +70,7 @@ M: #phi compute-copy-equiv*
 
 M: node compute-copy-equiv* drop ;
 
-: amend-copy-equiv ( node -- )
-    [
-        [ node-defs-values [ introduce-value ] each ]
-        [ compute-copy-equiv* ]
-        bi
-    ] each-node ;
-
-: compute-copy-equiv ( node -- node )
-    H{ } clone copies set
-    dup amend-copy-equiv ;
+: compute-copy-equiv ( node -- )
+    [ node-defs-values [ introduce-value ] each ]
+    [ compute-copy-equiv* ]
+    bi ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index b4f4a2a5dd..8bcaf53ab1 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -28,14 +28,9 @@ C: <slot-access> slot-access
 
 : record-allocation ( allocation value -- ) (allocation) set-at ;
 
-: unknown-allocation ( value -- ) t swap record-allocation ;
-
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
-: unknown-allocations ( values -- )
-    [ unknown-allocation ] each ;
-
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -66,10 +61,21 @@ SYMBOL: +escaping+
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;
 
+: add-escaping-value ( value -- )
+    +escaping+ escaping-values get equate ;
+
 : add-escaping-values ( values -- )
     escaping-values get
     '[ +escaping+ , equate ] each ;
 
+: unknown-allocation ( value -- )
+    [ add-escaping-value ]
+    [ t swap record-allocation ]
+    bi ;
+
+: unknown-allocations ( values -- )
+    [ unknown-allocation ] each ;
+
 : escaping-value? ( value -- ? )
     +escaping+ escaping-values get equiv? ;
 
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 256152a556..2728a3c933 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -12,7 +12,7 @@ prettyprint classes.tuple.private classes classes.tuple ;
 GENERIC: count-unboxed-allocations* ( m node -- n )
 
 : (count-unboxed-allocations) ( m node -- n )
-    out-d>> first escaping-allocation? [ 1+ ] unless ;
+    dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
 
 M: #call count-unboxed-allocations*
     dup word>> \ <tuple-boa> =
@@ -27,10 +27,8 @@ M: node count-unboxed-allocations* drop ;
 : count-unboxed-allocations ( quot -- sizes )
     build-tree
     normalize
-    compute-copy-equiv
     propagate
     cleanup
-    compute-copy-equiv
     escape-analysis
     0 swap [ count-unboxed-allocations* ] each-node ;
 
@@ -187,3 +185,99 @@ TUPLE: cons { car read-only } { cdr read-only } ;
         1 2 cons boa infinite-cons-loop
     ] count-unboxed-allocations
 ] unit-test
+
+TUPLE: rw-box i ;
+
+C: <rw-box> rw-box
+
+[ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
+
+: fake-fib ( m -- n )
+    dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
+
+[ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
+
+TUPLE: ro-box { i read-only } ;
+
+C: <ro-box> ro-box
+
+: tuple-fib ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup tuple-fib
+        swap
+        i>> 1- <ro-box>
+        tuple-fib
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
+
+[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-1 ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-1
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-1 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-2 ( m -- n )
+    dup .
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-2
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-2 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-2
+        swap
+        1- tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-3
+        swap
+        1- tuple-fib-3 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup bad-tuple-fib-3
+        swap
+        1- bad-tuple-fib-3
+        2drop f
+    ] if ; inline recursive
+
+[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index 0ba44a1dc5..d1b1ab2dd0 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -4,7 +4,6 @@ USING: kernel namespaces search-dequeues assocs fry sequences
 disjoint-sets
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
 compiler.tree.escape-analysis.allocations
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.branches
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
index 5bc386690d..e72f4b6a45 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences math combinators accessors namespaces
+fry disjoint-sets
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.branches
@@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive
         [ [ [ allocation ] bi@ congruent? ] 2all? ]
     } cond ;
 
-: check-fixed-point ( node alloc1 alloc2 -- node )
-    [ congruent? ] 2all?
-    [ dup label>> f >>fixed-point drop ] unless ; inline
+: check-fixed-point ( node alloc1 alloc2 -- )
+    [ congruent? ] 2all? [ drop ] [
+        label>> f >>fixed-point drop
+    ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
-        [ [ allocation ] map check-fixed-point drop ]
+        [ [ allocation ] map check-fixed-point ]
         [ record-allocations ]
         2bi
     ] 2bi ;
 
 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 ;
+: return-allocations ( node -- allocations )
+    label>> return>> node-input-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 ;
+M: #call-recursive escape-analysis* ( #call-label -- )
+    [ ] [ return-allocations ] [ node-output-allocations ] tri
+    [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
+
+M: #return-recursive escape-analysis* ( #return-recursive -- )
+    [ in-d>> ] [ label>> calls>> ] bi
+    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor
index b6a9f126d6..4eb28be917 100644
--- a/unfinished/compiler/tree/normalization/normalization.factor
+++ b/unfinished/compiler/tree/normalization/normalization.factor
@@ -128,6 +128,10 @@ M: #recursive normalize*
     dup dup label>> introductions>>
     eliminate-recursive-introductions ;
 
+M: #enter-recursive normalize*
+    dup [ label>> ] keep >>enter-recursive drop
+    dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
+
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index 753c962061..f28b192d2b 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -9,7 +9,6 @@ IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
     normalize
-    compute-copy-equiv
     propagate
     cleanup
     compute-def-use
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index eb6ba3697f..00a7833655 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =t ] bi* <--> ]
-                [ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =f ] bi* <--> ] 2bi /\
             ]
         }
         {
@@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =f ] bi* <--> ]
-                [ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =t ] bi* <--> ] 2bi /\
             ]
         }
         {
             { { t f } { f } }
-            [ first =t condition-value get =t /\ swap t--> assume ]
+            [
+                first =t
+                condition-value get =t /\
+                swap t-->
+            ]
         }
         {
             { { f } { t f } }
-            [ second =t condition-value get =f /\ swap t--> assume ]
+            [
+                second =t
+                condition-value get =f /\
+                swap t-->
+            ]
         }
-        [ 3drop ]
-    } case ;
+        ! {
+        !     { { t f } { } }
+        !     [ B
+        !         first
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        ! {
+        !     { { } { t f } }
+        !     [
+        !         second
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        [ 3drop f ]
+    } case assume ;
 
 M: #phi propagate-after ( #phi -- )
     condition-value get [
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index 3d79840f7e..bc6f1d73e3 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra kernel
 accessors math math.intervals namespaces sequences words
-combinators arrays compiler.tree.copy-equiv ;
+combinators combinators.short-circuit arrays
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -218,6 +219,28 @@ DEFER: (value-info-union)
     [ drop null-info ]
     [ dup first [ value-info-union ] reduce ] if ;
 
+: literals<= ( info1 info2 -- ? )
+    {
+        { [ dup literal?>> not ] [ 2drop t ] }
+        { [ over literal?>> not ] [ 2drop f ] }
+        [ [ literal>> ] bi@ eql? ]
+    } cond ;
+
+: value-info<= ( info1 info2 -- ? )
+    {
+        { [ dup not ] [ 2drop t ] }
+        { [ over not ] [ 2drop f ] }
+        [
+            {
+                [ [ class>> ] bi@ class<= ]
+                [ [ interval>> ] bi@ interval-subset? ]
+                [ literals<= ]
+                [ [ length>> ] bi@ value-info<= ]
+                [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
+            } 2&&
+        ]
+    } cond ;
+
 ! Current value --> info mapping
 SYMBOL: value-infos
 
diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor
index e4da863d68..22e056ce60 100644
--- a/unfinished/compiler/tree/propagation/inlining/inlining.factor
+++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor
@@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words
 namespaces
 compiler.tree
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
@@ -25,7 +24,7 @@ M: quotation splicing-nodes
     normalize ;
 
 : propagate-body ( #call -- )
-    body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
+    body>> (propagate) ;
 
 ! Dispatch elimination
 : eliminate-dispatch ( #call word/quot/f -- ? )
diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor
index 6317ec4e06..10dd1a03c6 100644
--- a/unfinished/compiler/tree/propagation/nodes/nodes.factor
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@@ -3,6 +3,7 @@
 USING: sequences accessors kernel assocs sequences
 compiler.tree
 compiler.tree.def-use
+compiler.tree.copy-equiv
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
@@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- )
 
 GENERIC: propagate-around ( node -- )
 
-: (propagate) ( node -- ) [ propagate-around ] each ;
+: (propagate) ( node -- )
+    [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
 
 : extract-value-info ( values -- assoc )
     [ dup value-info ] H{ } map>assoc ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 515d1bf474..d2583af832 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -1,5 +1,5 @@
 USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.propagation
 compiler.tree.normalization tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
@@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests
 : final-info ( quot -- seq )
     build-tree
     normalize
-    compute-copy-equiv
     propagate
     peek node-input-infos ;
 
@@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests
     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ] unit-test
 
+[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
+
 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
 
 [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
@@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
 [ V{ fixnum } ] [
diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor
index db69024413..7fa971bafe 100755
--- a/unfinished/compiler/tree/propagation/propagation.factor
+++ b/unfinished/compiler/tree/propagation/propagation.factor
@@ -3,6 +3,7 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
+compiler.tree.copy-equiv
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -13,8 +14,7 @@ compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
 : propagate ( node -- node )
-    [
-        H{ } clone constraints set
-        H{ } clone value-infos set
-        dup (propagate)
-    ] with-scope ;
+    H{ } clone copies set
+    H{ } clone constraints set
+    H{ } clone value-infos set
+    dup (propagate) ;
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 3732d7c08c..9e1bf52bbf 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -13,8 +13,9 @@ compiler.tree.propagation.branches
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.recursive
 
-: check-fixed-point ( node infos1 infos2 -- node )
-    sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
+: check-fixed-point ( node infos1 infos2 -- )
+    [ value-info<= ] 2all?
+    [ drop ] [ label>> f >>fixed-point drop ] if ;
 
 : recursive-stacks ( #enter-recursive -- stacks initial )
     [ label>> calls>> [ node-input-infos ] map flip ]
@@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive
 
 : propagate-recursive-phi ( #enter-recursive -- )
     [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
-    [ node-output-infos check-fixed-point drop ] 2keep
-    out-d>> set-value-infos ;
+    [ node-output-infos check-fixed-point ]
+    [ out-d>> set-value-infos drop ]
+    3bi ;
 
 M: #recursive propagate-around ( #recursive -- )
-    [
-        copies [ clone ] change
+    { 0 } clone [ USE: math
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         constraints [ clone ] change
 
         child>>
+        [ first compute-copy-equiv ]
         [ first propagate-recursive-phi ]
         [ (propagate) ]
-        bi
-    ] until-fixed-point ;
+        tri
+    ] curry until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
@@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- )
 : generalize-return ( infos -- infos' )
     [ generalize-return-interval ] map ;
 
-M: #call-recursive propagate-before ( #call-label -- )
-    dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
-    [ check-fixed-point ] keep
-    generalize-return swap out-d>> set-value-infos ;
+: return-infos ( node -- infos )
+    label>> return>> node-input-infos generalize-return ;
 
-M: #return-recursive propagate-before ( #return-recursive -- )
-    dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
-    check-fixed-point drop ;
+M: #call-recursive propagate-before ( #call-label -- )
+    [ ] [ return-infos ] [ node-output-infos ] tri
+    [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index ffa90c13ed..155baa7e65 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -17,7 +17,12 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
+TUPLE: inline-recursive
+word
+enter-out enter-recursive
+return calls
+fixed-point
+introductions ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new swap >>word ;

From f5ea3ccbbed2354f9f537b0fa4c1f40aa6d85e46 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Thu, 7 Aug 2008 01:58:50 -0500
Subject: [PATCH 11/42] minor fixes

---
 extra/24-game/24-game.factor | 56 +++++++++++++++++++++++++-----------
 extra/24-game/tags.txt       |  1 +
 2 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor
index 569cef8302..52f0cd6833 100644
--- a/extra/24-game/24-game.factor
+++ b/extra/24-game/24-game.factor
@@ -3,36 +3,60 @@
 
 USING: kernel random namespaces shuffle sequences
 parser io math prettyprint combinators continuations
-vectors words quotations accessors math.parser
-backtrack math.ranges locals fry memoize macros assocs ;
+arrays words quotations accessors math.parser backtrack assocs ;
 
 IN: 24-game
-
+SYMBOL: commands
 : nop ;
 : do-something ( a b -- c ) { + - * } amb-execute ;
 : maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
 : some-rots ( a b c -- a b c )
     #! Try each permutation of 3 elements.
     { nop rot -rot swap spin swapd } amb-execute ;
-: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
-: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: makes-24? ( a b c d -- ? )
+        [
+            2 [ some-rots do-something ] times
+            maybe-swap do-something
+            24 =
+        ]
+        [ 4drop ]
+    if-amb ;
 : q ( -- obj ) "quit" ;
-: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: show-commands ( -- ) "Commands: " write commands get unparse print ;
 : report ( vector -- ) unparse print show-commands ;
 : give-help ( -- ) "Command not found..." print show-commands ;
 : find-word ( string choices -- word ) [ name>> = ] with find nip ;
-: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: obtain-word ( -- word )
+    readln commands get find-word dup
+    [ drop give-help obtain-word ] unless ;
 : done? ( vector -- t/f ) 1 swap length = ;
-: victory? ( vector -- t/f ) V{ 24 } = ;
-: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
-: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+: victory? ( vector -- t/f ) { 24 } = ;
+: apply-word ( vector word -- array ) 1quotation with-datastack >array ;
+: update-commands ( vector -- )
+    length 3 <
+        [ commands [ \ rot swap remove ] change ]
+        [ ]
+    if ;
 DEFER: check-status
 : quit-game ( vector -- ) drop "you're a quitter" print ;
 : quit? ( vector -- t/f ) peek "quit" = ;
-: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
-: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status  ;
-: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
-: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
-: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
-: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
+: end-game ( vector -- )
+    dup victory? 
+        [ drop "You WON!" ]
+        [ pop number>string " is not 24... You lose." append ]
+    if print ;
+    
+! The following two words are mutually recursive,
+! providing the repl loop of the game
+: repeat ( vector -- )
+    dup report obtain-word apply-word dup update-commands check-status  ;
+: check-status ( object -- )
+    dup done?
+        [ end-game ] 
+        [ dup quit? [ quit-game ] [ repeat ] if ]
+    if ;
+: build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
+: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } commands set ;
 : play-game ( -- ) set-commands 24-able repeat ;
\ No newline at end of file
diff --git a/extra/24-game/tags.txt b/extra/24-game/tags.txt
index cb5fc203e1..d2f0464fdb 100644
--- a/extra/24-game/tags.txt
+++ b/extra/24-game/tags.txt
@@ -1 +1,2 @@
 demos
+games
\ No newline at end of file

From f9900202c8f3764adf66abf78446c2a10ea15dea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 7 Aug 2008 06:34:28 -0500
Subject: [PATCH 12/42] Working on tuple unboxing

---
 .../allocations/allocations.factor            |  50 ++++++--
 .../escape-analysis-tests.factor              |  10 +-
 .../escape-analysis/escape-analysis.factor    |   2 +
 .../tree/escape-analysis/nodes/nodes.factor   |  14 ++-
 .../recursive/recursive-tests.factor          |   1 -
 .../tree/escape-analysis/simple/simple.factor |  65 ++++++++---
 .../compiler/tree/optimizer/optimizer.factor  |  17 ++-
 .../constraints/constraints.factor            |   5 +-
 .../copy/copy-tests.factor}                   |   4 +-
 .../copy/copy.factor}                         |  21 +---
 .../tree/propagation/info/info.factor         |   2 +-
 .../tree/propagation/nodes/nodes.factor       |   2 +-
 .../tree/propagation/propagation.factor       |   4 +-
 .../propagation/recursive/recursive.factor    |   2 +-
 unfinished/compiler/tree/tree.factor          |  20 +++-
 .../tree/tuple-unboxing/tuple-unboxing.factor | 109 ++++++++++++++++++
 .../tree/untupling/untupling-tests.factor     |  50 --------
 .../compiler/tree/untupling/untupling.factor  |  59 ----------
 18 files changed, 250 insertions(+), 187 deletions(-)
 rename unfinished/compiler/tree/{copy-equiv/copy-equiv-tests.factor => propagation/copy/copy-tests.factor} (84%)
 rename unfinished/compiler/tree/{copy-equiv/copy-equiv.factor => propagation/copy/copy.factor} (76%)
 create mode 100644 unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
 delete mode 100644 unfinished/compiler/tree/untupling/untupling-tests.factor
 delete mode 100644 unfinished/compiler/tree/untupling/untupling.factor

diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 8bcaf53ab1..973720c388 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state
-compiler.tree.copy-equiv ;
+combinators sets disjoint-sets fry stack-checker.state ;
 IN: compiler.tree.escape-analysis.allocations
 
 ! A map from values to one of the following:
@@ -18,7 +17,7 @@ TUPLE: slot-access slot# value ;
 C: <slot-access> slot-access
 
 : (allocation) ( value -- value' allocations )
-    resolve-copy allocations get ; inline
+    allocations get ; inline
 
 : allocation ( value -- allocation )
     (allocation) at dup slot-access? [
@@ -26,7 +25,8 @@ C: <slot-access> slot-access
         allocation
     ] when ;
 
-: record-allocation ( allocation value -- ) (allocation) set-at ;
+: record-allocation ( allocation value -- )
+    (allocation) set-at ;
 
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
@@ -40,15 +40,16 @@ SYMBOL: +escaping+
     <disjoint-set> +escaping+ over add-atom ;
 
 : init-escaping-values ( -- )
-    copies get assoc>disjoint-set +escaping+ over add-atom
-    escaping-values set ;
+    <escaping-values> escaping-values set ;
+
+: introduce-value ( values -- )
+    escaping-values get add-atom ;
+
+: introduce-values ( values -- )
+    escaping-values get add-atoms ;
 
 : <slot-value> ( -- value )
-    <value>
-    [ introduce-value ]
-    [ escaping-values get add-atom ]
-    [ ]
-    tri ;
+    <value> dup escaping-values get add-atom ;
 
 : record-slot-access ( out slot# in -- )
     over zero? [ 3drop ] [
@@ -61,8 +62,11 @@ SYMBOL: +escaping+
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;
 
+: equate-values ( value1 value2 -- )
+    escaping-values get equate ;
+
 : add-escaping-value ( value -- )
-    +escaping+ escaping-values get equate ;
+    +escaping+ equate-values ;
 
 : add-escaping-values ( values -- )
     escaping-values get
@@ -79,6 +83,20 @@ SYMBOL: +escaping+
 : escaping-value? ( value -- ? )
     +escaping+ escaping-values get equiv? ;
 
+DEFER: copy-value
+
+: copy-allocation ( allocation -- allocation' )
+    {
+        { [ dup not ] [ ] }
+        { [ dup t eq? ] [ ] }
+        [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
+    } cond ;
+
+: copy-value ( from to -- )
+    [ equate-values ]
+    [ [ allocation copy-allocation ] dip record-allocation ]
+    2bi ;
+
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -88,3 +106,11 @@ SYMBOL: escaping-allocations
 
 : escaping-allocation? ( value -- ? )
     escaping-allocations get key? ;
+
+: unboxed-allocation ( value -- allocation/f )
+    dup escaping-allocation? [ drop f ] [ allocation ] if ;
+
+: unboxed-slot-access? ( value -- ? )
+    (allocation) at dup slot-access?
+    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
+
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 2728a3c933..f01949d422 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -1,9 +1,9 @@
 IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.normalization math.functions
 compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math
+compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple ;
 
@@ -12,10 +12,10 @@ prettyprint classes.tuple.private classes classes.tuple ;
 GENERIC: count-unboxed-allocations* ( m node -- n )
 
 : (count-unboxed-allocations) ( m node -- n )
-    dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
+    out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> \ <tuple-boa> =
+    dup word>> { <tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -281,3 +281,5 @@ C: <ro-box> ro-box
     ] if ; inline recursive
 
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index d1b1ab2dd0..5847f0a5e4 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -11,6 +11,8 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.simple ;
 IN: compiler.tree.escape-analysis
 
+! This pass must run after propagation
+
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set
diff --git a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
index eb56a9e338..3fdde22bd8 100644
--- a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
+++ b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
@@ -1,10 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.tree ;
+USING: kernel sequences
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.nodes
 
 GENERIC: escape-analysis* ( node -- )
 
-M: node escape-analysis* drop ;
-
-: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
+: (escape-analysis) ( node -- )
+    [
+        [ node-defs-values introduce-values ]
+        [ escape-analysis* ]
+        bi
+    ] each ;
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
index 89ff2e59b4..1f6f347ded 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
@@ -1,6 +1,5 @@
 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 ;
 
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index 51d3b6913a..22daa36644 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -1,26 +1,43 @@
 ! 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
+classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
-stack-checker.state
+classes.algebra stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
-M: #introduce escape-analysis*
-    value>> unknown-allocation ;
+M: #declare escape-analysis* drop ;
+
+M: #terminate escape-analysis* drop ;
+
+M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+
+M: #introduce escape-analysis* value>> unknown-allocation ;
+
+DEFER: record-literal-allocation
+
+: make-literal-slots ( seq -- values )
+    [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
+
+: record-literal-tuple-allocation ( value object -- )
+    tuple-slots rest-slice
+    make-literal-slots
+    swap record-allocation ;
+
+: record-literal-complex-allocation ( value object -- )
+    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
+    swap record-allocation ;
 
 : record-literal-allocation ( value object -- )
-    dup class immutable-tuple-class? [
-        tuple-slots rest-slice
-        [ <slot-value> [ swap record-literal-allocation ] keep ] map
-        swap record-allocation
-    ] [
-        drop unknown-allocation
-    ] if ;
+    {
+        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
+        { [ dup complex? ] [ record-literal-complex-allocation ] }
+        [ drop unknown-allocation ]
+    } cond ;
 
 M: #push escape-analysis*
     #! Delegation.
@@ -34,19 +51,29 @@ M: #push escape-analysis*
         record-allocation
     ] [ out-d>> unknown-allocations ] if ;
 
+: record-complex-allocation ( #call -- )
+    [ in-d>> ] [ out-d>> first ] bi record-allocation ;
+
+: slot-offset ( #call -- n/f )
+    dup in-d>>
+    [ first node-value-info class>> ]
+    [ second node-value-info literal>> ] 2bi
+    dup fixnum? [
+        {
+            { [ over tuple class<= ] [ 3 - ] }
+            { [ over complex class<= ] [ 1 - ] }
+            [ drop f ]
+        } cond nip
+    ] [ 2drop f ] 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
-    ] [
-        2drop unknown-allocation
-    ] if ;
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
 
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [
             drop
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index f28b192d2b..e44cf44db7 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -1,17 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.tree.normalization compiler.tree.copy-equiv
-compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.def-use compiler.tree.untupling
-compiler.tree.dead-code compiler.tree.strength-reduction
-compiler.tree.loop-detection compiler.tree.branch-fusion ;
+USING: compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.cleanup
+compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.strength-reduction
+compiler.tree.loop-detection
+compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
     normalize
     propagate
     cleanup
-    compute-def-use
+    escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor
index 46a9fc91ff..cfdf7f5169 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@@ -3,8 +3,9 @@
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
 combinators words
-compiler.tree compiler.tree.propagation.info
-compiler.tree.copy-equiv ;
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.
diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor b/unfinished/compiler/tree/propagation/copy/copy-tests.factor
similarity index 84%
rename from unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
rename to unfinished/compiler/tree/propagation/copy/copy-tests.factor
index 251c4d40d2..a99c2a2447 100644
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
+++ b/unfinished/compiler/tree/propagation/copy/copy-tests.factor
@@ -1,5 +1,5 @@
-IN: compiler.tree.copy-equiv.tests
-USING: compiler.tree.copy-equiv tools.test namespaces kernel
+IN: compiler.tree.propagation.copy.tests
+USING: compiler.tree.propagation.copy tools.test namespaces kernel
 assocs ;
 
 H{ } clone copies set
diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/propagation/copy/copy.factor
similarity index 76%
rename from unfinished/compiler/tree/copy-equiv/copy-equiv.factor
rename to unfinished/compiler/tree/propagation/copy/copy.factor
index 6a4cca7ff4..ee2d6e7415 100644
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
+++ b/unfinished/compiler/tree/propagation/copy/copy.factor
@@ -5,10 +5,7 @@ combinators sets locals
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
-IN: compiler.tree.copy-equiv
-
-! This is not really a compiler pass; its invoked as part of
-! propagation.
+IN: compiler.tree.propagation.copy
 
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation). This is just a weak form of
@@ -39,21 +36,7 @@ SYMBOL: copies
 
 GENERIC: compute-copy-equiv* ( node -- )
 
-M: #shuffle compute-copy-equiv*
-    [ out-d>> dup ] [ mapping>> ] bi
-    '[ , at ] map swap are-copies-of ;
-
-M: #>r compute-copy-equiv*
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> compute-copy-equiv*
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #return-recursive compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
 
 : compute-phi-equiv ( inputs outputs -- )
     #! An output is a copy of every input if all inputs are
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index bc6f1d73e3..1c50914d19 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -3,7 +3,7 @@
 USING: assocs classes classes.algebra kernel
 accessors math math.intervals namespaces sequences words
 combinators combinators.short-circuit arrays
-compiler.tree.copy-equiv ;
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor
index 10dd1a03c6..67a6b19d94 100644
--- a/unfinished/compiler/tree/propagation/nodes/nodes.factor
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@@ -3,7 +3,7 @@
 USING: sequences accessors kernel assocs sequences
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor
index 7fa971bafe..a31bfc4427 100755
--- a/unfinished/compiler/tree/propagation/propagation.factor
+++ b/unfinished/compiler/tree/propagation/propagation.factor
@@ -3,7 +3,7 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -13,6 +13,8 @@ compiler.tree.propagation.constraints
 compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
+! This pass must run after normalization
+
 : propagate ( node -- node )
     H{ } clone copies set
     H{ } clone constraints set
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 9e1bf52bbf..0e3af85b20 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -4,8 +4,8 @@ USING: kernel sequences accessors arrays fry math.intervals
 combinators namespaces
 stack-checker.inlining
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 196c3e3658..016afc3e89 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -39,7 +39,9 @@ TUPLE: #push < node literal out-d ;
         swap 1array >>out-d
         swap >>literal ;
 
-TUPLE: #shuffle < node mapping in-d out-d ;
+TUPLE: #renaming < node ;
+
+TUPLE: #shuffle < #renaming mapping in-d out-d ;
 
 : #shuffle ( inputs outputs mapping -- node )
     \ #shuffle new
@@ -50,14 +52,14 @@ TUPLE: #shuffle < node mapping in-d out-d ;
 : #drop ( inputs -- node )
     { } { } #shuffle ;
 
-TUPLE: #>r < node in-d out-r ;
+TUPLE: #>r < #renaming in-d out-r ;
 
 : #>r ( inputs outputs -- node )
     \ #>r new
         swap >>out-r
         swap >>in-d ;
 
-TUPLE: #r> < node in-r out-d ;
+TUPLE: #r> < #renaming in-r out-d ;
 
 : #r> ( inputs outputs -- node )
     \ #r> new
@@ -126,7 +128,7 @@ TUPLE: #enter-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #return-recursive < node in-d out-d label ;
+TUPLE: #return-recursive < #renaming in-d out-d label ;
 
 : #return-recursive ( label inputs outputs -- node )
     \ #return-recursive new
@@ -134,7 +136,7 @@ TUPLE: #return-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #copy < node in-d out-d ;
+TUPLE: #copy < #renaming in-d out-d ;
 
 : #copy ( inputs outputs -- node )
     \ #copy new
@@ -143,6 +145,14 @@ TUPLE: #copy < node in-d out-d ;
 
 : node, ( node -- ) stack-visitor get push ;
 
+GENERIC: inputs/outputs ( #renaming -- inputs outputs )
+
+M: #shuffle inputs/outputs mapping>> unzip swap ;
+M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
+M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
+M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
new file mode 100644
index 0000000000..6b49502722
--- /dev/null
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -0,0 +1,109 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.tuple-unboxing
+
+! This pass must run after escape analysis
+
+! Mapping from values to sequences of values
+SYMBOL: unboxed-tuples
+
+: unboxed-tuple ( value -- unboxed-tuple )
+    unboxed-tuples get at ;
+
+GENERIC: unbox-tuples* ( node -- )
+
+: value-info-slots ( info -- slots )
+    #! Delegation.
+    [ info>> ] [ class>> ] bi {
+        { [ dup tuple class<= ] [ drop 2 tail ] }
+        { [ dup complex class<= ] [ drop ] }
+    } cond ;
+
+: prepare-unboxed-values ( #push -- values )
+    out-d>> first unboxed-allocation ;
+
+: prepare-unboxed-info ( #push -- infos values )
+    dup prepare-unboxed-values dup
+    [ [ node-output-infos first value-info-slots ] dip ]
+    [ 2drop f f ]
+    if ;
+
+: expand-#push ( #push infos values -- )
+    [ [ literal>> ] dip #push ] 2map >>body drop ;
+
+M: #push unbox-tuples* ( #push -- )
+    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+
+: expand-<tuple-boa> ( #call values -- quot )
+    [ drop in-d>> peek #drop ]
+    [ [ in-d>> but-last ] dip #copy ]
+    2bi 2array ;
+
+: expand-<complex> ( #call values -- quot )
+    [ in-d>> ] dip #copy 1array ;
+
+: expand-constructor ( #call values -- )
+    [ drop ] [ ] [ drop word>> ] 2tri {
+        { <tuple-boa> [ expand-<tuple-boa> ] }
+        { <complex> [ expand-<complex> ] }
+    } case unbox-tuples >>body ;
+
+: unbox-constructor ( #call -- )
+    dup prepare-unboxed-values dup
+    [ expand-constructor ] [ 2drop ] if ;
+
+: (flatten-values) ( values -- values' )
+    [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+
+: flatten-values ( values -- values' )
+    (flatten-values) flatten ;
+
+: flatten-value ( values -- values )
+    1array flatten-values ;
+
+: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+    [ in-d>> first flatten-value ]
+    [
+        [ dup in-d>> second node-value-info literal>> ]
+        [ out-d>> first unboxed-allocation ]
+        bi nth flatten-value
+    ]
+    [ out-d>> flatten-values ]
+    tri ;
+
+: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
+    [ nip ] [ zip ] 2bi #shuffle ;
+
+: unbox-slot-access ( #call -- )
+    dup unboxed-slot-access? [
+        dup
+        [ in-d>> second 1array #drop ]
+        [ prepare-slot-access slot-access-shuffle ]
+        bi 2array unbox-tuples >>body
+    ] when drop ;
+
+M: #call unbox-tuples* ( #call -- )
+    dup word>> {
+        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <complex> [ unbox-<complex> ] }
+        { \ slot [ unbox-slot-access ] }
+        [ 2drop ]
+    } case ;
+
+M: #copy ... ;
+
+M: #>r ... ;
+
+M: #r> ... ;
+
+M: #shuffle ... ;
+
+M: #terrible ... ;
+
+! These nodes never participate in unboxing
+M: #return drop ;
+
+M: #introduce drop ;
+
+: unbox-tuples ( nodes -- nodes )
+    dup [ unbox-tuples* ] each-node ;
diff --git a/unfinished/compiler/tree/untupling/untupling-tests.factor b/unfinished/compiler/tree/untupling/untupling-tests.factor
deleted file mode 100644
index 27d8a66153..0000000000
--- a/unfinished/compiler/tree/untupling/untupling-tests.factor
+++ /dev/null
@@ -1,50 +0,0 @@
-IN: compiler.tree.untupling.tests
-USING: assocs math kernel quotations.private slots.private
-compiler.tree.builder
-compiler.tree.def-use
-compiler.tree.copy-equiv
-compiler.tree.untupling
-tools.test ;
-
-: check-untupling ( quot -- sizes )
-    build-tree
-    compute-copy-equiv
-    compute-def-use
-    compute-untupling
-    values ;
-
-[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
-] unit-test
-
-[ { 2 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
-] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
-] unit-test
diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor
deleted file mode 100644
index 7286e6fb65..0000000000
--- a/unfinished/compiler/tree/untupling/untupling.factor
+++ /dev/null
@@ -1,59 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors slots.private kernel namespaces disjoint-sets
-math sequences assocs classes.tuple.private combinators fry sets
-compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
-compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward ;
-IN: compiler.tree.untupling
-
-SYMBOL: escaping-values
-
-: mark-escaping-values ( node -- )
-    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
-
-SYMBOL: untupling-candidates
-
-: untupling-candidate ( #call class -- )
-    #! 1- for delegate
-    size>> 1- swap out-d>> first resolve-copy
-    untupling-candidates get set-at ;
-
-GENERIC: compute-untupling* ( node -- )
-
-M: #call compute-untupling*
-    dup word>> {
-        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
-        { \ curry [ \ curry tuple-layout untupling-candidate ] }
-        { \ compose [ \ compose tuple-layout untupling-candidate ] }
-        { \ slot [ drop ] }
-        [ drop mark-escaping-values ]
-    } case ;
-
-M: #return compute-untupling* mark-escaping-values ;
-
-M: node compute-untupling* drop ;
-
-GENERIC: check-consistency* ( node -- )
-
-: check-value-consistency ( out-value in-values -- )
-    swap escaping-values get key? [
-        escaping-values get '[ , conjoin ] each
-    ] [
-        untupling-candidates get 2dup '[ , at ] map all-equal?
-        [ 2drop ] [ '[ , delete-at ] each ] if
-    ] if ;
-
-M: #phi check-consistency*
-    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
-    bi ;
-
-M: node check-consistency* drop ;
-
-: compute-untupling ( node -- assoc )
-    H{ } clone escaping-values set
-    H{ } clone untupling-candidates set
-    [ [ compute-untupling* ] each-node ]
-    [ [ check-consistency* ] each-node ] bi
-    untupling-candidates get escaping-values get assoc-diff ;

From 14b83dc2195f6bacd116f613f2411dae0e75b61e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 7 Aug 2008 15:45:36 -0500
Subject: [PATCH 13/42] cfdg.models.rules08: Use new macros

---
 extra/cfdg/models/rules08/rules08.factor | 34 +++++++-----------------
 1 file changed, 9 insertions(+), 25 deletions(-)

diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor
index 20099d225a..f5398582c9 100644
--- a/extra/cfdg/models/rules08/rules08.factor
+++ b/extra/cfdg/models/rules08/rules08.factor
@@ -17,37 +17,21 @@ DEFER: line
 
 : ligne ( -- )
   {
-    { 1   [ 4.5 y 1.15 0.8 size* -0.3 b line ] do }
+    { 1   [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
     { 0.5 [ ] }
   }
-  call-random-weighted ;
+  rules ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line ( -- ) [ insct ligne ] recursive ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: line ( -- ) { [ insct ligne ] } rule ;
 
 : sole ( -- )
-  [
-    {
-      {
-        1 [
-            [ 1 brightness 0.5 saturation ligne ] do
-            [ 140 r 1 hue                 sole  ] do
-          ]
-      }
-      { 0.01 [ ] }
-    }
-    call-random-weighted
-  ]
-  recursive ;
+  {
+    { 1    [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
+    { 0.01 [ ] }
+  }
+  rules ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: centre ( -- )
-  [ 1 b 5 s circle ] do
-  [ sole ] do ;
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

From f891a057aff5d440e93880f30703b45d9f8ac86a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 7 Aug 2008 15:46:11 -0500
Subject: [PATCH 14/42] Move colors to basis

---
 {extra => basis}/colors/authors.txt     | 0
 {extra => basis}/colors/colors.factor   | 0
 {extra => basis}/colors/hsv/authors.txt | 0
 {extra => basis}/colors/hsv/hsv.factor  | 0
 4 files changed, 0 insertions(+), 0 deletions(-)
 rename {extra => basis}/colors/authors.txt (100%)
 rename {extra => basis}/colors/colors.factor (100%)
 rename {extra => basis}/colors/hsv/authors.txt (100%)
 rename {extra => basis}/colors/hsv/hsv.factor (100%)

diff --git a/extra/colors/authors.txt b/basis/colors/authors.txt
similarity index 100%
rename from extra/colors/authors.txt
rename to basis/colors/authors.txt
diff --git a/extra/colors/colors.factor b/basis/colors/colors.factor
similarity index 100%
rename from extra/colors/colors.factor
rename to basis/colors/colors.factor
diff --git a/extra/colors/hsv/authors.txt b/basis/colors/hsv/authors.txt
similarity index 100%
rename from extra/colors/hsv/authors.txt
rename to basis/colors/hsv/authors.txt
diff --git a/extra/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor
similarity index 100%
rename from extra/colors/hsv/hsv.factor
rename to basis/colors/hsv/hsv.factor

From d311893363bb8fda1d63f5b84955c3a79a235e37 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 7 Aug 2008 17:10:17 -0500
Subject: [PATCH 15/42] ui.gadgets.theme: Use 'gray' color objects

---
 extra/ui/gadgets/theme/theme.factor | 38 ++++++++++++++---------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/extra/ui/gadgets/theme/theme.factor b/extra/ui/gadgets/theme/theme.factor
index 20f560e309..46fa0105a3 100644
--- a/extra/ui/gadgets/theme/theme.factor
+++ b/extra/ui/gadgets/theme/theme.factor
@@ -18,41 +18,41 @@ IN: ui.gadgets.theme
 
 : plain-gradient
     T{ gradient f {
-        T{ rgba f 0.94 0.94 0.94 1.0 }
-        T{ rgba f 0.83 0.83 0.83 1.0 }
-        T{ rgba f 0.83 0.83 0.83 1.0 }
-        T{ rgba f 0.62 0.62 0.62 1.0 }
+        T{ gray f 0.94 1.0 }
+        T{ gray f 0.83 1.0 }
+        T{ gray f 0.83 1.0 }
+        T{ gray f 0.62 1.0 }
     } } ;
 
 : rollover-gradient
     T{ gradient f {
-        T{ rgba f 1.0 1.0 1.0 1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
-        T{ rgba f 0.75 0.75 0.75 1.0 }
+        T{ gray f 1.0  1.0 }
+        T{ gray f 0.9  1.0 }
+        T{ gray f 0.9  1.0 }
+        T{ gray f 0.75 1.0 }
     } } ;
 
 : pressed-gradient
     T{ gradient f {
-        T{ rgba f 0.75 0.75 0.75 1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
-        T{ rgba f 0.9 0.9 0.9 1.0 }
-        T{ rgba f 1.0 1.0 1.0 1.0 }
+        T{ gray f 0.75 1.0 }
+        T{ gray f 0.9  1.0 }
+        T{ gray f 0.9  1.0 }
+        T{ gray f 1.0  1.0 }
     } } ;
 
 : selected-gradient
     T{ gradient f {
-        T{ rgba f 0.65 0.65 0.65 1.0 }
-        T{ rgba f 0.8 0.8 0.8 1.0 }
-        T{ rgba f 0.8 0.8 0.8 1.0 }
-        T{ rgba f 1.0 1.0 1.0 1.0 }
+        T{ gray f 0.65 1.0 }
+        T{ gray f 0.8  1.0 }
+        T{ gray f 0.8  1.0 }
+        T{ gray f 1.0  1.0 }
     } } ;
 
 : lowered-gradient
     T{ gradient f {
-        T{ rgba f 0.37 0.37 0.37 1.0 }
-        T{ rgba f 0.43 0.43 0.43 1.0 }
-        T{ rgba f 0.5 0.5 0.5 1.0 }
+        T{ gray f 0.37 1.0 }
+        T{ gray f 0.43 1.0 }
+        T{ gray f 0.5  1.0 }
     } } ;
 
 : sans-serif-font { "sans-serif" plain 12 } ;

From 708e24fcb0c22063b11a0a50d0a0f3cde449618d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 7 Aug 2008 17:16:09 -0500
Subject: [PATCH 16/42] ui.gadgets.buttons: Minor '<radio-buttons>' update

---
 extra/ui/gadgets/buttons/buttons.factor | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index c5a5e8bad8..d60901d993 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -199,14 +199,11 @@ M: radio-control model-changed
 : <radio-button> ( value model label -- gadget )
     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 
-: radio-buttons-theme ( gadget -- )
-    { 5 5 } >>gap drop ;
-
 : <radio-buttons> ( model assoc -- gadget )
   <filled-pile>
     -rot
     [ <radio-button> ] <radio-controls>
-  dup radio-buttons-theme ;
+  { 5 5 } >>gap ;
 
 : <toggle-button> ( value model label -- gadget )
     <radio-control> bevel-button-theme ;

From 1603be0cec3a03925c7ec8f3bf3c7fc8ea23b72b Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 7 Aug 2008 14:00:54 -0300
Subject: [PATCH 17/42] irc.client: Improve testing, better handling of
 participant list changes notifications, fix quit notification.

---
 extra/irc/client/client-tests.factor | 285 ++++++++++++---------------
 extra/irc/client/client.factor       |  62 +++---
 2 files changed, 147 insertions(+), 200 deletions(-)

diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 1b338df442..97532cbd95 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -1,190 +1,153 @@
 USING: kernel tools.test accessors arrays sequences qualified
-       io.streams.string io.streams.duplex namespaces threads
+       io io.streams.duplex namespaces threads
        calendar irc.client.private irc.client irc.messages.private
        concurrency.mailboxes classes assocs combinators ;
 EXCLUDE: irc.messages => join ;
 RENAME: join irc.messages => join_
 IN: irc.client.tests
 
-! Utilities
-: <test-stream> ( lines -- stream )
-  "\n" join <string-reader> <string-writer> <duplex-stream> ;
+! Streams for testing
+TUPLE: mb-writer lines last-line disposed ;
+TUPLE: mb-reader lines disposed ;
+: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
+: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
+: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
+: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
+M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
+M: mb-writer stream-flush ( mb-writer -- ) drop ;
+M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
+M: mb-writer stream-nl ( mb-writer -- )
+    [ [ last-line>> concat ] [ lines>> ] bi push ] keep
+    V{ } clone >>last-line drop ;
 
-: make-client ( lines -- irc-client )
-    "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
-    swap [ 2nip <test-stream> f ] curry >>connect ;
+: spawn-client ( lines listeners -- irc-client )
+    "someserver" irc-port "factorbot" f <irc-profile>
+    <irc-client>
+        t >>is-running
+        <test-stream> >>stream
+    dup [ spawn-irc yield ] with-irc-client ;
 
-: set-nick ( irc-client nickname -- )
-    swap profile>> (>>nickname) ;
+! to be used inside with-irc-client quotations
+: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
+: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ;
 
-: with-dummy-client ( irc-client quot -- )
-    [ current-irc-client ] dip with-variable ; inline
+: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
+    [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
 
-{ "" } make-client dup "factorbot" set-nick [
-    { t } [ irc> profile>> nickname>> me? ] unit-test
+: with-irc ( quot: ( -- ) -- )
+    [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline
 
-    { "factorbot" } [ irc> profile>> nickname>> ] unit-test
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                       TESTS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-    { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+[ { t } [ irc> profile>> nickname>> me? ] unit-test
 
-    { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-                        parse-irc-line irc-message-origin ] unit-test
+  { "factorbot" } [ irc> profile>> nickname>> ] unit-test
 
-    { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
-                     parse-irc-line irc-message-origin ] unit-test
-] with-dummy-client
+  { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
+  { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+                      parse-irc-line irc-message-origin ] unit-test
+
+  { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+                   parse-irc-line irc-message-origin ] unit-test
+] with-irc
 
 ! 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 ]
-      [ drop 0.1 seconds sleep ]
-      [ profile>> nickname>> ]
-      [ terminate-irc ]
-    } cleave ] unit-test
+[ { "factorbot2" } [
+     ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
+      irc> profile>> nickname>>
+  ] unit-test
+] with-irc
 
-{ 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
-    { [ "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_ "#factortest" } [
+      { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+        ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+        ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+        ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+      } [ %push-line ] each
+      irc> join-messages>> 0.1 seconds mailbox-get-timeout
+      [ class ] [ trailing>> ] bi
+  ] unit-test
+] with-irc
 
-{ +join+ "somebody" } [
-    { ":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
+[ { T{ participant-changed f "somebody" +join+ } } [
+      "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+      ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
+      [ participant-changed? ] read-matching-message
+  ] unit-test
+] with-irc
 
-{ 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 "#factortest" "hello" } [
+      "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+      ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
+      [ privmsg? ] read-matching-message
+      [ class ] [ name>> ] [ trailing>> ] tri
+  ] unit-test
+] with-irc
 
-{ 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
+[ { privmsg "factorbot" "hello" } [
+      "somedude" <irc-nick-listener>  [ %add-named-listener ] keep
+      ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+      [ privmsg? ] read-matching-message
+      [ class ] [ name>> ] [ trailing>> ] tri
+  ] unit-test
+] with-irc
 
 ! 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{ { "somedude" +normal+ } } } [
+      "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+      ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+      participants>>
+  ] unit-test
+] with-irc
 
-{ 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+ } } } [
+      "#factortest" <irc-channel-listener>
+          H{ { "somedude2" +normal+ }
+             { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude!n=user@isp.net PART #factortest" %push-line
+      participants>>
+  ] unit-test
+] with-irc
 
-{ 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+ } } } [
+      "#factortest" <irc-channel-listener>
+          H{ { "somedude2" +normal+ }
+             { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude!n=user@isp.net QUIT" %push-line
+      participants>>
+  ] unit-test
+] with-irc
 
-{ 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
+[ { H{ { "somedude2" +normal+ } } } [
+      "#factortest" <irc-channel-listener>
+          H{ { "somedude2" +normal+ }
+             { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+      participants>>
+  ] unit-test
+] with-irc
 
 ! Namelist change 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
+[ { T{ participant-changed f f f } } [
+      "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+      ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+      ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+      [ participant-changed? ] read-matching-message
+  ] unit-test
+] with-irc
 
-{ T{ participant-changed f "somedude" +part+ } } [
-    { ":somedude!n=user@isp.net QUIT" } make-client
-    { [ "factorbot" set-nick ]
-      [ listeners>>
-        [ "#factortest" [ <irc-channel-listener>
-                          H{ { "somedude" +normal+ } } clone >>participants ] keep
-        ] dip set-at ]
-      [ connect-irc ]
-      [ drop 0.1 seconds sleep ]
-      [ listeners>> [ "#factortest" ] dip at
-        [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
-      [ terminate-irc ]
-    } cleave
-    ] unit-test
\ No newline at end of file
+[ { T{ participant-changed f "somedude" +part+ } } [
+      "#factortest" <irc-channel-listener>
+                    H{ { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude!n=user@isp.net QUIT" %push-line
+      [ participant-changed? ] read-matching-message
+  ] unit-test
+] with-irc
\ No newline at end of file
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 99922b1fb5..07885a3f82 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -100,17 +100,21 @@ M: string to-listener ( message string -- )
     listener> [ +server-listener+ listener> ] unless*
     [ to-listener ] [ drop ] if* ;
 
+M: irc-listener to-listener ( message irc-listener -- )
+    in-messages>> mailbox-put ;
+
 : 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 ;
+: (remove-participant) ( nick listener -- )
+    [ participants>> delete-at ]
+    [ [ +part+ <participant-changed> ] dip to-listener ] 2bi ;
 
 : remove-participant ( nick channel -- )
-    listener> [ participants>> delete-at ] [ drop ] if* ;
+    listener> [ (remove-participant) ] [ drop ] if* ;
 
 : listeners-with-participant ( nick -- seq )
     irc> listeners>> values
@@ -118,10 +122,13 @@ M: irc-listener to-listener ( message irc-listener -- )
     with filter ;
 
 : remove-participant-from-all ( nick -- )
-    dup listeners-with-participant [ participants>> delete-at ] with each ;
+    dup listeners-with-participant [ (remove-participant) ] with each ;
 
 : add-participant ( mode nick channel -- )
-    listener> [ participants>> set-at ] [ 2drop ] if* ;
+    listener> [
+        [ participants>> set-at ]
+        [ [ +join+ <participant-changed> ] dip to-listener ] 2bi
+    ] [ 2drop ] if* ;
 
 DEFER: me?
 
@@ -164,25 +171,6 @@ DEFER: me?
 : broadcast-message-to-listeners ( message -- )
     irc> listeners>> values [ to-listener ] with each ;
 
-GENERIC: handle-participant-change ( irc-message -- )
-
-M: join handle-participant-change ( join -- )
-    [ prefix>> parse-name +join+ <participant-changed> ]
-    [ trailing>> ] bi to-listener ;
-
-M: part handle-participant-change ( part -- )
-    [ prefix>> parse-name +part+ <participant-changed> ]
-    [ channel>> ] bi to-listener ;
-
-M: kick handle-participant-change ( kick -- )
-    [ who>> +part+ <participant-changed> ]
-    [ channel>> ] bi to-listener ;
-
-M: quit handle-participant-change ( quit -- )
-    prefix>> parse-name
-    [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
-    [ to-listener ] with each ;
-
 GENERIC: handle-incoming-irc ( irc-message -- )
 
 M: irc-message handle-incoming-irc ( irc-message -- )
@@ -201,31 +189,27 @@ M: privmsg handle-incoming-irc ( privmsg -- )
     dup irc-message-origin to-listener ;
 
 M: join handle-incoming-irc ( join -- )
-    { [ maybe-forward-join ]
-      [ dup trailing>> to-listener ]
-      [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
-      [ handle-participant-change ]
-    } cleave ;
+    [ maybe-forward-join ]
+    [ dup trailing>> to-listener ]
+    [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+    tri ;
 
 M: part handle-incoming-irc ( part -- )
     [ dup channel>> to-listener ]
     [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
-    [ handle-participant-change ]
-    tri ;
+    bi ;
 
 M: kick handle-incoming-irc ( kick -- )
-    { [ dup channel>> to-listener ]
-      [ [ who>> ] [ channel>> ] bi remove-participant ]
-      [ handle-participant-change ]
-      [ dup who>> me? [ unregister-listener ] [ drop ] if ]
-    } cleave ;
+    [ dup channel>> to-listener ]
+    [ [ who>> ] [ channel>> ] bi remove-participant ]
+    [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    tri ;
 
 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 ]
-    tri ;
+    bi ;
 
 ! FIXME: implement this
 ! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
@@ -367,7 +351,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
     in-messages>> [ irc-connected ] dip mailbox-put ;
 
 : with-irc-client ( irc-client quot: ( -- ) -- )
-    [ current-irc-client ] dip with-variable ; inline
+    [ \ current-irc-client ] dip with-variable ; inline
 
 PRIVATE>
 

From cd77f8ba503997b9894fca442dc05f2707689b15 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 7 Aug 2008 23:02:29 -0300
Subject: [PATCH 18/42] irc.client: Handle nick changes in participant lists
 and forward to channels with the participant. Forward mode messages to
 channels.

---
 extra/irc/client/client-tests.factor | 37 +++++++++++++++++++++++-----
 extra/irc/client/client.factor       | 31 +++++++++++++++++------
 2 files changed, 55 insertions(+), 13 deletions(-)

diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 97532cbd95..2b4b501952 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -30,7 +30,7 @@ M: mb-writer stream-nl ( mb-writer -- )
 ! to be used inside with-irc-client quotations
 : %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
 : %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
-: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
 
 : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
     [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
@@ -96,7 +96,14 @@ M: mb-writer stream-nl ( mb-writer -- )
   ] unit-test
 ] with-irc
 
-! Participants lists tests
+[ { mode } [
+      "#factortest" <irc-channel-listener>  [ %add-named-listener ] keep
+      ":ircserver.net MODE #factortest +ns" %push-line
+      [ mode? ] read-matching-message class
+  ] unit-test
+] with-irc
+
+! Participant lists tests
 [ { H{ { "somedude" +normal+ } } } [
       "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
       ":somedude!n=user@isp.net JOIN :#factortest" %push-line
@@ -134,8 +141,17 @@ M: mb-writer stream-nl ( mb-writer -- )
   ] unit-test
 ] with-irc
 
+[ { H{ { "somedude2" +normal+ } } } [
+      "#factortest" <irc-channel-listener>
+          H{ { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+      participants>>
+  ] unit-test
+] with-irc
+
 ! Namelist change notification
-[ { T{ participant-changed f f f } } [
+[ { T{ participant-changed f f f f } } [
       "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
       ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
       ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
@@ -143,11 +159,20 @@ M: mb-writer stream-nl ( mb-writer -- )
   ] unit-test
 ] with-irc
 
-[ { T{ participant-changed f "somedude" +part+ } } [
+[ { T{ participant-changed f "somedude" +part+ f } } [
       "#factortest" <irc-channel-listener>
-                    H{ { "somedude" +normal+ } } clone >>participants
+          H{ { "somedude" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
       ":somedude!n=user@isp.net QUIT" %push-line
       [ participant-changed? ] read-matching-message
   ] unit-test
-] with-irc
\ No newline at end of file
+] with-irc
+
+[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
+      "#factortest" <irc-channel-listener>
+          H{ { "somedude" +normal+ } } clone >>participants
+      [ %add-named-listener ] keep
+      ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+      [ participant-changed? ] read-matching-message
+  ] unit-test
+] with-irc
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 07885a3f82..e91767b22d 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -41,6 +41,7 @@ SYMBOL: +normal+
 SYMBOL: +join+
 SYMBOL: +part+
 SYMBOL: +mode+
+SYMBOL: +nick+
 
 ! listener objects
 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@@ -59,7 +60,7 @@ SYMBOL: +mode+
 ! Message objects
 ! ======================================
 
-TUPLE: participant-changed nick action ;
+TUPLE: participant-changed nick action parameter ;
 C: <participant-changed> participant-changed
 
 SINGLETON: irc-listener-end ! send to a listener to stop its execution
@@ -111,7 +112,7 @@ M: irc-listener to-listener ( message irc-listener -- )
 
 : (remove-participant) ( nick listener -- )
     [ participants>> delete-at ]
-    [ [ +part+ <participant-changed> ] dip to-listener ] 2bi ;
+    [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
 
 : remove-participant ( nick channel -- )
     listener> [ (remove-participant) ] [ drop ] if* ;
@@ -124,10 +125,21 @@ M: irc-listener to-listener ( message irc-listener -- )
 : remove-participant-from-all ( nick -- )
     dup listeners-with-participant [ (remove-participant) ] with each ;
 
+: notify-rename ( newnick oldnick listener -- )
+    [ participant-changed new +nick+ >>action
+      [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
+
+: rename-participant ( newnick oldnick listener -- )
+    [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
+    [ notify-rename ] 3bi ;
+
+: rename-participant-in-all ( oldnick newnick -- )
+    swap dup listeners-with-participant [ rename-participant ] with with each ;
+
 : add-participant ( mode nick channel -- )
     listener> [
         [ participants>> set-at ]
-        [ [ +join+ <participant-changed> ] dip to-listener ] 2bi
+        [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
     ] [ 2drop ] if* ;
 
 DEFER: me?
@@ -211,9 +223,14 @@ M: quit handle-incoming-irc ( quit -- )
     [ prefix>> parse-name remove-participant-from-all ]
     bi ;
 
-! FIXME: implement this
-! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
-! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
+M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
+    dup channel>> to-listener ;
+
+M: nick handle-incoming-irc ( nick -- )
+    [ dup prefix>> parse-name listeners-with-participant
+      [ to-listener ] with each ]
+    [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
+    bi ;
 
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -225,7 +242,7 @@ M: quit handle-incoming-irc ( quit -- )
 M: names-reply handle-incoming-irc ( names-reply -- )
     [ names-reply>participants ] [ channel>> listener> ] bi [
         [ (>>participants) ]
-        [ [ f f <participant-changed> ] dip name>> to-listener ] bi
+        [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
     ] [ drop ] if* ;
 
 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )

From 7402cd2ab765fb1cb672a35132af725699462926 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 7 Aug 2008 21:12:50 -0500
Subject: [PATCH 19/42] Move 'ui' to basis

---
 {extra => basis}/ui/authors.txt                                   | 0
 {extra => basis}/ui/backend/authors.txt                           | 0
 {extra => basis}/ui/backend/backend.factor                        | 0
 {extra => basis}/ui/backend/summary.txt                           | 0
 {extra => basis}/ui/clipboards/authors.txt                        | 0
 {extra => basis}/ui/clipboards/clipboards-docs.factor             | 0
 {extra => basis}/ui/clipboards/clipboards.factor                  | 0
 {extra => basis}/ui/clipboards/summary.txt                        | 0
 {extra => basis}/ui/cocoa/authors.txt                             | 0
 {extra => basis}/ui/cocoa/cocoa.factor                            | 0
 {extra => basis}/ui/cocoa/summary.txt                             | 0
 {extra => basis}/ui/cocoa/tags.txt                                | 0
 {extra => basis}/ui/cocoa/tools/authors.txt                       | 0
 {extra => basis}/ui/cocoa/tools/summary.txt                       | 0
 {extra => basis}/ui/cocoa/tools/tags.txt                          | 0
 {extra => basis}/ui/cocoa/tools/tools.factor                      | 0
 {extra => basis}/ui/cocoa/views/authors.txt                       | 0
 {extra => basis}/ui/cocoa/views/summary.txt                       | 0
 {extra => basis}/ui/cocoa/views/tags.txt                          | 0
 {extra => basis}/ui/cocoa/views/views.factor                      | 0
 {extra => basis}/ui/commands/authors.txt                          | 0
 {extra => basis}/ui/commands/commands-docs.factor                 | 0
 {extra => basis}/ui/commands/commands-tests.factor                | 0
 {extra => basis}/ui/commands/commands.factor                      | 0
 {extra => basis}/ui/commands/summary.txt                          | 0
 {extra => basis}/ui/freetype/authors.txt                          | 0
 {extra => basis}/ui/freetype/freetype-docs.factor                 | 0
 {extra => basis}/ui/freetype/freetype.factor                      | 0
 {extra => basis}/ui/freetype/summary.txt                          | 0
 {extra => basis}/ui/gadgets/authors.txt                           | 0
 {extra => basis}/ui/gadgets/books/authors.txt                     | 0
 {extra => basis}/ui/gadgets/books/books-docs.factor               | 0
 {extra => basis}/ui/gadgets/books/books-tests.factor              | 0
 {extra => basis}/ui/gadgets/books/books.factor                    | 0
 {extra => basis}/ui/gadgets/books/summary.txt                     | 0
 {extra => basis}/ui/gadgets/borders/authors.txt                   | 0
 {extra => basis}/ui/gadgets/borders/borders-docs.factor           | 0
 {extra => basis}/ui/gadgets/borders/borders-tests.factor          | 0
 {extra => basis}/ui/gadgets/borders/borders.factor                | 0
 {extra => basis}/ui/gadgets/borders/summary.txt                   | 0
 {extra => basis}/ui/gadgets/buttons/authors.txt                   | 0
 {extra => basis}/ui/gadgets/buttons/buttons-docs.factor           | 0
 {extra => basis}/ui/gadgets/buttons/buttons-tests.factor          | 0
 {extra => basis}/ui/gadgets/buttons/buttons.factor                | 0
 {extra => basis}/ui/gadgets/buttons/summary.txt                   | 0
 {extra => basis}/ui/gadgets/canvas/authors.txt                    | 0
 {extra => basis}/ui/gadgets/canvas/canvas.factor                  | 0
 {extra => basis}/ui/gadgets/cartesian/cartesian.factor            | 0
 {extra => basis}/ui/gadgets/editors/authors.txt                   | 0
 {extra => basis}/ui/gadgets/editors/editors-docs.factor           | 0
 {extra => basis}/ui/gadgets/editors/editors-tests.factor          | 0
 {extra => basis}/ui/gadgets/editors/editors.factor                | 0
 {extra => basis}/ui/gadgets/editors/summary.txt                   | 0
 {extra => basis}/ui/gadgets/frame-buffer/frame-buffer.factor      | 0
 {extra => basis}/ui/gadgets/frames/authors.txt                    | 0
 {extra => basis}/ui/gadgets/frames/frames-docs.factor             | 0
 {extra => basis}/ui/gadgets/frames/frames-tests.factor            | 0
 {extra => basis}/ui/gadgets/frames/frames.factor                  | 0
 {extra => basis}/ui/gadgets/frames/summary.txt                    | 0
 {extra => basis}/ui/gadgets/gadgets-docs.factor                   | 0
 {extra => basis}/ui/gadgets/gadgets-tests.factor                  | 0
 {extra => basis}/ui/gadgets/gadgets.factor                        | 0
 {extra => basis}/ui/gadgets/grid-lines/authors.txt                | 0
 {extra => basis}/ui/gadgets/grid-lines/grid-lines-docs.factor     | 0
 {extra => basis}/ui/gadgets/grid-lines/grid-lines.factor          | 0
 {extra => basis}/ui/gadgets/grid-lines/summary.txt                | 0
 {extra => basis}/ui/gadgets/grids/authors.txt                     | 0
 {extra => basis}/ui/gadgets/grids/grids-docs.factor               | 0
 {extra => basis}/ui/gadgets/grids/grids-tests.factor              | 0
 {extra => basis}/ui/gadgets/grids/grids.factor                    | 0
 {extra => basis}/ui/gadgets/grids/summary.txt                     | 0
 {extra => basis}/ui/gadgets/handler/authors.txt                   | 0
 {extra => basis}/ui/gadgets/handler/handler.factor                | 0
 {extra => basis}/ui/gadgets/incremental/authors.txt               | 0
 {extra => basis}/ui/gadgets/incremental/incremental-docs.factor   | 0
 {extra => basis}/ui/gadgets/incremental/incremental.factor        | 0
 {extra => basis}/ui/gadgets/incremental/summary.txt               | 0
 {extra => basis}/ui/gadgets/labelled/authors.txt                  | 0
 {extra => basis}/ui/gadgets/labelled/labelled-docs.factor         | 0
 {extra => basis}/ui/gadgets/labelled/labelled.factor              | 0
 {extra => basis}/ui/gadgets/labelled/summary.txt                  | 0
 {extra => basis}/ui/gadgets/labels/authors.txt                    | 0
 {extra => basis}/ui/gadgets/labels/labels-docs.factor             | 0
 {extra => basis}/ui/gadgets/labels/labels.factor                  | 0
 {extra => basis}/ui/gadgets/labels/summary.txt                    | 0
 {extra => basis}/ui/gadgets/lib/authors.txt                       | 0
 {extra => basis}/ui/gadgets/lib/lib.factor                        | 0
 {extra => basis}/ui/gadgets/lists/authors.txt                     | 0
 {extra => basis}/ui/gadgets/lists/lists-docs.factor               | 0
 {extra => basis}/ui/gadgets/lists/lists-tests.factor              | 0
 {extra => basis}/ui/gadgets/lists/lists.factor                    | 0
 {extra => basis}/ui/gadgets/lists/summary.txt                     | 0
 {extra => basis}/ui/gadgets/menus/authors.txt                     | 0
 {extra => basis}/ui/gadgets/menus/menus-docs.factor               | 0
 {extra => basis}/ui/gadgets/menus/menus.factor                    | 0
 {extra => basis}/ui/gadgets/menus/summary.txt                     | 0
 {extra => basis}/ui/gadgets/packs/authors.txt                     | 0
 {extra => basis}/ui/gadgets/packs/packs-docs.factor               | 0
 {extra => basis}/ui/gadgets/packs/packs-tests.factor              | 0
 {extra => basis}/ui/gadgets/packs/packs.factor                    | 0
 {extra => basis}/ui/gadgets/packs/summary.txt                     | 0
 {extra => basis}/ui/gadgets/panes/authors.txt                     | 0
 {extra => basis}/ui/gadgets/panes/panes-docs.factor               | 0
 {extra => basis}/ui/gadgets/panes/panes-tests.factor              | 0
 {extra => basis}/ui/gadgets/panes/panes.factor                    | 0
 {extra => basis}/ui/gadgets/panes/summary.txt                     | 0
 {extra => basis}/ui/gadgets/paragraphs/authors.txt                | 0
 {extra => basis}/ui/gadgets/paragraphs/paragraphs.factor          | 0
 {extra => basis}/ui/gadgets/paragraphs/summary.txt                | 0
 {extra => basis}/ui/gadgets/plot/plot.factor                      | 0
 {extra => basis}/ui/gadgets/presentations/authors.txt             | 0
 .../ui/gadgets/presentations/presentations-docs.factor            | 0
 .../ui/gadgets/presentations/presentations-tests.factor           | 0
 {extra => basis}/ui/gadgets/presentations/presentations.factor    | 0
 {extra => basis}/ui/gadgets/presentations/summary.txt             | 0
 {extra => basis}/ui/gadgets/scrollers/authors.txt                 | 0
 {extra => basis}/ui/gadgets/scrollers/scrollers-docs.factor       | 0
 {extra => basis}/ui/gadgets/scrollers/scrollers-tests.factor      | 0
 {extra => basis}/ui/gadgets/scrollers/scrollers.factor            | 0
 {extra => basis}/ui/gadgets/scrollers/summary.txt                 | 0
 {extra => basis}/ui/gadgets/slate/authors.txt                     | 0
 {extra => basis}/ui/gadgets/slate/slate.factor                    | 0
 {extra => basis}/ui/gadgets/sliders/authors.txt                   | 0
 {extra => basis}/ui/gadgets/sliders/sliders-docs.factor           | 0
 {extra => basis}/ui/gadgets/sliders/sliders.factor                | 0
 {extra => basis}/ui/gadgets/sliders/summary.txt                   | 0
 {extra => basis}/ui/gadgets/slots/authors.txt                     | 0
 {extra => basis}/ui/gadgets/slots/slots-tests.factor              | 0
 {extra => basis}/ui/gadgets/slots/slots.factor                    | 0
 {extra => basis}/ui/gadgets/slots/summary.txt                     | 0
 {extra => basis}/ui/gadgets/status-bar/authors.txt                | 0
 {extra => basis}/ui/gadgets/status-bar/status-bar-docs.factor     | 0
 {extra => basis}/ui/gadgets/status-bar/status-bar.factor          | 0
 {extra => basis}/ui/gadgets/status-bar/summary.txt                | 0
 {extra => basis}/ui/gadgets/summary.txt                           | 0
 {extra => basis}/ui/gadgets/tabs/authors.txt                      | 0
 {extra => basis}/ui/gadgets/tabs/summary.txt                      | 0
 {extra => basis}/ui/gadgets/tabs/tabs.factor                      | 0
 {extra => basis}/ui/gadgets/theme/authors.txt                     | 0
 {extra => basis}/ui/gadgets/theme/summary.txt                     | 0
 {extra => basis}/ui/gadgets/theme/theme.factor                    | 0
 {extra => basis}/ui/gadgets/tiling/tiling.factor                  | 0
 {extra => basis}/ui/gadgets/tracks/authors.txt                    | 0
 {extra => basis}/ui/gadgets/tracks/summary.txt                    | 0
 {extra => basis}/ui/gadgets/tracks/tracks-docs.factor             | 0
 {extra => basis}/ui/gadgets/tracks/tracks-tests.factor            | 0
 {extra => basis}/ui/gadgets/tracks/tracks.factor                  | 0
 {extra => basis}/ui/gadgets/viewports/authors.txt                 | 0
 {extra => basis}/ui/gadgets/viewports/summary.txt                 | 0
 {extra => basis}/ui/gadgets/viewports/viewports-docs.factor       | 0
 {extra => basis}/ui/gadgets/viewports/viewports.factor            | 0
 {extra => basis}/ui/gadgets/worlds/authors.txt                    | 0
 {extra => basis}/ui/gadgets/worlds/summary.txt                    | 0
 {extra => basis}/ui/gadgets/worlds/worlds-docs.factor             | 0
 {extra => basis}/ui/gadgets/worlds/worlds-tests.factor            | 0
 {extra => basis}/ui/gadgets/worlds/worlds.factor                  | 0
 {extra => basis}/ui/gadgets/wrappers/wrappers.factor              | 0
 {extra => basis}/ui/gestures/authors.txt                          | 0
 {extra => basis}/ui/gestures/gestures-docs.factor                 | 0
 {extra => basis}/ui/gestures/gestures.factor                      | 0
 {extra => basis}/ui/gestures/summary.txt                          | 0
 {extra => basis}/ui/operations/authors.txt                        | 0
 {extra => basis}/ui/operations/operations-docs.factor             | 0
 {extra => basis}/ui/operations/operations-tests.factor            | 0
 {extra => basis}/ui/operations/operations.factor                  | 0
 {extra => basis}/ui/operations/summary.txt                        | 0
 {extra => basis}/ui/render/authors.txt                            | 0
 {extra => basis}/ui/render/render-docs.factor                     | 0
 {extra => basis}/ui/render/render.factor                          | 0
 {extra => basis}/ui/render/summary.txt                            | 0
 {extra => basis}/ui/summary.txt                                   | 0
 {extra => basis}/ui/tools/authors.txt                             | 0
 {extra => basis}/ui/tools/browser/authors.txt                     | 0
 {extra => basis}/ui/tools/browser/browser-tests.factor            | 0
 {extra => basis}/ui/tools/browser/browser.factor                  | 0
 {extra => basis}/ui/tools/browser/summary.txt                     | 0
 {extra => basis}/ui/tools/browser/tags.txt                        | 0
 {extra => basis}/ui/tools/debugger/authors.txt                    | 0
 {extra => basis}/ui/tools/debugger/debugger-docs.factor           | 0
 {extra => basis}/ui/tools/debugger/debugger.factor                | 0
 {extra => basis}/ui/tools/debugger/summary.txt                    | 0
 {extra => basis}/ui/tools/debugger/tags.txt                       | 0
 {extra => basis}/ui/tools/deploy/authors.txt                      | 0
 {extra => basis}/ui/tools/deploy/deploy-docs.factor               | 0
 {extra => basis}/ui/tools/deploy/deploy.factor                    | 0
 {extra => basis}/ui/tools/inspector/authors.txt                   | 0
 {extra => basis}/ui/tools/inspector/inspector.factor              | 0
 {extra => basis}/ui/tools/inspector/summary.txt                   | 0
 {extra => basis}/ui/tools/inspector/tags.txt                      | 0
 {extra => basis}/ui/tools/interactor/authors.txt                  | 0
 {extra => basis}/ui/tools/interactor/interactor-docs.factor       | 0
 {extra => basis}/ui/tools/interactor/interactor-tests.factor      | 0
 {extra => basis}/ui/tools/interactor/interactor.factor            | 0
 {extra => basis}/ui/tools/interactor/summary.txt                  | 0
 {extra => basis}/ui/tools/listener/authors.txt                    | 0
 {extra => basis}/ui/tools/listener/listener-tests.factor          | 0
 {extra => basis}/ui/tools/listener/listener.factor                | 0
 {extra => basis}/ui/tools/listener/summary.txt                    | 0
 {extra => basis}/ui/tools/listener/tags.txt                       | 0
 {extra => basis}/ui/tools/operations/authors.txt                  | 0
 {extra => basis}/ui/tools/operations/operations.factor            | 0
 {extra => basis}/ui/tools/operations/summary.txt                  | 0
 {extra => basis}/ui/tools/profiler/authors.txt                    | 0
 {extra => basis}/ui/tools/profiler/profiler.factor                | 0
 {extra => basis}/ui/tools/profiler/summary.txt                    | 0
 {extra => basis}/ui/tools/profiler/tags.txt                       | 0
 {extra => basis}/ui/tools/search/authors.txt                      | 0
 {extra => basis}/ui/tools/search/search-tests.factor              | 0
 {extra => basis}/ui/tools/search/search.factor                    | 0
 {extra => basis}/ui/tools/search/summary.txt                      | 0
 {extra => basis}/ui/tools/summary.txt                             | 0
 {extra => basis}/ui/tools/tags.txt                                | 0
 {extra => basis}/ui/tools/tools-docs.factor                       | 0
 {extra => basis}/ui/tools/tools-tests.factor                      | 0
 {extra => basis}/ui/tools/tools.factor                            | 0
 {extra => basis}/ui/tools/traceback/authors.txt                   | 0
 {extra => basis}/ui/tools/traceback/summary.txt                   | 0
 {extra => basis}/ui/tools/traceback/traceback.factor              | 0
 {extra => basis}/ui/tools/walker/authors.txt                      | 0
 {extra => basis}/ui/tools/walker/summary.txt                      | 0
 {extra => basis}/ui/tools/walker/tags.txt                         | 0
 {extra => basis}/ui/tools/walker/walker-docs.factor               | 0
 {extra => basis}/ui/tools/walker/walker-tests.factor              | 0
 {extra => basis}/ui/tools/walker/walker.factor                    | 0
 {extra => basis}/ui/tools/workspace/authors.txt                   | 0
 {extra => basis}/ui/tools/workspace/summary.txt                   | 0
 {extra => basis}/ui/tools/workspace/tags.txt                      | 0
 {extra => basis}/ui/tools/workspace/workspace-tests.factor        | 0
 {extra => basis}/ui/tools/workspace/workspace.factor              | 0
 {extra => basis}/ui/traverse/authors.txt                          | 0
 {extra => basis}/ui/traverse/summary.txt                          | 0
 {extra => basis}/ui/traverse/traverse-tests.factor                | 0
 {extra => basis}/ui/traverse/traverse.factor                      | 0
 {extra => basis}/ui/ui-docs.factor                                | 0
 {extra => basis}/ui/ui.factor                                     | 0
 {extra => basis}/ui/windows/authors.txt                           | 0
 {extra => basis}/ui/windows/tags.txt                              | 0
 {extra => basis}/ui/windows/windows.factor                        | 0
 {extra => basis}/ui/x11/authors.txt                               | 0
 {extra => basis}/ui/x11/tags.txt                                  | 0
 {extra => basis}/ui/x11/x11.factor                                | 0
 241 files changed, 0 insertions(+), 0 deletions(-)
 rename {extra => basis}/ui/authors.txt (100%)
 rename {extra => basis}/ui/backend/authors.txt (100%)
 rename {extra => basis}/ui/backend/backend.factor (100%)
 rename {extra => basis}/ui/backend/summary.txt (100%)
 rename {extra => basis}/ui/clipboards/authors.txt (100%)
 rename {extra => basis}/ui/clipboards/clipboards-docs.factor (100%)
 rename {extra => basis}/ui/clipboards/clipboards.factor (100%)
 rename {extra => basis}/ui/clipboards/summary.txt (100%)
 rename {extra => basis}/ui/cocoa/authors.txt (100%)
 rename {extra => basis}/ui/cocoa/cocoa.factor (100%)
 rename {extra => basis}/ui/cocoa/summary.txt (100%)
 rename {extra => basis}/ui/cocoa/tags.txt (100%)
 rename {extra => basis}/ui/cocoa/tools/authors.txt (100%)
 rename {extra => basis}/ui/cocoa/tools/summary.txt (100%)
 rename {extra => basis}/ui/cocoa/tools/tags.txt (100%)
 rename {extra => basis}/ui/cocoa/tools/tools.factor (100%)
 rename {extra => basis}/ui/cocoa/views/authors.txt (100%)
 rename {extra => basis}/ui/cocoa/views/summary.txt (100%)
 rename {extra => basis}/ui/cocoa/views/tags.txt (100%)
 rename {extra => basis}/ui/cocoa/views/views.factor (100%)
 rename {extra => basis}/ui/commands/authors.txt (100%)
 rename {extra => basis}/ui/commands/commands-docs.factor (100%)
 rename {extra => basis}/ui/commands/commands-tests.factor (100%)
 rename {extra => basis}/ui/commands/commands.factor (100%)
 rename {extra => basis}/ui/commands/summary.txt (100%)
 rename {extra => basis}/ui/freetype/authors.txt (100%)
 rename {extra => basis}/ui/freetype/freetype-docs.factor (100%)
 rename {extra => basis}/ui/freetype/freetype.factor (100%)
 rename {extra => basis}/ui/freetype/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/books/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/books/books-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/books/books-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/books/books.factor (100%)
 rename {extra => basis}/ui/gadgets/books/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/borders/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/borders/borders-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/borders/borders-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/borders/borders.factor (100%)
 rename {extra => basis}/ui/gadgets/borders/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/buttons/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/buttons/buttons-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/buttons/buttons-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/buttons/buttons.factor (100%)
 rename {extra => basis}/ui/gadgets/buttons/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/canvas/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/canvas/canvas.factor (100%)
 rename {extra => basis}/ui/gadgets/cartesian/cartesian.factor (100%)
 rename {extra => basis}/ui/gadgets/editors/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/editors/editors-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/editors/editors-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/editors/editors.factor (100%)
 rename {extra => basis}/ui/gadgets/editors/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/frame-buffer/frame-buffer.factor (100%)
 rename {extra => basis}/ui/gadgets/frames/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/frames/frames-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/frames/frames-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/frames/frames.factor (100%)
 rename {extra => basis}/ui/gadgets/frames/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/gadgets-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/gadgets-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/gadgets.factor (100%)
 rename {extra => basis}/ui/gadgets/grid-lines/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/grid-lines/grid-lines-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/grid-lines/grid-lines.factor (100%)
 rename {extra => basis}/ui/gadgets/grid-lines/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/grids/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/grids/grids-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/grids/grids-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/grids/grids.factor (100%)
 rename {extra => basis}/ui/gadgets/grids/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/handler/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/handler/handler.factor (100%)
 rename {extra => basis}/ui/gadgets/incremental/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/incremental/incremental-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/incremental/incremental.factor (100%)
 rename {extra => basis}/ui/gadgets/incremental/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/labelled/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/labelled/labelled-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/labelled/labelled.factor (100%)
 rename {extra => basis}/ui/gadgets/labelled/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/labels/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/labels/labels-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/labels/labels.factor (100%)
 rename {extra => basis}/ui/gadgets/labels/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/lib/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/lib/lib.factor (100%)
 rename {extra => basis}/ui/gadgets/lists/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/lists/lists-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/lists/lists-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/lists/lists.factor (100%)
 rename {extra => basis}/ui/gadgets/lists/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/menus/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/menus/menus-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/menus/menus.factor (100%)
 rename {extra => basis}/ui/gadgets/menus/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/packs/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/packs/packs-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/packs/packs-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/packs/packs.factor (100%)
 rename {extra => basis}/ui/gadgets/packs/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/panes/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/panes/panes-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/panes/panes-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/panes/panes.factor (100%)
 rename {extra => basis}/ui/gadgets/panes/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/paragraphs/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/paragraphs/paragraphs.factor (100%)
 rename {extra => basis}/ui/gadgets/paragraphs/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/plot/plot.factor (100%)
 rename {extra => basis}/ui/gadgets/presentations/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/presentations/presentations-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/presentations/presentations-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/presentations/presentations.factor (100%)
 rename {extra => basis}/ui/gadgets/presentations/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/scrollers/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/scrollers/scrollers-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/scrollers/scrollers-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/scrollers/scrollers.factor (100%)
 rename {extra => basis}/ui/gadgets/scrollers/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/slate/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/slate/slate.factor (100%)
 rename {extra => basis}/ui/gadgets/sliders/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/sliders/sliders-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/sliders/sliders.factor (100%)
 rename {extra => basis}/ui/gadgets/sliders/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/slots/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/slots/slots-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/slots/slots.factor (100%)
 rename {extra => basis}/ui/gadgets/slots/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/status-bar/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/status-bar/status-bar-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/status-bar/status-bar.factor (100%)
 rename {extra => basis}/ui/gadgets/status-bar/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/tabs/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/tabs/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/tabs/tabs.factor (100%)
 rename {extra => basis}/ui/gadgets/theme/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/theme/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/theme/theme.factor (100%)
 rename {extra => basis}/ui/gadgets/tiling/tiling.factor (100%)
 rename {extra => basis}/ui/gadgets/tracks/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/tracks/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/tracks/tracks-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/tracks/tracks-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/tracks/tracks.factor (100%)
 rename {extra => basis}/ui/gadgets/viewports/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/viewports/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/viewports/viewports-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/viewports/viewports.factor (100%)
 rename {extra => basis}/ui/gadgets/worlds/authors.txt (100%)
 rename {extra => basis}/ui/gadgets/worlds/summary.txt (100%)
 rename {extra => basis}/ui/gadgets/worlds/worlds-docs.factor (100%)
 rename {extra => basis}/ui/gadgets/worlds/worlds-tests.factor (100%)
 rename {extra => basis}/ui/gadgets/worlds/worlds.factor (100%)
 rename {extra => basis}/ui/gadgets/wrappers/wrappers.factor (100%)
 rename {extra => basis}/ui/gestures/authors.txt (100%)
 rename {extra => basis}/ui/gestures/gestures-docs.factor (100%)
 rename {extra => basis}/ui/gestures/gestures.factor (100%)
 rename {extra => basis}/ui/gestures/summary.txt (100%)
 rename {extra => basis}/ui/operations/authors.txt (100%)
 rename {extra => basis}/ui/operations/operations-docs.factor (100%)
 rename {extra => basis}/ui/operations/operations-tests.factor (100%)
 rename {extra => basis}/ui/operations/operations.factor (100%)
 rename {extra => basis}/ui/operations/summary.txt (100%)
 rename {extra => basis}/ui/render/authors.txt (100%)
 rename {extra => basis}/ui/render/render-docs.factor (100%)
 rename {extra => basis}/ui/render/render.factor (100%)
 rename {extra => basis}/ui/render/summary.txt (100%)
 rename {extra => basis}/ui/summary.txt (100%)
 rename {extra => basis}/ui/tools/authors.txt (100%)
 rename {extra => basis}/ui/tools/browser/authors.txt (100%)
 rename {extra => basis}/ui/tools/browser/browser-tests.factor (100%)
 rename {extra => basis}/ui/tools/browser/browser.factor (100%)
 rename {extra => basis}/ui/tools/browser/summary.txt (100%)
 rename {extra => basis}/ui/tools/browser/tags.txt (100%)
 rename {extra => basis}/ui/tools/debugger/authors.txt (100%)
 rename {extra => basis}/ui/tools/debugger/debugger-docs.factor (100%)
 rename {extra => basis}/ui/tools/debugger/debugger.factor (100%)
 rename {extra => basis}/ui/tools/debugger/summary.txt (100%)
 rename {extra => basis}/ui/tools/debugger/tags.txt (100%)
 rename {extra => basis}/ui/tools/deploy/authors.txt (100%)
 rename {extra => basis}/ui/tools/deploy/deploy-docs.factor (100%)
 rename {extra => basis}/ui/tools/deploy/deploy.factor (100%)
 rename {extra => basis}/ui/tools/inspector/authors.txt (100%)
 rename {extra => basis}/ui/tools/inspector/inspector.factor (100%)
 rename {extra => basis}/ui/tools/inspector/summary.txt (100%)
 rename {extra => basis}/ui/tools/inspector/tags.txt (100%)
 rename {extra => basis}/ui/tools/interactor/authors.txt (100%)
 rename {extra => basis}/ui/tools/interactor/interactor-docs.factor (100%)
 rename {extra => basis}/ui/tools/interactor/interactor-tests.factor (100%)
 rename {extra => basis}/ui/tools/interactor/interactor.factor (100%)
 rename {extra => basis}/ui/tools/interactor/summary.txt (100%)
 rename {extra => basis}/ui/tools/listener/authors.txt (100%)
 rename {extra => basis}/ui/tools/listener/listener-tests.factor (100%)
 rename {extra => basis}/ui/tools/listener/listener.factor (100%)
 rename {extra => basis}/ui/tools/listener/summary.txt (100%)
 rename {extra => basis}/ui/tools/listener/tags.txt (100%)
 rename {extra => basis}/ui/tools/operations/authors.txt (100%)
 rename {extra => basis}/ui/tools/operations/operations.factor (100%)
 rename {extra => basis}/ui/tools/operations/summary.txt (100%)
 rename {extra => basis}/ui/tools/profiler/authors.txt (100%)
 rename {extra => basis}/ui/tools/profiler/profiler.factor (100%)
 rename {extra => basis}/ui/tools/profiler/summary.txt (100%)
 rename {extra => basis}/ui/tools/profiler/tags.txt (100%)
 rename {extra => basis}/ui/tools/search/authors.txt (100%)
 rename {extra => basis}/ui/tools/search/search-tests.factor (100%)
 rename {extra => basis}/ui/tools/search/search.factor (100%)
 rename {extra => basis}/ui/tools/search/summary.txt (100%)
 rename {extra => basis}/ui/tools/summary.txt (100%)
 rename {extra => basis}/ui/tools/tags.txt (100%)
 rename {extra => basis}/ui/tools/tools-docs.factor (100%)
 rename {extra => basis}/ui/tools/tools-tests.factor (100%)
 rename {extra => basis}/ui/tools/tools.factor (100%)
 rename {extra => basis}/ui/tools/traceback/authors.txt (100%)
 rename {extra => basis}/ui/tools/traceback/summary.txt (100%)
 rename {extra => basis}/ui/tools/traceback/traceback.factor (100%)
 rename {extra => basis}/ui/tools/walker/authors.txt (100%)
 rename {extra => basis}/ui/tools/walker/summary.txt (100%)
 rename {extra => basis}/ui/tools/walker/tags.txt (100%)
 rename {extra => basis}/ui/tools/walker/walker-docs.factor (100%)
 rename {extra => basis}/ui/tools/walker/walker-tests.factor (100%)
 rename {extra => basis}/ui/tools/walker/walker.factor (100%)
 rename {extra => basis}/ui/tools/workspace/authors.txt (100%)
 rename {extra => basis}/ui/tools/workspace/summary.txt (100%)
 rename {extra => basis}/ui/tools/workspace/tags.txt (100%)
 rename {extra => basis}/ui/tools/workspace/workspace-tests.factor (100%)
 rename {extra => basis}/ui/tools/workspace/workspace.factor (100%)
 rename {extra => basis}/ui/traverse/authors.txt (100%)
 rename {extra => basis}/ui/traverse/summary.txt (100%)
 rename {extra => basis}/ui/traverse/traverse-tests.factor (100%)
 rename {extra => basis}/ui/traverse/traverse.factor (100%)
 rename {extra => basis}/ui/ui-docs.factor (100%)
 rename {extra => basis}/ui/ui.factor (100%)
 rename {extra => basis}/ui/windows/authors.txt (100%)
 rename {extra => basis}/ui/windows/tags.txt (100%)
 rename {extra => basis}/ui/windows/windows.factor (100%)
 rename {extra => basis}/ui/x11/authors.txt (100%)
 rename {extra => basis}/ui/x11/tags.txt (100%)
 rename {extra => basis}/ui/x11/x11.factor (100%)

diff --git a/extra/ui/authors.txt b/basis/ui/authors.txt
similarity index 100%
rename from extra/ui/authors.txt
rename to basis/ui/authors.txt
diff --git a/extra/ui/backend/authors.txt b/basis/ui/backend/authors.txt
similarity index 100%
rename from extra/ui/backend/authors.txt
rename to basis/ui/backend/authors.txt
diff --git a/extra/ui/backend/backend.factor b/basis/ui/backend/backend.factor
similarity index 100%
rename from extra/ui/backend/backend.factor
rename to basis/ui/backend/backend.factor
diff --git a/extra/ui/backend/summary.txt b/basis/ui/backend/summary.txt
similarity index 100%
rename from extra/ui/backend/summary.txt
rename to basis/ui/backend/summary.txt
diff --git a/extra/ui/clipboards/authors.txt b/basis/ui/clipboards/authors.txt
similarity index 100%
rename from extra/ui/clipboards/authors.txt
rename to basis/ui/clipboards/authors.txt
diff --git a/extra/ui/clipboards/clipboards-docs.factor b/basis/ui/clipboards/clipboards-docs.factor
similarity index 100%
rename from extra/ui/clipboards/clipboards-docs.factor
rename to basis/ui/clipboards/clipboards-docs.factor
diff --git a/extra/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor
similarity index 100%
rename from extra/ui/clipboards/clipboards.factor
rename to basis/ui/clipboards/clipboards.factor
diff --git a/extra/ui/clipboards/summary.txt b/basis/ui/clipboards/summary.txt
similarity index 100%
rename from extra/ui/clipboards/summary.txt
rename to basis/ui/clipboards/summary.txt
diff --git a/extra/ui/cocoa/authors.txt b/basis/ui/cocoa/authors.txt
similarity index 100%
rename from extra/ui/cocoa/authors.txt
rename to basis/ui/cocoa/authors.txt
diff --git a/extra/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
similarity index 100%
rename from extra/ui/cocoa/cocoa.factor
rename to basis/ui/cocoa/cocoa.factor
diff --git a/extra/ui/cocoa/summary.txt b/basis/ui/cocoa/summary.txt
similarity index 100%
rename from extra/ui/cocoa/summary.txt
rename to basis/ui/cocoa/summary.txt
diff --git a/extra/ui/cocoa/tags.txt b/basis/ui/cocoa/tags.txt
similarity index 100%
rename from extra/ui/cocoa/tags.txt
rename to basis/ui/cocoa/tags.txt
diff --git a/extra/ui/cocoa/tools/authors.txt b/basis/ui/cocoa/tools/authors.txt
similarity index 100%
rename from extra/ui/cocoa/tools/authors.txt
rename to basis/ui/cocoa/tools/authors.txt
diff --git a/extra/ui/cocoa/tools/summary.txt b/basis/ui/cocoa/tools/summary.txt
similarity index 100%
rename from extra/ui/cocoa/tools/summary.txt
rename to basis/ui/cocoa/tools/summary.txt
diff --git a/extra/ui/cocoa/tools/tags.txt b/basis/ui/cocoa/tools/tags.txt
similarity index 100%
rename from extra/ui/cocoa/tools/tags.txt
rename to basis/ui/cocoa/tools/tags.txt
diff --git a/extra/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor
similarity index 100%
rename from extra/ui/cocoa/tools/tools.factor
rename to basis/ui/cocoa/tools/tools.factor
diff --git a/extra/ui/cocoa/views/authors.txt b/basis/ui/cocoa/views/authors.txt
similarity index 100%
rename from extra/ui/cocoa/views/authors.txt
rename to basis/ui/cocoa/views/authors.txt
diff --git a/extra/ui/cocoa/views/summary.txt b/basis/ui/cocoa/views/summary.txt
similarity index 100%
rename from extra/ui/cocoa/views/summary.txt
rename to basis/ui/cocoa/views/summary.txt
diff --git a/extra/ui/cocoa/views/tags.txt b/basis/ui/cocoa/views/tags.txt
similarity index 100%
rename from extra/ui/cocoa/views/tags.txt
rename to basis/ui/cocoa/views/tags.txt
diff --git a/extra/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
similarity index 100%
rename from extra/ui/cocoa/views/views.factor
rename to basis/ui/cocoa/views/views.factor
diff --git a/extra/ui/commands/authors.txt b/basis/ui/commands/authors.txt
similarity index 100%
rename from extra/ui/commands/authors.txt
rename to basis/ui/commands/authors.txt
diff --git a/extra/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor
similarity index 100%
rename from extra/ui/commands/commands-docs.factor
rename to basis/ui/commands/commands-docs.factor
diff --git a/extra/ui/commands/commands-tests.factor b/basis/ui/commands/commands-tests.factor
similarity index 100%
rename from extra/ui/commands/commands-tests.factor
rename to basis/ui/commands/commands-tests.factor
diff --git a/extra/ui/commands/commands.factor b/basis/ui/commands/commands.factor
similarity index 100%
rename from extra/ui/commands/commands.factor
rename to basis/ui/commands/commands.factor
diff --git a/extra/ui/commands/summary.txt b/basis/ui/commands/summary.txt
similarity index 100%
rename from extra/ui/commands/summary.txt
rename to basis/ui/commands/summary.txt
diff --git a/extra/ui/freetype/authors.txt b/basis/ui/freetype/authors.txt
similarity index 100%
rename from extra/ui/freetype/authors.txt
rename to basis/ui/freetype/authors.txt
diff --git a/extra/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor
similarity index 100%
rename from extra/ui/freetype/freetype-docs.factor
rename to basis/ui/freetype/freetype-docs.factor
diff --git a/extra/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
similarity index 100%
rename from extra/ui/freetype/freetype.factor
rename to basis/ui/freetype/freetype.factor
diff --git a/extra/ui/freetype/summary.txt b/basis/ui/freetype/summary.txt
similarity index 100%
rename from extra/ui/freetype/summary.txt
rename to basis/ui/freetype/summary.txt
diff --git a/extra/ui/gadgets/authors.txt b/basis/ui/gadgets/authors.txt
similarity index 100%
rename from extra/ui/gadgets/authors.txt
rename to basis/ui/gadgets/authors.txt
diff --git a/extra/ui/gadgets/books/authors.txt b/basis/ui/gadgets/books/authors.txt
similarity index 100%
rename from extra/ui/gadgets/books/authors.txt
rename to basis/ui/gadgets/books/authors.txt
diff --git a/extra/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor
similarity index 100%
rename from extra/ui/gadgets/books/books-docs.factor
rename to basis/ui/gadgets/books/books-docs.factor
diff --git a/extra/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor
similarity index 100%
rename from extra/ui/gadgets/books/books-tests.factor
rename to basis/ui/gadgets/books/books-tests.factor
diff --git a/extra/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor
similarity index 100%
rename from extra/ui/gadgets/books/books.factor
rename to basis/ui/gadgets/books/books.factor
diff --git a/extra/ui/gadgets/books/summary.txt b/basis/ui/gadgets/books/summary.txt
similarity index 100%
rename from extra/ui/gadgets/books/summary.txt
rename to basis/ui/gadgets/books/summary.txt
diff --git a/extra/ui/gadgets/borders/authors.txt b/basis/ui/gadgets/borders/authors.txt
similarity index 100%
rename from extra/ui/gadgets/borders/authors.txt
rename to basis/ui/gadgets/borders/authors.txt
diff --git a/extra/ui/gadgets/borders/borders-docs.factor b/basis/ui/gadgets/borders/borders-docs.factor
similarity index 100%
rename from extra/ui/gadgets/borders/borders-docs.factor
rename to basis/ui/gadgets/borders/borders-docs.factor
diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/basis/ui/gadgets/borders/borders-tests.factor
similarity index 100%
rename from extra/ui/gadgets/borders/borders-tests.factor
rename to basis/ui/gadgets/borders/borders-tests.factor
diff --git a/extra/ui/gadgets/borders/borders.factor b/basis/ui/gadgets/borders/borders.factor
similarity index 100%
rename from extra/ui/gadgets/borders/borders.factor
rename to basis/ui/gadgets/borders/borders.factor
diff --git a/extra/ui/gadgets/borders/summary.txt b/basis/ui/gadgets/borders/summary.txt
similarity index 100%
rename from extra/ui/gadgets/borders/summary.txt
rename to basis/ui/gadgets/borders/summary.txt
diff --git a/extra/ui/gadgets/buttons/authors.txt b/basis/ui/gadgets/buttons/authors.txt
similarity index 100%
rename from extra/ui/gadgets/buttons/authors.txt
rename to basis/ui/gadgets/buttons/authors.txt
diff --git a/extra/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
similarity index 100%
rename from extra/ui/gadgets/buttons/buttons-docs.factor
rename to basis/ui/gadgets/buttons/buttons-docs.factor
diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor
similarity index 100%
rename from extra/ui/gadgets/buttons/buttons-tests.factor
rename to basis/ui/gadgets/buttons/buttons-tests.factor
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
similarity index 100%
rename from extra/ui/gadgets/buttons/buttons.factor
rename to basis/ui/gadgets/buttons/buttons.factor
diff --git a/extra/ui/gadgets/buttons/summary.txt b/basis/ui/gadgets/buttons/summary.txt
similarity index 100%
rename from extra/ui/gadgets/buttons/summary.txt
rename to basis/ui/gadgets/buttons/summary.txt
diff --git a/extra/ui/gadgets/canvas/authors.txt b/basis/ui/gadgets/canvas/authors.txt
similarity index 100%
rename from extra/ui/gadgets/canvas/authors.txt
rename to basis/ui/gadgets/canvas/authors.txt
diff --git a/extra/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor
similarity index 100%
rename from extra/ui/gadgets/canvas/canvas.factor
rename to basis/ui/gadgets/canvas/canvas.factor
diff --git a/extra/ui/gadgets/cartesian/cartesian.factor b/basis/ui/gadgets/cartesian/cartesian.factor
similarity index 100%
rename from extra/ui/gadgets/cartesian/cartesian.factor
rename to basis/ui/gadgets/cartesian/cartesian.factor
diff --git a/extra/ui/gadgets/editors/authors.txt b/basis/ui/gadgets/editors/authors.txt
similarity index 100%
rename from extra/ui/gadgets/editors/authors.txt
rename to basis/ui/gadgets/editors/authors.txt
diff --git a/extra/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor
similarity index 100%
rename from extra/ui/gadgets/editors/editors-docs.factor
rename to basis/ui/gadgets/editors/editors-docs.factor
diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor
similarity index 100%
rename from extra/ui/gadgets/editors/editors-tests.factor
rename to basis/ui/gadgets/editors/editors-tests.factor
diff --git a/extra/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
similarity index 100%
rename from extra/ui/gadgets/editors/editors.factor
rename to basis/ui/gadgets/editors/editors.factor
diff --git a/extra/ui/gadgets/editors/summary.txt b/basis/ui/gadgets/editors/summary.txt
similarity index 100%
rename from extra/ui/gadgets/editors/summary.txt
rename to basis/ui/gadgets/editors/summary.txt
diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/basis/ui/gadgets/frame-buffer/frame-buffer.factor
similarity index 100%
rename from extra/ui/gadgets/frame-buffer/frame-buffer.factor
rename to basis/ui/gadgets/frame-buffer/frame-buffer.factor
diff --git a/extra/ui/gadgets/frames/authors.txt b/basis/ui/gadgets/frames/authors.txt
similarity index 100%
rename from extra/ui/gadgets/frames/authors.txt
rename to basis/ui/gadgets/frames/authors.txt
diff --git a/extra/ui/gadgets/frames/frames-docs.factor b/basis/ui/gadgets/frames/frames-docs.factor
similarity index 100%
rename from extra/ui/gadgets/frames/frames-docs.factor
rename to basis/ui/gadgets/frames/frames-docs.factor
diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/basis/ui/gadgets/frames/frames-tests.factor
similarity index 100%
rename from extra/ui/gadgets/frames/frames-tests.factor
rename to basis/ui/gadgets/frames/frames-tests.factor
diff --git a/extra/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor
similarity index 100%
rename from extra/ui/gadgets/frames/frames.factor
rename to basis/ui/gadgets/frames/frames.factor
diff --git a/extra/ui/gadgets/frames/summary.txt b/basis/ui/gadgets/frames/summary.txt
similarity index 100%
rename from extra/ui/gadgets/frames/summary.txt
rename to basis/ui/gadgets/frames/summary.txt
diff --git a/extra/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor
similarity index 100%
rename from extra/ui/gadgets/gadgets-docs.factor
rename to basis/ui/gadgets/gadgets-docs.factor
diff --git a/extra/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
similarity index 100%
rename from extra/ui/gadgets/gadgets-tests.factor
rename to basis/ui/gadgets/gadgets-tests.factor
diff --git a/extra/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
similarity index 100%
rename from extra/ui/gadgets/gadgets.factor
rename to basis/ui/gadgets/gadgets.factor
diff --git a/extra/ui/gadgets/grid-lines/authors.txt b/basis/ui/gadgets/grid-lines/authors.txt
similarity index 100%
rename from extra/ui/gadgets/grid-lines/authors.txt
rename to basis/ui/gadgets/grid-lines/authors.txt
diff --git a/extra/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor
similarity index 100%
rename from extra/ui/gadgets/grid-lines/grid-lines-docs.factor
rename to basis/ui/gadgets/grid-lines/grid-lines-docs.factor
diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor
similarity index 100%
rename from extra/ui/gadgets/grid-lines/grid-lines.factor
rename to basis/ui/gadgets/grid-lines/grid-lines.factor
diff --git a/extra/ui/gadgets/grid-lines/summary.txt b/basis/ui/gadgets/grid-lines/summary.txt
similarity index 100%
rename from extra/ui/gadgets/grid-lines/summary.txt
rename to basis/ui/gadgets/grid-lines/summary.txt
diff --git a/extra/ui/gadgets/grids/authors.txt b/basis/ui/gadgets/grids/authors.txt
similarity index 100%
rename from extra/ui/gadgets/grids/authors.txt
rename to basis/ui/gadgets/grids/authors.txt
diff --git a/extra/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor
similarity index 100%
rename from extra/ui/gadgets/grids/grids-docs.factor
rename to basis/ui/gadgets/grids/grids-docs.factor
diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor
similarity index 100%
rename from extra/ui/gadgets/grids/grids-tests.factor
rename to basis/ui/gadgets/grids/grids-tests.factor
diff --git a/extra/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor
similarity index 100%
rename from extra/ui/gadgets/grids/grids.factor
rename to basis/ui/gadgets/grids/grids.factor
diff --git a/extra/ui/gadgets/grids/summary.txt b/basis/ui/gadgets/grids/summary.txt
similarity index 100%
rename from extra/ui/gadgets/grids/summary.txt
rename to basis/ui/gadgets/grids/summary.txt
diff --git a/extra/ui/gadgets/handler/authors.txt b/basis/ui/gadgets/handler/authors.txt
similarity index 100%
rename from extra/ui/gadgets/handler/authors.txt
rename to basis/ui/gadgets/handler/authors.txt
diff --git a/extra/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor
similarity index 100%
rename from extra/ui/gadgets/handler/handler.factor
rename to basis/ui/gadgets/handler/handler.factor
diff --git a/extra/ui/gadgets/incremental/authors.txt b/basis/ui/gadgets/incremental/authors.txt
similarity index 100%
rename from extra/ui/gadgets/incremental/authors.txt
rename to basis/ui/gadgets/incremental/authors.txt
diff --git a/extra/ui/gadgets/incremental/incremental-docs.factor b/basis/ui/gadgets/incremental/incremental-docs.factor
similarity index 100%
rename from extra/ui/gadgets/incremental/incremental-docs.factor
rename to basis/ui/gadgets/incremental/incremental-docs.factor
diff --git a/extra/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor
similarity index 100%
rename from extra/ui/gadgets/incremental/incremental.factor
rename to basis/ui/gadgets/incremental/incremental.factor
diff --git a/extra/ui/gadgets/incremental/summary.txt b/basis/ui/gadgets/incremental/summary.txt
similarity index 100%
rename from extra/ui/gadgets/incremental/summary.txt
rename to basis/ui/gadgets/incremental/summary.txt
diff --git a/extra/ui/gadgets/labelled/authors.txt b/basis/ui/gadgets/labelled/authors.txt
similarity index 100%
rename from extra/ui/gadgets/labelled/authors.txt
rename to basis/ui/gadgets/labelled/authors.txt
diff --git a/extra/ui/gadgets/labelled/labelled-docs.factor b/basis/ui/gadgets/labelled/labelled-docs.factor
similarity index 100%
rename from extra/ui/gadgets/labelled/labelled-docs.factor
rename to basis/ui/gadgets/labelled/labelled-docs.factor
diff --git a/extra/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
similarity index 100%
rename from extra/ui/gadgets/labelled/labelled.factor
rename to basis/ui/gadgets/labelled/labelled.factor
diff --git a/extra/ui/gadgets/labelled/summary.txt b/basis/ui/gadgets/labelled/summary.txt
similarity index 100%
rename from extra/ui/gadgets/labelled/summary.txt
rename to basis/ui/gadgets/labelled/summary.txt
diff --git a/extra/ui/gadgets/labels/authors.txt b/basis/ui/gadgets/labels/authors.txt
similarity index 100%
rename from extra/ui/gadgets/labels/authors.txt
rename to basis/ui/gadgets/labels/authors.txt
diff --git a/extra/ui/gadgets/labels/labels-docs.factor b/basis/ui/gadgets/labels/labels-docs.factor
similarity index 100%
rename from extra/ui/gadgets/labels/labels-docs.factor
rename to basis/ui/gadgets/labels/labels-docs.factor
diff --git a/extra/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
similarity index 100%
rename from extra/ui/gadgets/labels/labels.factor
rename to basis/ui/gadgets/labels/labels.factor
diff --git a/extra/ui/gadgets/labels/summary.txt b/basis/ui/gadgets/labels/summary.txt
similarity index 100%
rename from extra/ui/gadgets/labels/summary.txt
rename to basis/ui/gadgets/labels/summary.txt
diff --git a/extra/ui/gadgets/lib/authors.txt b/basis/ui/gadgets/lib/authors.txt
similarity index 100%
rename from extra/ui/gadgets/lib/authors.txt
rename to basis/ui/gadgets/lib/authors.txt
diff --git a/extra/ui/gadgets/lib/lib.factor b/basis/ui/gadgets/lib/lib.factor
similarity index 100%
rename from extra/ui/gadgets/lib/lib.factor
rename to basis/ui/gadgets/lib/lib.factor
diff --git a/extra/ui/gadgets/lists/authors.txt b/basis/ui/gadgets/lists/authors.txt
similarity index 100%
rename from extra/ui/gadgets/lists/authors.txt
rename to basis/ui/gadgets/lists/authors.txt
diff --git a/extra/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor
similarity index 100%
rename from extra/ui/gadgets/lists/lists-docs.factor
rename to basis/ui/gadgets/lists/lists-docs.factor
diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/basis/ui/gadgets/lists/lists-tests.factor
similarity index 100%
rename from extra/ui/gadgets/lists/lists-tests.factor
rename to basis/ui/gadgets/lists/lists-tests.factor
diff --git a/extra/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
similarity index 100%
rename from extra/ui/gadgets/lists/lists.factor
rename to basis/ui/gadgets/lists/lists.factor
diff --git a/extra/ui/gadgets/lists/summary.txt b/basis/ui/gadgets/lists/summary.txt
similarity index 100%
rename from extra/ui/gadgets/lists/summary.txt
rename to basis/ui/gadgets/lists/summary.txt
diff --git a/extra/ui/gadgets/menus/authors.txt b/basis/ui/gadgets/menus/authors.txt
similarity index 100%
rename from extra/ui/gadgets/menus/authors.txt
rename to basis/ui/gadgets/menus/authors.txt
diff --git a/extra/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor
similarity index 100%
rename from extra/ui/gadgets/menus/menus-docs.factor
rename to basis/ui/gadgets/menus/menus-docs.factor
diff --git a/extra/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor
similarity index 100%
rename from extra/ui/gadgets/menus/menus.factor
rename to basis/ui/gadgets/menus/menus.factor
diff --git a/extra/ui/gadgets/menus/summary.txt b/basis/ui/gadgets/menus/summary.txt
similarity index 100%
rename from extra/ui/gadgets/menus/summary.txt
rename to basis/ui/gadgets/menus/summary.txt
diff --git a/extra/ui/gadgets/packs/authors.txt b/basis/ui/gadgets/packs/authors.txt
similarity index 100%
rename from extra/ui/gadgets/packs/authors.txt
rename to basis/ui/gadgets/packs/authors.txt
diff --git a/extra/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor
similarity index 100%
rename from extra/ui/gadgets/packs/packs-docs.factor
rename to basis/ui/gadgets/packs/packs-docs.factor
diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor
similarity index 100%
rename from extra/ui/gadgets/packs/packs-tests.factor
rename to basis/ui/gadgets/packs/packs-tests.factor
diff --git a/extra/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor
similarity index 100%
rename from extra/ui/gadgets/packs/packs.factor
rename to basis/ui/gadgets/packs/packs.factor
diff --git a/extra/ui/gadgets/packs/summary.txt b/basis/ui/gadgets/packs/summary.txt
similarity index 100%
rename from extra/ui/gadgets/packs/summary.txt
rename to basis/ui/gadgets/packs/summary.txt
diff --git a/extra/ui/gadgets/panes/authors.txt b/basis/ui/gadgets/panes/authors.txt
similarity index 100%
rename from extra/ui/gadgets/panes/authors.txt
rename to basis/ui/gadgets/panes/authors.txt
diff --git a/extra/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor
similarity index 100%
rename from extra/ui/gadgets/panes/panes-docs.factor
rename to basis/ui/gadgets/panes/panes-docs.factor
diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor
similarity index 100%
rename from extra/ui/gadgets/panes/panes-tests.factor
rename to basis/ui/gadgets/panes/panes-tests.factor
diff --git a/extra/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
similarity index 100%
rename from extra/ui/gadgets/panes/panes.factor
rename to basis/ui/gadgets/panes/panes.factor
diff --git a/extra/ui/gadgets/panes/summary.txt b/basis/ui/gadgets/panes/summary.txt
similarity index 100%
rename from extra/ui/gadgets/panes/summary.txt
rename to basis/ui/gadgets/panes/summary.txt
diff --git a/extra/ui/gadgets/paragraphs/authors.txt b/basis/ui/gadgets/paragraphs/authors.txt
similarity index 100%
rename from extra/ui/gadgets/paragraphs/authors.txt
rename to basis/ui/gadgets/paragraphs/authors.txt
diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor
similarity index 100%
rename from extra/ui/gadgets/paragraphs/paragraphs.factor
rename to basis/ui/gadgets/paragraphs/paragraphs.factor
diff --git a/extra/ui/gadgets/paragraphs/summary.txt b/basis/ui/gadgets/paragraphs/summary.txt
similarity index 100%
rename from extra/ui/gadgets/paragraphs/summary.txt
rename to basis/ui/gadgets/paragraphs/summary.txt
diff --git a/extra/ui/gadgets/plot/plot.factor b/basis/ui/gadgets/plot/plot.factor
similarity index 100%
rename from extra/ui/gadgets/plot/plot.factor
rename to basis/ui/gadgets/plot/plot.factor
diff --git a/extra/ui/gadgets/presentations/authors.txt b/basis/ui/gadgets/presentations/authors.txt
similarity index 100%
rename from extra/ui/gadgets/presentations/authors.txt
rename to basis/ui/gadgets/presentations/authors.txt
diff --git a/extra/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor
similarity index 100%
rename from extra/ui/gadgets/presentations/presentations-docs.factor
rename to basis/ui/gadgets/presentations/presentations-docs.factor
diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/basis/ui/gadgets/presentations/presentations-tests.factor
similarity index 100%
rename from extra/ui/gadgets/presentations/presentations-tests.factor
rename to basis/ui/gadgets/presentations/presentations-tests.factor
diff --git a/extra/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor
similarity index 100%
rename from extra/ui/gadgets/presentations/presentations.factor
rename to basis/ui/gadgets/presentations/presentations.factor
diff --git a/extra/ui/gadgets/presentations/summary.txt b/basis/ui/gadgets/presentations/summary.txt
similarity index 100%
rename from extra/ui/gadgets/presentations/summary.txt
rename to basis/ui/gadgets/presentations/summary.txt
diff --git a/extra/ui/gadgets/scrollers/authors.txt b/basis/ui/gadgets/scrollers/authors.txt
similarity index 100%
rename from extra/ui/gadgets/scrollers/authors.txt
rename to basis/ui/gadgets/scrollers/authors.txt
diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor
similarity index 100%
rename from extra/ui/gadgets/scrollers/scrollers-docs.factor
rename to basis/ui/gadgets/scrollers/scrollers-docs.factor
diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
similarity index 100%
rename from extra/ui/gadgets/scrollers/scrollers-tests.factor
rename to basis/ui/gadgets/scrollers/scrollers-tests.factor
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
similarity index 100%
rename from extra/ui/gadgets/scrollers/scrollers.factor
rename to basis/ui/gadgets/scrollers/scrollers.factor
diff --git a/extra/ui/gadgets/scrollers/summary.txt b/basis/ui/gadgets/scrollers/summary.txt
similarity index 100%
rename from extra/ui/gadgets/scrollers/summary.txt
rename to basis/ui/gadgets/scrollers/summary.txt
diff --git a/extra/ui/gadgets/slate/authors.txt b/basis/ui/gadgets/slate/authors.txt
similarity index 100%
rename from extra/ui/gadgets/slate/authors.txt
rename to basis/ui/gadgets/slate/authors.txt
diff --git a/extra/ui/gadgets/slate/slate.factor b/basis/ui/gadgets/slate/slate.factor
similarity index 100%
rename from extra/ui/gadgets/slate/slate.factor
rename to basis/ui/gadgets/slate/slate.factor
diff --git a/extra/ui/gadgets/sliders/authors.txt b/basis/ui/gadgets/sliders/authors.txt
similarity index 100%
rename from extra/ui/gadgets/sliders/authors.txt
rename to basis/ui/gadgets/sliders/authors.txt
diff --git a/extra/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor
similarity index 100%
rename from extra/ui/gadgets/sliders/sliders-docs.factor
rename to basis/ui/gadgets/sliders/sliders-docs.factor
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
similarity index 100%
rename from extra/ui/gadgets/sliders/sliders.factor
rename to basis/ui/gadgets/sliders/sliders.factor
diff --git a/extra/ui/gadgets/sliders/summary.txt b/basis/ui/gadgets/sliders/summary.txt
similarity index 100%
rename from extra/ui/gadgets/sliders/summary.txt
rename to basis/ui/gadgets/sliders/summary.txt
diff --git a/extra/ui/gadgets/slots/authors.txt b/basis/ui/gadgets/slots/authors.txt
similarity index 100%
rename from extra/ui/gadgets/slots/authors.txt
rename to basis/ui/gadgets/slots/authors.txt
diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/basis/ui/gadgets/slots/slots-tests.factor
similarity index 100%
rename from extra/ui/gadgets/slots/slots-tests.factor
rename to basis/ui/gadgets/slots/slots-tests.factor
diff --git a/extra/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor
similarity index 100%
rename from extra/ui/gadgets/slots/slots.factor
rename to basis/ui/gadgets/slots/slots.factor
diff --git a/extra/ui/gadgets/slots/summary.txt b/basis/ui/gadgets/slots/summary.txt
similarity index 100%
rename from extra/ui/gadgets/slots/summary.txt
rename to basis/ui/gadgets/slots/summary.txt
diff --git a/extra/ui/gadgets/status-bar/authors.txt b/basis/ui/gadgets/status-bar/authors.txt
similarity index 100%
rename from extra/ui/gadgets/status-bar/authors.txt
rename to basis/ui/gadgets/status-bar/authors.txt
diff --git a/extra/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor
similarity index 100%
rename from extra/ui/gadgets/status-bar/status-bar-docs.factor
rename to basis/ui/gadgets/status-bar/status-bar-docs.factor
diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor
similarity index 100%
rename from extra/ui/gadgets/status-bar/status-bar.factor
rename to basis/ui/gadgets/status-bar/status-bar.factor
diff --git a/extra/ui/gadgets/status-bar/summary.txt b/basis/ui/gadgets/status-bar/summary.txt
similarity index 100%
rename from extra/ui/gadgets/status-bar/summary.txt
rename to basis/ui/gadgets/status-bar/summary.txt
diff --git a/extra/ui/gadgets/summary.txt b/basis/ui/gadgets/summary.txt
similarity index 100%
rename from extra/ui/gadgets/summary.txt
rename to basis/ui/gadgets/summary.txt
diff --git a/extra/ui/gadgets/tabs/authors.txt b/basis/ui/gadgets/tabs/authors.txt
similarity index 100%
rename from extra/ui/gadgets/tabs/authors.txt
rename to basis/ui/gadgets/tabs/authors.txt
diff --git a/extra/ui/gadgets/tabs/summary.txt b/basis/ui/gadgets/tabs/summary.txt
similarity index 100%
rename from extra/ui/gadgets/tabs/summary.txt
rename to basis/ui/gadgets/tabs/summary.txt
diff --git a/extra/ui/gadgets/tabs/tabs.factor b/basis/ui/gadgets/tabs/tabs.factor
similarity index 100%
rename from extra/ui/gadgets/tabs/tabs.factor
rename to basis/ui/gadgets/tabs/tabs.factor
diff --git a/extra/ui/gadgets/theme/authors.txt b/basis/ui/gadgets/theme/authors.txt
similarity index 100%
rename from extra/ui/gadgets/theme/authors.txt
rename to basis/ui/gadgets/theme/authors.txt
diff --git a/extra/ui/gadgets/theme/summary.txt b/basis/ui/gadgets/theme/summary.txt
similarity index 100%
rename from extra/ui/gadgets/theme/summary.txt
rename to basis/ui/gadgets/theme/summary.txt
diff --git a/extra/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor
similarity index 100%
rename from extra/ui/gadgets/theme/theme.factor
rename to basis/ui/gadgets/theme/theme.factor
diff --git a/extra/ui/gadgets/tiling/tiling.factor b/basis/ui/gadgets/tiling/tiling.factor
similarity index 100%
rename from extra/ui/gadgets/tiling/tiling.factor
rename to basis/ui/gadgets/tiling/tiling.factor
diff --git a/extra/ui/gadgets/tracks/authors.txt b/basis/ui/gadgets/tracks/authors.txt
similarity index 100%
rename from extra/ui/gadgets/tracks/authors.txt
rename to basis/ui/gadgets/tracks/authors.txt
diff --git a/extra/ui/gadgets/tracks/summary.txt b/basis/ui/gadgets/tracks/summary.txt
similarity index 100%
rename from extra/ui/gadgets/tracks/summary.txt
rename to basis/ui/gadgets/tracks/summary.txt
diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor
similarity index 100%
rename from extra/ui/gadgets/tracks/tracks-docs.factor
rename to basis/ui/gadgets/tracks/tracks-docs.factor
diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/basis/ui/gadgets/tracks/tracks-tests.factor
similarity index 100%
rename from extra/ui/gadgets/tracks/tracks-tests.factor
rename to basis/ui/gadgets/tracks/tracks-tests.factor
diff --git a/extra/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor
similarity index 100%
rename from extra/ui/gadgets/tracks/tracks.factor
rename to basis/ui/gadgets/tracks/tracks.factor
diff --git a/extra/ui/gadgets/viewports/authors.txt b/basis/ui/gadgets/viewports/authors.txt
similarity index 100%
rename from extra/ui/gadgets/viewports/authors.txt
rename to basis/ui/gadgets/viewports/authors.txt
diff --git a/extra/ui/gadgets/viewports/summary.txt b/basis/ui/gadgets/viewports/summary.txt
similarity index 100%
rename from extra/ui/gadgets/viewports/summary.txt
rename to basis/ui/gadgets/viewports/summary.txt
diff --git a/extra/ui/gadgets/viewports/viewports-docs.factor b/basis/ui/gadgets/viewports/viewports-docs.factor
similarity index 100%
rename from extra/ui/gadgets/viewports/viewports-docs.factor
rename to basis/ui/gadgets/viewports/viewports-docs.factor
diff --git a/extra/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
similarity index 100%
rename from extra/ui/gadgets/viewports/viewports.factor
rename to basis/ui/gadgets/viewports/viewports.factor
diff --git a/extra/ui/gadgets/worlds/authors.txt b/basis/ui/gadgets/worlds/authors.txt
similarity index 100%
rename from extra/ui/gadgets/worlds/authors.txt
rename to basis/ui/gadgets/worlds/authors.txt
diff --git a/extra/ui/gadgets/worlds/summary.txt b/basis/ui/gadgets/worlds/summary.txt
similarity index 100%
rename from extra/ui/gadgets/worlds/summary.txt
rename to basis/ui/gadgets/worlds/summary.txt
diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
similarity index 100%
rename from extra/ui/gadgets/worlds/worlds-docs.factor
rename to basis/ui/gadgets/worlds/worlds-docs.factor
diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/basis/ui/gadgets/worlds/worlds-tests.factor
similarity index 100%
rename from extra/ui/gadgets/worlds/worlds-tests.factor
rename to basis/ui/gadgets/worlds/worlds-tests.factor
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
similarity index 100%
rename from extra/ui/gadgets/worlds/worlds.factor
rename to basis/ui/gadgets/worlds/worlds.factor
diff --git a/extra/ui/gadgets/wrappers/wrappers.factor b/basis/ui/gadgets/wrappers/wrappers.factor
similarity index 100%
rename from extra/ui/gadgets/wrappers/wrappers.factor
rename to basis/ui/gadgets/wrappers/wrappers.factor
diff --git a/extra/ui/gestures/authors.txt b/basis/ui/gestures/authors.txt
similarity index 100%
rename from extra/ui/gestures/authors.txt
rename to basis/ui/gestures/authors.txt
diff --git a/extra/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
similarity index 100%
rename from extra/ui/gestures/gestures-docs.factor
rename to basis/ui/gestures/gestures-docs.factor
diff --git a/extra/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
similarity index 100%
rename from extra/ui/gestures/gestures.factor
rename to basis/ui/gestures/gestures.factor
diff --git a/extra/ui/gestures/summary.txt b/basis/ui/gestures/summary.txt
similarity index 100%
rename from extra/ui/gestures/summary.txt
rename to basis/ui/gestures/summary.txt
diff --git a/extra/ui/operations/authors.txt b/basis/ui/operations/authors.txt
similarity index 100%
rename from extra/ui/operations/authors.txt
rename to basis/ui/operations/authors.txt
diff --git a/extra/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
similarity index 100%
rename from extra/ui/operations/operations-docs.factor
rename to basis/ui/operations/operations-docs.factor
diff --git a/extra/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor
similarity index 100%
rename from extra/ui/operations/operations-tests.factor
rename to basis/ui/operations/operations-tests.factor
diff --git a/extra/ui/operations/operations.factor b/basis/ui/operations/operations.factor
similarity index 100%
rename from extra/ui/operations/operations.factor
rename to basis/ui/operations/operations.factor
diff --git a/extra/ui/operations/summary.txt b/basis/ui/operations/summary.txt
similarity index 100%
rename from extra/ui/operations/summary.txt
rename to basis/ui/operations/summary.txt
diff --git a/extra/ui/render/authors.txt b/basis/ui/render/authors.txt
similarity index 100%
rename from extra/ui/render/authors.txt
rename to basis/ui/render/authors.txt
diff --git a/extra/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor
similarity index 100%
rename from extra/ui/render/render-docs.factor
rename to basis/ui/render/render-docs.factor
diff --git a/extra/ui/render/render.factor b/basis/ui/render/render.factor
similarity index 100%
rename from extra/ui/render/render.factor
rename to basis/ui/render/render.factor
diff --git a/extra/ui/render/summary.txt b/basis/ui/render/summary.txt
similarity index 100%
rename from extra/ui/render/summary.txt
rename to basis/ui/render/summary.txt
diff --git a/extra/ui/summary.txt b/basis/ui/summary.txt
similarity index 100%
rename from extra/ui/summary.txt
rename to basis/ui/summary.txt
diff --git a/extra/ui/tools/authors.txt b/basis/ui/tools/authors.txt
similarity index 100%
rename from extra/ui/tools/authors.txt
rename to basis/ui/tools/authors.txt
diff --git a/extra/ui/tools/browser/authors.txt b/basis/ui/tools/browser/authors.txt
similarity index 100%
rename from extra/ui/tools/browser/authors.txt
rename to basis/ui/tools/browser/authors.txt
diff --git a/extra/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor
similarity index 100%
rename from extra/ui/tools/browser/browser-tests.factor
rename to basis/ui/tools/browser/browser-tests.factor
diff --git a/extra/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
similarity index 100%
rename from extra/ui/tools/browser/browser.factor
rename to basis/ui/tools/browser/browser.factor
diff --git a/extra/ui/tools/browser/summary.txt b/basis/ui/tools/browser/summary.txt
similarity index 100%
rename from extra/ui/tools/browser/summary.txt
rename to basis/ui/tools/browser/summary.txt
diff --git a/extra/ui/tools/browser/tags.txt b/basis/ui/tools/browser/tags.txt
similarity index 100%
rename from extra/ui/tools/browser/tags.txt
rename to basis/ui/tools/browser/tags.txt
diff --git a/extra/ui/tools/debugger/authors.txt b/basis/ui/tools/debugger/authors.txt
similarity index 100%
rename from extra/ui/tools/debugger/authors.txt
rename to basis/ui/tools/debugger/authors.txt
diff --git a/extra/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
similarity index 100%
rename from extra/ui/tools/debugger/debugger-docs.factor
rename to basis/ui/tools/debugger/debugger-docs.factor
diff --git a/extra/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
similarity index 100%
rename from extra/ui/tools/debugger/debugger.factor
rename to basis/ui/tools/debugger/debugger.factor
diff --git a/extra/ui/tools/debugger/summary.txt b/basis/ui/tools/debugger/summary.txt
similarity index 100%
rename from extra/ui/tools/debugger/summary.txt
rename to basis/ui/tools/debugger/summary.txt
diff --git a/extra/ui/tools/debugger/tags.txt b/basis/ui/tools/debugger/tags.txt
similarity index 100%
rename from extra/ui/tools/debugger/tags.txt
rename to basis/ui/tools/debugger/tags.txt
diff --git a/extra/ui/tools/deploy/authors.txt b/basis/ui/tools/deploy/authors.txt
similarity index 100%
rename from extra/ui/tools/deploy/authors.txt
rename to basis/ui/tools/deploy/authors.txt
diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/basis/ui/tools/deploy/deploy-docs.factor
similarity index 100%
rename from extra/ui/tools/deploy/deploy-docs.factor
rename to basis/ui/tools/deploy/deploy-docs.factor
diff --git a/extra/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
similarity index 100%
rename from extra/ui/tools/deploy/deploy.factor
rename to basis/ui/tools/deploy/deploy.factor
diff --git a/extra/ui/tools/inspector/authors.txt b/basis/ui/tools/inspector/authors.txt
similarity index 100%
rename from extra/ui/tools/inspector/authors.txt
rename to basis/ui/tools/inspector/authors.txt
diff --git a/extra/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor
similarity index 100%
rename from extra/ui/tools/inspector/inspector.factor
rename to basis/ui/tools/inspector/inspector.factor
diff --git a/extra/ui/tools/inspector/summary.txt b/basis/ui/tools/inspector/summary.txt
similarity index 100%
rename from extra/ui/tools/inspector/summary.txt
rename to basis/ui/tools/inspector/summary.txt
diff --git a/extra/ui/tools/inspector/tags.txt b/basis/ui/tools/inspector/tags.txt
similarity index 100%
rename from extra/ui/tools/inspector/tags.txt
rename to basis/ui/tools/inspector/tags.txt
diff --git a/extra/ui/tools/interactor/authors.txt b/basis/ui/tools/interactor/authors.txt
similarity index 100%
rename from extra/ui/tools/interactor/authors.txt
rename to basis/ui/tools/interactor/authors.txt
diff --git a/extra/ui/tools/interactor/interactor-docs.factor b/basis/ui/tools/interactor/interactor-docs.factor
similarity index 100%
rename from extra/ui/tools/interactor/interactor-docs.factor
rename to basis/ui/tools/interactor/interactor-docs.factor
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor
similarity index 100%
rename from extra/ui/tools/interactor/interactor-tests.factor
rename to basis/ui/tools/interactor/interactor-tests.factor
diff --git a/extra/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
similarity index 100%
rename from extra/ui/tools/interactor/interactor.factor
rename to basis/ui/tools/interactor/interactor.factor
diff --git a/extra/ui/tools/interactor/summary.txt b/basis/ui/tools/interactor/summary.txt
similarity index 100%
rename from extra/ui/tools/interactor/summary.txt
rename to basis/ui/tools/interactor/summary.txt
diff --git a/extra/ui/tools/listener/authors.txt b/basis/ui/tools/listener/authors.txt
similarity index 100%
rename from extra/ui/tools/listener/authors.txt
rename to basis/ui/tools/listener/authors.txt
diff --git a/extra/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor
similarity index 100%
rename from extra/ui/tools/listener/listener-tests.factor
rename to basis/ui/tools/listener/listener-tests.factor
diff --git a/extra/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
similarity index 100%
rename from extra/ui/tools/listener/listener.factor
rename to basis/ui/tools/listener/listener.factor
diff --git a/extra/ui/tools/listener/summary.txt b/basis/ui/tools/listener/summary.txt
similarity index 100%
rename from extra/ui/tools/listener/summary.txt
rename to basis/ui/tools/listener/summary.txt
diff --git a/extra/ui/tools/listener/tags.txt b/basis/ui/tools/listener/tags.txt
similarity index 100%
rename from extra/ui/tools/listener/tags.txt
rename to basis/ui/tools/listener/tags.txt
diff --git a/extra/ui/tools/operations/authors.txt b/basis/ui/tools/operations/authors.txt
similarity index 100%
rename from extra/ui/tools/operations/authors.txt
rename to basis/ui/tools/operations/authors.txt
diff --git a/extra/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor
similarity index 100%
rename from extra/ui/tools/operations/operations.factor
rename to basis/ui/tools/operations/operations.factor
diff --git a/extra/ui/tools/operations/summary.txt b/basis/ui/tools/operations/summary.txt
similarity index 100%
rename from extra/ui/tools/operations/summary.txt
rename to basis/ui/tools/operations/summary.txt
diff --git a/extra/ui/tools/profiler/authors.txt b/basis/ui/tools/profiler/authors.txt
similarity index 100%
rename from extra/ui/tools/profiler/authors.txt
rename to basis/ui/tools/profiler/authors.txt
diff --git a/extra/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
similarity index 100%
rename from extra/ui/tools/profiler/profiler.factor
rename to basis/ui/tools/profiler/profiler.factor
diff --git a/extra/ui/tools/profiler/summary.txt b/basis/ui/tools/profiler/summary.txt
similarity index 100%
rename from extra/ui/tools/profiler/summary.txt
rename to basis/ui/tools/profiler/summary.txt
diff --git a/extra/ui/tools/profiler/tags.txt b/basis/ui/tools/profiler/tags.txt
similarity index 100%
rename from extra/ui/tools/profiler/tags.txt
rename to basis/ui/tools/profiler/tags.txt
diff --git a/extra/ui/tools/search/authors.txt b/basis/ui/tools/search/authors.txt
similarity index 100%
rename from extra/ui/tools/search/authors.txt
rename to basis/ui/tools/search/authors.txt
diff --git a/extra/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor
similarity index 100%
rename from extra/ui/tools/search/search-tests.factor
rename to basis/ui/tools/search/search-tests.factor
diff --git a/extra/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
similarity index 100%
rename from extra/ui/tools/search/search.factor
rename to basis/ui/tools/search/search.factor
diff --git a/extra/ui/tools/search/summary.txt b/basis/ui/tools/search/summary.txt
similarity index 100%
rename from extra/ui/tools/search/summary.txt
rename to basis/ui/tools/search/summary.txt
diff --git a/extra/ui/tools/summary.txt b/basis/ui/tools/summary.txt
similarity index 100%
rename from extra/ui/tools/summary.txt
rename to basis/ui/tools/summary.txt
diff --git a/extra/ui/tools/tags.txt b/basis/ui/tools/tags.txt
similarity index 100%
rename from extra/ui/tools/tags.txt
rename to basis/ui/tools/tags.txt
diff --git a/extra/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
similarity index 100%
rename from extra/ui/tools/tools-docs.factor
rename to basis/ui/tools/tools-docs.factor
diff --git a/extra/ui/tools/tools-tests.factor b/basis/ui/tools/tools-tests.factor
similarity index 100%
rename from extra/ui/tools/tools-tests.factor
rename to basis/ui/tools/tools-tests.factor
diff --git a/extra/ui/tools/tools.factor b/basis/ui/tools/tools.factor
similarity index 100%
rename from extra/ui/tools/tools.factor
rename to basis/ui/tools/tools.factor
diff --git a/extra/ui/tools/traceback/authors.txt b/basis/ui/tools/traceback/authors.txt
similarity index 100%
rename from extra/ui/tools/traceback/authors.txt
rename to basis/ui/tools/traceback/authors.txt
diff --git a/extra/ui/tools/traceback/summary.txt b/basis/ui/tools/traceback/summary.txt
similarity index 100%
rename from extra/ui/tools/traceback/summary.txt
rename to basis/ui/tools/traceback/summary.txt
diff --git a/extra/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
similarity index 100%
rename from extra/ui/tools/traceback/traceback.factor
rename to basis/ui/tools/traceback/traceback.factor
diff --git a/extra/ui/tools/walker/authors.txt b/basis/ui/tools/walker/authors.txt
similarity index 100%
rename from extra/ui/tools/walker/authors.txt
rename to basis/ui/tools/walker/authors.txt
diff --git a/extra/ui/tools/walker/summary.txt b/basis/ui/tools/walker/summary.txt
similarity index 100%
rename from extra/ui/tools/walker/summary.txt
rename to basis/ui/tools/walker/summary.txt
diff --git a/extra/ui/tools/walker/tags.txt b/basis/ui/tools/walker/tags.txt
similarity index 100%
rename from extra/ui/tools/walker/tags.txt
rename to basis/ui/tools/walker/tags.txt
diff --git a/extra/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor
similarity index 100%
rename from extra/ui/tools/walker/walker-docs.factor
rename to basis/ui/tools/walker/walker-docs.factor
diff --git a/extra/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor
similarity index 100%
rename from extra/ui/tools/walker/walker-tests.factor
rename to basis/ui/tools/walker/walker-tests.factor
diff --git a/extra/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
similarity index 100%
rename from extra/ui/tools/walker/walker.factor
rename to basis/ui/tools/walker/walker.factor
diff --git a/extra/ui/tools/workspace/authors.txt b/basis/ui/tools/workspace/authors.txt
similarity index 100%
rename from extra/ui/tools/workspace/authors.txt
rename to basis/ui/tools/workspace/authors.txt
diff --git a/extra/ui/tools/workspace/summary.txt b/basis/ui/tools/workspace/summary.txt
similarity index 100%
rename from extra/ui/tools/workspace/summary.txt
rename to basis/ui/tools/workspace/summary.txt
diff --git a/extra/ui/tools/workspace/tags.txt b/basis/ui/tools/workspace/tags.txt
similarity index 100%
rename from extra/ui/tools/workspace/tags.txt
rename to basis/ui/tools/workspace/tags.txt
diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/basis/ui/tools/workspace/workspace-tests.factor
similarity index 100%
rename from extra/ui/tools/workspace/workspace-tests.factor
rename to basis/ui/tools/workspace/workspace-tests.factor
diff --git a/extra/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
similarity index 100%
rename from extra/ui/tools/workspace/workspace.factor
rename to basis/ui/tools/workspace/workspace.factor
diff --git a/extra/ui/traverse/authors.txt b/basis/ui/traverse/authors.txt
similarity index 100%
rename from extra/ui/traverse/authors.txt
rename to basis/ui/traverse/authors.txt
diff --git a/extra/ui/traverse/summary.txt b/basis/ui/traverse/summary.txt
similarity index 100%
rename from extra/ui/traverse/summary.txt
rename to basis/ui/traverse/summary.txt
diff --git a/extra/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor
similarity index 100%
rename from extra/ui/traverse/traverse-tests.factor
rename to basis/ui/traverse/traverse-tests.factor
diff --git a/extra/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor
similarity index 100%
rename from extra/ui/traverse/traverse.factor
rename to basis/ui/traverse/traverse.factor
diff --git a/extra/ui/ui-docs.factor b/basis/ui/ui-docs.factor
similarity index 100%
rename from extra/ui/ui-docs.factor
rename to basis/ui/ui-docs.factor
diff --git a/extra/ui/ui.factor b/basis/ui/ui.factor
similarity index 100%
rename from extra/ui/ui.factor
rename to basis/ui/ui.factor
diff --git a/extra/ui/windows/authors.txt b/basis/ui/windows/authors.txt
similarity index 100%
rename from extra/ui/windows/authors.txt
rename to basis/ui/windows/authors.txt
diff --git a/extra/ui/windows/tags.txt b/basis/ui/windows/tags.txt
similarity index 100%
rename from extra/ui/windows/tags.txt
rename to basis/ui/windows/tags.txt
diff --git a/extra/ui/windows/windows.factor b/basis/ui/windows/windows.factor
similarity index 100%
rename from extra/ui/windows/windows.factor
rename to basis/ui/windows/windows.factor
diff --git a/extra/ui/x11/authors.txt b/basis/ui/x11/authors.txt
similarity index 100%
rename from extra/ui/x11/authors.txt
rename to basis/ui/x11/authors.txt
diff --git a/extra/ui/x11/tags.txt b/basis/ui/x11/tags.txt
similarity index 100%
rename from extra/ui/x11/tags.txt
rename to basis/ui/x11/tags.txt
diff --git a/extra/ui/x11/x11.factor b/basis/ui/x11/x11.factor
similarity index 100%
rename from extra/ui/x11/x11.factor
rename to basis/ui/x11/x11.factor

From 10d91d712cec0c078408e56218c1d15b6943e053 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 8 Aug 2008 12:06:10 -0500
Subject: [PATCH 20/42] ui.gadgets.plot: method on callable

---
 basis/ui/gadgets/plot/plot.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/gadgets/plot/plot.factor b/basis/ui/gadgets/plot/plot.factor
index cf48c5ab9d..52cd2faed7 100644
--- a/basis/ui/gadgets/plot/plot.factor
+++ b/basis/ui/gadgets/plot/plot.factor
@@ -28,7 +28,7 @@ TUPLE: function function color ;
 
 GENERIC: plot-function ( plot object -- plot )
 
-M: quotation plot-function ( plot quotation -- plot )
+M: callable plot-function ( plot quotation -- plot )
   >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
 
 M: function plot-function ( plot function -- plot )

From 2d07fd6826cd46c63784e046352721a1ca5d9827 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 Aug 2008 13:14:36 -0500
Subject: [PATCH 21/42] Tuple unboxing progress

---
 basis/disjoint-sets/disjoint-sets.factor      |   4 +
 .../compiler/tree/cleanup/cleanup.factor      |  13 +-
 .../tree/dead-code/dead-code-tests.factor     |  23 ++--
 .../compiler/tree/dead-code/dead-code.factor  |  79 ++++++-----
 .../allocations/allocations.factor            |  59 +++++----
 .../escape-analysis-tests.factor              |  11 ++
 .../escape-analysis/escape-analysis.factor    |   1 +
 .../recursive/recursive-tests.factor          |   2 +-
 .../recursive/recursive.factor                |  20 ++-
 .../tree/escape-analysis/simple/simple.factor |  36 +++--
 .../tree/intrinsics/intrinsics.factor         |   6 +
 .../tuple-unboxing-tests.factor               |  31 +++++
 .../tree/tuple-unboxing/tuple-unboxing.factor | 125 ++++++++----------
 13 files changed, 248 insertions(+), 162 deletions(-)
 create mode 100644 unfinished/compiler/tree/intrinsics/intrinsics.factor
 create mode 100644 unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index 680103f188..f48129fbd4 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -66,6 +66,10 @@ M: disjoint-set add-atom
 
 : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
 
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;
diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor
index 08fd12f177..45a916b984 100644
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs math math.private
-math.partial-dispatch
+math.partial-dispatch classes.tuple classes.tuple.private
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;
@@ -53,11 +54,21 @@ GENERIC: cleanup* ( node -- node/nodes )
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
 
+: immutable-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        dup in-d>> peek node-value-info
+        literal>> class>> immutable-tuple-class?
+    ] [ drop f ] if ;
+
+: immutable-tuple-boa ( #call -- #call )
+    \ <immutable-tuple-boa> >>word ;
+
 M: #call cleanup*
     {
         { [ dup body>> ] [ cleanup-inlining ] }
         { [ dup cleanup-folding? ] [ cleanup-folding ] }
         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
+        { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
         [ ]
     } cond ;
 
diff --git a/unfinished/compiler/tree/dead-code/dead-code-tests.factor b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
index 51a34bcd50..7b0919562f 100644
--- a/unfinished/compiler/tree/dead-code/dead-code-tests.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
@@ -1,7 +1,7 @@
 USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators tools.test kernel math
-stack-checker.state accessors ;
+stack-checker.state accessors combinators ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
@@ -10,20 +10,27 @@ IN: compiler.tree.dead-code.tests
     build-tree
     compute-def-use
     remove-dead-code
-    compute-def-use
-    0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
+    0 swap [
+        {
+            { [ dup #push? ] [ out-d>> length + ] }
+            { [ dup #introduce? ] [ drop 1 + ] }
+            [ drop ]
+        } cond
+    ] each-node ;
 
 [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
 
+[ 1 ] [ [ drop ] count-live-values ] unit-test
+
 [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
 
 [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
 
-[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
 
 [ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
 
@@ -33,9 +40,9 @@ IN: compiler.tree.dead-code.tests
 
 [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
 
-[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
 
 [ 0 ] [ [ [ ] call ] count-live-values ] unit-test
 
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index ccf8a9cd09..6703f924fd 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -3,15 +3,18 @@
 USING: fry accessors namespaces assocs dequeues search-dequeues
 kernel sequences words sets stack-checker.inlining
 compiler.tree
+compiler.tree.combinators
 compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward
-compiler.tree.combinators ;
+compiler.tree.dataflow-analysis.backward ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
 ! outputs are unused using backward DFA.
 GENERIC: mark-live-values ( node -- )
 
+M: #introduce mark-live-values
+    value>> look-at-value ;
+
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
@@ -34,9 +37,6 @@ SYMBOL: live-values
 
 GENERIC: remove-dead-values* ( node -- )
 
-M: #introduce remove-dead-values*
-    [ [ live-value? ] filter ] change-values drop ;
-
 M: #>r remove-dead-values*
     dup out-r>> first live-value? [ { } >>out-r ] unless
     dup in-d>> first live-value? [ { } >>in-d ] unless
@@ -57,6 +57,30 @@ M: #push remove-dead-values*
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
+M: #call remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    drop ;
+
+M: #call-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #enter-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #return-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
 M: #shuffle remove-dead-values*
     [ filter-live ] change-in-d
     [ filter-live ] change-out-d
@@ -92,24 +116,19 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
-M: f remove-dead-values* drop ;
+: remove-dead-values ( nodes -- )
+    [ remove-dead-values* ] each-node ;
 
-GENERIC: remove-dead-nodes* ( node -- newnode/t )
+GENERIC: remove-dead-nodes* ( node -- node/f )
 
-: prune-if-empty ( node seq -- successor/t )
-    empty? [ successor>> ] [ drop t ] if ; inline
+: prune-if-empty ( node seq -- node/f )
+    empty? [ drop f ] when ; inline
 
-M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
-
-: live-call? ( #call -- ? )
-    out-d>> [ live-value? ] contains? ;
+: live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
 
 M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
 
-M: #call remove-dead-nodes*
-    dup live-call? [ drop t ] [
-        [ in-d>> #drop ] [ successor>> ] bi >>successor
-    ] if ;
+M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
 
 M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
 
@@ -121,25 +140,13 @@ M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
 
 M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
 
-: (remove-dead-code) ( node -- newnode )
-    [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq?
-        [ drop ] [ nip (remove-dead-code) ] if
-    ] transform-nodes ;
+M: node remove-dead-nodes* ;
 
-M: #if remove-dead-nodes*
-    [ (remove-dead-code) ] map-children t ;
-
-M: #dispatch remove-dead-nodes*
-    [ (remove-dead-code) ] map-children t ;
-
-M: #recursive remove-dead-nodes*
-    [ (remove-dead-code) ] change-child drop t ;
-
-M: node remove-dead-nodes* drop t ;
-
-M: f remove-dead-nodes* drop t ;
+: remove-dead-nodes ( nodes -- nodes' )
+    [ remove-dead-nodes* ] map-nodes ;
 
 : remove-dead-code ( node -- newnode )
-    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
+    [ compute-live-values ]
+    [ remove-dead-values ]
+    [ remove-dead-nodes ]
+    tri ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 973720c388..2296afebc4 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -9,21 +9,13 @@ IN: compiler.tree.escape-analysis.allocations
 !        may potentially become an allocation later
 ! - a sequence of values -- potentially unboxed tuple allocations
 ! - t -- not allocated in this procedure, can never be unboxed
-
 SYMBOL: allocations
 
-TUPLE: slot-access slot# value ;
-
-C: <slot-access> slot-access
-
 : (allocation) ( value -- value' allocations )
     allocations get ; inline
 
 : allocation ( value -- allocation )
-    (allocation) at dup slot-access? [
-        [ slot#>> ] [ value>> allocation ] bi nth
-        allocation
-    ] when ;
+    (allocation) at ;
 
 : record-allocation ( allocation value -- )
     (allocation) set-at ;
@@ -31,6 +23,17 @@ C: <slot-access> slot-access
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
+! We track slot access to connect constructor inputs with
+! accessor outputs.
+SYMBOL: slot-accesses
+
+TUPLE: slot-access slot# value ;
+
+C: <slot-access> slot-access
+
+: record-slot-access ( out slot# in -- )
+    <slot-access> swap slot-accesses get set-at ;
+
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -43,18 +46,15 @@ SYMBOL: +escaping+
     <escaping-values> escaping-values set ;
 
 : introduce-value ( values -- )
-    escaping-values get add-atom ;
+    escaping-values get
+    2dup disjoint-set-member?
+    [ 2drop ] [ add-atom ] if ;
 
 : introduce-values ( values -- )
-    escaping-values get add-atoms ;
+    [ introduce-value ] each ;
 
 : <slot-value> ( -- value )
-    <value> dup escaping-values get add-atom ;
-
-: record-slot-access ( out slot# in -- )
-    over zero? [ 3drop ] [
-        <slot-access> swap record-allocation
-    ] if ;
+    <value> dup introduce-value ;
 
 : merge-values ( in-values out-value -- )
     escaping-values get '[ , , equate ] each ;
@@ -66,11 +66,17 @@ SYMBOL: +escaping+
     escaping-values get equate ;
 
 : add-escaping-value ( value -- )
-    +escaping+ equate-values ;
+    [
+        allocation {
+            { [ dup not ] [ drop ] }
+            { [ dup t eq? ] [ drop ] }
+            [ [ add-escaping-value ] each ]
+        } cond
+    ]
+    [ +escaping+ equate-values ] bi ;
 
 : add-escaping-values ( values -- )
-    escaping-values get
-    '[ +escaping+ , equate ] each ;
+    [ add-escaping-value ] each ;
 
 : unknown-allocation ( value -- )
     [ add-escaping-value ]
@@ -97,6 +103,14 @@ DEFER: copy-value
     [ [ allocation copy-allocation ] dip record-allocation ]
     2bi ;
 
+: copy-slot-value ( out slot# in -- )
+    allocation {
+        { [ dup not ] [ 3drop ] }
+        { [ dup t eq? ] [ 3drop ] }
+        [ nth swap copy-value ]
+    } cond ;
+
+! Compute which tuples escape
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -111,6 +125,5 @@ SYMBOL: escaping-allocations
     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 
 : unboxed-slot-access? ( value -- ? )
-    (allocation) at dup slot-access?
-    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
-
+    slot-accesses get at*
+    [ value>> unboxed-allocation >boolean ] when ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index f01949d422..a0c27ac069 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -217,6 +217,11 @@ C: <ro-box> ro-box
 
 [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
 
+: tuple-fib' ( m -- n )
+    dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+
+[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
+
 : bad-tuple-fib-1 ( m -- n )
     dup i>> 1 <= [
         drop 1 <ro-box>
@@ -283,3 +288,9 @@ C: <ro-box> ro-box
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 
 [ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index 5847f0a5e4..f515641343 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -16,5 +16,6 @@ IN: compiler.tree.escape-analysis
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set
+    H{ } clone slot-accesses set
     dup (escape-analysis)
     compute-escaping-allocations ;
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
index 1f6f347ded..033d5b01cc 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
@@ -4,7 +4,7 @@ compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 
 H{ } clone allocations set
-H{ } clone copies set
+<escaping-values> escaping-values set
 
 [ ] [ 8 [ introduce-value ] each ] unit-test
 
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
index e72f4b6a45..604bed6b6d 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -29,10 +29,12 @@ IN: compiler.tree.escape-analysis.recursive
     out-d>> [ allocation ] map ;
 
 : recursive-stacks ( #enter-recursive -- stacks )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+    escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
+    flip ;
 
 : analyze-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks flip ] [ out-d>> ] tri
+    [ ] [ recursive-stacks ] [ out-d>> ] tri
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
@@ -44,11 +46,16 @@ IN: compiler.tree.escape-analysis.recursive
 M: #recursive escape-analysis* ( #recursive -- )
     [
         child>>
+        [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
-        bi
+        tri
     ] until-fixed-point ;
 
+M: #enter-recursive escape-analysis* ( #enter-recursive -- )
+    #! Handled by #recursive
+    drop ;
+
 : return-allocations ( node -- allocations )
     label>> return>> node-input-allocations ;
 
@@ -57,5 +64,8 @@ M: #call-recursive escape-analysis* ( #call-label -- )
     [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
 
 M: #return-recursive escape-analysis* ( #return-recursive -- )
-    [ in-d>> ] [ label>> calls>> ] bi
-    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
+    [ call-next-method ]
+    [
+        [ in-d>> ] [ label>> calls>> ] bi
+        [ out-d>> escaping-values get '[ , equate ] 2each ] with each
+    ] bi ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index 22daa36644..d7699cfc73 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -5,6 +5,7 @@ classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
 classes.algebra stack-checker.state
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
@@ -23,33 +24,24 @@ DEFER: record-literal-allocation
 : make-literal-slots ( seq -- values )
     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
 
-: record-literal-tuple-allocation ( value object -- )
-    tuple-slots rest-slice
-    make-literal-slots
-    swap record-allocation ;
-
-: record-literal-complex-allocation ( value object -- )
-    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
-    swap record-allocation ;
+: object-slots ( object -- slots/f )
+    #! Delegation
+    {
+        { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
+        { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
+        [ drop f ]
+    } cond ;
 
 : record-literal-allocation ( value object -- )
-    {
-        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
-        { [ dup complex? ] [ record-literal-complex-allocation ] }
-        [ drop unknown-allocation ]
-    } cond ;
+    object-slots dup
+    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
 
 M: #push escape-analysis*
     #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-tuple-allocation ( #call -- )
-    #! Delegation.
-    dup dup in-d>> peek node-value-info literal>>
-    class>> immutable-tuple-class? [
-        [ in-d>> but-last ] [ out-d>> first ] bi
-        record-allocation
-    ] [ out-d>> unknown-allocations ] if ;
+    [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
 
 : record-complex-allocation ( #call -- )
     [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@@ -68,11 +60,13 @@ M: #push escape-analysis*
 
 : record-slot-call ( #call -- )
     [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
-    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
+    over [
+        [ record-slot-access ] [ copy-slot-value ] 3bi
+    ] [ 2drop unknown-allocation ] if ;
 
 M: #call escape-analysis*
     dup word>> {
-        { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
         { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [
diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor
new file mode 100644
index 0000000000..a3328114bd
--- /dev/null
+++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: compiler.tree.intrinsics
+
+: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
new file mode 100644
index 0000000000..df721f0c6c
--- /dev/null
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -0,0 +1,31 @@
+IN: compiler.tree.tuple-unboxing.tests
+USING: tools.test compiler.tree.tuple-unboxing
+compiler.tree compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.escape-analysis compiler.tree.tuple-unboxing
+compiler.tree.def-use kernel accessors sequences math ;
+
+\ unbox-tuples must-infer
+
+: test-unboxing ( quot -- )
+    #! Just make sure it doesn't throw errors; compute def use
+    #! for kicks.
+    build-tree
+    normalize
+    propagate
+    cleanup
+    escape-analysis
+    unbox-tuples
+    compute-def-use
+    drop ;
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+TUPLE: empty-tuple ;
+
+{
+    [ empty-tuple boa drop ]
+    [ cons boa [ car>> ] [ cdr>> ] bi ]
+    [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
+    [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+} [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 6b49502722..81933c37dc 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -1,56 +1,41 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs accessors kernel combinators
+classes.algebra sequences sequences.deep slots.private
+classes.tuple.private math math.private arrays
+compiler.tree
+compiler.tree.intrinsics
+compiler.tree.combinators
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.tuple-unboxing
 
 ! This pass must run after escape analysis
 
-! Mapping from values to sequences of values
-SYMBOL: unboxed-tuples
+GENERIC: unbox-tuples* ( node -- node/nodes )
 
-: unboxed-tuple ( value -- unboxed-tuple )
-    unboxed-tuples get at ;
-
-GENERIC: unbox-tuples* ( node -- )
-
-: value-info-slots ( info -- slots )
-    #! Delegation.
-    [ info>> ] [ class>> ] bi {
-        { [ dup tuple class<= ] [ drop 2 tail ] }
-        { [ dup complex class<= ] [ drop ] }
-    } cond ;
-
-: prepare-unboxed-values ( #push -- values )
+: unbox-output? ( node -- values )
     out-d>> first unboxed-allocation ;
 
-: prepare-unboxed-info ( #push -- infos values )
-    dup prepare-unboxed-values dup
-    [ [ node-output-infos first value-info-slots ] dip ]
-    [ 2drop f f ]
-    if ;
+: (expand-#push) ( object value -- nodes )
+    dup unboxed-allocation dup [
+        [ object-slots ] [ drop ] [ ] tri*
+        [ (expand-#push) ] 2map
+    ] [
+        drop #push
+    ] if ;
 
-: expand-#push ( #push infos values -- )
-    [ [ literal>> ] dip #push ] 2map >>body drop ;
+: expand-#push ( #push -- nodes )
+    [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
 
-M: #push unbox-tuples* ( #push -- )
-    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+M: #push unbox-tuples* ( #push -- nodes )
+    dup unbox-output? [ expand-#push ] when ;
 
-: expand-<tuple-boa> ( #call values -- quot )
-    [ drop in-d>> peek #drop ]
-    [ [ in-d>> but-last ] dip #copy ]
-    2bi 2array ;
+: unbox-<tuple-boa> ( #call -- nodes )
+    dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
 
-: expand-<complex> ( #call values -- quot )
-    [ in-d>> ] dip #copy 1array ;
-
-: expand-constructor ( #call values -- )
-    [ drop ] [ ] [ drop word>> ] 2tri {
-        { <tuple-boa> [ expand-<tuple-boa> ] }
-        { <complex> [ expand-<complex> ] }
-    } case unbox-tuples >>body ;
-
-: unbox-constructor ( #call -- )
-    dup prepare-unboxed-values dup
-    [ expand-constructor ] [ 2drop ] if ;
+: unbox-<complex> ( #call -- nodes )
+    dup unbox-output? [ drop { } ] when ;
 
 : (flatten-values) ( values -- values' )
     [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
@@ -59,51 +44,57 @@ M: #push unbox-tuples* ( #push -- )
     (flatten-values) flatten ;
 
 : flatten-value ( values -- values )
-    1array flatten-values ;
+    [ unboxed-allocation ] [ 1array ] bi or ;
 
-: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+: prepare-slot-access ( #call -- tuple-values outputs slot-values )
     [ in-d>> first flatten-value ]
-    [
-        [ dup in-d>> second node-value-info literal>> ]
-        [ out-d>> first unboxed-allocation ]
-        bi nth flatten-value
-    ]
     [ out-d>> flatten-values ]
-    tri ;
+    [
+        out-d>> first slot-accesses get at
+        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+    ] tri ;
 
-: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
-    [ nip ] [ zip ] 2bi #shuffle ;
+: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
+    [ drop ] [ zip ] 2bi #shuffle ;
 
-: unbox-slot-access ( #call -- )
-    dup unboxed-slot-access? [
-        dup
+: unbox-slot-access ( #call -- nodes )
+    dup out-d>> first unboxed-slot-access? [
         [ in-d>> second 1array #drop ]
         [ prepare-slot-access slot-access-shuffle ]
-        bi 2array unbox-tuples >>body
-    ] when drop ;
+        bi 2array
+    ] when ;
 
-M: #call unbox-tuples* ( #call -- )
+M: #call unbox-tuples*
     dup word>> {
-        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
         { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
-        [ 2drop ]
+        [ drop ]
     } case ;
 
-M: #copy ... ;
+M: #copy unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
 
-M: #>r ... ;
+M: #>r unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-r ;
 
-M: #r> ... ;
+M: #r> unbox-tuples*
+    [ flatten-values ] change-in-r
+    [ flatten-values ] change-out-d ;
 
-M: #shuffle ... ;
+M: #shuffle unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d
+    [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
 
-M: #terrible ... ;
+M: #terminate unbox-tuples*
+    [ flatten-values ] change-in-d ;
 
 ! These nodes never participate in unboxing
-M: #return drop ;
+M: #return unbox-tuples* ;
 
-M: #introduce drop ;
+M: #introduce unbox-tuples* ;
 
-: unbox-tuples ( nodes -- nodes )
-    dup [ unbox-tuples* ] each-node ;
+: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

From 63bc32eda31debf6e349455d99b5fcc54ca5628d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 Aug 2008 16:04:33 -0500
Subject: [PATCH 22/42] More unboxing work

---
 .../tuple-unboxing-tests.factor               |  6 ++-
 .../tree/tuple-unboxing/tuple-unboxing.factor | 37 +++++++++++++++++--
 2 files changed, 39 insertions(+), 4 deletions(-)

diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index df721f0c6c..5b06b37638 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -3,7 +3,8 @@ USING: tools.test compiler.tree.tuple-unboxing
 compiler.tree compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.def-use kernel accessors sequences math ;
+compiler.tree.def-use kernel accessors sequences math
+sorting math.order binary-search ;
 
 \ unbox-tuples must-infer
 
@@ -24,8 +25,11 @@ TUPLE: cons { car read-only } { cdr read-only } ;
 TUPLE: empty-tuple ;
 
 {
+    [ 1 2 cons boa [ car>> ] [ cdr>> ] bi ]
     [ empty-tuple boa drop ]
     [ cons boa [ car>> ] [ cdr>> ] bi ]
     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+    [ [ <=> ] sort ]
+    [ [ <=> ] with search ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 81933c37dc..71ff79d95b 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -72,6 +72,9 @@ M: #call unbox-tuples*
         [ drop ]
     } case ;
 
+M: #declare unbox-tuples*
+    [ unzip [ flatten-values ] dip zip ] change-declaration ;
+
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
     [ flatten-values ] change-out-d ;
@@ -92,9 +95,37 @@ M: #shuffle unbox-tuples*
 M: #terminate unbox-tuples*
     [ flatten-values ] change-in-d ;
 
-! These nodes never participate in unboxing
-M: #return unbox-tuples* ;
+M: #phi unbox-tuples*
+    [ flip [ flatten-values ] map flip ] change-phi-in-d
+    [ flip [ flatten-values ] map flip ] change-phi-in-r
+    [ flatten-values ] change-out-d
+    [ flatten-values ] change-out-r ;
 
-M: #introduce unbox-tuples* ;
+M: #recursive unbox-tuples*
+    [ flatten-values ] change-in-d ;
+
+M: #enter-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+M: #call-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+M: #return-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+! These nodes never participate in unboxing
+: assert-not-unboxed ( values -- )
+    dup array?
+    [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+    [ "Unboxing wrong value" throw ] when ;
+
+M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
 
 : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

From b5473d7f142b098c2355aa3002edd09373114fd6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sat, 9 Aug 2008 12:40:17 -0400
Subject: [PATCH 23/42] Persistent deques

---
 basis/persistent/deques/authors.txt         |  1 +
 basis/persistent/deques/deques-docs.factor  | 56 +++++++++++++++
 basis/persistent/deques/deques-tests.factor | 35 ++++++++++
 basis/persistent/deques/deques.factor       | 76 +++++++++++++++++++++
 basis/persistent/deques/summary.txt         |  1 +
 basis/persistent/deques/tags.txt            |  1 +
 6 files changed, 170 insertions(+)
 create mode 100644 basis/persistent/deques/authors.txt
 create mode 100644 basis/persistent/deques/deques-docs.factor
 create mode 100644 basis/persistent/deques/deques-tests.factor
 create mode 100644 basis/persistent/deques/deques.factor
 create mode 100644 basis/persistent/deques/summary.txt
 create mode 100644 basis/persistent/deques/tags.txt

diff --git a/basis/persistent/deques/authors.txt b/basis/persistent/deques/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/basis/persistent/deques/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor
new file mode 100644
index 0000000000..56ee46a6a9
--- /dev/null
+++ b/basis/persistent/deques/deques-docs.factor
@@ -0,0 +1,56 @@
+USING: help.markup help.syntax kernel sequences ;
+IN: persistent.deques
+
+ARTICLE: "persistent.deques" "Persistent deques"
+"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern."
+$nl
+"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one."
+$nl
+"The class of persistent deques:"
+{ $subsection deque }
+"To create a deque:"
+{ $subsection <deque> }
+{ $subsection sequence>deque }
+"To test if a deque is empty:"
+{ $subsection deque-empty? }
+"To manipulate deques:"
+{ $subsection push-left }
+{ $subsection push-right }
+{ $subsection pop-left }
+{ $subsection pop-right }
+{ $subsection deque>sequence } ;
+
+HELP: deque
+{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ;
+
+HELP: <deque>
+{ $values { "deque" "an empty deque" } }
+{ $description "Creates an empty deque." } ;
+
+HELP: sequence>deque
+{ $values { "sequence" sequence } { "deque" deque } }
+{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ;
+
+HELP: deque>sequence
+{ $values { "deque" deque } { "sequence" sequence } }
+{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ;
+
+HELP: deque-empty?
+{ $values { "deque" deque } { "?" "t/f" } }
+{ $description "Returns true if the deque is empty. This takes constant time." } ;
+
+HELP: push-left
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ;
+
+HELP: push-right
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ;
+
+HELP: pop-left
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ;
+
+HELP: pop-right
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ;
diff --git a/basis/persistent/deques/deques-tests.factor b/basis/persistent/deques/deques-tests.factor
new file mode 100644
index 0000000000..353828cb14
--- /dev/null
+++ b/basis/persistent/deques/deques-tests.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test persistent.deques kernel math ;
+IN: persistent.deques.tests
+
+[ 3 2 1 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test
+
+[ 1 2 3 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test
+
+[ 1 3 2 t ]
+[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ]
+unit-test
+
+[ { 2 3 4 5 6 1 } ]
+[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ]
+unit-test
+
+[ 1 t ] [ <deque> 1 push-left pop-right deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-left pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-left 2 push-left pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-right 2 push-right pop-left deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-right 2 push-right pop-right deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-left 2 push-left pop-left deque-empty? ] unit-test
diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor
new file mode 100644
index 0000000000..b30153aada
--- /dev/null
+++ b/basis/persistent/deques/deques.factor
@@ -0,0 +1,76 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math qualified ;
+QUALIFIED: sequences
+IN: persistent.deques
+
+! Amortized O(1) push/pop on both ends for single-threaded access
+! In a pathological case, if there are m modified versions from the
+!   same source, it could take O(m) amortized time per update.
+
+<PRIVATE
+TUPLE: cons { car read-only } { cdr read-only } ;
+C: <cons> cons
+
+: each ( list quot -- )
+    over
+    [ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
+    [ 2drop ] if ; inline
+
+: reduce ( list start quot -- end )
+    swapd each ; inline
+
+: reverse ( list -- reversed )
+    f [ swap <cons> ] reduce ;
+
+: length ( list -- length )
+    0 [ drop 1+ ] reduce ;
+
+: cut ( list index -- back front-reversed )
+    f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
+
+: split-reverse ( list -- back-reversed front )
+    dup length 2/ cut [ reverse ] bi@ ;
+PRIVATE>
+
+TUPLE: deque { lhs read-only } { rhs read-only } ;
+: <deque> ( -- deque ) T{ deque } ;
+
+: deque-empty? ( deque -- ? )
+    [ lhs>> ] [ rhs>> ] bi or not ;
+
+: push-left ( deque item -- newdeque )
+    swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
+
+: push-right ( deque item -- newdeque )
+    swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
+
+<PRIVATE
+: (pop-left) ( deque -- item newdeque )
+    [ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
+
+: transfer-left ( deque -- item newdeque )
+    rhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-left ( deque -- item newdeque )
+    dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
+
+<PRIVATE
+: (pop-right) ( deque -- item newdeque )
+    [ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
+
+: transfer-right ( deque -- newdeque item )
+    lhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-right ( deque -- item newdeque )
+    dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
+
+: sequence>deque ( sequence -- deque )
+    <deque> [ push-right ] sequences:reduce ;
+
+: deque>sequence ( deque -- sequence )
+    [ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;
diff --git a/basis/persistent/deques/summary.txt b/basis/persistent/deques/summary.txt
new file mode 100644
index 0000000000..021a1e3fef
--- /dev/null
+++ b/basis/persistent/deques/summary.txt
@@ -0,0 +1 @@
+Persistent amortized O(1) deques
diff --git a/basis/persistent/deques/tags.txt b/basis/persistent/deques/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/basis/persistent/deques/tags.txt
@@ -0,0 +1 @@
+collections

From d46b5387d506941bb3254098ead070a73e33f3a2 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sat, 9 Aug 2008 22:33:58 -0400
Subject: [PATCH 24/42] backtrack: Added cut-amb

---
 extra/backtrack/backtrack.factor | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor
index 3c1a794121..db2c50173c 100755
--- a/extra/backtrack/backtrack.factor
+++ b/extra/backtrack/backtrack.factor
@@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot )
         tri* if
     ] with-scope ; inline
 
+: cut-amb ( -- )
+    f failure set ;

From ca57e4386cdc39f8ae9cff36c33ce35cab2381b1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 9 Aug 2008 23:00:27 -0500
Subject: [PATCH 25/42] Various fixes

---
 .../compiler/tree/checker/checker.factor      | 61 +++++++++++++++++++
 .../compiler/tree/cleanup/cleanup.factor      |  5 +-
 .../dataflow-analysis.factor                  |  7 ++-
 .../tree/def-use/def-use-tests.factor         | 22 +++++--
 .../compiler/tree/def-use/def-use.factor      | 20 +++---
 .../escape-analysis/branches/branches.factor  |  6 +-
 .../escape-analysis-tests.factor              |  5 +-
 .../recursive/recursive.factor                |  9 ++-
 .../tree/escape-analysis/simple/simple.factor |  6 +-
 .../normalization/normalization-tests.factor  |  4 +-
 .../tree/normalization/normalization.factor   | 12 +++-
 .../tree/propagation/branches/branches.factor | 16 +++--
 .../tree/propagation/copy/copy.factor         |  3 +-
 .../propagation/recursive/recursive.factor    |  2 +-
 .../tuple-unboxing-tests.factor               | 20 +++---
 .../tree/tuple-unboxing/tuple-unboxing.factor | 18 +++---
 .../stack-checker/branches/branches.factor    | 21 +++++--
 17 files changed, 173 insertions(+), 64 deletions(-)
 create mode 100644 unfinished/compiler/tree/checker/checker.factor

diff --git a/unfinished/compiler/tree/checker/checker.factor b/unfinished/compiler/tree/checker/checker.factor
new file mode 100644
index 0000000000..08beec8b8f
--- /dev/null
+++ b/unfinished/compiler/tree/checker/checker.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel sets namespaces accessors assocs
+arrays combinators continuations
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.checker
+
+! Check some invariants.
+ERROR: check-use-error value message ;
+
+: check-use ( value uses -- )
+    [ empty? [ "No use" check-use-error ] [ drop ] if ]
+    [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+
+: check-def-use ( -- )
+    def-use get [ uses>> check-use ] assoc-each ;
+
+GENERIC: check-node ( node -- )
+
+M: #shuffle check-node
+    [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+    [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+    bi ;
+
+: check-lengths ( seq -- )
+    [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
+
+M: #copy check-node inputs/outputs 2array check-lengths ;
+
+M: #>r check-node inputs/outputs 2array check-lengths ;
+
+M: #r> check-node inputs/outputs 2array check-lengths ;
+
+M: #return-recursive check-node inputs/outputs 2array check-lengths ;
+
+M: #phi check-node
+    {
+        [ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+        [ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
+        [ phi-in-d>> check-lengths ]
+        [ phi-in-r>> check-lengths ]
+    } cleave ;
+
+M: #enter-recursive check-node
+    [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+    [ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
+    bi ;
+
+M: #push check-node
+    out-d>> length 1 = [ "Bad #push" throw ] unless ;
+
+M: node check-node drop ;
+
+ERROR: check-node-error node error ;
+
+: check-nodes ( nodes -- )
+    compute-def-use
+    check-def-use
+    [ [ check-node ] [ check-node-error ] recover ] each-node ;
diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor
index 45a916b984..1ea31fe815 100644
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@@ -105,10 +105,10 @@ SYMBOL: live-branches
 
 M: #branch cleanup*
     {
-        [ live-branches>> live-branches set ]
         [ delete-unreachable-branches ]
         [ cleanup-children ]
         [ fold-only-branch ]
+        [ live-branches>> live-branches set ]
     } cleave ;
 
 : cleanup-phi-in ( phi-in live-branches -- phi-in' )
@@ -122,7 +122,8 @@ M: #phi cleanup*
         [ '[ , cleanup-phi-in ] change-phi-in-r ]
         [ '[ , cleanup-phi-in ] change-phi-info-d ]
         [ '[ , cleanup-phi-in ] change-phi-info-r ]
-    } cleave ;
+    } cleave
+    live-branches off ;
 
 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
 
diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
index c7d558f4bf..54b10e9612 100644
--- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
-compiler.tree.def-use compiler.tree.combinators ;
+kernel sequences words sets
+stack-checker.branches stack-checker.inlining
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
 IN: compiler.tree.dataflow-analysis
 
 ! Dataflow analysis
@@ -34,5 +35,5 @@ SYMBOL: work-list
 : dfa ( node mark-quot iterate-quot -- assoc )
     init-dfa
     [ each-node ] dip
-    work-list get H{ { f f } } clone
+    work-list get H{ { +bottom+ f } } clone
     [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
diff --git a/unfinished/compiler/tree/def-use/def-use-tests.factor b/unfinished/compiler/tree/def-use/def-use-tests.factor
index 34e28761ac..88172443ad 100755
--- a/unfinished/compiler/tree/def-use/def-use-tests.factor
+++ b/unfinished/compiler/tree/def-use/def-use-tests.factor
@@ -1,7 +1,9 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
 stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.def-use arrays kernel.private ;
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
+sorting math.order binary-search compiler.tree.checker ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
@@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
     } 1&&
 ] unit-test
 
-! compute-def-use checks for SSA violations, so we make sure
-! some common patterns are generated correctly.
+: test-def-use ( quot -- )
+    build-tree
+    normalize
+    propagate
+    cleanup
+    compute-def-use
+    check-nodes ;
+
+! compute-def-use checks for SSA violations, so we use that to
+! ensure we generate some common patterns correctly.
 {
     [ [ drop ] each-integer ]
     [ [ 2drop ] curry each-integer ]
@@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] 2 [ + ] curry compose call + ]
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
+    [ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ <=> ] sort ]
+    [ [ <=> ] with search ]
 } [
-    [ ] swap [ build-tree compute-def-use drop ] curry unit-test
+    [ ] swap [ test-def-use ] curry unit-test
 ] each
diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor
index 189dd292a2..c0cc240fd4 100755
--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays namespaces assocs sequences kernel generic assocs
-classes vectors accessors combinators sets stack-checker.state
-compiler.tree compiler.tree.combinators ;
+classes vectors accessors combinators sets
+stack-checker.state
+stack-checker.branches
+compiler.tree
+compiler.tree.combinators ;
 IN: compiler.tree.def-use
 
 SYMBOL: def-use
@@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
 M: #push node-uses-values drop f ;
 M: #r> node-uses-values in-r>> ;
 M: #phi node-uses-values
-    [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
+    [ phi-in-d>> ] [ phi-in-r>> ] bi
+    append concat remove-bottom prune ;
 M: #declare node-uses-values declaration>> keys ;
 M: node node-uses-values in-d>> ;
 
@@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
     [ dup node-uses-values [ use-value ] with each ]
     [ dup node-defs-values [ def-value ] with each ] bi ;
 
-: check-use ( uses -- )
-    [ empty? [ "No use" throw ] when ]
-    [ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
-
-: check-def-use ( -- )
-    def-use get [ nip uses>> check-use ] assoc-each ;
-
 : compute-def-use ( node -- node )
     H{ } clone def-use set
-    dup [ node-def-use ] each-node
-    check-def-use ;
+    dup [ node-def-use ] each-node ;
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 391649fcb2..910726e069 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.branches
 
 M: #branch escape-analysis*
-    live-children sift [ (escape-analysis) ] each ;
+    [ in-d>> add-escaping-values ]
+    [ live-children sift [ (escape-analysis) ] each ]
+    bi ;
 
 : (merge-allocations) ( values -- allocation )
     [
@@ -25,7 +27,7 @@ M: #branch escape-analysis*
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
-    [ [ sift ] map ] dip
+    [ [ remove-bottom ] map ] dip
     [ [ merge-values ] 2each ]
     [ [ (merge-allocations) ] dip record-allocations ]
     2bi ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index a0c27ac069..532c5a9ac3 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple ;
+prettyprint classes.tuple.private classes classes.tuple
+compiler.tree.intrinsics ;
 
 \ escape-analysis must-infer
 
@@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> { <tuple-boa> <complex> } memq?
+    dup word>> { <immutable-tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
index 604bed6b6d..1ea89787df 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
     } cond ;
 
 : check-fixed-point ( node alloc1 alloc2 -- )
-    [ congruent? ] 2all? [ drop ] [
-        label>> f >>fixed-point drop
-    ] if ;
+    [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
-    [
+    { 0 } clone [ USE: math
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         child>>
         [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         tri
-    ] until-fixed-point ;
+    ] curry until-fixed-point ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index d7699cfc73..c6c407b048 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -33,8 +33,10 @@ DEFER: record-literal-allocation
     } cond ;
 
 : record-literal-allocation ( value object -- )
-    object-slots dup
-    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
+    object-slots
+    [ make-literal-slots swap record-allocation ]
+    [ unknown-allocation ]
+    if* ;
 
 M: #push escape-analysis*
     #! Delegation.
diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor
index 91c11f3be6..6986439dcc 100644
--- a/unfinished/compiler/tree/normalization/normalization-tests.factor
+++ b/unfinished/compiler/tree/normalization/normalization-tests.factor
@@ -1,6 +1,6 @@
 IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel ;
+compiler.tree sequences accessors tools.test kernel math ;
 
 \ count-introductions must-infer
 \ fixup-enter-recursive must-infer
@@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
     [ recursive-inputs ]
     [ normalize recursive-inputs ] bi
 ] unit-test
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor
index 4eb28be917..285964e393 100644
--- a/unfinished/compiler/tree/normalization/normalization.factor
+++ b/unfinished/compiler/tree/normalization/normalization.factor
@@ -1,7 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
-stack-checker.backend stack-checker.inlining compiler.tree
+stack-checker.backend
+stack-checker.branches
+stack-checker.inlining
+compiler.tree
 compiler.tree.combinators ;
 IN: compiler.tree.normalization
 
@@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
-    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+    [ flip ] dip [
+        [ nip ] [
+            dup [ +bottom+ eq? ] left-trim
+            [ [ length ] bi@ - tail* ] keep append
+        ] if
+    ] 3map flip ;
 
 M: #phi eliminate-introductions*
     remaining-introductions get swap dup terminated>>
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 00a7833655..25b4775b8e 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators
@@ -59,7 +60,14 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
+    '[
+        , [
+            [
+                dup +bottom+ eq?
+                [ drop null-info ] [ value-info ] if
+            ] bind
+        ] 2map
+    ] map ;
 
 : annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
 M: #phi propagate-after ( #phi -- )
     condition-value get [
         [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
-        3array flip [
-            first3 [ possible-boolean-values ] map
+        [
+            [ possible-boolean-values ] map
             branch-phi-constraints
-        ] each
+        ] 3each
     ] [ drop ] if ;
 
 M: #phi propagate-around ( #phi -- )
diff --git a/unfinished/compiler/tree/propagation/copy/copy.factor b/unfinished/compiler/tree/propagation/copy/copy.factor
index ee2d6e7415..1f4e5c0a86 100644
--- a/unfinished/compiler/tree/propagation/copy/copy.factor
+++ b/unfinished/compiler/tree/propagation/copy/copy.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences assocs math kernel accessors fry
 combinators sets locals
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
@@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     #! An output is a copy of every input if all inputs are
     #! copies of the same original value.
     [
-        swap sift [ resolve-copy ] map
+        swap remove-bottom [ resolve-copy ] map
         dup [ all-equal? ] [ empty? not ] bi and
         [ first swap is-copy-of ] [ 2drop ] if
     ] 2each ;
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 0e3af85b20..6b266c4ea8 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
 : unify-recursive-stacks ( stacks initial -- infos )
     over empty? [ nip ] [
         [
-            [ sift value-infos-union ] dip
+            [ value-infos-union ] dip
             [ generalize-counter ] keep
             value-info-union
         ] 2map
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 5b06b37638..0dd8f3e3de 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -1,24 +1,22 @@
 IN: compiler.tree.tuple-unboxing.tests
-USING: tools.test compiler.tree.tuple-unboxing
-compiler.tree compiler.tree.builder compiler.tree.normalization
+USING: tools.test compiler.tree.tuple-unboxing compiler.tree
+compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.def-use kernel accessors sequences math
-sorting math.order binary-search ;
+compiler.tree.checker compiler.tree.def-use kernel accessors
+sequences math math.private sorting math.order binary-search
+sequences.private slots.private ;
 
 \ unbox-tuples must-infer
 
 : test-unboxing ( quot -- )
-    #! Just make sure it doesn't throw errors; compute def use
-    #! for kicks.
     build-tree
     normalize
     propagate
     cleanup
     escape-analysis
     unbox-tuples
-    compute-def-use
-    drop ;
+    check-nodes ;
 
 TUPLE: cons { car read-only } { cdr read-only } ;
 
@@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
     [ cons boa [ car>> ] [ cdr>> ] bi ]
     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+    [ 2 cons boa { [ ] [ ] } dispatch ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+    [ [ ] [ ] curry curry call ]
+    [ <complex> <complex> dup 1 slot drop 2 slot drop ]
+    [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 71ff79d95b..3b832917d8 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -3,6 +3,7 @@
 USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
+stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
 : flatten-values ( values -- values' )
     (flatten-values) flatten ;
 
-: flatten-value ( values -- values )
-    [ unboxed-allocation ] [ 1array ] bi or ;
-
 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
-    [ in-d>> first flatten-value ]
+    [ in-d>> flatten-values ]
     [ out-d>> flatten-values ]
     [
         out-d>> first slot-accesses get at
-        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+        [ slot#>> ] [ value>> ] bi allocation nth
+        1array flatten-values
     ] tri ;
 
 : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
@@ -73,7 +72,8 @@ M: #call unbox-tuples*
     } case ;
 
 M: #declare unbox-tuples*
-    [ unzip [ flatten-values ] dip zip ] change-declaration ;
+    #! We don't look at declarations after propagation anyway.
+    f >>declaration ;
 
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
@@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
     [ flatten-values ] change-in-d ;
 
 M: #phi unbox-tuples*
-    [ flip [ flatten-values ] map flip ] change-phi-in-d
-    [ flip [ flatten-values ] map flip ] change-phi-in-r
-    [ flatten-values ] change-out-d
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
+    [ flatten-values ] change-out-d 
     [ flatten-values ] change-out-r ;
 
 M: #recursive unbox-tuples*
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index c4a89deb05..72a32574e1 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -9,21 +9,30 @@ IN: stack-checker.branches
 : balanced? ( pairs -- ? )
     [ second ] filter [ first2 length - ] map all-equal? ;
 
-: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
-    dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
+SYMBOL: +bottom+
 
-: pad-with-f ( seq -- newseq )
-    dup [ length ] map supremum '[ , f pad-left ] map ;
+: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
+    dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
+
+: pad-with-bottom ( seq -- newseq )
+    dup empty? [
+        dup [ length ] map supremum
+        '[ , +bottom+ pad-left ] map
+    ] unless ;
 
 : phi-inputs ( max-d-in pairs -- newseq )
     dup empty? [ nip ] [
         swap '[ , _ first2 unify-inputs ] map
-        pad-with-f
+        pad-with-bottom
         flip
     ] if ;
 
+: remove-bottom ( seq -- seq' )
+    +bottom+ swap remove ;
+
 : unify-values ( values -- phi-out )
-    sift dup empty? [ drop <value> ] [
+    remove-bottom
+    dup empty? [ drop <value> ] [
         [ known ] map dup all-eq?
         [ first make-known ] [ drop <value> ] if
     ] if ;

From 4cf2b064c52934010843d1fda61a251919e37114 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 01:58:39 -0500
Subject: [PATCH 26/42] Loop detection

---
 .../loop/detection/detection-tests.factor     | 150 ++++++++++++++++++
 .../tree/loop/detection/detection.factor      | 102 +++++++++++-
 .../stack-checker/inlining/inlining.factor    |  12 +-
 3 files changed, 259 insertions(+), 5 deletions(-)
 create mode 100644 unfinished/compiler/tree/loop/detection/detection-tests.factor

diff --git a/unfinished/compiler/tree/loop/detection/detection-tests.factor b/unfinished/compiler/tree/loop/detection/detection-tests.factor
new file mode 100644
index 0000000000..5864dc368f
--- /dev/null
+++ b/unfinished/compiler/tree/loop/detection/detection-tests.factor
@@ -0,0 +1,150 @@
+IN: compiler.tree.loop.detection.tests
+USING: compiler.tree.loop.detection tools.test
+kernel combinators.short-circuit math sequences accessors
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators ;
+
+[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
+[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
+
+\ detect-loops must-infer
+
+: label-is-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-loop? must-infer
+
+: label-is-not-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> not ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-not-loop? must-infer
+
+: loop-test-1 ( a -- )
+    dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+                          
+[ t ] [
+    [ loop-test-1 ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ loop-test-1 1 2 3 ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] build-tree detect-loops
+    \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-2 ] build-tree detect-loops
+    \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-3 ] build-tree detect-loops
+    \ loop-test-3 label-is-not-loop?
+] unit-test
+
+: loop-test-4 ( a -- )
+    dup [
+        loop-test-4
+    ] [
+        drop
+    ] if ; inline recursive
+
+[ f ] [
+    [ [ [ ] map ] map ] build-tree detect-loops
+    [
+        dup #recursive? [ label>> loop?>> not ] [ drop f ] if
+    ] contains-node?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+: a ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ b label-is-loop?
+] unit-test
+
+[ t ] [
+    [ b ] build-tree detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ b label-is-loop?
+] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline recursive
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline recursive
+
+[ f ] [
+    [ a' ] build-tree detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] build-tree detect-loops
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound.
+
+[ t ] [
+    [ b' ] build-tree detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] build-tree detect-loops
+    \ b' label-is-loop?
+] unit-test
diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index e29ae22f0d..1c881e9ee4 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -1,5 +1,103 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop-detection
+USING: kernel sequences namespaces assocs accessors fry
+compiler.tree ;
+IN: compiler.tree.loop.detection
 
-: detect-loops ( nodes -- nodes' ) ;
+! A loop is a #recursive which only tail calls itself, and those
+! calls are nested inside other loops only.
+
+TUPLE: recursive-call tail? nesting ;
+
+! calls is a sequence of recursive-call instances
+TUPLE: loop-info calls height ;
+
+! Mapping inline-recursive instances to loop-info instances
+SYMBOL: loop-infos
+
+! A sequence of inline-recursive instances
+SYMBOL: label-stack
+
+: (tail-calls) ( tail? seq -- seq' )
+    reverse [ swap [ and ] keep ] map nip reverse ;
+
+: tail-calls ( tail? node -- seq )
+    [
+        [ #phi? ]
+        [ #return? ]
+        [ #return-recursive? ]
+        tri or or
+    ] map (tail-calls) ;
+
+GENERIC: collect-loop-info* ( tail? node -- )
+
+: non-tail-label-info ( nodes -- )
+    [ f swap collect-loop-info* ] each ;
+
+: (collect-loop-info) ( tail? nodes -- )
+    [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+
+: remember-loop-info ( #recursive -- )
+    V{ } clone label-stack get length loop-info boa
+    swap label>> loop-infos get set-at ;
+
+M: #recursive collect-loop-info*
+    nip
+    [
+        [ label-stack [ swap label>> suffix ] change ]
+        [ remember-loop-info ]
+        [ t swap child>> (collect-loop-info) ]
+        tri
+    ] with-scope ;
+
+M: #call-recursive collect-loop-info*
+    label>> loop-infos get at
+    [ label-stack get swap height>> tail recursive-call boa ]
+    [ calls>> ]
+    bi push ;
+
+M: #if collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: #dispatch collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: node collect-loop-info* 2drop ;
+
+: collect-loop-info ( node -- )
+    { } label-stack set
+    H{ } clone loop-infos set
+    t swap (collect-loop-info) ;
+
+! Sub-assoc of loop-infos
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    loop-infos get
+    [ nip calls>> [ tail?>> ] all? ] assoc-filter
+    potential-loops set ;
+
+: (remove-non-loop-calls) ( loop-infos -- )
+    f over [
+        ! If label X is called from within a label Y that is
+        ! no longer a potential loop, then X is no longer a
+        ! potential loop either.
+        over potential-loops get key? [
+            potential-loops get '[ , key? ] all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each
+    [ (remove-non-loop-calls) ] [ drop ] if ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
+    (remove-non-loop-calls) ;
+
+: detect-loops ( nodes -- nodes )
+    dup
+    collect-loop-info
+    remove-non-tail-calls
+    remove-non-loop-calls
+    potential-loops get [ drop t >>loop? drop ] assoc-each ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 155baa7e65..6442bc5740 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -17,15 +17,21 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive
+TUPLE: inline-recursive < identity-tuple
+id
 word
 enter-out enter-recursive
 return calls
 fixed-point
-introductions ;
+introductions
+loop? ;
+
+M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
-    inline-recursive new swap >>word ;
+    inline-recursive new
+        gensym >>id
+        swap >>word ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;

From 215f6ef65b9ac75ffdf690c79abda92997e6d3f1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 01:59:55 -0500
Subject: [PATCH 27/42] Add minimum and maximum float constants

---
 basis/math/constants/constants.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor
index c207eaa63c..118a8e8197 100755
--- a/basis/math/constants/constants.factor
+++ b/basis/math/constants/constants.factor
@@ -1,5 +1,6 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USE: math
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
@@ -7,3 +8,5 @@ IN: math.constants
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

From bbd05723a5a4725d01d9518ed8b1303115d10ec6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 19:22:13 -0500
Subject: [PATCH 28/42] Cleaner loop detection pass

---
 .../tree/loop/detection/detection.factor      | 95 ++++++++-----------
 1 file changed, 40 insertions(+), 55 deletions(-)

diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index 1c881e9ee4..5c21e8c237 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -1,22 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences namespaces assocs accessors fry
-compiler.tree ;
+compiler.tree dequeues search-dequeues ;
 IN: compiler.tree.loop.detection
 
 ! A loop is a #recursive which only tail calls itself, and those
-! calls are nested inside other loops only.
-
-TUPLE: recursive-call tail? nesting ;
-
-! calls is a sequence of recursive-call instances
-TUPLE: loop-info calls height ;
-
-! Mapping inline-recursive instances to loop-info instances
-SYMBOL: loop-infos
-
-! A sequence of inline-recursive instances
-SYMBOL: label-stack
+! calls are nested inside other loops only. We optimistically
+! assume all #recursive nodes are loops, disqualifying them as
+! we see evidence to the contrary.
 
 : (tail-calls) ( tail? seq -- seq' )
     reverse [ swap [ and ] keep ] map nip reverse ;
@@ -29,6 +20,11 @@ SYMBOL: label-stack
         tri or or
     ] map (tail-calls) ;
 
+SYMBOL: loop-heights
+SYMBOL: loop-calls
+SYMBOL: label-stack
+SYMBOL: work-list
+
 GENERIC: collect-loop-info* ( tail? node -- )
 
 : non-tail-label-info ( nodes -- )
@@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- )
 : (collect-loop-info) ( tail? nodes -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
-: remember-loop-info ( #recursive -- )
-    V{ } clone label-stack get length loop-info boa
-    swap label>> loop-infos get set-at ;
+: remember-loop-info ( label -- )
+    label-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
-        [ label-stack [ swap label>> suffix ] change ]
-        [ remember-loop-info ]
-        [ t swap child>> (collect-loop-info) ]
-        tri
+        [
+            label>>
+            [ label-stack [ swap suffix ] change ]
+            [ remember-loop-info ]
+            [ t >>loop? drop ]
+            tri
+        ]
+        [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
+: current-loop-nesting ( label -- labels )
+    label-stack get swap loop-heights get at tail ;
+
+: disqualify-loop ( label -- )
+    work-list get push-front ;
+
 M: #call-recursive collect-loop-info*
-    label>> loop-infos get at
-    [ label-stack get swap height>> tail recursive-call boa ]
-    [ calls>> ]
-    bi push ;
+    label>>
+    swap [ dup disqualify-loop ] unless
+    dup current-loop-nesting [ loop-calls get push-at ] with each ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;
@@ -66,38 +70,19 @@ M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
     { } label-stack set
-    H{ } clone loop-infos set
+    H{ } clone loop-calls set
+    H{ } clone loop-heights set
+    <hashed-dlist> work-list set
     t swap (collect-loop-info) ;
 
-! Sub-assoc of loop-infos
-SYMBOL: potential-loops
-
-: remove-non-tail-calls ( -- )
-    loop-infos get
-    [ nip calls>> [ tail?>> ] all? ] assoc-filter
-    potential-loops set ;
-
-: (remove-non-loop-calls) ( loop-infos -- )
-    f over [
-        ! If label X is called from within a label Y that is
-        ! no longer a potential loop, then X is no longer a
-        ! potential loop either.
-        over potential-loops get key? [
-            potential-loops get '[ , key? ] all?
-            [ drop ] [ potential-loops get delete-at t or ] if
-        ] [ 2drop ] if
-    ] assoc-each
-    [ (remove-non-loop-calls) ] [ drop ] if ;
-
-: remove-non-loop-calls ( -- )
-    ! Boolean is set to t if something changed.
-    !  We recurse until a fixed point is reached.
-    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
-    (remove-non-loop-calls) ;
+: disqualify-loops ( -- )
+    work-list get [
+        dup loop?>> [
+            [ f >>loop? drop ]
+            [ loop-calls get at [ disqualify-loop ] each ]
+            bi
+        ] [ drop ] if
+    ] slurp-dequeue ;
 
 : detect-loops ( nodes -- nodes )
-    dup
-    collect-loop-info
-    remove-non-tail-calls
-    remove-non-loop-calls
-    potential-loops get [ drop t >>loop? drop ] assoc-each ;
+    dup collect-loop-info disqualify-loops ;

From 73ed573a05398c99ce2136dcd83b37296d58b9d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 22:20:14 -0500
Subject: [PATCH 29/42] Fix typo in docs

---
 core/kernel/kernel-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 0a1a3cb7f2..94f0ddea51 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -629,7 +629,7 @@ HELP: 2bi*
     "The following two lines are equivalent:"
     { $code
         "[ p ] [ q ] 2bi*"
-        ">r >r q r> r> q"
+        ">r >r p r> r> q"
     }
 } ;
 

From fe16de52e030c47f074498743d365e504e5dc9dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 22:22:26 -0500
Subject: [PATCH 30/42] Inference transforms can now give up; remove
 elaboration phase since we'll do that while building CFG

---
 .../compiler/tree/builder/builder.factor      |   5 +
 .../tree/elaboration/elaboration.factor       |   5 -
 .../tree/intrinsics/intrinsics.factor         |  24 +++-
 .../tree/loop/detection/detection.factor      |  10 +-
 .../compiler/tree/optimizer/optimizer.factor  |  10 +-
 .../tree/propagation/inlining/inlining.factor |   5 +-
 .../known-words/known-words.factor            |   9 +-
 .../transforms/transforms.factor              | 114 +++++++++++++++---
 8 files changed, 138 insertions(+), 44 deletions(-)
 delete mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor

diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor
index afa57556ca..e2315dbdf7 100644
--- a/unfinished/compiler/tree/builder/builder.factor
+++ b/unfinished/compiler/tree/builder/builder.factor
@@ -22,6 +22,11 @@ IN: compiler.tree.builder
     ] with-tree-builder nip
     unclip-last in-d>> ;
 
+: build-sub-tree ( #call quot -- nodes )
+    [ [ out-d>> ] [ in-d>> ] bi ] dip
+    build-tree-with
+    rot #copy suffix ;
+
 : (make-specializer) ( class picker -- quot )
     swap "predicate" word-prop append ;
 
diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor
deleted file mode 100644
index b0f4306964..0000000000
--- a/unfinished/compiler/tree/elaboration/elaboration.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.elaboration
-
-: elaborate ( nodes -- nodes' ) ;
diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor
index a3328114bd..322e0dabe1 100644
--- a/unfinished/compiler/tree/intrinsics/intrinsics.factor
+++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor
@@ -1,6 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: kernel classes.tuple classes.tuple.private math arrays 
+byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
+: <immutable-tuple-boa> ( ... class -- tuple )
+    "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
+
+: (tuple) ( layout -- tuple )
+    "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } define-primitive
+\ (tuple) make-flushable
+
+: (array) ( n -- array )
+    "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } define-primitive
+\ (array) make-flushable
+
+: (byte-array) ( n -- byte-array )
+    "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } define-primitive
+\ (byte-array) make-flushable
diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index 5c21e8c237..21d7e2a694 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -22,7 +22,7 @@ IN: compiler.tree.loop.detection
 
 SYMBOL: loop-heights
 SYMBOL: loop-calls
-SYMBOL: label-stack
+SYMBOL: loop-stack
 SYMBOL: work-list
 
 GENERIC: collect-loop-info* ( tail? node -- )
@@ -34,14 +34,14 @@ GENERIC: collect-loop-info* ( tail? node -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
 : remember-loop-info ( label -- )
-    label-stack get length swap loop-heights get set-at ;
+    loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
         [
             label>>
-            [ label-stack [ swap suffix ] change ]
+            [ loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -50,7 +50,7 @@ M: #recursive collect-loop-info*
     ] with-scope ;
 
 : current-loop-nesting ( label -- labels )
-    label-stack get swap loop-heights get at tail ;
+    loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
     work-list get push-front ;
@@ -69,7 +69,7 @@ M: #dispatch collect-loop-info*
 M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
-    { } label-stack set
+    { } loop-stack set
     H{ } clone loop-calls set
     H{ } clone loop-heights set
     <hashed-dlist> work-list set
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index e44cf44db7..24df9b5af3 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
-compiler.tree.loop-detection
+compiler.tree.loop.detection
 compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
@@ -16,11 +16,11 @@ IN: compiler.tree.optimizer
     normalize
     propagate
     cleanup
+    detect-loops
+    invert-loops
+    fuse-branches
     escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
-    strength-reduce
-    detect-loops
-    fuse-branches
-    elaborate ;
+    strength-reduce ;
diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor
index 22e056ce60..d333842657 100644
--- a/unfinished/compiler/tree/propagation/inlining/inlining.factor
+++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor
@@ -18,10 +18,7 @@ M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: quotation splicing-nodes
-    [ [ out-d>> ] [ in-d>> ] bi ] dip
-    build-tree-with
-    rot #copy suffix
-    normalize ;
+    build-sub-tree normalize ;
 
 : propagate-body ( #call -- )
     body>> (propagate) ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 01991147f7..2e0c979f98 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -165,24 +165,27 @@ M: object infer-call*
 { call execute dispatch load-locals get-local drop-locals }
 [ t "no-compile" set-word-prop ] each
 
+SYMBOL: +primitive+
+
 : non-inline-word ( word -- )
     dup +called+ depends-on
     {
         { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
         { [ dup +special+ word-prop ] [ infer-special ] }
-        { [ dup primitive? ] [ infer-primitive ] }
+        { [ dup +primitive+ word-prop ] [ infer-primitive ] }
         { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
         { [ dup recursive-label ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
 
 : define-primitive ( word inputs outputs -- )
+    [ 2drop t +primitive+ set-word-prop ]
     [ drop "input-classes" set-word-prop ]
     [ nip "default-output-classes" set-word-prop ]
-    3bi ;
+    3tri ;
 
 ! Stack effects for all primitives
 \ fixnum< { fixnum fixnum } { object } define-primitive
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index 5ec3f5ad64..d9e889f188 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -11,31 +11,45 @@ IN: stack-checker.transforms
 SYMBOL: +transform-quot+
 SYMBOL: +transform-n+
 
-: (apply-transform) ( quot n -- newquot )
-    dup zero? [
-        drop recursive-state get 1array
-    ] [
-        consume-d
-        [ #drop, ]
-        [ [ literal value>> ] map ]
-        [ first literal recursion>> ] tri prefix
-    ] if
-    swap with-datastack ;
+: give-up-transform ( word -- )
+    dup recursive-label
+    [ call-recursive-word ]
+    [ dup infer-word apply-word/effect ]
+    if ;
+
+: ((apply-transform)) ( word quot stack -- )
+    swap with-datastack first2
+    dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
+    inline
+
+: (apply-transform) ( word quot n -- )
+    consume-d dup [ known literal? ] all? [
+        dup empty? [
+            drop recursive-state get 1array
+        ] [
+            [ #drop, ]
+            [ [ literal value>> ] map ]
+            [ first literal recursion>> ] tri prefix
+        ] if
+        ((apply-transform))
+    ] [ 2drop give-up-transform ] if ;
 
 : apply-transform ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ +transform-quot+ word-prop ]
         [ +transform-n+ word-prop ]
-        bi (apply-transform)
-        first2 swap infer-quot
+        tri
+        (apply-transform)
     ] bi ;
 
 : apply-macro ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ "macro" word-prop ]
         [ "declared-effect" word-prop in>> length ]
-        bi (apply-transform)
-        first2 swap infer-quot
+        tri
+        (apply-transform)
     ] bi ;
 
 : define-transform ( word quot n -- )
@@ -66,20 +80,80 @@ SYMBOL: +transform-n+
 
 \ spread [ spread>quot ] 1 define-transform
 
+\ (call-next-method) [
+    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
+
+! Constructors
 \ boa [
     dup tuple-class? [
         dup +inlined+ depends-on
         [ "boa-check" word-prop ]
         [ tuple-layout '[ , <tuple-boa> ] ]
         bi append
-    ] [
-        \ boa \ no-method boa time-bomb
-    ] if
+    ] [ drop f ] if
 ] 1 define-transform
 
-\ (call-next-method) [
-    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
-] 2 define-transform
+\ new [
+    dup tuple-class? [
+        dup +inlined+ depends-on
+        dup all-slots rest-slice ! delegate slot
+        [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
+    ] [ drop f ] if
+] 1 define-transform
+
+! Membership testing
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+    #! Can we use a fast byte array test here?
+    {
+        { [ dup length 8 < ] [ f ] }
+        { [ dup [ integer? not ] contains? ] [ f ] }
+        { [ dup [ 0 < ] contains? ] [ f ] }
+        { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+    bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+    dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+    [
+        [ drop ] % ! drop the sequence itself; we don't use it at run time
+        bit-member-seq ,
+        [
+            {
+                { [ over fixnum? ] [ ?nth 1 eq? ] }
+                { [ over bignum? ] [ ?nth 1 eq? ] }
+                { [ over exact-float? ] [ ?nth 1 eq? ] }
+                [ 2drop f ]
+            } cond
+        ] %
+    ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+    dup bit-member? [
+        bit-member-quot
+    ] [
+        [ literalize [ t ] ] { } map>assoc
+        [ drop f ] suffix [ nip case ] curry
+    ] if ;
+
+\ member? [
+    dup sequence? [ member-quot ] [ drop f ] if
+] 1 define-transform
+
+: memq-quot ( seq -- newquot )
+    [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+    [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? [
+    dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-transform
 
 ! Deprecated
 \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform

From a483a5afd5d0cea839f9090278fd963498cbeb44 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 23:36:46 -0500
Subject: [PATCH 31/42] Fix effect>string

---
 core/effects/effects.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index c221ad073b..022490a907 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces sequences strings words assocs
-combinators accessors arrays ;
+USING: kernel math math.parser namespaces sequences strings
+words assocs combinators accessors arrays ;
 IN: effects
 
 TUPLE: effect in out terminated? ;
@@ -25,7 +25,7 @@ TUPLE: effect in out terminated? ;
 GENERIC: effect>string ( obj -- str )
 M: string effect>string ;
 M: word effect>string name>> ;
-M: integer effect>string drop "object" ;
+M: integer effect>string number>string ;
 M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
 
 : stack-picture ( seq -- string )

From b411d896a4124416a3c659961d466cdbf9d01974 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 23:37:12 -0500
Subject: [PATCH 32/42] Port optimizer report

---
 .../tree/debugger/debugger-tests.factor       |   6 +
 .../compiler/tree/debugger/debugger.factor    | 141 ++++++++++++++++++
 .../tree/loop/inversion/inversion.factor      |   5 +
 .../tree/optimizer/optimizer-tests.factor     |   4 +
 .../compiler/tree/optimizer/optimizer.factor  |   1 +
 5 files changed, 157 insertions(+)
 create mode 100644 unfinished/compiler/tree/debugger/debugger-tests.factor
 create mode 100644 unfinished/compiler/tree/debugger/debugger.factor
 create mode 100644 unfinished/compiler/tree/loop/inversion/inversion.factor
 create mode 100644 unfinished/compiler/tree/optimizer/optimizer-tests.factor

diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
new file mode 100644
index 0000000000..e6a4385c3e
--- /dev/null
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -0,0 +1,6 @@
+IN: compiler.tree.debugger.tests
+USING: compiler.tree.debugger tools.test ;
+
+\ optimized-quot. must-infer
+\ optimized-word. must-infer
+\ optimizer-report. must-infer
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
new file mode 100644
index 0000000000..804d6ea240
--- /dev/null
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -0,0 +1,141 @@
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs fry match accessors namespaces effects
+sequences sequences.private quotations generic macros arrays
+prettyprint prettyprint.backend prettyprint.sections math words
+combinators io sorting
+compiler.tree
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.debugger
+
+! A simple tool for turning tree IR into quotations and
+! printing reports, for debugging purposes.
+
+GENERIC: node>quot ( node -- )
+
+MACRO: match-choose ( alist -- )
+    [ '[ , ] ] assoc-map '[ , match-cond ] ;
+
+MATCH-VARS: ?a ?b ?c ;
+
+: pretty-shuffle ( in out -- word/f )
+    2array {
+        { { { ?a } { ?a } } [ ] }
+        { { { ?a ?b } { ?a ?b } } [ ] }
+        { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
+        { { { ?a } { } } [ drop ] }
+        { { { ?a ?b } { } } [ 2drop ] }
+        { { { ?a ?b ?c } { } } [ 3drop ] }
+        { { { ?a } { ?a ?a } } [ dup ] }
+        { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
+        { { { ?a ?b } { ?a ?b ?a } } [ over ] }
+        { { { ?b ?a } { ?a ?b } } [ swap ] }
+        { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+        { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+        { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+        { { { ?a ?b } { ?b } } [ nip ] }
+        { { { ?a ?b ?c } { ?c } } [ 2nip ] }
+        { _ f }
+    } match-choose ;
+
+TUPLE: shuffle effect ;
+
+M: shuffle pprint* effect>> effect>string text ;
+
+: shuffle-inputs/outputs ( node -- in out )
+    [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+    [ at ] curry map ;
+
+M: #shuffle node>quot
+    shuffle-inputs/outputs 2dup pretty-shuffle dup
+    [ 2nip % ] [ drop <effect> shuffle boa , ] if ;
+
+: pushed-literals ( node -- seq )
+    dup out-d>> [ node-value-info literal>> literalize ] with map ;
+
+M: #push node>quot pushed-literals % ;
+
+M: #call node>quot word>> , ;
+
+M: #call-recursive node>quot label>> id>> , ;
+
+DEFER: nodes>quot
+
+DEFER: label
+
+M: #recursive node>quot
+    [ label>> id>> literalize , ]
+    [ child>> nodes>quot , \ label , ]
+    bi ;
+
+M: #if node>quot
+    children>> [ nodes>quot ] map % \ if , ;
+
+M: #dispatch node>quot
+    children>> [ nodes>quot ] map , \ dispatch , ;
+
+M: #>r node>quot in-d>> length \ >r <repetition> % ;
+
+M: #r> node>quot out-d>> length \ r> <repetition> % ;
+
+M: node node>quot drop ;
+
+: nodes>quot ( node -- quot )
+    [ [ node>quot ] each ] [ ] make ;
+
+: optimized-quot. ( quot -- )
+    dup word? [ specialized-def ] when
+    build-tree optimize-tree nodes>quot . ;
+
+SYMBOL: words-called
+SYMBOL: generics-called
+SYMBOL: methods-called
+SYMBOL: intrinsics-called
+SYMBOL: node-count
+
+: make-report ( word/quot -- assoc )
+    [
+        dup word? [ build-tree-from-word nip ] [ build-tree ] if
+        optimize-tree
+
+        H{ } clone words-called set
+        H{ } clone generics-called set
+        H{ } clone methods-called set
+        H{ } clone intrinsics-called set
+
+        0 swap [
+            >r 1+ r>
+            dup #call? [
+                word>> {
+                    { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+                    { [ dup generic? ] [ generics-called ] }
+                    { [ dup method-body? ] [ methods-called ] }
+                    [ words-called ]
+                } cond 1 -rot get at+
+            ] [ drop ] if
+        ] each-node
+        node-count set
+    ] H{ } make-assoc ;
+
+: report. ( report -- )
+    [
+        "==== Total number of IR nodes:" print
+        node-count get .
+
+        {
+            { generics-called "==== Generic word calls:" }
+            { words-called "==== Ordinary word calls:" }
+            { methods-called "==== Non-inlined method calls:" }
+            { intrinsics-called "==== Open-coded intrinsic calls:" }
+        } [
+            nl print get keys natural-sort stack.
+        ] assoc-each
+    ] bind ;
+
+: optimizer-report. ( word -- )
+    make-report report. ;
diff --git a/unfinished/compiler/tree/loop/inversion/inversion.factor b/unfinished/compiler/tree/loop/inversion/inversion.factor
new file mode 100644
index 0000000000..719fc4ad70
--- /dev/null
+++ b/unfinished/compiler/tree/loop/inversion/inversion.factor
@@ -0,0 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop.inversion
+
+: invert-loops ( nodes -- nodes' ) ;
diff --git a/unfinished/compiler/tree/optimizer/optimizer-tests.factor b/unfinished/compiler/tree/optimizer/optimizer-tests.factor
new file mode 100644
index 0000000000..1075e441e7
--- /dev/null
+++ b/unfinished/compiler/tree/optimizer/optimizer-tests.factor
@@ -0,0 +1,4 @@
+USING: compiler.tree.optimizer tools.test ;
+IN: compiler.tree.optimizer.tests
+
+\ optimize-tree must-infer
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index 24df9b5af3..2d2a376bc0 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -9,6 +9,7 @@ compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
 compiler.tree.loop.detection
+compiler.tree.loop.inversion
 compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 

From 1ef85fe1bc373996729f1287a041206566cbfcf4 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Mon, 11 Aug 2008 01:22:26 -0400
Subject: [PATCH 33/42] irc.ui: Various added features

---
 extra/irc/ui/commands/commands.factor | 11 +++-
 extra/irc/ui/ui.factor                | 72 ++++++++++++++++-----------
 extra/ui/gadgets/tabs/tabs.factor     |  5 +-
 3 files changed, 56 insertions(+), 32 deletions(-)

diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor
index 59f4526d23..ddae783f06 100755
--- a/extra/irc/ui/commands/commands.factor
+++ b/extra/irc/ui/commands/commands.factor
@@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
 IN: irc.ui.commands
 
 : say ( string -- )
-    [ client get profile>> nickname>> <own-message> print-irc ]
-    [ listener get write-message ] bi ;
+    irc-tab get
+    [ window>> client>> profile>> nickname>> <own-message> print-irc ]
+    [ listener>> write-message ] 2bi ;
+
+: join ( string -- )
+    irc-tab get window>> join-channel ;
+
+: query ( string -- )
+    irc-tab get window>> query-nick ;
 
 : quote ( string -- )
     drop ; ! THIS WILL CHANGE
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index a524168d54..4757e36660 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -19,9 +19,9 @@ SYMBOL: listener
 
 SYMBOL: client
 
-TUPLE: ui-window client tabs ;
+TUPLE: ui-window < tabbed client ;
 
-TUPLE: irc-tab < frame listener client userlist ;
+TUPLE: irc-tab < frame listener client window userlist ;
 
 : write-color ( str color -- )
     foreground associate format ;
@@ -161,44 +161,54 @@ M: object handle-inbox
     <scrolling-pane>
     [ <pane-stream> swap display ] 2keep ;
 
-TUPLE: irc-editor < editor outstream listener client ;
+TUPLE: irc-editor < editor outstream tab ;
 
 : <irc-editor> ( tab pane -- tab editor )
-    over irc-editor new-editor
-    swap listener>> >>listener swap <pane-stream> >>outstream
-    over client>> >>client ;
+    irc-editor new-editor
+    swap <pane-stream> >>outstream ;
 
 : editor-send ( irc-editor -- )
     { [ outstream>> ]
-      [ listener>> ]
-      [ client>> ]
+      [ [ irc-tab? ] find-parent ]
       [ editor-string ]
       [ "" swap set-editor-string ] } cleave
-     '[ , listener set , client set , parse-message ] with-output-stream ;
+     '[ , irc-tab set , parse-message ] with-output-stream ;
 
 irc-editor "general" f {
     { T{ key-down f f "RET" } editor-send }
     { T{ key-down f f "ENTER" } editor-send }
 } define-command-map
 
-: <irc-tab> ( listener client -- irc-tab )
-    irc-tab new-frame
-    swap client>> >>client swap >>listener
+: new-irc-tab ( listener ui-window class -- irc-tab )
+    new-frame
+    swap >>window
+    swap >>listener
     <irc-pane> [ <scroller> @center grid-add ] keep
     <irc-editor> <scroller> @bottom grid-add ;
 
-: <irc-channel-tab> ( listener client -- irc-tab )
-    <irc-tab>
-    <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>> ] [ window>> client>> ] bi add-listener ;
 
 M: irc-tab ungraft*
-    [ listener>> ] [ client>> ] bi remove-listener ;
+    [ listener>> ] [ window>> client>> ] bi remove-listener ;
+
+TUPLE: irc-channel-tab < irc-tab userlist ;
+
+: <irc-channel-tab> ( listener ui-window -- irc-tab )
+    irc-tab new-irc-tab
+    <pile> [ <scroller> @right grid-add ] keep >>userlist ;
+
+TUPLE: irc-server-tab < irc-tab ;
+
+: <irc-server-tab> ( listener -- irc-tab )
+    f irc-server-tab new-irc-tab ;
+
+M: irc-server-tab ungraft*
+    [ window>> client>> terminate-irc ]
+    [ listener>> ] [ window>> client>> ] tri remove-listener ;
+
+: <irc-nick-tab> ( listener ui-window -- irc-tab )
+    irc-tab new-irc-tab ;
 
 M: irc-tab pref-dim*
     drop { 480 480 } ;
@@ -206,19 +216,25 @@ M: irc-tab pref-dim*
 : join-channel ( name ui-window -- )
     [ dup <irc-channel-listener> ] dip
     [ <irc-channel-tab> swap ] keep
-    tabs>> add-page ;
+    add-page ;
+
+: query-nick ( nick ui-window -- )
+    [ dup <irc-nick-listener> ] dip
+    [ <irc-nick-tab> swap ] keep
+    add-page ;
 
 : irc-window ( ui-window -- )
-    [ tabs>> ]
+    [ ]
     [ client>> profile>> server>> ] bi
     open-window ;
 
 : 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 ] tri ;
+    <irc-client>
+    { [ [ <irc-server-listener> ] dip add-listener ]
+      [ listeners>> +server-listener+ swap at <irc-server-tab> dup
+        "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
+      [ >>client ]
+      [ connect-irc ] } cleave ;
 
 : server-open ( server port nick password channels -- )
     [ <irc-profile> ui-connect [ irc-window ] keep ] dip
diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor
index 12031e5911..50e2df2e9e 100755
--- a/extra/ui/gadgets/tabs/tabs.factor
+++ b/extra/ui/gadgets/tabs/tabs.factor
@@ -48,8 +48,8 @@ DEFER: (del-page)
 : del-page ( name tabbed -- )
     [ names>> index ] 2keep (del-page) ;
 
-: <tabbed> ( assoc -- tabbed )
-  tabbed new-frame
+: new-tabbed ( assoc class -- tabbed )
+    new-frame
     0 <model> >>model
     <pile> 1 >>fill >>toggler
     dup toggler>> @left grid-add
@@ -59,3 +59,4 @@ DEFER: (del-page)
     bi
     dup redo-toggler ;
     
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;

From 5e9a323ac1e6eadcef7c255b279c23d68120c1d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 02:49:37 -0500
Subject: [PATCH 34/42] Updating CFG builder

---
 .../compiler/cfg/builder/builder-tests.factor |   4 +
 .../compiler/cfg/builder/builder.factor       | 176 ++++++++----------
 .../debug.factor => debugger/debugger.factor} |  24 ++-
 .../compiler/tree/debugger/debugger.factor    |   5 +-
 4 files changed, 104 insertions(+), 105 deletions(-)
 create mode 100644 unfinished/compiler/cfg/builder/builder-tests.factor
 rename unfinished/compiler/machine/{debug/debug.factor => debugger/debugger.factor} (58%)

diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor
new file mode 100644
index 0000000000..098919c868
--- /dev/null
+++ b/unfinished/compiler/cfg/builder/builder-tests.factor
@@ -0,0 +1,4 @@
+IN: compiler.cfg.builder.tests
+USING: compiler.cfg.builder tools.test ;
+
+\ build-cfg must-infer
diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor
index 2f68864e81..76a1b67dd2 100644
--- a/unfinished/compiler/cfg/builder/builder.factor
+++ b/unfinished/compiler/cfg/builder/builder.factor
@@ -1,29 +1,33 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel assocs sequences sequences.lib fry accessors
-compiler.cfg compiler.vops compiler.vops.builder
-namespaces math inference.dataflow optimizer.allot combinators
-math.order ;
+namespaces math combinators math.order
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.vops
+compiler.vops.builder ;
 IN: compiler.cfg.builder
 
-! Convert dataflow IR to procedure CFG.
+! Convert tree SSA IR to CFG SSA IR.
+
 ! We construct the graph and set successors first, then we
 ! set predecessors in a separate pass. This simplifies the
 ! logic.
 
 SYMBOL: procedures
 
-SYMBOL: values>vregs
-
 SYMBOL: loop-nesting
 
-GENERIC: convert* ( node -- )
+SYMBOL: values>vregs
 
 GENERIC: convert ( node -- )
 
+M: #introduce convert drop ;
+
 : init-builder ( -- )
-    H{ } clone values>vregs set
-    V{ } clone loop-nesting set ;
+    H{ } clone values>vregs set ;
 
 : end-basic-block ( -- )
     basic-block get [ %b emit ] when ;
@@ -40,15 +44,12 @@ GENERIC: convert ( node -- )
     set-basic-block ;
 
 : convert-nodes ( node -- )
-    dup basic-block get and [
-        [ convert ] [ successor>> convert-nodes ] bi
-    ] [ drop ] if ;
+    [ convert ] each ;
 
 : (build-cfg) ( node word -- )
     init-builder
     begin-basic-block
     basic-block get swap procedures get set-at
-    %prolog emit
     convert-nodes ;
 
 : build-cfg ( node word -- procedures )
@@ -73,10 +74,9 @@ GENERIC: convert ( node -- )
         2bi
     ] if ;
 
-: load-inputs ( node -- )
-    [ in-d>> %data (load-inputs) ]
-    [ in-r>> %retain (load-inputs) ]
-    bi ;
+: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+
+: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
 
 : (store-outputs) ( seq stack -- )
     over empty? [ 2drop ] [
@@ -86,40 +86,21 @@ GENERIC: convert ( node -- )
         2bi
     ] if ;
 
-: store-outputs ( node -- )
-    [ out-d>> %data (store-outputs) ]
-    [ out-r>> %retain (store-outputs) ]
-    bi ;
+: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
 
-M: #push convert*
-    out-d>> [
-        [ produce-vreg ] [ value-literal ] bi
-        emit-literal
-    ] each ;
-
-M: #shuffle convert* drop ;
-
-M: #>r convert* drop ;
-
-M: #r> convert* drop ;
-
-M: node convert
-    [ load-inputs ]
-    [ convert* ]
-    [ store-outputs ]
-    tri ;
+: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
 
 : (emit-call) ( word -- )
     begin-basic-block %call emit begin-basic-block ;
 
 : intrinsic-inputs ( node -- )
-    [ load-inputs ]
+    [ load-in-d ]
     [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
     bi ;
 
 : intrinsic-outputs ( node -- )
     [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
-    [ store-outputs ]
+    [ store-out-d ]
     bi ;
 
 : intrinsic ( node quot -- )
@@ -132,19 +113,17 @@ M: node convert
         tri
     ] with-scope ; inline
 
-USING: kernel.private math.private slots.private
-optimizer.allot ;
+USING: kernel.private math.private slots.private ;
 
 : maybe-emit-fixnum-shift-fast ( node -- node )
-    dup dup in-d>> second node-literal? [
-        dup dup in-d>> second node-literal
+    dup dup in-d>> second node-value-info literal>> dup fixnum? [
         '[ , emit-fixnum-shift-fast ] intrinsic
     ] [
-        dup param>> (emit-call)
+        drop dup word>> (emit-call)
     ] if ;
 
 : emit-call ( node -- )
-    dup param>> {
+    dup word>> {
         { \ tag [ [ emit-tag ] intrinsic ] }
 
         { \ slot [ [ dup emit-slot ] intrinsic ] }
@@ -175,24 +154,43 @@ optimizer.allot ;
         { \ float> [ [ emit-float> ] intrinsic ] }
         { \ float? [ [ emit-float= ] intrinsic ] }
 
-        { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
-        { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
-        { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+        ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+        ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+        ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
 
         [ (emit-call) ]
     } case drop ;
 
 M: #call convert emit-call ;
 
-M: #call-label convert
-    dup param>> loop-nesting get at [
-        basic-block get successors>> push
-        end-basic-block
-        basic-block off
-        drop
-    ] [
-        (emit-call)
-    ] if* ;
+: emit-call-loop ( #recursive -- )
+    dup label>> loop-nesting get at basic-block get successors>> push
+    end-basic-block
+    basic-block off
+    drop ;
+
+: emit-call-recursive ( #recursive -- )
+    label>> id>> (emit-call) ;
+
+M: #call-recursive convert
+    dup label>> loop?>>
+    [ emit-call-loop ] [ emit-call-recursive ] if ;
+
+M: #push convert
+    [
+        [ out-d>> first produce-vreg ]
+        [ node-output-infos first literal>> ]
+        bi emit-literal
+    ]
+    [ store-out-d ] bi ;
+
+M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+
+M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+
+M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+
+M: #terminate convert drop ;
 
 : integer-conditional ( in1 in2 cc -- )
     [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
@@ -221,50 +219,38 @@ M: #call-label convert
     [ set-basic-block ]
     bi ;
 
-: phi-inputs ( #if -- vregs-seq )
-    children>>
-    [ last-node ] map
-    [ #values? ] filter
-    [ in-d>> [ value>vreg ] map ] map ;
-
-: phi-outputs ( #if -- vregs )
-    successor>> out-d>> [ produce-vreg ] map ;
-
-: emit-phi ( #if -- )
-    [ phi-outputs ] [ phi-inputs ] bi %phi emit ;
-
 M: #if convert
-    {
-        [ load-inputs ]
-        [ emit-if ]
-        [ convert-if-children ]
-        [ emit-phi ]
-    } cleave ;
+    [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
 
-M: #values convert drop ;
+M: #dispatch convert
+    "Unimplemented" throw ;
 
-M: #merge convert drop ;
-
-M: #entry convert drop ;
+M: #phi convert drop ;
 
 M: #declare convert drop ;
 
-M: #terminate convert drop ;
+M: #return convert drop %return emit ;
 
-M: #label convert
-    #! Labels create a new procedure.
-    [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
+: convert-recursive ( #recursive -- )
+    [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
+    [ (emit-call) ]
+    bi ;
 
-M: #loop convert
-    #! Loops become part of the current CFG.
-    begin-basic-block
-    [ param>> basic-block get 2array loop-nesting get push ]
-    [ node-child convert-nodes ]
-    bi
+: begin-loop ( #recursive -- )
+    label>> basic-block get 2array loop-nesting get push ;
+
+: end-loop ( -- )
     loop-nesting get pop* ;
 
-M: #return convert
-    param>> loop-nesting get key? [
-        %epilog emit
-        %return emit
-    ] unless ;
+: convert-loop ( #recursive -- )
+    begin-basic-block
+    [ begin-loop ]
+    [ child>> convert-nodes ]
+    [ drop end-loop ]
+    tri ;
+
+M: #recursive convert
+    dup label>> loop?>>
+    [ convert-loop ] [ convert-recursive ] if ;
+
+M: #copy convert drop ;
diff --git a/unfinished/compiler/machine/debug/debug.factor b/unfinished/compiler/machine/debugger/debugger.factor
similarity index 58%
rename from unfinished/compiler/machine/debug/debug.factor
rename to unfinished/compiler/machine/debugger/debugger.factor
index f83dadadec..adc84d771f 100644
--- a/unfinished/compiler/machine/debug/debug.factor
+++ b/unfinished/compiler/machine/debugger/debugger.factor
@@ -1,12 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer compiler.vops
-compiler.cfg.builder compiler.cfg.simplifier
-compiler.machine.builder compiler.machine.simplifier ;
-IN: compiler.machine.debug
+prettyprint inference generator optimizer
+compiler.vops
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.cfg.builder
+compiler.cfg.simplifier
+compiler.machine.builder
+compiler.machine.simplifier ;
+IN: compiler.machine.debugger
 
-: dataflow>linear ( dataflow word -- linear )
+: tree>linear ( tree word -- linear )
     [
         init-counter
         build-cfg
@@ -20,15 +25,16 @@ IN: compiler.machine.debug
     ] assoc-each ;
 
 : linearized-quot. ( quot -- )
-    dataflow optimize
-    "Anonymous quotation" dataflow>linear
+    build-tree optimize-tree
+    "Anonymous quotation" tree>linear
     linear. ;
 
 : linearized-word. ( word -- )
-    dup word-dataflow nip optimize swap dataflow>linear linear. ;
+    dup build-tree-from-word nip optimize-tree
+    dup word-dataflow nip optimize swap tree>linear linear. ;
 
 : >basic-block ( quot -- basic-block )
-    dataflow optimize
+    build-tree optimize-tree
     [
         init-counter
         "Anonymous quotation" build-cfg
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index 804d6ea240..5e8b8888ee 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -23,6 +23,7 @@ MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( in out -- word/f )
     2array {
+        { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }
         { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
@@ -34,6 +35,8 @@ MATCH-VARS: ?a ?b ?c ;
         { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
         { { { ?a ?b } { ?a ?b ?a } } [ over ] }
         { { { ?b ?a } { ?a ?b } } [ swap ] }
+        { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
+        { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
         { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
         { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
         { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
@@ -88,7 +91,7 @@ M: node node>quot drop ;
 : nodes>quot ( node -- quot )
     [ [ node>quot ] each ] [ ] make ;
 
-: optimized-quot. ( quot -- )
+: optimized. ( quot/word -- )
     dup word? [ specialized-def ] when
     build-tree optimize-tree nodes>quot . ;
 

From ed848621a3adc38e77b98ccee43c264a24cb80b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 02:49:43 -0500
Subject: [PATCH 35/42] Fix

---
 core/effects/effects.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 022490a907..2e0aa4c279 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -29,6 +29,7 @@ M: integer effect>string number>string ;
 M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
 
 : stack-picture ( seq -- string )
+    dup integer? [ "object" <repetition> ] when
     [ [ effect>string % CHAR: \s , ] each ] "" make ;
 
 M: effect effect>string ( effect -- string )

From d42edecffba30584bcc8c1534932d3085319442c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 23:30:18 -0500
Subject: [PATCH 36/42] Updating codegen for new optimizer

---
 unfinished/compiler/generator/authors.txt     |   1 +
 .../compiler/generator/fixup/authors.txt      |   1 +
 .../generator/fixup/fixup-docs.factor         |  16 +
 .../compiler/generator/fixup/fixup.factor     | 154 ++++
 .../compiler/generator/fixup/summary.txt      |   1 +
 .../compiler/generator/generator-docs.factor  |  88 +++
 .../compiler/generator/generator.factor       | 269 +++++++
 .../generator/iterator/iterator.factor        |  41 ++
 .../compiler/generator/registers/authors.txt  |   1 +
 .../generator/registers/registers.factor      | 660 ++++++++++++++++++
 .../compiler/generator/registers/summary.txt  |   1 +
 unfinished/compiler/generator/summary.txt     |   1 +
 unfinished/compiler/generator/tags.txt        |   1 +
 .../compiler/tree/debugger/debugger.factor    |  12 +-
 unfinished/compiler/tree/tree.factor          |   5 +
 .../stack-checker/inlining/inlining.factor    |   4 +-
 16 files changed, 1247 insertions(+), 9 deletions(-)
 create mode 100644 unfinished/compiler/generator/authors.txt
 create mode 100644 unfinished/compiler/generator/fixup/authors.txt
 create mode 100644 unfinished/compiler/generator/fixup/fixup-docs.factor
 create mode 100755 unfinished/compiler/generator/fixup/fixup.factor
 create mode 100644 unfinished/compiler/generator/fixup/summary.txt
 create mode 100755 unfinished/compiler/generator/generator-docs.factor
 create mode 100755 unfinished/compiler/generator/generator.factor
 create mode 100644 unfinished/compiler/generator/iterator/iterator.factor
 create mode 100644 unfinished/compiler/generator/registers/authors.txt
 create mode 100755 unfinished/compiler/generator/registers/registers.factor
 create mode 100644 unfinished/compiler/generator/registers/summary.txt
 create mode 100644 unfinished/compiler/generator/summary.txt
 create mode 100644 unfinished/compiler/generator/tags.txt

diff --git a/unfinished/compiler/generator/authors.txt b/unfinished/compiler/generator/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/authors.txt b/unfinished/compiler/generator/fixup/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/fixup-docs.factor b/unfinished/compiler/generator/fixup/fixup-docs.factor
new file mode 100644
index 0000000000..a4ff549e8e
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup-docs.factor
@@ -0,0 +1,16 @@
+USING: help.syntax help.markup math kernel
+words strings alien ;
+IN: compiler.generator.fixup
+
+HELP: frame-required
+{ $values { "n" "a non-negative integer" } }
+{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
+
+HELP: add-literal
+{ $values { "obj" object } { "n" integer } }
+{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
+
+HELP: rel-dlsym
+{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
+{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
+} ;
diff --git a/unfinished/compiler/generator/fixup/fixup.factor b/unfinished/compiler/generator/fixup/fixup.factor
new file mode 100755
index 0000000000..e1b4e42e67
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup.factor
@@ -0,0 +1,154 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
+IN: compiler.generator.fixup
+
+: no-stack-frame -1 ; inline
+
+TUPLE: frame-required n ;
+
+: frame-required ( n -- ) \ frame-required boa , ;
+
+: stack-frame-size ( code -- n )
+    no-stack-frame [
+        dup frame-required? [ frame-required-n max ] [ drop ] if
+    ] reduce ;
+
+GENERIC: fixup* ( frame-size obj -- frame-size )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+
+M: label fixup*
+    compiled-offset swap set-label-offset ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+: if-stack-frame ( frame-size quot -- )
+    swap dup no-stack-frame =
+    [ 2drop ] [ stack-frame swap call ] if ; inline
+
+M: word fixup*
+    {
+        { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+        { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+    } case ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+! Relocation classes
+: rc-absolute-cell     0 ;
+: rc-absolute          1 ;
+: rc-relative          2 ;
+: rc-absolute-ppc-2/2  3 ;
+: rc-relative-ppc-2    4 ;
+: rc-relative-ppc-3    5 ;
+: rc-relative-arm-3    6 ;
+: rc-indirect-arm      7 ;
+: rc-indirect-arm-pc   8 ;
+
+: rc-absolute? ( n -- ? )
+    dup rc-absolute-cell =
+    over rc-absolute =
+    rot rc-absolute-ppc-2/2 = or or ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym     1 ;
+: rt-literal   2 ;
+: rt-dispatch  3 ;
+: rt-xt        4 ;
+: rt-here      5 ;
+: rt-label     6 ;
+: rt-immediate 7 ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+    dup class>> rc-absolute?
+    [ "Absolute labels not supported" throw ] when
+    dup label>> swap class>> compiled-offset 4 - rot
+    3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+    swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+    [ relocation-table get push-4 ] bi@ ;
+
+M: frame-required fixup* drop ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+    2dup swap [ eq? ] curry find drop
+    [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+    >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+    >r literal-table get length >r
+    add-dlsym-literals
+    r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+    >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+    >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+    >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+    0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+    0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+    BV{ } clone relocation-table set
+    V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+    [
+        first3 label-offset
+        [ "Unresolved label" throw ] unless*
+        3array
+    ] map concat ;
+
+: fixup ( code -- literals relocation labels code )
+    [
+        init-fixup
+        dup stack-frame-size swap [ fixup* ] each drop
+
+        literal-table get >array
+        relocation-table get >byte-array
+        label-table get resolve-labels
+    ] { } make ;
diff --git a/unfinished/compiler/generator/fixup/summary.txt b/unfinished/compiler/generator/fixup/summary.txt
new file mode 100644
index 0000000000..ce83e6d253
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/summary.txt
@@ -0,0 +1 @@
+Support for generation of relocatable code
diff --git a/unfinished/compiler/generator/generator-docs.factor b/unfinished/compiler/generator/generator-docs.factor
new file mode 100755
index 0000000000..e00b8d5b28
--- /dev/null
+++ b/unfinished/compiler/generator/generator-docs.factor
@@ -0,0 +1,88 @@
+USING: help.markup help.syntax words debugger generator.fixup
+generator.registers quotations kernel vectors arrays effects
+sequences ;
+IN: compiler.generator
+
+ARTICLE: "generator" "Compiled code generator"
+"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+$nl
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
+{ $subsection compiled-stack-traces? }
+"Assembler intrinsics can be defined for low-level optimization:"
+{ $subsection define-intrinsic }
+{ $subsection define-intrinsics }
+{ $subsection define-if-intrinsic }
+{ $subsection define-if-intrinsics }
+"The main entry point into the code generator:"
+{ $subsection generate } ;
+
+ABOUT: "generator"
+
+HELP: compiled
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
+
+HELP: compiling-word
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiling-label
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiled-stack-traces?
+{ $values { "?" "a boolean" } }
+{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
+{ $description "Prepares to generate machine code for a word." } ;
+
+HELP: with-generator
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
+
+HELP: generate-node
+{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
+{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate-nodes
+{ $values { "node" "a dataflow node" } } 
+{ $description "Recursively generate machine code for a dataflow graph." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate
+{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
+{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
+
+HELP: define-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
+{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: define-intrinsic
+{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
+{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: if>boolean-intrinsic
+{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
+{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
+
+HELP: define-if-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
+{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
+$nl
+"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
+$nl
+"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
+{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
+
+HELP: define-if-intrinsic
+{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
+{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
+$nl
+"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
new file mode 100755
index 0000000000..19e60ae19c
--- /dev/null
+++ b/unfinished/compiler/generator/generator.factor
@@ -0,0 +1,269 @@
+ ! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+cpu.architecture effects generic hashtables io kernel
+kernel.private layouts math namespaces prettyprint quotations
+sequences system threads words vectors sets dequeues cursors
+stack-checker.inlining
+compiler.tree compiler.tree.builder compiler.tree.combinators
+compiler.tree.propagation.info compiler.generator.fixup
+compiler.generator.registers compiler.generator.iterator ;
+IN: compiler.generator
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+    {
+        { [ dup "forgotten" word-prop ] [ ] }
+        { [ dup compiled get key? ] [ ] }
+        { [ dup inlined-block? ] [ ] }
+        { [ dup primitive? ] [ ] }
+        [ dup compile-queue get push-front ]
+    } cond drop ;
+
+: maybe-compile ( word -- )
+    dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: compiling-word
+
+SYMBOL: compiling-label
+
+SYMBOL: compiling-loops
+
+! Label of current word, after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+: begin-compiling ( word label -- )
+    H{ } clone compiling-loops set
+    compiling-label set
+    compiling-word set
+    compiled-stack-traces?
+    compiling-word get f ?
+    1vector literal-table set
+    f compiling-label get compiled get set-at ;
+
+: save-machine-code ( literals relocation labels code -- )
+    4array compiling-label get compiled get set-at ;
+
+: with-generator ( node word label quot -- )
+    [
+        >r begin-compiling r>
+        { } make fixup
+        save-machine-code
+    ] with-scope ; inline
+
+GENERIC: generate-node ( node -- next )
+
+: generate-nodes ( nodes -- )
+    [ current-node generate-node ] iterate-nodes end-basic-block ;
+
+: init-generate-nodes ( -- )
+    init-templates
+    %save-word-xt
+    %prologue-later
+    current-label-start define-label
+    current-label-start resolve-label ;
+
+: generate ( nodes word label -- )
+    [
+        init-generate-nodes
+        [ generate-nodes ] with-node-iterator
+    ] with-generator ;
+
+: intrinsics ( #call -- quot )
+    word>> "intrinsics" word-prop ;
+
+: if-intrinsics ( #call -- quot )
+    word>> "if-intrinsics" word-prop ;
+
+! node
+M: node generate-node drop iterate-next ;
+
+: %jump ( word -- )
+    dup compiling-label get eq?
+    [ drop current-label-start get ] [ %epilogue-later ] if
+    %jump-label ;
+
+: generate-call ( label -- next )
+    dup maybe-compile
+    end-basic-block
+    dup compiling-loops get at [
+        %jump-label f
+    ] [
+        tail-call? [
+            %jump f
+        ] [
+            0 frame-required
+            %call
+            iterate-next
+        ] if
+    ] ?if ;
+
+! #recursive
+: compile-recursive ( node -- )
+    dup label>> id>> generate-call >r
+    [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
+    r> ;
+
+: compiling-loop ( word -- )
+    <label> dup resolve-label swap compiling-loops get set-at ;
+
+: compile-loop ( node -- )
+    end-basic-block
+    [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
+    iterate-next ;
+
+M: #recursive generate-node
+    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: end-false-branch ( label -- )
+    tail-call? [ %return drop ] [ %jump-label ] if ;
+
+: generate-branch ( nodes -- )
+    [ copy-templates generate-nodes ] with-scope ;
+
+: generate-if ( node label -- next )
+    <label> [
+        >r >r children>> first2 swap generate-branch
+        r> r> end-false-branch resolve-label
+        generate-branch
+        init-templates
+    ] keep resolve-label iterate-next ;
+
+M: #if generate-node
+    [ <label> dup %jump-f ]
+    H{ { +input+ { { f "flag" } } } }
+    with-template
+    generate-if ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+    gensym [
+        [
+            copy-templates
+            %save-dispatch-xt
+            %prologue-later
+            [ generate-nodes ] with-node-iterator
+        ] with-generator
+    ] keep ;
+
+: dispatch-branches ( node -- )
+    children>> [
+        compiling-word get dispatch-branch
+        %dispatch-label
+    ] each ;
+
+: generate-dispatch ( node -- )
+    %dispatch dispatch-branches init-templates ;
+
+M: #dispatch generate-node
+    #! The order here is important, dispatch-branches must
+    #! run after %dispatch, so that each branch gets the
+    #! correct register state
+    tail-call? [
+        generate-dispatch iterate-next
+    ] [
+        compiling-word get gensym [
+            [
+                init-generate-nodes
+                generate-dispatch
+            ] with-generator
+        ] keep generate-call
+    ] if ;
+
+! #call
+: define-intrinsics ( word intrinsics -- )
+    "intrinsics" set-word-prop ;
+
+: define-intrinsic ( word quot assoc -- )
+    2array 1array define-intrinsics ;
+
+: define-if>branch-intrinsics ( word intrinsics -- )
+    "if-intrinsics" set-word-prop ;
+
+: if>boolean-intrinsic ( quot -- )
+    "false" define-label
+    "end" define-label
+    "false" get swap call
+    t "if-scratch" get load-literal
+    "end" get %jump-label
+    "false" resolve-label
+    f "if-scratch" get load-literal
+    "end" resolve-label
+    "if-scratch" get phantom-push ; inline
+
+: define-if>boolean-intrinsics ( word intrinsics -- )
+    [
+        >r [ if>boolean-intrinsic ] curry r>
+        { { f "if-scratch" } } +scratch+ associate assoc-union
+    ] assoc-map "intrinsics" set-word-prop ;
+
+: define-if-intrinsics ( word intrinsics -- )
+    [ +input+ associate ] assoc-map
+    2dup define-if>branch-intrinsics
+    define-if>boolean-intrinsics ;
+
+: define-if-intrinsic ( word quot inputs -- )
+    2array 1array define-if-intrinsics ;
+
+: do-if-intrinsic ( pair -- next )
+    <label> [
+        swap do-template
+        node> next dup >node
+    ] keep generate-if ;
+
+: find-intrinsic ( #call -- pair/f )
+    intrinsics find-template ;
+
+: find-if-intrinsic ( #call -- pair/f )
+    node@ next #if? [
+        if-intrinsics find-template
+    ] [
+        drop f
+    ] if ;
+
+M: #call generate-node
+    dup node-input-infos [ class>> ] map set-operand-classes
+    dup find-if-intrinsic [
+        do-if-intrinsic
+    ] [
+        dup find-intrinsic [
+            do-template iterate-next
+        ] [
+            word>> generate-call
+        ] ?if
+    ] ?if ;
+
+! #call-recursive
+M: #call-recursive generate-node label>> id>> generate-call ;
+
+! #push
+M: #push generate-node
+    literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle generate-node
+    shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r generate-node
+    in-d>> length
+    phantom->r
+    iterate-next ;
+
+M: #r> generate-node
+    out-d>> length
+    phantom-r>
+    iterate-next ;
+
+! #return
+M: #return generate-node
+    drop end-basic-block %return f ;
+
+M: #return-recursive generate-node
+    end-basic-block
+    label>> id>> compiling-loops get key?
+    [ %return ] unless f ;
diff --git a/unfinished/compiler/generator/iterator/iterator.factor b/unfinished/compiler/generator/iterator/iterator.factor
new file mode 100644
index 0000000000..68881990be
--- /dev/null
+++ b/unfinished/compiler/generator/iterator/iterator.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences cursors kernel compiler.tree ;
+IN: compiler.generator.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ value ;
+
+: iterate-next ( -- cursor ) node@ next ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+    over [
+        [ swap >node call node> drop ] keep iterate-nodes
+    ] [
+        2drop
+    ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+    >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+    [ value #phi? ] [ next (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+    [ value [ #return? ] [ #terminate? ] bi or ]
+    [ tail-phi? ]
+    bi or ;
+
+: tail-call? ( -- ? )
+    node-stack get [
+        next
+        [ (tail-call?) ]
+        [ value #terminate? not ]
+        bi and
+    ] all? ;
diff --git a/unfinished/compiler/generator/registers/authors.txt b/unfinished/compiler/generator/registers/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/registers/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/registers/registers.factor b/unfinished/compiler/generator/registers/registers.factor
new file mode 100755
index 0000000000..dc32afb264
--- /dev/null
+++ b/unfinished/compiler/generator/registers/registers.factor
@@ -0,0 +1,660 @@
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators cpu.architecture generator.fixup hashtables kernel
+layouts math namespaces quotations sequences system vectors
+words effects alien byte-arrays
+accessors sets math.order ;
+IN: compiler.generator.registers
+
+SYMBOL: +input+
+SYMBOL: +output+
+SYMBOL: +scratch+
+SYMBOL: +clobber+
+SYMBOL: known-tag
+
+<PRIVATE
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-vregs* ( obj -- )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+MIXIN: value
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+    operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-vregs* drop ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+! A scratch register for computations
+TUPLE: vreg n reg-class ;
+
+C: <vreg> vreg ( n reg-class -- vreg )
+
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
+M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
+
+INSTANCE: vreg value
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
+
+! Temporary register for stack shuffling
+SINGLETON: temp-reg
+
+M: temp-reg move-spec drop f ;
+
+INSTANCE: temp-reg value
+
+! A data stack location.
+TUPLE: ds-loc n class ;
+
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc operand-class* ds-loc-class ;
+M: ds-loc set-operand-class set-ds-loc-class ;
+M: ds-loc live-loc?
+    over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+! A retain stack location.
+TUPLE: rs-loc n class ;
+
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+M: rs-loc operand-class* rs-loc-class ;
+M: rs-loc set-operand-class set-rs-loc-class ;
+M: rs-loc live-loc?
+    over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+UNION: loc ds-loc rs-loc ;
+
+M: loc move-spec drop loc ;
+
+INSTANCE: loc value
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+
+C: <cached> cached
+
+M: cached set-operand-class cached-vreg set-operand-class ;
+M: cached operand-class* cached-vreg operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-loc? cached-loc live-loc? ;
+M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached lazy-store
+    2dup cached-loc live-loc?
+    [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+
+: <tagged> ( vreg -- tagged )
+    f tagged boa ;
+
+M: tagged v>operand tagged-vreg v>operand ;
+M: tagged set-operand-class set-tagged-class ;
+M: tagged operand-class* tagged-class ;
+M: tagged move-spec drop f ;
+M: tagged live-vregs* tagged-vreg , ;
+
+INSTANCE: tagged value
+
+! Unboxed alien pointers
+TUPLE: unboxed-alien vreg ;
+C: <unboxed-alien> unboxed-alien
+M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+
+INSTANCE: unboxed-alien value
+
+TUPLE: unboxed-byte-array vreg ;
+C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array operand-class* drop c-ptr ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+
+INSTANCE: unboxed-byte-array value
+
+TUPLE: unboxed-f vreg ;
+C: <unboxed-f> unboxed-f
+M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+
+INSTANCE: unboxed-f value
+
+TUPLE: unboxed-c-ptr vreg ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr operand-class* drop c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+
+INSTANCE: unboxed-c-ptr value
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+M: constant operand-class* constant-value class ;
+M: constant move-spec class ;
+
+INSTANCE: constant value
+
+<PRIVATE
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+    dup operand-class {
+        { [ dup \ f class<= ] [ drop %unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+        [ drop %unbox-any-c-ptr ]
+    } cond ; inline
+
+: %move-via-temp ( dst src -- )
+    #! For many transfers, such as loc to unboxed-alien, we
+    #! don't have an intrinsic, so we transfer the source to
+    #! temp then temp to the destination.
+    temp-reg over %move
+    operand-class temp-reg
+    tagged new
+        swap >>vreg
+        swap >>class
+    %move ;
+
+: %move ( dst src -- )
+    2dup [ move-spec ] bi@ 2array {
+        { { f f } [ %move-bug ] }
+        { { f unboxed-c-ptr } [ %move-bug ] }
+        { { f unboxed-byte-array } [ %move-bug ] }
+
+        { { f constant } [ constant-value swap load-literal ] }
+
+        { { f float } [ %box-float ] }
+        { { f unboxed-alien } [ %box-alien ] }
+        { { f loc } [ %peek ] }
+
+        { { float f } [ %unbox-float ] }
+        { { unboxed-alien f } [ %unbox-alien ] }
+        { { unboxed-byte-array f } [ %unbox-byte-array ] }
+        { { unboxed-f f } [ %unbox-f ] }
+        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+        { { loc f } [ swap %replace ] }
+
+        [ drop %move-via-temp ]
+    } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+    call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+    >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+    #! Utility for methods on <loc>
+    height>> - ;
+
+: (finalize-height) ( stack word -- )
+    #! We consolidate multiple stack height changes until the
+    #! last moment, and we emit the final height changing
+    #! instruction here.
+    [
+        over zero? [ 2drop ] [ execute ] if 0
+    ] curry change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+    phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+    \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+    phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+    \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+    #! A sequence of n ds-locs or rs-locs indexing the stack.
+    >r <reversed> r> [ <loc> ] curry map ;
+
+: phantom-locs* ( phantom -- locs )
+    [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+    phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+    phantoms 2array swap [ (each-loc) ] curry each ; inline
+
+: adjust-phantom ( n phantom -- )
+    swap [ + ] curry change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+    swap [ cut* swap ] curry change-stack drop ;
+
+: phantom-append ( seq stack -- )
+    over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+    2dup stack>> length <= [
+        2drop
+    ] [
+        [ phantom-locs ] keep
+        [ stack>> length head-slice* ] keep
+        [ append >vector ] change-stack drop
+    ] if ;
+
+: phantom-input ( n phantom -- seq )
+    2dup add-locs
+    2dup cut-phantom
+    >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: live-vregs ( -- seq )
+    [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
+
+: (live-locs) ( phantom -- seq )
+    #! Discard locs which haven't moved
+    [ phantom-locs* ] [ stack>> ] bi zip
+    [ live-loc? ] assoc-filter
+    values ;
+
+: live-locs ( -- seq )
+    [ (live-locs) ] each-phantom append prune ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+! Computing free registers and initializing allocator
+: reg-spec>class ( spec -- class )
+    float eq? double-float-regs int-regs ? ;
+
+: free-vregs ( reg-class -- seq )
+    #! Free vregs in a given register class
+    \ free-vregs get at ;
+
+: alloc-vreg ( spec -- reg )
+    [ reg-spec>class free-vregs pop ] keep {
+        { f [ <tagged> ] }
+        { unboxed-alien [ <unboxed-alien> ] }
+        { unboxed-byte-array [ <unboxed-byte-array> ] }
+        { unboxed-f [ <unboxed-f> ] }
+        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+        [ drop ]
+    } case ;
+
+: compatible? ( value spec -- ? )
+    >r move-spec r> {
+        { [ 2dup = ] [ t ] }
+        { [ dup unboxed-c-ptr eq? ] [
+            over { unboxed-byte-array unboxed-alien } member?
+        ] }
+        [ f ]
+    } cond 2nip ;
+
+: allocation ( value spec -- reg-class )
+    {
+        { [ dup quotation? ] [ 2drop f ] }
+        { [ 2dup compatible? ] [ 2drop f ] }
+        [ nip reg-spec>class ]
+    } cond ;
+
+: alloc-vreg-for ( value spec -- vreg )
+    alloc-vreg swap operand-class
+    over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+    2dup allocation [
+        dupd alloc-vreg-for dup rot %move
+    ] [
+        drop
+    ] if ;
+
+: (compute-free-vregs) ( used class -- vector )
+    #! Find all vregs in 'class' which are not in 'used'.
+    [ vregs length reverse ] keep
+    [ <vreg> ] curry map swap diff
+    >vector ;
+
+: compute-free-vregs ( -- )
+    #! Create a new hashtable for thee free-vregs variable.
+    live-vregs
+    { int-regs double-float-regs }
+    [ 2dup (compute-free-vregs) ] H{ } map>assoc
+    \ free-vregs set
+    drop ;
+
+M: loc lazy-store
+    2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: do-shuffle ( hash -- )
+    dup assoc-empty? [
+        drop
+    ] [
+        "live-locs" set
+        [ lazy-store ] each-loc
+    ] if ;
+
+: fast-shuffle ( locs -- )
+    #! We have enough free registers to load all shuffle inputs
+    #! at once
+    [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
+
+: minimal-ds-loc ( phantom -- n )
+    #! When shuffling more values than can fit in registers, we
+    #! need to find an area on the data stack which isn't in
+    #! use.
+    [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
+
+: find-tmp-loc ( -- n )
+    #! Find an area of the data stack which is not referenced
+    #! from the phantom stacks. We can clobber there all we want
+    [ minimal-ds-loc ] each-phantom min 1- ;
+
+: slow-shuffle-mapping ( locs tmp -- pairs )
+    >r dup length r>
+    [ swap - <ds-loc> ] curry map zip ;
+
+: slow-shuffle ( locs -- )
+    #! We don't have enough free registers to load all shuffle
+    #! inputs, so we use a single temporary register, together
+    #! with the area of the data stack above the stack pointer
+    find-tmp-loc slow-shuffle-mapping [
+        [
+            swap dup cached? [ cached-vreg ] when %move
+        ] assoc-each
+    ] keep >hashtable do-shuffle ;
+
+: fast-shuffle? ( live-locs -- ? )
+    #! Test if we have enough free registers to load all
+    #! shuffle inputs at once.
+    int-regs free-vregs [ length ] bi@ <= ;
+
+: finalize-locs ( -- )
+    #! Perform any deferred stack shuffling.
+    [
+        \ free-vregs [ [ clone ] assoc-map ] change
+        live-locs dup fast-shuffle?
+        [ fast-shuffle ] [ slow-shuffle ] if
+    ] with-scope ;
+
+: finalize-vregs ( -- )
+    #! Store any vregs to their final stack locations.
+    [
+        dup loc? over cached? or [ 2drop ] [ %move ] if
+    ] each-loc ;
+
+: reset-phantom ( phantom -- )
+    #! Kill register assignments but preserve constants and
+    #! class information.
+    dup phantom-locs*
+    over stack>> [
+        dup constant? [ nip ] [
+            operand-class over set-operand-class
+        ] if
+    ] 2map
+    over stack>> delete-all
+    swap stack>> push-all ;
+
+: reset-phantoms ( -- )
+    [ reset-phantom ] each-phantom ;
+
+: finalize-contents ( -- )
+    finalize-locs finalize-vregs reset-phantoms ;
+
+! Loading stacks to vregs
+: free-vregs? ( int# float# -- ? )
+    double-float-regs free-vregs length <=
+    >r int-regs free-vregs length <= r> and ;
+
+: phantom&spec ( phantom spec -- phantom' spec' )
+    >r stack>> r>
+    [ length f pad-left ] keep
+    [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+    >r phantom&spec r> 2all? ; inline
+
+: vreg-substitution ( value vreg -- pair )
+    dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+    #! We don't substitute locs for float or alien vregs,
+    #! since in those cases the boxing overhead might kill us.
+    cached-vreg tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+    [ vreg-substitution ] 2map
+    [ substitute-vreg? ] assoc-filter >hashtable
+    [ >r stack>> r> substitute-here ] curry each-phantom ;
+
+: set-operand ( value var -- )
+    >r dup constant? [ constant-value ] when r> set ;
+
+: lazy-load ( values template -- )
+    #! Set operand vars here.
+    2dup [ first (lazy-load) ] 2map
+    dup rot [ second set-operand ] 2each
+    substitute-vregs ;
+
+: load-inputs ( -- )
+    +input+ get
+    [ length phantom-datastack get phantom-input ] keep
+    lazy-load ;
+
+: output-vregs ( -- seq seq )
+    +output+ +clobber+ [ get [ get ] map ] bi@ ;
+
+: clash? ( seq -- ? )
+    phantoms [ stack>> ] bi@ append [
+        dup cached? [ cached-vreg ] when swap member?
+    ] with contains? ;
+
+: outputs-clash? ( -- ? )
+    output-vregs append clash? ;
+
+: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
+
+: count-input-vregs ( phantom spec -- )
+    phantom&spec [
+        >r dup cached? [ cached-vreg ] when r> first allocation
+    ] 2map count-vregs ;
+
+: count-scratch-regs ( spec -- )
+    [ first reg-spec>class ] map count-vregs ;
+
+: guess-vregs ( dinput rinput scratch -- int# float# )
+    [
+        0 int-regs set
+        0 double-float-regs set
+        count-scratch-regs
+        phantom-retainstack get swap count-input-vregs
+        phantom-datastack get swap count-input-vregs
+        int-regs get double-float-regs get
+    ] with-scope ;
+
+: alloc-scratch ( -- )
+    +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
+
+: guess-template-vregs ( -- int# float# )
+    +input+ get { } +scratch+ get guess-vregs ;
+
+: template-inputs ( -- )
+    ! Load input values into registers
+    load-inputs
+    ! Allocate scratch registers
+    alloc-scratch
+    ! If outputs clash, we write values back to the stack
+    outputs-clash? [ finalize-contents ] when ;
+
+: template-outputs ( -- )
+    +output+ get [ get ] map phantom-datastack get phantom-append ;
+
+: value-matches? ( value spec -- ? )
+    #! If the spec is a quotation and the value is a literal
+    #! fixnum, see if the quotation yields true when applied
+    #! to the fixnum. Otherwise, the values don't match. If the
+    #! spec is not a quotation, its a reg-class, in which case
+    #! the value is always good.
+    dup quotation? [
+        over constant?
+        [ >r constant-value r> call ] [ 2drop f ] if
+    ] [
+        2drop t
+    ] if ;
+
+: class-matches? ( actual expected -- ? )
+    {
+        { f [ drop t ] }
+        { known-tag [ dup [ class-tag >boolean ] when ] }
+        [ class<= ]
+    } case ;
+
+: spec-matches? ( value spec -- ? )
+    2dup first value-matches?
+    >r >r operand-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( spec -- ? )
+    phantom-datastack get +input+ rot at
+    [ spec-matches? ] phantom&spec-agree? ;
+
+: ensure-template-vregs ( -- )
+    guess-template-vregs free-vregs? [
+        finalize-contents compute-free-vregs
+    ] unless ;
+
+: clear-phantoms ( -- )
+    [ stack>> delete-all ] each-phantom ;
+
+PRIVATE>
+
+: set-operand-classes ( classes -- )
+    phantom-datastack get
+    over length over add-locs
+    stack>> [ set-operand-class ] 2reverse-each ;
+
+: end-basic-block ( -- )
+    #! Commit all deferred stacking shuffling, and ensure the
+    #! in-memory data and retain stacks are up to date with
+    #! respect to the compiler's current picture.
+    finalize-contents
+    clear-phantoms
+    finalize-heights
+    fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+
+: with-template ( quot hash -- )
+    clone [
+        ensure-template-vregs
+        template-inputs call template-outputs
+    ] bind
+    compute-free-vregs ; inline
+
+: do-template ( pair -- )
+    #! Use with return value from find-template
+    first2 with-template ;
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-templates ( -- )
+    #! Initialize register allocator.
+    V{ } clone fresh-objects set
+    <phantom-datastack> phantom-datastack set
+    <phantom-retainstack> phantom-retainstack set
+    compute-free-vregs ;
+
+: copy-templates ( -- )
+    #! Copies register allocator state, used when compiling
+    #! branches.
+    fresh-objects [ clone ] change
+    phantom-datastack [ clone ] change
+    phantom-retainstack [ clone ] change
+    compute-free-vregs ;
+
+: find-template ( templates -- pair/f )
+    #! Pair has shape { quot hash }
+    [ second template-matches? ] find nip ;
+
+: operand-tag ( operand -- tag/f )
+    operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+    operand-class immediate class<= ;
+
+: phantom-push ( obj -- )
+    1 phantom-datastack get adjust-phantom
+    phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+    [ effect-in length phantom-datastack get phantom-input ] keep
+    shuffle* phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+    phantom-datastack get phantom-input
+    phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+    phantom-retainstack get phantom-input
+    phantom-datastack get phantom-append ;
diff --git a/unfinished/compiler/generator/registers/summary.txt b/unfinished/compiler/generator/registers/summary.txt
new file mode 100644
index 0000000000..89a46afc03
--- /dev/null
+++ b/unfinished/compiler/generator/registers/summary.txt
@@ -0,0 +1 @@
+Register allocation and intrinsic selection
diff --git a/unfinished/compiler/generator/summary.txt b/unfinished/compiler/generator/summary.txt
new file mode 100644
index 0000000000..cf857ad971
--- /dev/null
+++ b/unfinished/compiler/generator/summary.txt
@@ -0,0 +1 @@
+Final stage of compilation generates machine code from dataflow IR
diff --git a/unfinished/compiler/generator/tags.txt b/unfinished/compiler/generator/tags.txt
new file mode 100644
index 0000000000..86a7c8e637
--- /dev/null
+++ b/unfinished/compiler/generator/tags.txt
@@ -0,0 +1 @@
+compiler
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index 5e8b8888ee..c5b35438b1 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -21,8 +21,8 @@ MACRO: match-choose ( alist -- )
 
 MATCH-VARS: ?a ?b ?c ;
 
-: pretty-shuffle ( in out -- word/f )
-    2array {
+: pretty-shuffle ( effect -- word/f )
+    [ in>> ] [ out>> ] bi {
         { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }
@@ -50,13 +50,9 @@ TUPLE: shuffle effect ;
 
 M: shuffle pprint* effect>> effect>string text ;
 
-: shuffle-inputs/outputs ( node -- in out )
-    [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
-    [ at ] curry map ;
-
 M: #shuffle node>quot
-    shuffle-inputs/outputs 2dup pretty-shuffle dup
-    [ 2nip % ] [ drop <effect> shuffle boa , ] if ;
+    shuffle-effect dup pretty-shuffle
+    [ % ] [ shuffle boa , ] ?if ;
 
 : pushed-literals ( node -- seq )
     dup out-d>> [ node-value-info literal>> literalize ] with map ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 016afc3e89..3db97fdfe0 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -153,6 +153,11 @@ M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 
+: shuffle-effect ( #shuffle -- effect )
+    [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+    [ at ] curry map
+    <effect> ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 6442bc5740..fcbf18f01c 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -28,9 +28,11 @@ loop? ;
 
 M: inline-recursive hashcode* id>> hashcode* ;
 
+: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
+
 : <inline-recursive> ( word -- label )
     inline-recursive new
-        gensym >>id
+        gensym t "inlined-block" set-word-prop >>id
         swap >>word ;
 
 : quotation-param? ( obj -- ? )

From aededc406fc23ce687f3e75dfdc1d85914cc1bdc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 02:41:18 -0500
Subject: [PATCH 37/42] Adding FFI to new front-end

---
 basis/alien/c-types/c-types-tests.factor      |  6 ++
 basis/alien/c-types/c-types.factor            | 13 ++-
 .../backward/backward.factor                  |  6 ++
 .../compiler/tree/dead-code/dead-code.factor  |  6 ++
 .../tree/debugger/debugger-tests.factor       |  3 +-
 .../compiler/tree/debugger/debugger.factor    |  2 +-
 .../tree/escape-analysis/simple/simple.factor | 10 +++
 .../tree/propagation/simple/simple.factor     |  6 ++
 unfinished/compiler/tree/tree.factor          | 27 ++++++
 .../tree/tuple-unboxing/tuple-unboxing.factor |  4 +
 unfinished/stack-checker/alien/alien.factor   | 84 +++++++++++++++++++
 .../stack-checker/inlining/inlining.factor    |  2 +-
 .../known-words/known-words.factor            | 22 +++--
 .../stack-checker/visitor/dummy/dummy.factor  |  3 +
 .../stack-checker/visitor/visitor.factor      |  3 +
 15 files changed, 181 insertions(+), 16 deletions(-)
 create mode 100644 unfinished/stack-checker/alien/alien.factor

diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 276dd581c5..edda9e7fdb 100755
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index c553ca5cfb..a9b39f80ab 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use def>> call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter
diff --git a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
index c9caeb864b..d69202c7ad 100644
--- a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
@@ -35,6 +35,12 @@ M: #phi backward
     [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
     2bi ;
 
+M: #alien-invoke backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: node backward 2drop ;
 
 : backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 6703f924fd..652fa19af3 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -23,6 +23,12 @@ M: #call mark-live-values
     dup word>> "flushable" word-prop
     [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
 
+M: #alien-invoke mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: #return mark-live-values
     look-at-inputs ;
 
diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
index e6a4385c3e..eb0bbd5ce6 100644
--- a/unfinished/compiler/tree/debugger/debugger-tests.factor
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -1,6 +1,5 @@
 IN: compiler.tree.debugger.tests
 USING: compiler.tree.debugger tools.test ;
 
-\ optimized-quot. must-infer
-\ optimized-word. must-infer
+\ optimized. must-infer
 \ optimizer-report. must-infer
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index c5b35438b1..c541311ef2 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -22,7 +22,7 @@ MACRO: match-choose ( alist -- )
 MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( effect -- word/f )
-    [ in>> ] [ out>> ] bi {
+    [ in>> ] [ out>> ] bi 2array {
         { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index c6c407b048..af42dc5145 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -80,3 +80,13 @@ M: #call escape-analysis*
 
 M: #return escape-analysis*
     in-d>> add-escaping-values ;
+
+M: #alien-invoke escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;
+
+M: #alien-indirect escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 4237738625..45bbbf19db 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -115,3 +115,9 @@ M: #call propagate-before
 M: #call propagate-after
     dup word>> "input-classes" word-prop dup
     [ propagate-input-classes ] [ 2drop ] if ;
+
+M: #alien-invoke propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;
+
+M: #alien-indirect propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 3db97fdfe0..175c1ddfdd 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -143,6 +143,30 @@ TUPLE: #copy < #renaming in-d out-d ;
         swap >>out-d
         swap >>in-d ;
 
+TUPLE: #alien-node < node params ;
+
+: new-alien-node ( params class -- node )
+    new
+        over in-d>> >>in-d
+        over out-d>> >>out-d
+        swap >>params ; inline
+
+TUPLE: #alien-invoke < #alien-node in-d out-d ;
+
+: #alien-invoke ( params -- node )
+    \ #alien-invoke new-alien-node ;
+
+TUPLE: #alien-indirect < #alien-node in-d out-d ;
+
+: #alien-indirect ( params -- node )
+    \ #alien-indirect new-alien-node ;
+
+TUPLE: #alien-callback < #alien-node ;
+
+: #alien-callback ( params -- node )
+    \ #alien-callback new
+        swap >>params ;
+
 : node, ( node -- ) stack-visitor get push ;
 
 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
@@ -177,3 +201,6 @@ M: vector #phi, #phi node, ;
 M: vector #declare, #declare node, ;
 M: vector #recursive, #recursive node, ;
 M: vector #copy, #copy node, ;
+M: vector #alien-invoke, #alien-invoke node, ;
+M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-callback, #alien-callback node, ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 3b832917d8..1b92d66db4 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -128,4 +128,8 @@ M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
 
+M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+
 : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
diff --git a/unfinished/stack-checker/alien/alien.factor b/unfinished/stack-checker/alien/alien.factor
new file mode 100644
index 0000000000..f81b7fdaa3
--- /dev/null
+++ b/unfinished/stack-checker/alien/alien.factor
@@ -0,0 +1,84 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors combinators math namespaces
+init sets words
+alien alien.c-types
+stack-checker.backend stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.alien
+
+TUPLE: alien-node-params return parameters abi in-d out-d ;
+
+TUPLE: alien-invoke-params < alien-node-params library function ;
+
+TUPLE: alien-indirect-params < alien-node-params ;
+
+TUPLE: alien-callback-params < alien-node-params quot xt ;
+
+: pop-parameters ( -- seq )
+    pop-literal nip [ expand-constants ] map ;
+
+: param-prep-quot ( node -- quot )
+    parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
+
+: alien-stack ( params extra -- )
+    over parameters>> length + consume-d >>in-d
+    dup return>> "void" = 0 1 ? produce-d >>out-d
+    drop ;
+
+: return-prep-quot ( node -- quot )
+    return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
+
+: infer-alien-invoke ( -- )
+    alien-invoke-params new
+    ! Compile-time parameters
+    pop-parameters >>parameters
+    pop-literal nip >>function
+    pop-literal nip >>library
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot recursive-state get infer-quot
+    ! Set ABI
+    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
+    ! Magic #: consume exactly the number of inputs
+    dup 0 alien-stack
+    ! Add node to IR
+    dup #alien-invoke,
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot ;
+
+: infer-alien-indirect ( -- )
+    alien-indirect-params new
+    ! Compile-time parameters
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+    ! Magic #: consume the function pointer, too
+    dup 1 alien-stack
+    ! Add node to IR
+    dup #alien-indirect,
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+
+: register-callback ( word -- ) callbacks get conjoin ;
+
+: callback-bottom ( params -- )
+    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
+    recursive-state get infer-quot ;
+
+: infer-alien-callback ( -- )
+    alien-callback-params new
+    pop-literal nip >>quot
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    gensym >>xt
+    dup callback-bottom
+    #alien-callback, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index fcbf18f01c..3be2e21b7e 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -32,7 +32,7 @@ M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new
-        gensym t "inlined-block" set-word-prop >>id
+        gensym dup t "inlined-block" set-word-prop >>id
         swap >>word ;
 
 : quotation-param? ( obj -- ? )
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 2e0c979f98..eb9a9dbdf7 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -10,10 +10,14 @@ sequences sequences.private slots.private strings
 strings.private system threads.private classes.tuple
 classes.tuple.private vectors vectors.private words definitions
 words.private assocs summary compiler.units system.private
-combinators locals.backend stack-checker.state
-stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.transforms
-stack-checker.visitor ;
+combinators locals.backend
+stack-checker.state
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.visitor
+stack-checker.alien ;
 IN: stack-checker.known-words
 
 : infer-primitive ( word -- )
@@ -153,13 +157,15 @@ M: object infer-call*
         { \ get-local [ infer-get-local ] }
         { \ drop-locals [ infer-drop-locals ] }
         { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+        { \ alien-invoke [ infer-alien-invoke ] }
+        { \ alien-indirect [ infer-alien-indirect ] }
+        { \ alien-callback [ infer-alien-callback ] }
     } case ;
 
 {
-    >r r> declare call curry compose
-    execute if dispatch <tuple-boa>
-    (throw) load-locals get-local drop-locals
-    do-primitive
+    >r r> declare call curry compose execute if dispatch
+    <tuple-boa> (throw) load-locals get-local drop-locals
+    do-primitive alien-invoke alien-indirect alien-callback
 } [ t +special+ set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }
diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index a1ed5c83a1..381405bd31 100644
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -22,3 +22,6 @@ M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;
+M: f #alien-invoke, drop ;
+M: f #alien-indirect, drop ;
+M: f #alien-callback, drop ;
diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index 3afc8f752d..25775ca3f0 100644
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -27,3 +27,6 @@ HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
 HOOK: #copy, stack-visitor ( inputs outputs -- )
+HOOK: #alien-invoke, stack-visitor ( params -- )
+HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params -- )

From 762007b28e0e9d47d4ce8cc59eb07c9898d0b92e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 03:18:15 -0500
Subject: [PATCH 38/42] Debugging front-end, updating FFI codegen

---
 .../compiler/generator/generator.factor       | 321 +++++++++++++++++-
 .../known-words/known-words.factor            |   4 +-
 .../transforms/transforms.factor              |   6 +-
 3 files changed, 323 insertions(+), 8 deletions(-)

diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
index 19e60ae19c..a4a7815d70 100755
--- a/unfinished/compiler/generator/generator.factor
+++ b/unfinished/compiler/generator/generator.factor
@@ -2,8 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes combinators
 cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math namespaces prettyprint quotations
-sequences system threads words vectors sets dequeues cursors
+kernel.private layouts math math.parser namespaces prettyprint
+quotations sequences system threads words vectors sets dequeues
+cursors continuations.private summary alien alien.c-types
+alien.structs alien.strings alien.arrays libc compiler.errors
 stack-checker.inlining
 compiler.tree compiler.tree.builder compiler.tree.combinators
 compiler.tree.propagation.info compiler.generator.fixup
@@ -48,7 +50,7 @@ SYMBOL: current-label-start
 : save-machine-code ( literals relocation labels code -- )
     4array compiling-label get compiled get set-at ;
 
-: with-generator ( node word label quot -- )
+: with-generator ( nodes word label quot -- )
     [
         >r begin-compiling r>
         { } make fixup
@@ -267,3 +269,316 @@ M: #return-recursive generate-node
     end-basic-block
     label>> id>> compiling-loops get key?
     [ %return ] unless f ;
+
+! #alien-invoke
+: large-struct? ( ctype -- ? )
+    dup c-struct? [
+        heap-size struct-small-enough? not
+    ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+    dup parameters>>
+    swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+    return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+    over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+    #! Compute stack frame locations.
+    [
+        0 [
+            [ parameter-align drop dup , ] keep stack-size +
+        ] reduce cell align
+    ] { } make ;
+
+: return-size ( ctype -- n )
+    #! Amount of space we reserve for a return value.
+    dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-stack-frame ( params -- n )
+    alien-parameters parameter-sizes drop ;
+
+: alien-invoke-frame ( params -- n )
+    #! One cell is temporary storage, temp@
+    dup return>> return-size
+    swap alien-stack-frame +
+    cell + ;
+
+: set-stack-frame ( n -- )
+    dup [ frame-required ] when* \ stack-frame set ;
+
+: with-stack-frame ( n quot -- )
+    swap set-stack-frame
+    call
+    f set-stack-frame ; inline
+
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+    dup reg-class-variable inc
+    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+    dup call-next-method
+    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+: reg-class-full? ( class -- ? )
+    [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+    stack-params get
+    >r reg-size stack-params +@ r>
+    stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+    [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+    c-type-reg-class dup reg-class-full?
+    [ spill-param ] [ fastcall-param ] if
+    [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- )
+    cell /i "void*" c-type <repetition> % ;
+
+GENERIC: flatten-value-type ( type -- )
+
+M: object flatten-value-type , ;
+
+M: struct-type flatten-value-type ( type -- )
+    stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- )
+    stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+    #! Convert value type structs to consecutive void*s.
+    [
+        0 [
+            c-type
+            [ parameter-align (flatten-int-type) ] keep
+            [ stack-size cell align + ] keep
+            flatten-value-type
+        ] reduce drop
+    ] { } make ;
+
+: each-parameter ( parameters quot -- )
+    >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+    { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+    #! In quot you can call alloc-parameter
+    [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+    #! Moves values from C stack to registers (if word is
+    #! %load-param-reg) and registers to C stack (if word is
+    #! %save-param-reg).
+    >r
+    alien-parameters
+    flatten-value-types
+    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+    inline
+
+: unbox-parameters ( offset node -- )
+    parameters>> [
+        %prepare-unbox >r over + r> unbox-parameter
+    ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+    #! Return offset on C stack where to store unboxed
+    #! parameters. If the C function is returning a structure,
+    #! the first parameter is an implicit target area pointer,
+    #! so we need to use a different offset.
+    return>> dup large-struct?
+    [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+    #! Generate code for unboxing a list of C types, then
+    #! generate code for moving these parameters to register on
+    #! architectures where parameters are passed in registers.
+    [
+        [ prepare-box-struct ] keep
+        [ unbox-parameters ] keep
+        \ %load-param-reg move-parameters
+    ] with-param-regs ;
+
+: box-return* ( node -- )
+    return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+    drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+    drop +linkage+ ;
+
+: no-such-library ( name -- )
+    \ no-such-library boa
+    compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+    drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+    drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+    \ no-such-symbol boa
+    compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+    dup dll-valid? [
+        dupd [ dlsym ] curry contains?
+        [ drop ] [ no-such-symbol ] if
+    ] [
+        dll-path no-such-library drop
+    ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+    "@"
+    swap parameters>> parameter-sizes drop
+    number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+    dup function>> dup pick stdcall-mangle 2array
+    swap library>> library dup [ dll>> ] when
+    2dup check-dlsym ;
+
+M: #alien-invoke generate-node
+    params>>
+    dup alien-invoke-frame [
+        end-basic-block
+        %prepare-alien-invoke
+        dup objects>registers
+        %prepare-var-args
+        dup alien-invoke-dlsym %alien-invoke
+        dup %cleanup
+        box-return*
+        iterate-next
+    ] with-stack-frame ;
+
+! #alien-indirect
+M: #alien-indirect generate-node
+    params>>
+    dup alien-invoke-frame [
+        ! Flush registers
+        end-basic-block
+        ! Save registers for GC
+        %prepare-alien-invoke
+        ! Save alien at top of stack to temporary storage
+        %prepare-alien-indirect
+        dup objects>registers
+        %prepare-var-args
+        ! Call alien in temporary storage
+        %alien-indirect
+        dup %cleanup
+        box-return*
+        iterate-next
+    ] with-stack-frame ;
+
+! #alien-callback
+: box-parameters ( params -- )
+    alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+    [
+        dup \ %save-param-reg move-parameters
+        "nest_stacks" f %alien-invoke
+        box-parameters
+    ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+    dup current-callback eq? [
+        drop
+    ] [
+        yield wait-to-return
+    ] if ;
+
+: do-callback ( quot token -- )
+    init-catchstack
+    dup 2 setenv
+    slip
+    wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+    return>> {
+        { [ dup "void" = ] [ drop [ ] ] }
+        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+        [ c-type c-type-unboxer-quot ]
+    } cond ;
+
+: callback-prep-quot ( params -- quot )
+    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+    [
+        [ callback-prep-quot ]
+        [ quot>> ]
+        [ callback-return-quot ] tri 3append ,
+        [ callback-context new do-callback ] %
+    ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+    {
+        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond ;
+
+: %callback-return ( params -- )
+    #! All the extra book-keeping for %unwind is only for x86.
+    #! On other platforms its an alias for %return.
+    dup alien-return
+    [ %unnest-stacks ] [ %callback-value ] if-void
+    callback-unwind %unwind ;
+
+: generate-callback ( params -- )
+    dup xt>> dup [
+        init-templates
+        %prologue-later
+        dup alien-stack-frame [
+            [ registers>objects ]
+            [ wrap-callback-quot %alien-callback ]
+            [ %callback-return ]
+            tri
+        ] with-stack-frame
+    ] with-generator ;
+
+M: #alien-callback generate-node
+    end-basic-block
+    params>> generate-callback iterate-next ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index eb9a9dbdf7..a0c91f679b 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -179,10 +179,10 @@ SYMBOL: +primitive+
         { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
         { [ dup +special+ word-prop ] [ infer-special ] }
         { [ dup +primitive+ word-prop ] [ infer-primitive ] }
-        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
         { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
+        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup recursive-label ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index d9e889f188..f22960dd39 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -23,10 +23,11 @@ SYMBOL: +transform-n+
     inline
 
 : (apply-transform) ( word quot n -- )
-    consume-d dup [ known literal? ] all? [
+    dup ensure-d [ known literal? ] all? [
         dup empty? [
             drop recursive-state get 1array
         ] [
+            consume-d
             [ #drop, ]
             [ [ literal value>> ] map ]
             [ first literal recursion>> ] tri prefix
@@ -123,7 +124,6 @@ SYMBOL: +transform-n+
 
 : bit-member-quot ( seq -- newquot )
     [
-        [ drop ] % ! drop the sequence itself; we don't use it at run time
         bit-member-seq ,
         [
             {
@@ -140,7 +140,7 @@ SYMBOL: +transform-n+
         bit-member-quot
     ] [
         [ literalize [ t ] ] { } map>assoc
-        [ drop f ] suffix [ nip case ] curry
+        [ drop f ] suffix [ case ] curry
     ] if ;
 
 \ member? [

From 6f78e38ab4c3dd474c3b16f747fd88e1056043a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:19:48 -0500
Subject: [PATCH 39/42] Add a couple of words to disjoint-sets

---
 basis/disjoint-sets/disjoint-sets.factor | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index f48129fbd4..77e4a53f7b 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -88,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- )
         disjoint-set link-sets
     ] if ;
 
+: equate-all-with ( seq a disjoint-set -- )
+    '[ , , equate ] each ;
+
+: equate-all ( seq disjoint-set -- )
+    over dup empty? [ 2drop ] [
+        [ unclip-slice ] dip equate-all-with
+    ] if ;
+
 M: disjoint-set clone
     [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
     disjoint-set boa ;

From 35a1ca3201a6af3b9354ea6a4e852e38c337ef69 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:19:58 -0500
Subject: [PATCH 40/42] Improve ranges docs

---
 basis/math/ranges/ranges-docs.factor | 40 ++++++++++++++++------------
 1 file changed, 23 insertions(+), 17 deletions(-)

diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor
index 714fc67c9f..f3c65e51a4 100644
--- a/basis/math/ranges/ranges-docs.factor
+++ b/basis/math/ranges/ranges-docs.factor
@@ -1,21 +1,27 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup arrays sequences ;
 
 IN: math.ranges
 
 ARTICLE: "ranges" "Ranges"
-
-  "A " { $emphasis "range" } " is a virtual sequence with real elements "
-  "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
-
-  $nl
-
-  "Creating ranges:"
-
-  { $subsection <range> }
-  { $subsection [a,b]   }
-  { $subsection (a,b]   }
-  { $subsection [a,b)   }
-  { $subsection (a,b)   }
-  { $subsection [0,b]   }
-  { $subsection [1,b]   }
-  { $subsection [0,b)   } ;
\ No newline at end of file
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
+$nl
+"The class of ranges:"
+{ $subsection range }
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
+{ $subsection [a,b] }
+{ $subsection (a,b] }
+{ $subsection [a,b) }
+{ $subsection (a,b) }
+{ $subsection [0,b] }
+{ $subsection [1,b] }
+{ $subsection [0,b) }
+"Creating general ranges:"
+{ $subsection <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code
+    "3 10 [a,b] [ sqrt ] map"
+}
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+  
+ABOUT: "ranges"
\ No newline at end of file

From f683c63da1c5a66a9e4a1ebc08bad7d7be79c9fe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:20:09 -0500
Subject: [PATCH 41/42] Fix code duplication

---
 extra/math/combinatorics/combinatorics.factor | 7 ++-----
 1 file changed, 2 insertions(+), 5 deletions(-)

diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index f7d7b76fa4..6193edfb91 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sorting ;
+namespaces sequences sequences.lib sorting ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -27,9 +27,6 @@ IN: math.combinatorics
 : permutation-indices ( n seq -- permutation )
     length [ factoradic ] dip 0 pad-left >permutation ;
 
-: reorder ( seq indices -- seq )
-    [ [ over nth , ] each drop ] { } make ;
-
 PRIVATE>
 
 : factorial ( n -- n! )
@@ -42,7 +39,7 @@ PRIVATE>
     twiddle [ nPk ] keep factorial / ;
 
 : permutation ( n seq -- seq )
-    tuck permutation-indices reorder ;
+    tuck permutation-indices nths ;
 
 : all-permutations ( seq -- seq )
     [

From bb76f2f61707364c41a4a47e5704c8047d873d98 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 18:57:57 -0500
Subject: [PATCH 42/42] Fix combinatorics tests

---
 extra/math/combinatorics/combinatorics-tests.factor | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor
index e6a2824433..5ef435a4e0 100644
--- a/extra/math/combinatorics/combinatorics-tests.factor
+++ b/extra/math/combinatorics/combinatorics-tests.factor
@@ -13,11 +13,6 @@ IN: math.combinatorics.tests
 [ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
 [ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
 
-[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
-[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
-[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
-[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
-
 [ 1 ] [ 0 factorial ] unit-test
 [ 1 ] [ 1 factorial ] unit-test
 [ 3628800 ] [ 10 factorial ] unit-test