From 00e5607a2c26a8d82b7e021528810cf8def3c5cd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Nov 2007 16:25:58 -0600
Subject: [PATCH 01/23] Fix a bug in delete-node where the prev pointer wasn't
 getting set right Add more unit tests

---
 core/dlists/dlists-tests.factor | 3 +++
 core/dlists/dlists.factor       | 3 ++-
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index f4482d680d..2d24dbae4c 100644
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -59,3 +59,6 @@ IN: temporary
 [ 0 ] [ <dlist> dlist-length ] unit-test
 [ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
 [ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
+
+[ 4 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back 4 over push-back 5 over push-back [ 3 = ] over delete-node drop dlist-front dlist-node-next dlist-node-next dlist-node-obj ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back 4 over push-back 5 over push-back [ 3 = ] over delete-node drop dlist-front dlist-node-next dlist-node-next dlist-node-prev dlist-node-obj ] unit-test
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index 890185d4c4..f18665b38e 100644
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -107,7 +107,8 @@ PRIVATE>
     {
         { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
         { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
-        { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
+        { [ t ] [ dup dlist-node-prev over dlist-node-next set-prev-when
+                  dup dlist-node-next swap dlist-node-prev set-next-when
                   dec-length ] }
     } cond ;
 

From b4df054dd4ac59fe10f9965c50972da851e8567b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 15 Nov 2007 17:21:45 -0500
Subject: [PATCH 02/23] add inline declarations to dlists

---
 core/dlists/dlists.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)
 mode change 100644 => 100755 core/dlists/dlists.factor

diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
old mode 100644
new mode 100755
index 890185d4c4..cc6a8b3699
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -49,15 +49,15 @@ C: <dlist-node> dlist-node
         drop nip t
     ] [
         drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
-    ] if ;
+    ] if ; inline
 
 : dlist-find-node ( quot dlist -- node/f ? )
-    dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
+    dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
 
 : (dlist-each-node) ( quot dlist -- )
     over
     [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
-    [ 2drop ] if ;
+    [ 2drop ] if ; inline
 
 : dlist-each-node ( quot dlist -- )
     >r dlist-front r> (dlist-each-node) ; inline
@@ -98,10 +98,10 @@ PRIVATE>
 : pop-back* ( dlist -- ) pop-back drop ;
 
 : dlist-find ( quot dlist -- obj/f ? )
-    dlist-find-node dup [ >r dlist-node-obj r> ] when ;
+    dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
 
 : dlist-contains? ( quot dlist -- ? )
-    dlist-find nip ;
+    dlist-find nip ; inline
 
 : (delete-node) ( dlist dlist-node -- )
     {
@@ -116,10 +116,10 @@ PRIVATE>
         [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
     ] [
         2drop f f
-    ] if ;
+    ] if ; inline
 
 : delete-node ( quot dlist -- obj/f )
-    delete-node* drop ;
+    delete-node* drop ; inline
 
 : dlist-each ( dlist quot -- )
     [ dlist-node-obj ] swap compose dlist-each-node ; inline

From 1bd8176b4a1cba9d78469ea344df8b1ffdfda2bb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 15 Nov 2007 17:29:00 -0500
Subject: [PATCH 03/23] New tools.test.inference vocabulary with
 unit-test-effect word

---
 core/compiler/test/alien.factor             |  10 +-
 core/compiler/test/redefine.factor          |  39 ++-
 core/inference/inference-tests.factor       | 338 ++++++++++----------
 extra/tools/test/inference/inference.factor |   9 +
 4 files changed, 196 insertions(+), 200 deletions(-)
 mode change 100644 => 100755 core/compiler/test/alien.factor
 mode change 100644 => 100755 core/compiler/test/redefine.factor
 create mode 100755 extra/tools/test/inference/inference.factor

diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor
old mode 100644
new mode 100755
index aa6b7aea7c..8358709590
--- a/core/compiler/test/alien.factor
+++ b/core/compiler/test/alien.factor
@@ -2,7 +2,8 @@ IN: temporary
 USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences inference words
 arrays parser quotations continuations inference.backend effects
-namespaces.private io io.streams.string memory system threads ;
+namespaces.private io io.streams.string memory system threads
+tools.test.inference ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -79,10 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 : indirect-test-1
     "int" { } "cdecl" alien-indirect ;
 
-: short-effect
-    dup effect-in length swap effect-out length 2array ;
-
-[ { 1 1 } ] [ [ indirect-test-1 ] infer short-effect ] unit-test
+{ 1 1 } [ indirect-test-1 ] unit-test-effect
 
 [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
 
@@ -91,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 : indirect-test-2
     "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
 
-[ { 3 1 } ] [ [ indirect-test-2 ] infer short-effect ] unit-test
+{ 3 1 } [ indirect-test-2 ] unit-test-effect
 
 [ 5 ]
 [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
old mode 100644
new mode 100755
index df2f3c3915..1fac112b2d
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -1,36 +1,33 @@
 USING: compiler definitions generic assocs inference math
 namespaces parser tools.test words kernel sequences arrays io
-effects ;
+effects tools.test.inference ;
 IN: temporary
 
 parse-hook get [
     DEFER: foo \ foo reset-generic
     DEFER: bar \ bar reset-generic
 
-    : short-effect
-        dup effect-in length swap effect-out length 2array ;
-
-    [   ] [ \ foo [ 1 2 ] define-compound     ] unit-test
-    [ { 0 2 } ] [ [ foo ] infer short-effect ] unit-test
-    [   ] [ \ foo compile                     ] unit-test
+    [   ] [ \ foo [ 1 2 ] define-compound ] unit-test
+    { 0 2 } [ foo ] unit-test-effect
+    [   ] [ \ foo compile ] unit-test
     [   ] [ \ bar [ foo foo ] define-compound ] unit-test
-    [   ] [ \ bar compile                     ] unit-test
-    [   ] [ \ foo [ 1 2 3 ] define-compound   ] unit-test
-    [ t ] [ \ bar changed-words get key?  ] unit-test
+    [   ] [ \ bar compile ] unit-test
+    [   ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
+    [ t ] [ \ bar changed-words get key? ] unit-test
     [   ] [ recompile ] unit-test
-    [ { 0 3 } ] [ [ foo ] infer short-effect ] unit-test
-    [ f ] [ \ bar changed-words get key?  ] unit-test
-    [   ] [ \ bar [ 1 2 ] define-compound     ] unit-test
-    [ t ] [ \ bar changed-words get key?  ] unit-test
+    { 0 3 } [ foo ] unit-test-effect
+    [ f ] [ \ bar changed-words get key? ] unit-test
+    [   ] [ \ bar [ 1 2 ] define-compound ] unit-test
+    [ t ] [ \ bar changed-words get key? ] unit-test
     [   ] [ recompile ] unit-test
-    [ { 0 2 } ] [ [ bar ] infer short-effect ] unit-test
-    [ f ] [ \ bar changed-words get key?  ] unit-test
-    [   ] [ \ foo [ 1 2 3 ] define-compound   ] unit-test
-    [ f ] [ \ bar changed-words get key?  ] unit-test
-    [   ] [ \ bar [ 1 2 3 ] define-compound   ] unit-test
-    [ t ] [ \ bar changed-words get key?  ] unit-test
+    { 0 2 } [ bar ] unit-test-effect
+    [ f ] [ \ bar changed-words get key? ] unit-test
+    [   ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
+    [ f ] [ \ bar changed-words get key? ] unit-test
+    [   ] [ \ bar [ 1 2 3 ] define-compound ] unit-test
+    [ t ] [ \ bar changed-words get key? ] unit-test
     [   ] [ \ bar forget ] unit-test
-    [ f ] [ \ bar changed-words get key?  ] unit-test
+    [ f ] [ \ bar changed-words get key? ] unit-test
 
     : xy ;
     : yx xy ;
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 1d3d6ebcf2..3462dee83a 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -6,46 +6,40 @@ continuations generic.standard sorting assocs definitions
 prettyprint io inspector bootstrap.image tuples
 classes.union classes.predicate debugger bootstrap.image
 bootstrap.image.private io.launcher threads.private
-io.streams.string combinators.private ;
+io.streams.string combinators.private tools.test.inference ;
 IN: temporary
 
-: short-effect
-    dup effect-in length swap effect-out length 2array ;
+{ 0 2 } [ 2 "Hello" ] unit-test-effect
+{ 1 2 } [ dup ] unit-test-effect
 
-[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test
-[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test
+{ 1 2 } [ [ dup ] call ] unit-test-effect
+[ [ call ] infer ] unit-test-fails
 
-[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test
-[ [ call ] infer short-effect ] unit-test-fails
+{ 2 4 } [ 2dup ] unit-test-effect
 
-[ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test
+{ 1 0 } [ [ ] [ ] if ] unit-test-effect
+[ [ if ] infer ] unit-test-fails
+[ [ [ ] if ] infer ] unit-test-fails
+[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
+{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
 
-[ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test
-[ [ if ] infer short-effect ] unit-test-fails
-[ [ [ ] if ] infer short-effect ] unit-test-fails
-[ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails
-[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test
-
-[ { 4 3 } ] [
+{ 4 3 } [
     [
-        [
-            [ swap 3 ] [ nip 5 5 ] if
-        ] [
-            -rot
-        ] if
-    ] infer short-effect
-] unit-test
+        [ swap 3 ] [ nip 5 5 ] if
+    ] [
+        -rot
+    ] if
+] unit-test-effect
 
-[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test
+{ 1 1 } [ dup [ ] when ] unit-test-effect
+{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
+{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
 
-[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test
+{ 1 0 } [ [ drop ] when* ] unit-test-effect
+{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
 
-[ { 0 1 } ] [
-    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect
-] unit-test
+{ 0 1 }
+[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
 
 [
     [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
@@ -57,37 +51,37 @@ IN: temporary
 
 : termination-test-2 [ termination-test-1 ] [ 3 ] if ;
 
-[ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test
+{ 1 1 } [ termination-test-2 ] unit-test-effect
 
 : infinite-loop infinite-loop ;
 
-[ [ infinite-loop ] infer short-effect ] unit-test-fails
+[ [ infinite-loop ] infer ] unit-test-fails
 
 : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer short-effect ] unit-test-fails
+[ [ no-base-case-1 ] infer ] unit-test-fails
 
 : simple-recursion-1 ( obj -- obj )
     dup [ simple-recursion-1 ] [ ] if ;
 
-[ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test
+{ 1 1 } [ simple-recursion-1 ] unit-test-effect
 
 : simple-recursion-2 ( obj -- obj )
     dup [ ] [ simple-recursion-2 ] if ;
 
-[ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test
+{ 1 1 } [ simple-recursion-2 ] unit-test-effect
 
 : bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
 
-[ [ bad-recursion-2 ] infer short-effect ] unit-test-fails
+[ [ bad-recursion-2 ] infer ] unit-test-fails
 
 : funny-recursion ( obj -- obj )
     dup [ funny-recursion 1 ] [ 2 ] if drop ;
 
-[ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test
+{ 1 1 } [ funny-recursion ] unit-test-effect
 
 ! Simple combinators
-[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test
+{ 1 2 } [ [ first ] keep second ] unit-test-effect
 
 ! Mutual recursion
 DEFER: foe
@@ -110,8 +104,8 @@ DEFER: foe
         2drop f
     ] if ;
 
-[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test
+{ 2 1 } [ fie ] unit-test-effect
+{ 2 1 } [ foe ] unit-test-effect
 
 : nested-when ( -- )
     t [
@@ -120,7 +114,7 @@ DEFER: foe
         ] when
     ] when ;
 
-[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test
+{ 0 0 } [ nested-when ] unit-test-effect
 
 : nested-when* ( obj -- )
     [
@@ -129,11 +123,11 @@ DEFER: foe
         ] when*
     ] when* ;
 
-[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test
+{ 1 0 } [ nested-when* ] unit-test-effect
 
 SYMBOL: sym-test
 
-[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test
+{ 0 1 } [ sym-test ] unit-test-effect
 
 : terminator-branch
     dup [
@@ -142,7 +136,7 @@ SYMBOL: sym-test
         "foo" throw
     ] if ;
 
-[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test
+{ 1 1 } [ terminator-branch ] unit-test-effect
 
 : recursive-terminator ( obj -- )
     dup [
@@ -151,12 +145,12 @@ SYMBOL: sym-test
         "Hi" throw
     ] if ;
 
-[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test
+{ 1 0 } [ recursive-terminator ] unit-test-effect
 
 GENERIC: potential-hang ( obj -- obj )
 M: fixnum potential-hang dup [ potential-hang ] when ;
 
-[ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test
+[ ] [ [ 5 potential-hang ] infer drop ] unit-test
 
 TUPLE: funny-cons car cdr ;
 GENERIC: iterate ( obj -- )
@@ -164,24 +158,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
-[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test
+{ 1 0 } [ iterate ] unit-test-effect
 
 ! Regression
 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
-[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test
+{ 3 0 } [ dog ] unit-test-effect
 
 ! Regression
 DEFER: monkey
 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
-[ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test
+{ 3 0 } [ friend ] unit-test-effect
 
-! Regression -- same as above but we infer short-effect the second word first
+! Regression -- same as above but we infer the second word first
 DEFER: blah2
 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
-[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test
+{ 3 0 } [ blah2 ] unit-test-effect
 
 ! Regression
 DEFER: blah4
@@ -189,7 +183,7 @@ DEFER: blah4
     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 : blah4 ( a b c -- )
     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
-[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test
+{ 3 0 } [ blah4 ] unit-test-effect
 
 ! Regression
 : bad-combinator ( obj quot -- )
@@ -199,14 +193,14 @@ DEFER: blah4
         [ swap slip ] keep swap bad-combinator
     ] if ; inline
 
-[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails
+[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
 
 ! Regression
 : bad-input#
     dup string? [ 2array throw ] unless
     over string? [ 2array throw ] unless ;
 
-[ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test
+{ 2 2 } [ bad-input# ] unit-test-effect
 
 ! Regression
 
@@ -214,18 +208,18 @@ DEFER: blah4
 DEFER: do-crap
 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer short-effect ] unit-test-fails
+[ [ do-crap ] infer ] unit-test-fails
 
 ! This one does not
 DEFER: do-crap*
 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer short-effect ] unit-test-fails
+[ [ do-crap* ] infer ] unit-test-fails
 
 ! Regression
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
-[ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test
+{ 2 1 } [ too-deep ] unit-test-effect
 
 ! Error reporting is wrong
 MATH: xyz
@@ -233,7 +227,7 @@ M: fixnum xyz 2array ;
 M: float xyz
     [ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
 
-[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
+[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
 
 ! Doug Coleman discovered this one while working on the
 ! calendar library
@@ -265,17 +259,17 @@ DEFER: C
         [ dup B C ]
     } dispatch ;
 
-[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test
+{ 1 0 } [ A ] unit-test-effect
+{ 1 0 } [ B ] unit-test-effect
+{ 1 0 } [ C ] unit-test-effect
 
 ! I found this bug by thinking hard about the previous one
 DEFER: Y
 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 : Y ( a b -- c d ) X ;
 
-[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test
-[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test
+{ 2 2 } [ X ] unit-test-effect
+{ 2 2 } [ Y ] unit-test-effect
 
 ! This one comes from UI code
 DEFER: #1
@@ -284,17 +278,17 @@ DEFER: #1
 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
 
-[ \ #4 word-def infer short-effect ] unit-test-fails
-[ [ #1 ] infer short-effect ] unit-test-fails
+[ \ #4 word-def infer ] unit-test-fails
+[ [ #1 ] infer ] unit-test-fails
 
 ! Similar
 DEFER: bar
 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 
-[ [ foo ] infer short-effect ] unit-test-fails
+[ [ foo ] infer ] unit-test-fails
 
-[ 1234 infer short-effect ] unit-test-fails
+[ 1234 infer ] unit-test-fails
 
 ! This used to hang
 [ t ] [
@@ -340,128 +334,128 @@ DEFER: bar
 : bad-recursion-1 ( a -- b )
     dup [ drop bad-recursion-1 5 ] [ ] if ;
 
-[ [ bad-recursion-1 ] infer short-effect ] unit-test-fails
+[ [ bad-recursion-1 ] infer ] unit-test-fails
 
 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer short-effect ] unit-test-fails
+[ [ bad-bin ] infer ] unit-test-fails
 
-[ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test
+[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
 
 ! Regression
 [ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
 
 ! Test some curry stuff
-[ { 1 1 } ] [ [ 3 [ ] curry 4 [ ] curry if ] infer short-effect ] unit-test
+{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
 
-[ { 2 1 } ] [ [ [ ] curry 4 [ ] curry if ] infer short-effect ] unit-test
+{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
 
 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
 
 ! Test number protocol
-[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test
-[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test
+{ 2 1 } [ bitor ] unit-test-effect
+{ 2 1 } [ bitand ] unit-test-effect
+{ 2 1 } [ bitxor ] unit-test-effect
+{ 2 1 } [ mod ] unit-test-effect
+{ 2 1 } [ /i ] unit-test-effect
+{ 2 1 } [ /f ] unit-test-effect
+{ 2 2 } [ /mod ] unit-test-effect
+{ 2 1 } [ + ] unit-test-effect
+{ 2 1 } [ - ] unit-test-effect
+{ 2 1 } [ * ] unit-test-effect
+{ 2 1 } [ / ] unit-test-effect
+{ 2 1 } [ < ] unit-test-effect
+{ 2 1 } [ <= ] unit-test-effect
+{ 2 1 } [ > ] unit-test-effect
+{ 2 1 } [ >= ] unit-test-effect
+{ 2 1 } [ number= ] unit-test-effect
 
 ! Test object protocol
-[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ clone ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ hashcode* ] infer short-effect ] unit-test
+{ 2 1 } [ = ] unit-test-effect
+{ 1 1 } [ clone ] unit-test-effect
+{ 2 1 } [ hashcode* ] unit-test-effect
 
 ! Test sequence protocol
-[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ nth ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test
-[ { 3 0 } ] [ [ set-nth ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ new ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ new-resizable ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ like ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ lengthen ] infer short-effect ] unit-test
+{ 1 1 } [ length ] unit-test-effect
+{ 2 1 } [ nth ] unit-test-effect
+{ 2 0 } [ set-length ] unit-test-effect
+{ 3 0 } [ set-nth ] unit-test-effect
+{ 2 1 } [ new ] unit-test-effect
+{ 2 1 } [ new-resizable ] unit-test-effect
+{ 2 1 } [ like ] unit-test-effect
+{ 2 0 } [ lengthen ] unit-test-effect
 
 ! Test assoc protocol
-[ { 2 2 } ] [ [ at* ] infer short-effect ] unit-test
-[ { 3 0 } ] [ [ set-at ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ new-assoc ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ delete-at ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ clear-assoc ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ assoc-size ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ assoc-like ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ assoc-clone-like ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ >alist ] infer short-effect ] unit-test
-[ { 1 3 } ] [ [ [ 2drop f ] assoc-find ] infer short-effect ] unit-test
+{ 2 2 } [ at* ] unit-test-effect
+{ 3 0 } [ set-at ] unit-test-effect
+{ 2 1 } [ new-assoc ] unit-test-effect
+{ 2 0 } [ delete-at ] unit-test-effect
+{ 1 0 } [ clear-assoc ] unit-test-effect
+{ 1 1 } [ assoc-size ] unit-test-effect
+{ 2 1 } [ assoc-like ] unit-test-effect
+{ 2 1 } [ assoc-clone-like ] unit-test-effect
+{ 1 1 } [ >alist ] unit-test-effect
+{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
 
 ! Test some random library words
-[ { 1 1 } ] [ [ 1quotation ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test
+{ 1 1 } [ 1quotation ] unit-test-effect
+{ 1 1 } [ string>number ] unit-test-effect
+{ 1 1 } [ get ] unit-test-effect
 
-[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test
+{ 2 0 } [ push ] unit-test-effect
+{ 2 1 } [ append ] unit-test-effect
+{ 1 1 } [ peek ] unit-test-effect
 
-[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test
+{ 1 1 } [ reverse ] unit-test-effect
+{ 2 1 } [ member? ] unit-test-effect
+{ 2 1 } [ remove ] unit-test-effect
+{ 1 1 } [ natural-sort ] unit-test-effect
 
-[ { 1 0 } ] [ [ forget ] infer short-effect ] unit-test
-[ { 4 0 } ] [ [ define-class ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ define-tuple-class ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ define-union-class ] infer short-effect ] unit-test
-[ { 3 0 } ] [ [ define-predicate-class ] infer short-effect ] unit-test
+{ 1 0 } [ forget ] unit-test-effect
+{ 4 0 } [ define-class ] unit-test-effect
+{ 2 0 } [ define-tuple-class ] unit-test-effect
+{ 2 0 } [ define-union-class ] unit-test-effect
+{ 3 0 } [ define-predicate-class ] unit-test-effect
 
 ! Test words with continuations
-[ { 0 0 } ] [ [ [ drop ] callcc0 ] infer short-effect ] unit-test
-[ { 0 1 } ] [ [ [ 4 swap continue-with ] callcc1 ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ [ + ] [ ] [ ] cleanup ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ [ + ] [ 3drop 0 ] recover ] infer short-effect ] unit-test
+{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
+{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
+{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
+{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
 
 ! Test stream protocol
-[ { 2 0 } ] [ [ set-timeout ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ stream-read ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ stream-read1 ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ stream-readln ] infer short-effect ] unit-test
-[ { 2 2 } ] [ [ stream-read-until ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ stream-write ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ stream-write1 ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ stream-nl ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ stream-close ] infer short-effect ] unit-test
-[ { 3 0 } ] [ [ stream-format ] infer short-effect ] unit-test
-[ { 3 0 } ] [ [ stream-write-table ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ stream-flush ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ make-span-stream ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ make-block-stream ] infer short-effect ] unit-test
-[ { 2 1 } ] [ [ make-cell-stream ] infer short-effect ] unit-test
+{ 2 0 } [ set-timeout ] unit-test-effect
+{ 2 1 } [ stream-read ] unit-test-effect
+{ 1 1 } [ stream-read1 ] unit-test-effect
+{ 1 1 } [ stream-readln ] unit-test-effect
+{ 2 2 } [ stream-read-until ] unit-test-effect
+{ 2 0 } [ stream-write ] unit-test-effect
+{ 2 0 } [ stream-write1 ] unit-test-effect
+{ 1 0 } [ stream-nl ] unit-test-effect
+{ 1 0 } [ stream-close ] unit-test-effect
+{ 3 0 } [ stream-format ] unit-test-effect
+{ 3 0 } [ stream-write-table ] unit-test-effect
+{ 1 0 } [ stream-flush ] unit-test-effect
+{ 2 1 } [ make-span-stream ] unit-test-effect
+{ 2 1 } [ make-block-stream ] unit-test-effect
+{ 2 1 } [ make-cell-stream ] unit-test-effect
 
 ! Test stream utilities
-[ { 1 1 } ] [ [ lines ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ contents ] infer short-effect ] unit-test
+{ 1 1 } [ lines ] unit-test-effect
+{ 1 1 } [ contents ] unit-test-effect
 
 ! Test prettyprinting
-[ { 1 0 } ] [ [ . ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ short. ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ unparse ] infer short-effect ] unit-test
+{ 1 0 } [ . ] unit-test-effect
+{ 1 0 } [ short. ] unit-test-effect
+{ 1 1 } [ unparse ] unit-test-effect
 
-[ { 1 0 } ] [ [ describe ] infer short-effect ] unit-test
-[ { 1 0 } ] [ [ error. ] infer short-effect ] unit-test
+{ 1 0 } [ describe ] unit-test-effect
+{ 1 0 } [ error. ] unit-test-effect
 
 ! Test odds and ends
-[ { 1 1 } ] [ [ ' ] infer short-effect ] unit-test
-[ { 2 0 } ] [ [ write-image ] infer short-effect ] unit-test
-[ { 1 1 } ] [ [ <process-stream> ] infer short-effect ] unit-test
-[ { 0 0 } ] [ [ idle-thread ] infer short-effect ] unit-test
+{ 1 1 } [ ' ] unit-test-effect
+{ 2 0 } [ write-image ] unit-test-effect
+{ 1 1 } [ <process-stream> ] unit-test-effect
+{ 0 0 } [ idle-thread ] unit-test-effect
 
 ! Incorrect stack declarations on inline recursive words should
 ! be caught
@@ -471,13 +465,13 @@ DEFER: bar
 [ [ barxxx ] infer ] unit-test-fails
 
 ! A typo
-[ { 1 0 } ] [ [ { [ ] } dispatch ] infer short-effect ] unit-test
+{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
 
 DEFER: inline-recursive-2
 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 : inline-recursive-2 ( -- ) inline-recursive-1 ;
 
-[ { 0 0 } ] [ [ inline-recursive-1 ] infer short-effect ] unit-test
+{ 0 0 } [ inline-recursive-1 ] unit-test-effect
 
 ! Hooks
 SYMBOL: my-var
@@ -486,23 +480,22 @@ HOOK: my-hook my-var ( -- x )
 M: integer my-hook "an integer" ;
 M: string my-hook "a string" ;
 
-[ { 0 1 } ] [ [ my-hook ] infer short-effect ] unit-test
+{ 0 1 } [ my-hook ] unit-test-effect
 
 DEFER: deferred-word
 
 : calls-deferred-word [ deferred-word ] [ 3 ] if ;
 
-[ { 1 1 } ] [ [ calls-deferred-word ] infer short-effect ] unit-test
+{ 1 1 } [ calls-deferred-word ] unit-test-effect
 
 USE: inference.dataflow
 
-[ { 1 0 } ] [ [ [ iterate-next ] iterate-nodes ] infer short-effect ] unit-test
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
 
-[ { 1 0 } ] [
-    [
-        [ [ iterate-next ] iterate-nodes ] with-node-iterator
-    ] infer short-effect
-] unit-test
+{ 1 0 }
+[
+    [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] unit-test-effect
 
 : nilpotent ( quot -- )
     t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@@ -510,14 +503,13 @@ USE: inference.dataflow
 : semisimple ( quot -- )
     [ call ] keep [ [ semisimple ] keep ] nilpotent drop ; inline
 
-[ { 0 1 } ] [
-    [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
-    infer short-effect
-] unit-test
+{ 0 1 }
+[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
+unit-test-effect
 
-[ { 0 0 } ] [ [ [ ] semisimple ] infer short-effect ] unit-test
+{ 0 0 } [ [ ] semisimple ] unit-test-effect
 
-[ { 1 0 } ] [ [ [ drop ] each-node ] infer short-effect ] unit-test
+{ 1 0 } [ [ drop ] each-node ] unit-test-effect
 
 DEFER: an-inline-word
 
@@ -533,9 +525,9 @@ DEFER: an-inline-word
 : an-inline-word ( obj quot -- )
     >r normal-word r> call ; inline
 
-[ { 1 1 } ] [ [ [ 3 * ] an-inline-word ] infer short-effect ] unit-test
+{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
 
-[ { 0 1 } ] [ [ [ 2 ] [ 2 ] [ + ] compose compose call ] infer short-effect ] unit-test
+{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
 
 TUPLE: custom-error ;
 
@@ -559,4 +551,4 @@ TUPLE: custom-error ;
 
 ! This was a false trigger of the undecidable quotation
 ! recursion bug
-[ { 2 1 } ] [ [ find-last-sep ] infer short-effect ] unit-test
+{ 2 1 } [ find-last-sep ] unit-test-effect
diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor
new file mode 100755
index 0000000000..5c222a1b6e
--- /dev/null
+++ b/extra/tools/test/inference/inference.factor
@@ -0,0 +1,9 @@
+USING: effects sequences kernel arrays quotations inference
+tools.test ;
+IN: tools.test.inference
+
+: short-effect
+    dup effect-in length swap effect-out length 2array ;
+
+: unit-test-effect ( effect quot -- )
+    >r 1quotation r> [ infer short-effect ] curry unit-test ;

From 0ef46b423413b918255fa59e951c6aeef5f93de4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 15 Nov 2007 21:44:10 -0500
Subject: [PATCH 04/23] Some dlists unit tests added

---
 core/dlists/dlists-tests.factor | 24 +++++++++++++++++++++++-
 core/dlists/dlists.factor       |  3 +++
 2 files changed, 26 insertions(+), 1 deletion(-)
 mode change 100644 => 100755 core/dlists/dlists-tests.factor

diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
old mode 100644
new mode 100755
index f4482d680d..7ac01a9070
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -1,4 +1,6 @@
-USING: dlists dlists.private kernel tools.test ;
+USING: dlists dlists.private kernel tools.test random assocs
+hashtables sequences namespaces sorting debugger io prettyprint
+math ;
 IN: temporary
 
 [ t ] [ <dlist> dlist-empty? ] unit-test
@@ -59,3 +61,23 @@ IN: temporary
 [ 0 ] [ <dlist> dlist-length ] unit-test
 [ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
 [ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
+
+: assert-same-elements
+    [ prune natural-sort ] 2apply assert= ;
+
+: dlist-push-all [ push-front ] curry each ;
+
+: dlist-delete-all [ dlist-delete drop ] curry each ;
+
+: dlist>array [ [ , ] dlist-slurp ] { } make ;
+
+[ ] [
+    5 [ drop 30 random >fixnum ] map prune
+    6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
+    [
+        <dlist>
+        [ dlist-push-all ] keep
+        [ dlist-delete-all ] keep
+        dlist>array
+    ] 2keep seq-diff assert-same-elements
+] unit-test
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index cc6a8b3699..a48de4943a 100755
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -121,6 +121,9 @@ PRIVATE>
 : delete-node ( quot dlist -- obj/f )
     delete-node* drop ; inline
 
+: dlist-delete ( obj dlist -- obj/f )
+    >r [ eq? ] curry r> delete-node ;
+
 : dlist-each ( dlist quot -- )
     [ dlist-node-obj ] swap compose dlist-each-node ; inline
 

From 1bc4a852e1a41f2e45dd560e2402ad89888e930b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 00:10:34 -0500
Subject: [PATCH 05/23] Remove run.s

---
 vm/run.s | 1117 ------------------------------------------------------
 1 file changed, 1117 deletions(-)
 delete mode 100644 vm/run.s

diff --git a/vm/run.s b/vm/run.s
deleted file mode 100644
index 8700b6cce8..0000000000
--- a/vm/run.s
+++ /dev/null
@@ -1,1117 +0,0 @@
-	.file	"run.c"
-	.text
-	.align	0
-	.global	reset_datastack
-	.def	reset_datastack;	.scl	2;	.type	32;	.endef
-reset_datastack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L3
-	@ lr needed for prologue
-	ldr	r2, [r3, #0]
-	ldr	r1, [r2, #24]
-	ldr	r3, [r1, #0]
-	sub	r5, r3, #4
-	mov	pc, lr
-.L4:
-	.align	0
-.L3:
-	.word	stack_chain
-	.align	0
-	.global	reset_retainstack
-	.def	reset_retainstack;	.scl	2;	.type	32;	.endef
-reset_retainstack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L7
-	@ lr needed for prologue
-	ldr	r2, [r3, #0]
-	ldr	r1, [r2, #28]
-	ldr	r3, [r1, #0]
-	sub	r6, r3, #4
-	mov	pc, lr
-.L8:
-	.align	0
-.L7:
-	.word	stack_chain
-	.align	0
-	.global	save_stacks
-	.def	save_stacks;	.scl	2;	.type	32;	.endef
-save_stacks:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L11
-	@ lr needed for prologue
-	ldr	r2, [r3, #0]
-	str	r6, [r2, #12]
-	str	r5, [r2, #8]
-	mov	pc, lr
-.L12:
-	.align	0
-.L11:
-	.word	stack_chain
-	.align	0
-	.global	init_stacks
-	.def	init_stacks;	.scl	2;	.type	32;	.endef
-init_stacks:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L15
-	ldr	r2, .L15+4
-	str	r0, [r3, #0]
-	ldr	r3, .L15+8
-	str	r1, [r2, #0]
-	mov	r1, #0
-	@ lr needed for prologue
-	str	r1, [r3, #0]
-	mov	pc, lr
-.L16:
-	.align	0
-.L15:
-	.word	ds_size
-	.word	rs_size
-	.word	stack_chain
-	.align	0
-	.global	enable_word_profiling
-	.def	enable_word_profiling;	.scl	2;	.type	32;	.endef
-enable_word_profiling:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L21
-	ldr	r2, [r0, #32]
-	@ lr needed for prologue
-	cmp	r2, r3
-	ldreq	r3, .L21+4
-	streq	r3, [r0, #32]
-	mov	pc, lr
-.L22:
-	.align	0
-.L21:
-	.word	docol
-	.word	docol_profiling
-	.align	0
-	.global	disable_word_profiling
-	.def	disable_word_profiling;	.scl	2;	.type	32;	.endef
-disable_word_profiling:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	@ link register save eliminated.
-	ldr	r3, .L27
-	ldr	r2, [r0, #32]
-	@ lr needed for prologue
-	cmp	r2, r3
-	ldreq	r3, .L27+4
-	streq	r3, [r0, #32]
-	mov	pc, lr
-.L28:
-	.align	0
-.L27:
-	.word	docol_profiling
-	.word	docol
-	.align	0
-	.global	primitive_3drop
-	.def	primitive_3drop;	.scl	2;	.type	32;	.endef
-primitive_3drop:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	sub	r5, r5, #12
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_2drop
-	.def	primitive_2drop;	.scl	2;	.type	32;	.endef
-primitive_2drop:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	sub	r5, r5, #8
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_millis
-	.def	primitive_millis;	.scl	2;	.type	32;	.endef
-primitive_millis:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	bl	current_millis
-	ldr	lr, [sp], #4
-	b	box_unsigned_8
-	.align	0
-	.global	array_to_stack
-	.def	array_to_stack;	.scl	2;	.type	32;	.endef
-array_to_stack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, r7, lr}
-	ldr	r4, [r0, #4]
-	mov	r7, r1
-	mov	r4, r4, lsr #3
-	mov	r4, r4, asl #2
-	add	r1, r0, #8
-	mov	r2, r4
-	mov	r0, r7
-	bl	memcpy
-	add	r4, r4, r7
-	sub	r0, r4, #4
-	ldmfd	sp!, {r4, r7, pc}
-	.align	0
-	.global	unnest_stacks
-	.def	unnest_stacks;	.scl	2;	.type	32;	.endef
-unnest_stacks:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, lr}
-	ldr	r4, .L39
-	ldr	r3, [r4, #0]
-	ldr	r0, [r3, #24]
-	bl	dealloc_segment
-	ldr	r3, [r4, #0]
-	ldr	r0, [r3, #28]
-	bl	dealloc_segment
-	ldr	r0, [r4, #0]
-	ldr	r1, .L39+4
-	ldr	r2, [r0, #36]
-	ldr	r5, [r0, #16]
-	ldr	r6, [r0, #20]
-	str	r2, [r1, #8]
-	ldr	r3, [r0, #32]
-	str	r3, [r1, #4]
-	ldr	r2, [r0, #40]
-	ldr	r1, [r0, #44]
-	ldr	r3, .L39+8
-	str	r1, [r4, #0]
-	str	r2, [r3, #0]
-	ldmfd	sp!, {r4, lr}
-	b	free
-.L40:
-	.align	0
-.L39:
-	.word	stack_chain
-	.word	userenv
-	.word	extra_roots
-	.align	0
-	.global	primitive_drop
-	.def	primitive_drop;	.scl	2;	.type	32;	.endef
-primitive_drop:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	sub	r5, r5, #4
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_swapd
-	.def	primitive_swapd;	.scl	2;	.type	32;	.endef
-primitive_swapd:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r1, [r5, #-4]
-	ldr	r2, [r5, #-8]
-	stmdb	r5, {r1, r2}	@ phole stm
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_swap
-	.def	primitive_swap;	.scl	2;	.type	32;	.endef
-primitive_swap:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r1, [r5, #0]
-	ldr	r2, [r5, #-4]
-	stmda	r5, {r1, r2}	@ phole stm
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive__rot
-	.def	primitive__rot;	.scl	2;	.type	32;	.endef
-primitive__rot:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r0, [r5, #0]
-	ldmdb	r5, {r1, r2}	@ phole ldm
-	stmda	r5, {r0, r1, r2}	@ phole stm
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_rot
-	.def	primitive_rot;	.scl	2;	.type	32;	.endef
-primitive_rot:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r0, [r5, #0]
-	ldr	r2, [r5, #-8]
-	ldr	r1, [r5, #-4]
-	stmda	r5, {r0, r2}	@ phole stm
-	str	r1, [r5, #-8]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_3dup
-	.def	primitive_3dup;	.scl	2;	.type	32;	.endef
-primitive_3dup:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldmda	r5, {r0, r1, r2}	@ phole ldm
-	mov	r3, r5
-	add	r5, r5, #12
-	str	r2, [r3, #12]
-	stmdb	r5, {r0, r1}	@ phole stm
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_2dup
-	.def	primitive_2dup;	.scl	2;	.type	32;	.endef
-primitive_2dup:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r0, [r5, #0]
-	ldr	r2, [r5, #-4]
-	add	r1, r5, #8
-	mov	r5, r1
-	str	r2, [r5, #-4]
-	str	r0, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_sleep
-	.def	primitive_sleep;	.scl	2;	.type	32;	.endef
-primitive_sleep:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r0, [r3], #-4
-	mov	r5, r3
-	bl	to_cell
-	ldr	lr, [sp], #4
-	b	sleep_millis
-	.align	0
-	.global	primitive_exit
-	.def	primitive_exit;	.scl	2;	.type	32;	.endef
-primitive_exit:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r0, [r3], #-4
-	mov	r5, r3
-	bl	to_fixnum
-	bl	exit
-	.align	0
-	.global	primitive_to_r
-	.def	primitive_to_r;	.scl	2;	.type	32;	.endef
-primitive_to_r:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r1, [r3], #-4
-	add	r2, r6, #4
-	mov	r6, r2
-	mov	r5, r3
-	str	r1, [r6, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_eq
-	.def	primitive_eq;	.scl	2;	.type	32;	.endef
-primitive_eq:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r0, r5
-	ldr	r1, [r5, #-4]
-	ldr	r2, [r0], #-4
-	mov	r3, #7
-	cmp	r2, r1
-	ldreq	r3, .L66
-	mov	r5, r0
-	ldreq	r3, [r3, #0]
-	str	r3, [r0, #0]
-	ldr	pc, [sp], #4
-.L67:
-	.align	0
-.L66:
-	.word	T
-	.align	0
-	.global	primitive_getenv
-	.def	primitive_getenv;	.scl	2;	.type	32;	.endef
-primitive_getenv:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r3, [r5, #0]
-	ldr	r2, .L70
-	mov	r3, r3, asr #3
-	ldr	r1, [r2, r3, asl #2]
-	str	r1, [r5, #0]
-	ldr	pc, [sp], #4
-.L71:
-	.align	0
-.L70:
-	.word	userenv
-	.align	0
-	.global	primitive_2nip
-	.def	primitive_2nip;	.scl	2;	.type	32;	.endef
-primitive_2nip:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	r2, [r5, #0]
-	mov	r3, r5
-	sub	r5, r5, #8
-	str	r2, [r3, #-8]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_nip
-	.def	primitive_nip;	.scl	2;	.type	32;	.endef
-primitive_nip:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r2, r5
-	ldr	r1, [r2], #-4
-	str	r1, [r5, #-4]
-	mov	r5, r2
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_os_env
-	.def	primitive_os_env;	.scl	2;	.type	32;	.endef
-primitive_os_env:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	bl	unbox_char_string
-	bl	getenv
-	add	r3, r5, #4
-	cmp	r0, #0
-	moveq	r5, r3
-	moveq	r3, #7
-	streq	r3, [r5, #0]
-	ldreq	pc, [sp], #4
-	ldr	lr, [sp], #4
-	b	box_char_string
-	.align	0
-	.global	stack_to_array
-	.def	stack_to_array;	.scl	2;	.type	32;	.endef
-stack_to_array:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, r7, r8, lr}
-	mov	r8, r0
-	rsb	r1, r8, r1
-	adds	r7, r1, #4
-	mov	r0, #8
-	mov	r1, r7, asr #2
-	mov	r3, #0
-	bmi	.L85
-	bl	allot_array_internal
-	mov	r1, r8
-	mov	r4, r0
-	mov	r2, r7
-	add	r0, r0, #8
-	bl	memcpy
-	bic	r4, r4, #7
-	add	r3, r5, #4
-	mov	r5, r3
-	orr	r4, r4, #3
-	str	r4, [r5, #0]
-	mov	r3, #1
-.L85:
-	mov	r0, r3
-	ldmfd	sp!, {r4, r7, r8, pc}
-	.align	0
-	.global	primitive_from_r
-	.def	primitive_from_r;	.scl	2;	.type	32;	.endef
-primitive_from_r:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r3, r6
-	ldr	r1, [r3], #-4
-	add	r2, r5, #4
-	mov	r5, r2
-	mov	r6, r3
-	str	r1, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_pick
-	.def	primitive_pick;	.scl	2;	.type	32;	.endef
-primitive_pick:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	r2, [r5, #-8]
-	mov	r3, r5
-	add	r5, r5, #4
-	str	r2, [r3, #4]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_over
-	.def	primitive_over;	.scl	2;	.type	32;	.endef
-primitive_over:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	r2, [r5, #-4]
-	mov	r3, r5
-	add	r5, r5, #4
-	str	r2, [r3, #4]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_tuck
-	.def	primitive_tuck;	.scl	2;	.type	32;	.endef
-primitive_tuck:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r0, [r5, #0]
-	ldr	r2, [r5, #-4]
-	add	r1, r5, #4
-	mov	r3, r5
-	mov	r5, r1
-	stmda	r3, {r0, r2}	@ phole stm
-	str	r0, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_dupd
-	.def	primitive_dupd;	.scl	2;	.type	32;	.endef
-primitive_dupd:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r0, [r5, #0]
-	ldr	r2, [r5, #-4]
-	add	r1, r5, #4
-	mov	r3, r5
-	mov	r5, r1
-	str	r2, [r3, #0]
-	str	r0, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_dup
-	.def	primitive_dup;	.scl	2;	.type	32;	.endef
-primitive_dup:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r2, r5
-	ldr	r1, [r2], #4
-	str	r1, [r5, #4]
-	mov	r5, r2
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_set_slot
-	.def	primitive_set_slot;	.scl	2;	.type	32;	.endef
-primitive_set_slot:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r0, r5
-	ldr	r1, [r0], #-4
-	ldr	ip, [r5, #-4]
-	ldr	lr, [r0, #-4]
-	mov	r1, r1, asr #3
-	bic	r3, ip, #7
-	ldr	r2, .L101
-	str	lr, [r3, r1, asl #2]
-	ldr	r1, [r2, #0]
-	sub	lr, r0, #4
-	ldrb	r3, [r1, ip, lsr #6]	@ zero_extendqisi2
-	mov	r5, r0
-	mvn	r3, r3, asl #26
-	mvn	r3, r3, lsr #26
-	mov	r5, lr
-	sub	r5, lr, #4
-	strb	r3, [r1, ip, lsr #6]
-	ldr	pc, [sp], #4
-.L102:
-	.align	0
-.L101:
-	.word	cards_offset
-	.align	0
-	.global	primitive_slot
-	.def	primitive_slot;	.scl	2;	.type	32;	.endef
-primitive_slot:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r1, r5
-	ldr	r2, [r1], #-4
-	ldr	r3, [r5, #-4]
-	mov	r2, r2, asr #3
-	bic	r3, r3, #7
-	ldr	ip, [r3, r2, asl #2]
-	mov	r0, r5
-	mov	r5, r1
-	sub	r5, r1, #4
-	mov	r5, r1
-	str	ip, [r0, #-4]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_setenv
-	.def	primitive_setenv;	.scl	2;	.type	32;	.endef
-primitive_setenv:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	mov	r1, r5
-	ldr	r3, [r1], #-4
-	ldr	r0, [r5, #-4]
-	ldr	r2, .L107
-	mov	r3, r3, asr #3
-	mov	r5, r1
-	sub	r5, r1, #4
-	str	r0, [r2, r3, asl #2]
-	ldr	pc, [sp], #4
-.L108:
-	.align	0
-.L107:
-	.word	userenv
-	.align	0
-	.global	primitive_class_hash
-	.def	primitive_class_hash;	.scl	2;	.type	32;	.endef
-primitive_class_hash:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r3, [r5, #0]
-	and	r2, r3, #7
-	cmp	r2, #2
-	bic	r0, r3, #7
-	beq	.L116
-	cmp	r2, #3
-	bic	r3, r3, #7
-	ldreq	r3, [r3, #0]
-	mov	r0, r2, asl #3
-	streq	r3, [r5, #0]
-	strne	r0, [r5, #0]
-	ldr	pc, [sp], #4
-.L116:
-	ldr	r3, [r0, #8]
-	bic	r3, r3, #7
-	ldr	r2, [r3, #4]
-	str	r2, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	primitive_tag
-	.def	primitive_tag;	.scl	2;	.type	32;	.endef
-primitive_tag:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	str	lr, [sp, #-4]!
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	r3, [r5, #0]
-	and	r3, r3, #7
-	mov	r3, r3, asl #3
-	str	r3, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	nest_stacks
-	.def	nest_stacks;	.scl	2;	.type	32;	.endef
-nest_stacks:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, lr}
-	mov	r0, #48
-	bl	safe_malloc
-	mov	r4, r0
-	ldr	r0, .L121
-	str	r5, [r4, #16]
-	str	r6, [r4, #20]
-	ldr	r3, [r0, #8]
-	mvn	r2, #0
-	str	r3, [r4, #36]
-	ldr	r1, [r0, #4]
-	ldr	r3, .L121+4
-	str	r1, [r4, #32]
-	str	r2, [r4, #0]
-	str	r2, [r4, #4]
-	ldr	r0, [r3, #0]
-	bl	alloc_segment
-	ldr	r3, .L121+8
-	str	r0, [r4, #24]
-	ldr	r0, [r3, #0]
-	bl	alloc_segment
-	ldr	r3, .L121+12
-	ldr	ip, [r4, #24]
-	ldr	r2, [r3, #0]
-	ldr	r1, .L121+16
-	str	r2, [r4, #40]
-	ldr	lr, [ip, #0]
-	ldr	r2, [r0, #0]
-	ldr	r3, [r1, #0]
-	sub	r5, lr, #4
-	sub	r6, r2, #4
-	str	r3, [r4, #44]
-	str	r0, [r4, #28]
-	str	r4, [r1, #0]
-	ldmfd	sp!, {r4, pc}
-.L122:
-	.align	0
-.L121:
-	.word	userenv
-	.word	ds_size
-	.word	rs_size
-	.word	extra_roots
-	.word	stack_chain
-	.align	0
-	.global	fix_stacks
-	.def	fix_stacks;	.scl	2;	.type	32;	.endef
-fix_stacks:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	ldr	r2, .L131
-	add	r3, r5, #4
-	ldr	r2, [r2, #0]
-	stmfd	sp!, {r4, lr}
-	ldr	r0, [r2, #24]
-	add	r4, r6, #256
-	ldr	ip, [r0, #0]
-	add	lr, r5, #256
-	cmp	r3, ip
-	add	r1, r6, #4
-	bcc	.L124
-	ldr	r3, [r0, #8]
-	cmp	lr, r3
-	bcs	.L124
-.L126:
-	ldr	r2, [r2, #28]
-	ldr	r0, [r2, #0]
-	cmp	r1, r0
-	bcc	.L127
-	ldr	r3, [r2, #8]
-	cmp	r4, r3
-	ldmccfd	sp!, {r4, pc}
-.L127:
-	sub	r6, r0, #4
-	ldmfd	sp!, {r4, pc}
-.L124:
-	sub	r5, ip, #4
-	b	.L126
-.L132:
-	.align	0
-.L131:
-	.word	stack_chain
-	.align	0
-	.global	primitive_type
-	.def	primitive_type;	.scl	2;	.type	32;	.endef
-primitive_type:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	str	lr, [sp, #-4]!
-	bl	save_callstack_top
-	ldr	r3, [r5, #0]
-	bic	r1, r3, #7
-	and	r3, r3, #7
-	cmp	r3, #3
-	ldreq	r3, [r1, #0]
-	moveq	r3, r3, lsr #3
-	mov	r3, r3, asl #3
-	str	r3, [r5, #0]
-	ldr	pc, [sp], #4
-	.align	0
-	.global	default_word_xt
-	.def	default_word_xt;	.scl	2;	.type	32;	.endef
-default_word_xt:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	ldr	r3, .L154
-	ldr	r0, [r0, #16]
-	ldr	r2, [r3, #0]
-	str	lr, [sp, #-4]!
-	cmp	r0, r2
-	ldreq	r0, .L154+4
-	ldreq	pc, [sp], #4
-	and	r1, r0, #7
-	cmp	r1, #3
-	biceq	r3, r0, #7
-	ldreq	r2, [r3, #0]
-	movne	r2, r1
-	moveq	r2, r2, lsr #3
-	cmp	r2, #14
-	beq	.L153
-	cmp	r1, #3
-	biceq	r3, r0, #7
-	ldreq	r2, [r3, #0]
-	moveq	r1, r2, lsr #3
-	cmp	r1, #0
-	ldrne	r0, .L154+8
-	ldrne	pc, [sp], #4
-	bl	to_fixnum
-	ldr	r3, .L154+12
-	ldr	r0, [r3, r0, asl #2]
-	ldr	pc, [sp], #4
-.L153:
-	ldr	r3, .L154+16
-	ldr	r2, .L154+20
-	ldrb	r1, [r3, #0]	@ zero_extendqisi2
-	ldr	r3, .L154+24
-	cmp	r1, #0
-	moveq	r0, r2
-	movne	r0, r3
-	ldr	pc, [sp], #4
-.L155:
-	.align	0
-.L154:
-	.word	T
-	.word	dosym
-	.word	undefined
-	.word	primitives
-	.word	profiling
-	.word	docol
-	.word	docol_profiling
-	.align	0
-	.global	primitive_profiling
-	.def	primitive_profiling;	.scl	2;	.type	32;	.endef
-primitive_profiling:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, r7, r8, lr}
-	mov	r0, r1
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r0, [r3], #-4
-	ldr	r4, .L175
-	mov	r5, r3
-	bl	to_boolean
-	strb	r0, [r4, #0]
-	bl	begin_scan
-	ldr	r8, .L175+4
-	ldr	r7, .L175+8
-.L173:
-	bl	next_object
-	cmp	r0, #7
-	bic	r2, r0, #7
-	and	r3, r0, #7
-	beq	.L174
-.L158:
-	cmp	r3, #3
-	ldreq	r3, [r2, #0]
-	moveq	r3, r3, lsr #3
-	cmp	r3, #17
-	bne	.L173
-	ldrb	r3, [r4, #0]	@ zero_extendqisi2
-	bic	r2, r0, #7
-	cmp	r3, #0
-	bic	r0, r0, #7
-	beq	.L162
-	ldr	r3, [r2, #32]
-	cmp	r3, r8
-	streq	r7, [r2, #32]
-	bl	next_object
-	cmp	r0, #7
-	bic	r2, r0, #7
-	and	r3, r0, #7
-	bne	.L158
-.L174:
-	ldr	r3, .L175+12
-	mov	r2, #0
-	strb	r2, [r3, #0]
-	ldmfd	sp!, {r4, r7, r8, pc}
-.L162:
-	ldr	r3, [r0, #32]
-	cmp	r3, r7
-	streq	r8, [r0, #32]
-	b	.L173
-.L176:
-	.align	0
-.L175:
-	.word	profiling
-	.word	docol
-	.word	docol_profiling
-	.word	gc_off
-	.align	0
-	.global	primitive_set_retainstack
-	.def	primitive_set_retainstack;	.scl	2;	.type	32;	.endef
-primitive_set_retainstack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	stmfd	sp!, {r4, r7, lr}
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r1, [r3], #-4
-	mov	r0, #8
-	and	r2, r1, #7
-	cmp	r2, #3
-	bic	r4, r1, #7
-	mov	r5, r3
-	ldreq	r3, [r4, #0]
-	moveq	r2, r3, lsr #3
-	cmp	r2, #8
-	blne	type_error
-.L181:
-	ldr	r3, .L184
-	ldr	r7, [r4, #4]
-	ldr	r2, [r3, #0]
-	add	r1, r4, #8
-	ldr	r0, [r2, #28]
-	mov	r7, r7, lsr #3
-	ldr	r4, [r0, #0]
-	mov	r7, r7, asl #2
-	mov	r0, r4
-	mov	r2, r7
-	bl	memcpy
-	add	r4, r4, r7
-	sub	r6, r4, #4
-	ldmfd	sp!, {r4, r7, pc}
-.L185:
-	.align	0
-.L184:
-	.word	stack_chain
-	.align	0
-	.global	primitive_set_datastack
-	.def	primitive_set_datastack;	.scl	2;	.type	32;	.endef
-primitive_set_datastack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	mov	r0, r1
-	stmfd	sp!, {r4, r7, lr}
-	bl	save_callstack_top
-	mov	r3, r5
-	ldr	r1, [r3], #-4
-	mov	r0, #8
-	and	r2, r1, #7
-	cmp	r2, #3
-	bic	r4, r1, #7
-	mov	r5, r3
-	ldreq	r3, [r4, #0]
-	moveq	r2, r3, lsr #3
-	cmp	r2, #8
-	blne	type_error
-.L190:
-	ldr	r3, .L193
-	ldr	r7, [r4, #4]
-	ldr	r2, [r3, #0]
-	add	r1, r4, #8
-	ldr	r0, [r2, #24]
-	mov	r7, r7, lsr #3
-	ldr	r4, [r0, #0]
-	mov	r7, r7, asl #2
-	mov	r0, r4
-	mov	r2, r7
-	bl	memcpy
-	add	r4, r4, r7
-	sub	r5, r4, #4
-	ldmfd	sp!, {r4, r7, pc}
-.L194:
-	.align	0
-.L193:
-	.word	stack_chain
-	.align	0
-	.global	primitive_retainstack
-	.def	primitive_retainstack;	.scl	2;	.type	32;	.endef
-primitive_retainstack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, r7, r8, lr}
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	ip, .L200
-	mov	r1, #7
-	ldr	lr, [ip, #0]
-	mov	r0, #8
-	ldr	r4, [lr, #28]
-	mov	r2, r1
-	ldr	r8, [r4, #0]
-	mov	r3, #0
-	rsb	ip, r8, r6
-	adds	r7, ip, #4
-	bmi	.L196
-	mov	r1, r7, asr #2
-	bl	allot_array_internal
-	mov	r1, r8
-	mov	r4, r0
-	mov	r2, r7
-	add	r0, r0, #8
-	bl	memcpy
-	bic	r4, r4, #7
-	add	r3, r5, #4
-	mov	r5, r3
-	orr	r4, r4, #3
-	str	r4, [r5, #0]
-	ldmfd	sp!, {r4, r7, r8, pc}
-.L196:
-	mov	r0, #13
-	ldmfd	sp!, {r4, r7, r8, lr}
-	b	general_error
-.L201:
-	.align	0
-.L200:
-	.word	stack_chain
-	.align	0
-	.global	primitive_datastack
-	.def	primitive_datastack;	.scl	2;	.type	32;	.endef
-primitive_datastack:
-	@ args = 0, pretend = 0, frame = 0
-	@ frame_needed = 0, uses_anonymous_args = 0
-	stmfd	sp!, {r4, r7, r8, lr}
-	mov	r0, r1
-	bl	save_callstack_top
-	ldr	ip, .L207
-	mov	r1, #7
-	ldr	lr, [ip, #0]
-	mov	r0, #8
-	ldr	r4, [lr, #24]
-	mov	r2, r1
-	ldr	r8, [r4, #0]
-	mov	r3, #0
-	rsb	ip, r8, r5
-	adds	r7, ip, #4
-	bmi	.L203
-	mov	r1, r7, asr #2
-	bl	allot_array_internal
-	mov	r1, r8
-	mov	r4, r0
-	mov	r2, r7
-	add	r0, r0, #8
-	bl	memcpy
-	bic	r4, r4, #7
-	add	r3, r5, #4
-	mov	r5, r3
-	orr	r4, r4, #3
-	str	r4, [r5, #0]
-	ldmfd	sp!, {r4, r7, r8, pc}
-.L203:
-	mov	r0, #11
-	ldmfd	sp!, {r4, r7, r8, lr}
-	b	general_error
-.L208:
-	.align	0
-.L207:
-	.word	stack_chain
-	.comm	errno, 4	@ 4
-	.comm	profiling, 4	@ 1
-	.comm	userenv, 160	@ 160
-	.comm	T, 4	@ 4
-	.comm	stack_chain, 4	@ 4
-	.comm	ds_size, 4	@ 4
-	.comm	rs_size, 4	@ 4
-	.comm	signal_number, 4	@ 4
-	.comm	signal_fault_addr, 4	@ 4
-	.comm	signal_callstack_top, 4	@ 4
-	.comm	secure_gc, 4	@ 1
-	.comm	data_heap, 4	@ 4
-	.comm	cards_offset, 4	@ 4
-	.comm	newspace, 4	@ 4
-	.comm	nursery, 4	@ 4
-	.comm	gc_time, 8	@ 8
-	.comm	minor_collections, 4	@ 4
-	.comm	cards_scanned, 4	@ 4
-	.comm	performing_gc, 4	@ 1
-	.comm	collecting_gen, 4	@ 4
-	.comm	collecting_code, 4	@ 1
-	.comm	collecting_aging_again, 4	@ 1
-	.comm	last_code_heap_scan, 4	@ 4
-	.comm	growing_data_heap, 4	@ 1
-	.comm	old_data_heap, 4	@ 4
-	.comm	gc_jmp, 44	@ 44
-	.comm	heap_scan_ptr, 4	@ 4
-	.comm	gc_off, 4	@ 1
-	.comm	extra_roots_region, 4	@ 4
-	.comm	extra_roots, 4	@ 4
-	.comm	bignum_zero, 4	@ 4
-	.comm	bignum_pos_one, 4	@ 4
-	.comm	bignum_neg_one, 4	@ 4
-	.comm	code_heap, 8	@ 8
-	.comm	data_relocation_base, 4	@ 4
-	.comm	code_relocation_base, 4	@ 4
-	.comm	posix_argc, 4	@ 4
-	.comm	posix_argv, 4	@ 4
-	.def	memcpy;	.scl	2;	.type	32;	.endef
-	.def	type_error;	.scl	2;	.type	32;	.endef
-	.def	safe_malloc;	.scl	2;	.type	32;	.endef
-	.def	alloc_segment;	.scl	2;	.type	32;	.endef
-	.def	dealloc_segment;	.scl	2;	.type	32;	.endef
-	.def	free;	.scl	2;	.type	32;	.endef
-	.def	allot_array_internal;	.scl	2;	.type	32;	.endef
-	.def	general_error;	.scl	2;	.type	32;	.endef
-	.def	memcpy;	.scl	2;	.type	32;	.endef
-	.def	dosym;	.scl	2;	.type	32;	.endef
-	.def	undefined;	.scl	2;	.type	32;	.endef
-	.def	exit;	.scl	2;	.type	32;	.endef
-	.def	to_fixnum;	.scl	2;	.type	32;	.endef
-	.def	unbox_char_string;	.scl	2;	.type	32;	.endef
-	.def	getenv;	.scl	2;	.type	32;	.endef
-	.def	box_char_string;	.scl	2;	.type	32;	.endef
-	.def	box_unsigned_8;	.scl	2;	.type	32;	.endef
-	.def	current_millis;	.scl	2;	.type	32;	.endef
-	.def	sleep_millis;	.scl	2;	.type	32;	.endef
-	.def	to_cell;	.scl	2;	.type	32;	.endef
-	.def	docol_profiling;	.scl	2;	.type	32;	.endef
-	.def	docol;	.scl	2;	.type	32;	.endef
-	.def	save_callstack_top;	.scl	2;	.type	32;	.endef
-	.def	to_boolean;	.scl	2;	.type	32;	.endef
-	.def	begin_scan;	.scl	2;	.type	32;	.endef
-	.def	next_object;	.scl	2;	.type	32;	.endef
-	.section .drectve
-	.ascii " -export:nursery,data"
-	.ascii " -export:cards_offset,data"
-	.ascii " -export:stack_chain,data"
-	.ascii " -export:userenv,data"
-	.ascii " -export:profiling,data"
-	.ascii " -export:nest_stacks"
-	.ascii " -export:unnest_stacks"
-	.ascii " -export:save_stacks"

From 24de62e335420d84d6e52d999b65976e61a462ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 00:17:34 -0500
Subject: [PATCH 06/23] Fix bug in delete-node

---
 core/dlists/dlists-tests.factor | 14 ++++++++++++++
 core/dlists/dlists.factor       | 11 +++++++----
 2 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index 7ac01a9070..ebae68472b 100755
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -81,3 +81,17 @@ IN: temporary
         dlist>array
     ] 2keep seq-diff assert-same-elements
 ] unit-test
+
+[ ] [
+    <dlist> "d" set
+    1 "d" get push-front
+    2 "d" get push-front
+    3 "d" get push-front
+    4 "d" get push-front
+    2 "d" get dlist-delete drop
+    3 "d" get dlist-delete drop
+    4 "d" get dlist-delete drop
+] unit-test
+
+[ 1 ] [ "d" get dlist-length ] unit-test
+[ 1 ] [ "d" get dlist>array length ] unit-test
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index a48de4943a..a3c869efaf 100755
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -103,12 +103,15 @@ PRIVATE>
 : dlist-contains? ( quot dlist -- ? )
     dlist-find nip ; inline
 
+: unlink-node ( dlist-node -- )
+    dup dlist-node-prev over dlist-node-next set-prev-when
+    dup dlist-node-next swap dlist-node-prev set-next-when ;
+
 : (delete-node) ( dlist dlist-node -- )
     {
-        { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
-        { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
-        { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
-                  dec-length ] }
+        { [ over dlist-front over eq? ] [ drop pop-front* ] }
+        { [ over dlist-back over eq? ] [ drop pop-back* ] }
+        { [ t ] [ unlink-node dec-length ] }
     } cond ;
 
 : delete-node* ( quot dlist -- obj/f ? )

From cef837184ba1a86aeb57ad3e8781f41e1e24aee9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 01:19:13 -0500
Subject: [PATCH 07/23] graft*/ungraft* refactoring

---
 extra/tools/test/ui/ui.factor                 |  16 +++
 extra/ui/cocoa/cocoa.factor                   |   1 -
 extra/ui/gadgets/buttons/buttons-tests.factor |   9 +-
 extra/ui/gadgets/editors/editors-tests.factor |   5 +-
 extra/ui/gadgets/editors/editors.factor       |   9 +-
 extra/ui/gadgets/gadgets-tests.factor         | 100 +++++++++++++++++-
 extra/ui/gadgets/gadgets.factor               |  90 ++++++++++++----
 .../ui/gadgets/incremental/incremental.factor |   2 +
 extra/ui/gadgets/panes/panes-tests.factor     |   7 +-
 .../gadgets/scrollers/scrollers-tests.factor  |  37 ++++---
 extra/ui/gadgets/scrollers/scrollers.factor   |   4 +-
 extra/ui/gadgets/sliders/sliders.factor       |   6 +-
 extra/ui/gadgets/viewports/viewports.factor   |   3 +-
 extra/ui/gadgets/worlds/worlds.factor         |  11 +-
 extra/ui/render/render-docs.factor            |   2 +-
 extra/ui/tools/browser/browser-tests.factor   |   6 ++
 extra/ui/tools/listener/listener-tests.factor |  40 +++----
 extra/ui/tools/search/search-tests.factor     |  27 +++--
 extra/ui/tools/tools-tests.factor             |  39 ++++---
 extra/ui/tools/tools.factor                   |  17 ++-
 extra/ui/tools/traceback/traceback.factor     |   6 +-
 .../ui/tools/workspace/workspace-tests.factor |   4 +
 extra/ui/ui-docs.factor                       |   6 --
 extra/ui/ui.factor                            |  52 +++++----
 extra/ui/windows/windows.factor               |  26 +++--
 extra/ui/x11/x11.factor                       |   1 -
 26 files changed, 371 insertions(+), 155 deletions(-)
 create mode 100755 extra/tools/test/ui/ui.factor
 mode change 100644 => 100755 extra/ui/cocoa/cocoa.factor
 mode change 100644 => 100755 extra/ui/gadgets/editors/editors-tests.factor
 mode change 100644 => 100755 extra/ui/gadgets/gadgets-tests.factor
 mode change 100644 => 100755 extra/ui/gadgets/incremental/incremental.factor
 mode change 100644 => 100755 extra/ui/gadgets/panes/panes-tests.factor
 mode change 100644 => 100755 extra/ui/gadgets/worlds/worlds.factor
 mode change 100644 => 100755 extra/ui/render/render-docs.factor
 create mode 100755 extra/ui/tools/browser/browser-tests.factor
 create mode 100755 extra/ui/tools/workspace/workspace-tests.factor
 mode change 100644 => 100755 extra/ui/ui-docs.factor
 mode change 100644 => 100755 extra/ui/ui.factor
 mode change 100644 => 100755 extra/ui/x11/x11.factor

diff --git a/extra/tools/test/ui/ui.factor b/extra/tools/test/ui/ui.factor
new file mode 100755
index 0000000000..0376e7f4c7
--- /dev/null
+++ b/extra/tools/test/ui/ui.factor
@@ -0,0 +1,16 @@
+USING: dlists ui.gadgets kernel ui namespaces io.streams.string
+io ;
+IN: tools.test.ui
+
+! We can't print to stdio here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+: with-grafted-gadget ( gadget quot -- )
+    [
+        <dlist> \ graft-queue [
+            over
+            graft notify-queued
+            swap slip
+            ungraft notify-queued
+        ] with-variable
+    ] string-out print ;
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
old mode 100644
new mode 100755
index c7a4b62abb..52722a2fab
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -62,7 +62,6 @@ M: cocoa-ui-backend set-title ( string world -- )
 
 M: cocoa-ui-backend (open-world-window) ( world -- )
     dup gadget-window
-    dup start-world
     dup auto-position
     world-handle second f -> makeKeyAndOrderFront: ;
 
diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor
index b8cf5892eb..8565098e70 100755
--- a/extra/ui/gadgets/buttons/buttons-tests.factor
+++ b/extra/ui/gadgets/buttons/buttons-tests.factor
@@ -1,6 +1,7 @@
 IN: temporary
 USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets tools.test namespaces sequences kernel models ;
+ui.gadgets tools.test namespaces sequences kernel models
+tools.test.inference ;
 
 TUPLE: foo-gadget ;
 
@@ -27,6 +28,12 @@ T{ foo-gadget } <toolbar> "t" set
     } <radio-buttons> "religion" set
 ] unit-test
 
+{ 2 1 } [ <radio-buttons> ] unit-test-effect
+
+{ 2 1 } [ <toggle-buttons> ] unit-test-effect
+
+{ 2 1 } [ <checkbox> ] unit-test-effect
+
 [ 0 ] [
     "religion" get gadget-child radio-control-value
 ] unit-test
diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor
old mode 100644
new mode 100755
index daaeac6fad..b7ddc8359c
--- a/extra/ui/gadgets/editors/editors-tests.factor
+++ b/extra/ui/gadgets/editors/editors-tests.factor
@@ -1,6 +1,7 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
 io.streams.string definitions namespaces ui.gadgets
-ui.gadgets.grids prettyprint documents ui.gestures ;
+ui.gadgets.grids prettyprint documents ui.gestures
+tools.test.inference ;
 
 [ t ] [
     <editor> "editor" set
@@ -36,3 +37,5 @@ ui.gadgets.grids prettyprint documents ui.gestures ;
     "editor" get position-caret
     "editor" get ungraft*
 ] unit-test
+
+{ 0 1 } [ <editor> ] unit-test-effect
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index 9e2a258c0f..2221cb2bfd 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -2,10 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays documents ui.clipboards ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets.scrollers ui.gadgets.theme
-ui.render ui.gestures io kernel math models namespaces opengl
-opengl.gl sequences strings io.styles math.vectors sorting
-colors combinators ;
+ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
+kernel math models namespaces opengl opengl.gl sequences strings
+io.styles math.vectors sorting colors combinators ;
 IN: ui.gadgets.editors
 
 TUPLE: editor
@@ -129,7 +128,7 @@ M: editor model-changed
     line-height 0 swap 2array ;
 
 : scroll>caret ( editor -- )
-    dup gadget-grafted? [
+    dup gadget-status second [
         dup caret-loc over caret-dim { 1 0 } v+ <rect>
         over scroll>rect
     ] when drop ;
diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor
old mode 100644
new mode 100755
index 2a4527fbf2..a5a5b36a1b
--- a/extra/ui/gadgets/gadgets-tests.factor
+++ b/extra/ui/gadgets/gadgets-tests.factor
@@ -1,6 +1,8 @@
 IN: temporary
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel ;
+namespaces models kernel tools.test.inference dlists math
+math.parser ui sequences hashtables assocs io arrays
+prettyprint io.streams.string ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [
@@ -49,11 +51,11 @@ C: <fooey> fooey
     "a" get "b" get add-gadget
     <gadget> "c" set
     "b" get "c" get add-gadget
-    
+
     ! position a and b
     { 100 200 } "a" get set-rect-loc
     { 200 100 } "b" get set-rect-loc
-    
+
     ! give c a loc, it doesn't matter
     { -1000 23 } "c" get set-rect-loc
 
@@ -108,3 +110,95 @@ C: <fooey> fooey
 { 1 1 } "g4" get set-rect-dim
 
 [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
+
+TUPLE: mock-gadget graft-called ungraft-called ;
+
+: <mock-gadget>
+    0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+
+M: mock-gadget graft*
+    dup mock-gadget-graft-called 1+
+    swap set-mock-gadget-graft-called ;
+
+M: mock-gadget ungraft*
+    dup mock-gadget-ungraft-called 1+
+    swap set-mock-gadget-ungraft-called ;
+
+! We can't print to stdio here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+[
+    <dlist> \ graft-queue [
+        [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+    ] with-variable
+
+    <dlist> \ graft-queue [
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+
+        <mock-gadget> "g" set
+        [ ] [ "g" get queue-graft ] unit-test
+        [ f ] [ graft-queue dlist-empty? ] unit-test
+        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ { f f } ] [ "g" get gadget-status ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ ] [ notify-queued ] unit-test
+        [ { t t } ] [ "g" get gadget-status ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ { t f } ] [ "g" get gadget-status ] unit-test
+        [ ] [ notify-queued ] unit-test
+        [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
+        [ { f f } ] [ "g" get gadget-status ] unit-test
+    ] with-variable
+
+    : add-some-children
+        3 [
+            <mock-gadget> over <model> over set-gadget-model
+            dup "g" get add-gadget
+            swap 1+ number>string set
+        ] each ;
+
+    : status-flags
+        { "g" "1" "2" "3" } [ get gadget-status ] map prune ;
+
+    : notify-combo ( ? ? -- )
+        nl "===== Combo: " write 2dup 2array . nl
+        <dlist> \ graft-queue [
+            <mock-gadget> "g" set
+            [ ] [ add-some-children ] unit-test
+            [ V{ { f f } } ] [ status-flags ] unit-test
+            [ ] [ "g" get graft ] unit-test
+            [ V{ { f t } } ] [ status-flags ] unit-test
+            dup [ [ ] [ notify-queued ] unit-test ] when
+            [ ] [ "g" get clear-gadget ] unit-test
+            [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
+            [ [ ] [ notify-queued ] unit-test ] when
+            [ ] [ add-some-children ] unit-test
+            [ { f t } ] [ "1" get gadget-status ] unit-test
+            [ { f t } ] [ "2" get gadget-status ] unit-test
+            [ { f t } ] [ "3" get gadget-status ] unit-test
+            [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
+            [ ] [ notify-queued ] unit-test
+            [ V{ { t t } } ] [ status-flags ] unit-test
+        ] with-variable ;
+
+    { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
+] string-out print
+
+{ 0 1 } [ <gadget> ] unit-test-effect
+{ 1 0 } [ unparent ] unit-test-effect
+{ 2 0 } [ add-gadget ] unit-test-effect
+{ 2 0 } [ add-gadgets ] unit-test-effect
+{ 1 0 } [ clear-gadget ] unit-test-effect
+
+{ 1 0 } [ relayout ] unit-test-effect
+{ 1 0 } [ relayout-1 ] unit-test-effect
+{ 1 1 } [ pref-dim ] unit-test-effect
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index 526c4864c8..ed5c4b935b 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -42,7 +42,7 @@ M: array rect-dim drop { 0 0 } ;
 
 TUPLE: gadget
 pref-dim parent children orientation state focus
-visible? root? clipped? grafted?
+visible? root? clipped? status
 interior boundary
 model ;
 
@@ -59,10 +59,11 @@ M: gadget model-changed drop ;
 : <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
 
 : <gadget> ( -- gadget )
-    <zero-rect> { 0 1 } t {
+    <zero-rect> { 0 1 } t { f f } {
         set-delegate
         set-gadget-orientation
         set-gadget-visible?
+        set-gadget-status
     } gadget construct ;
 
 : construct-gadget ( class -- tuple )
@@ -173,13 +174,13 @@ M: array gadget-text*
 
 : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
 
-: invalid ( -- queue ) \ invalid get-global ;
+: layout-queue ( -- queue ) \ layout-queue get ;
 
-: add-invalid ( gadget -- )
+: layout-later ( gadget -- )
     #! When unit testing gadgets without the UI running, the
     #! invalid queue is not initialized and we simply ignore
     #! invalidation requests.
-    invalid [ push-front ] [ drop ] if* ;
+    layout-queue [ push-front ] [ drop ] if* ;
 
 DEFER: relayout
 
@@ -187,7 +188,7 @@ DEFER: relayout
     \ invalidate* over set-gadget-state
     dup forget-pref-dim
     dup gadget-root?
-    [ add-invalid ] [ gadget-parent [ relayout ] when* ] if ;
+    [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )
     dup gadget-state \ invalidate* eq?
@@ -195,7 +196,7 @@ DEFER: relayout
 
 : relayout-1 ( gadget -- )
     dup gadget-state
-    [ drop ] [ dup invalidate add-invalid ] if ;
+    [ drop ] [ dup invalidate layout-later ] if ;
 
 : show-gadget t swap set-gadget-visible? ;
 
@@ -241,27 +242,70 @@ M: gadget layout* drop ;
         dup [ layout ] each-child
     ] when drop ;
 
+: graft-queue \ graft-queue get ;
+
+: unqueue-graft ( gadget -- )
+    dup graft-queue dlist-delete [ "Not queued" throw ] unless
+    dup gadget-status first { t t } { f f } ?
+    swap set-gadget-status ;
+
+: queue-graft ( gadget -- )
+    { f t } over set-gadget-status
+    graft-queue push-front ;
+
+: queue-ungraft ( gadget -- )
+    { t f } over set-gadget-status
+    graft-queue push-front ;
+
+: graft-later ( gadget -- )
+    dup gadget-status {
+        { { f t } [ drop ] }
+        { { t t } [ drop ] }
+        { { t f } [ unqueue-graft ] }
+        { { f f } [ queue-graft ] }
+    } case ;
+
+: ungraft-later ( gadget -- )
+    dup gadget-status {
+        { { f f } [ drop ] }
+        { { t f } [ drop ] }
+        { { f t } [ unqueue-graft ] }
+        { { t t } [ queue-ungraft ] }
+    } case ;
+
 GENERIC: graft* ( gadget -- )
 
 M: gadget graft* drop ;
 
+! : graft ( gadget -- )
+!     dup gadget-grafted? [
+!         drop
+!     ] [
+!         t over set-gadget-grafted?
+!         dup graft*
+!         dup activate-control
+!         [ graft ] each-child
+!     ] if ;
+
 : graft ( gadget -- )
-    t over set-gadget-grafted?
-    dup graft*
-    dup activate-control
-    [ graft ] each-child ;
+    dup graft-later [ graft ] each-child ;
 
 GENERIC: ungraft* ( gadget -- )
 
 M: gadget ungraft* drop ;
 
+! : ungraft ( gadget -- )
+!     dup gadget-grafted? [
+!         dup [ ungraft ] each-child
+!         dup deactivate-control
+!         dup ungraft*
+!         f swap set-gadget-grafted?
+!     ] [
+!         drop ! "Fuck you" throw
+!     ] if ;
+
 : ungraft ( gadget -- )
-    dup gadget-grafted? [
-        dup [ ungraft ] each-child
-        dup deactivate-control
-        dup ungraft*
-        f over set-gadget-grafted?
-    ] when drop ;
+    dup [ ungraft ] each-child ungraft-later ;
 
 : (unparent) ( gadget -- )
     dup ungraft
@@ -272,7 +316,14 @@ M: gadget ungraft* drop ;
     tuck gadget-focus eq?
     [ f swap set-gadget-focus ] [ drop ] if ;
 
+SYMBOL: in-layout?
+
+: not-in-layout
+    in-layout? get
+    [ "Cannot add/remove gadgets in layout*" throw ] when ;
+
 : unparent ( gadget -- )
+    not-in-layout
     [
         dup gadget-parent dup [
             over (unparent)
@@ -290,6 +341,7 @@ M: gadget ungraft* drop ;
     f swap set-gadget-children ;
 
 : clear-gadget ( gadget -- )
+    not-in-layout
     dup (clear-gadget) relayout ;
 
 : ((add-gadget)) ( gadget box -- )
@@ -299,12 +351,14 @@ M: gadget ungraft* drop ;
     over unparent
     dup pick set-gadget-parent
     [ ((add-gadget)) ] 2keep
-    gadget-grafted? [ graft ] [ drop ] if ;
+    gadget-status second [ graft ] [ drop ] if ;
 
 : add-gadget ( gadget parent -- )
+    not-in-layout
     [ (add-gadget) ] keep relayout ;
 
 : add-gadgets ( seq parent -- )
+    not-in-layout
     swap [ over (add-gadget) ] each relayout ;
 
 : parents ( gadget -- seq )
diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor
old mode 100644
new mode 100755
index 0e15515750..5f213bc31a
--- a/extra/ui/gadgets/incremental/incremental.factor
+++ b/extra/ui/gadgets/incremental/incremental.factor
@@ -42,6 +42,7 @@ M: incremental pref-dim*
     dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
 
 : add-incremental ( gadget incremental -- )
+    not-in-layout
     2dup (add-gadget)
     over prefer-incremental
     2dup incremental-loc
@@ -50,6 +51,7 @@ M: incremental pref-dim*
     gadget-parent [ invalidate* ] when* ;
 
 : clear-incremental ( incremental -- )
+    not-in-layout
     dup (clear-gadget) dup forget-pref-dim
     { 0 0 } over set-incremental-cursor
     gadget-parent [ relayout ] when* ;
diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor
old mode 100644
new mode 100755
index f9663d8249..248de5e889
--- a/extra/ui/gadgets/panes/panes-tests.factor
+++ b/extra/ui/gadgets/panes/panes-tests.factor
@@ -1,7 +1,8 @@
 IN: temporary
 USING: alien ui.gadgets.panes ui.gadgets namespaces
 kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting ;
+definitions help help.syntax help.markup splitting
+tools.test.ui models ;
 
 : #children "pane" get gadget-children length ;
 
@@ -33,3 +34,7 @@ ARTICLE: "test-article" "This is a test article"
 
 <pane> [ \ = see ] with-pane
 <pane> [ \ = help ] with-pane
+
+[ ] [
+    \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
+] unit-test
diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor
index 8b11c4f8a2..a53cf1fb0e 100755
--- a/extra/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor
@@ -2,7 +2,8 @@ IN: temporary
 USING: ui.gadgets ui.gadgets.scrollers
 namespaces tools.test kernel models ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
-ui.gadgets.sliders math math.vectors arrays sequences ;
+ui.gadgets.sliders math math.vectors arrays sequences
+tools.test.inference tools.test.ui ;
 
 [ ] [
     <gadget> "g" set
@@ -20,12 +21,14 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
 [ ] [
     <gadget> dup "g" set
     10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
-    <viewport> "v" set 
+    <viewport> "v" set
 ] unit-test
 
-[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
+"v" get [
+    [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+    [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
 
 [ ] [
     <gadget> { 100 100 } over set-rect-dim
@@ -36,27 +39,25 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
 
 [ ] [ "s" get layout ] unit-test
 
-[ ] [ "s" get graft ] unit-test
+"s" get [
+    [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
 
-[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
+    [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
 
-[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
+    [ ] [ { 0 0 } "s" get scroll ] unit-test
 
-[ ] [ { 0 0 } "s" get scroll ] unit-test
+    [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
 
-[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
+    [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
 
-[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
+    [ ] [ { 10 20 } "s" get scroll ] unit-test
 
-[ ] [ { 10 20 } "s" get scroll ] unit-test
+    [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
+    [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
-
-[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-
-[ ] [ "s" get ungraft ] unit-test
+    [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
 
 <gadget> { 600 400 } over set-rect-dim "g1" set
 <gadget> { 600 10 } over set-rect-dim "g2" set
@@ -84,3 +85,5 @@ dup layout
 [ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
 [ t ] [ "s" get @right grid-child slider? ] unit-test
 [ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+
+{ 1 1 } [ <scroller> ] unit-test-effect
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index b6c3f263cd..83f8edc70e 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -28,7 +28,7 @@ scroller H{
     { T{ mouse-scroll } [ do-mouse-scroll ] }
 } set-gestures
 
-: viewport, ( -- )
+: viewport, ( child -- )
     g gadget-model <viewport>
     g-> set-scroller-viewport @center frame, ;
 
@@ -106,7 +106,7 @@ scroller H{
     dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
 
 : scroll>bottom ( gadget -- )
-    find-scroller* [
+    find-scroller [
         t over set-scroller-follows relayout-1
     ] when* ;
 
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor
index 4c558ad8c9..0d5c587a54 100755
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@@ -131,7 +131,7 @@ M: elevator layout*
 : slide-by-line ( amount slider -- )
     [ slider-line * ] keep slide-by ;
 
-: <slide-button> ( vector polygon amount -- )
+: <slide-button> ( vector polygon amount -- button )
     >r gray swap <polygon-gadget> r>
     [ swap find-slider slide-by-line ] curry <repeat-button>
     [ set-gadget-orientation ] keep ;
@@ -144,7 +144,7 @@ M: elevator layout*
 : <left-button> { 0 1 } arrow-left -1 <slide-button> ;
 : <right-button> { 0 1 } arrow-right 1 <slide-button> ;
 
-: build-x-slider ( slider -- slider )
+: build-x-slider ( slider -- )
     [
         <left-button> @left frame,
         { 0 1 } elevator,
@@ -154,7 +154,7 @@ M: elevator layout*
 : <up-button> { 1 0 } arrow-up -1 <slide-button> ;
 : <down-button> { 1 0 } arrow-down 1 <slide-button> ;
 
-: build-y-slider ( slider -- slider )
+: build-y-slider ( slider -- )
     [
         <up-button> @top frame,
         { 1 0 } elevator,
diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor
index b5dc2da337..e879f32a02 100755
--- a/extra/ui/gadgets/viewports/viewports.factor
+++ b/extra/ui/gadgets/viewports/viewports.factor
@@ -16,8 +16,7 @@ TUPLE: viewport ;
 : <viewport> ( content model -- viewport )
     <gadget> viewport construct-control
     t over set-gadget-clipped?
-    [ add-gadget ] keep
-    [ model-changed ] keep ;
+    [ add-gadget ] keep ;
 
 M: viewport layout*
     dup rect-dim viewport-gap 2 v*n v-
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
old mode 100644
new mode 100755
index 2f5a5a17e9..fc0e78a61c
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -112,12 +112,6 @@ world H{
     { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
 } set-gestures
 
-: start-world ( world -- )
-    dup graft
-    dup relayout
-    dup world-title over set-title
-    request-focus ;
-
 : close-global ( world global -- )
     dup get-global find-world rot eq?
     [ f swap set-global ] [ drop ] if ;
@@ -126,3 +120,8 @@ world H{
     drop-prefix <reversed>
     T{ lose-focus } swap each-gesture
     T{ gain-focus } swap each-gesture ;
+
+M: world graft*
+    dup (open-world-window)
+    dup world-title over set-title
+    request-focus ;
diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor
old mode 100644
new mode 100755
index b0479c7c29..3c5ad22e30
--- a/extra/ui/render/render-docs.factor
+++ b/extra/ui/render/render-docs.factor
@@ -13,9 +13,9 @@ HELP: gadget
         { { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
         { { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
         { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
-        { { $link gadget-grafted? } " - if set to " { $link t } ", the gadget is parented in a native window." }
         { { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
         { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+        { { $link gadget-model } " - XXX" }
     }
 "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
 { $notes
diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor
new file mode 100755
index 0000000000..5a343919e7
--- /dev/null
+++ b/extra/ui/tools/browser/browser-tests.factor
@@ -0,0 +1,6 @@
+IN: temporary
+USING: tools.test tools.test.ui ui.tools.browser
+tools.test.inference ;
+
+{ 0 1 } [ <browser-gadget> ] unit-test-effect
+[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor
index 5c1335ce9a..4e59fd63ee 100755
--- a/extra/ui/tools/listener/listener-tests.factor
+++ b/extra/ui/tools/listener/listener-tests.factor
@@ -1,35 +1,39 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words ;
+ui.gadgets.panes vocabs words tools.test.ui ;
 IN: temporary
 
 timers [ init-timers ] unless
 
 [ f ] [ "word" source-editor command-map empty? ] unit-test
 
-<listener-gadget> "listener" set
+[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
 
-{ "kernel" } [ vocab-words ] map use associate
-"listener" get listener-gadget-input set-interactor-vars
+[ ] [ <listener-gadget> "listener" set ] unit-test
 
-[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
+"listener" get [
+    { "kernel" } [ vocab-words ] map use associate
+    "listener" get listener-gadget-input set-interactor-vars
 
-[ "USE: words word-name" ]
-[ \ word-name "listener" get word-completion-string ] unit-test
+    [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
 
-<pane> <interactor> "i" set
-H{ } "i" get set-interactor-vars
+    [ "USE: words word-name" ]
+    [ \ word-name "listener" get word-completion-string ] unit-test
 
-[ t ] [ "i" get interactor? ] unit-test
+    <pane> <interactor> "i" set
+    H{ } "i" get set-interactor-vars
 
-[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
+    [ t ] [ "i" get interactor? ] unit-test
 
-[ ] [
-    "i" get [ "SYMBOL:" parse ] catch go-to-error
-] unit-test
+    [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
 
-[ t ] [
-    "i" get gadget-model doc-end
-    "i" get editor-caret* =
-] unit-test
+    [ ] [
+        "i" get [ "SYMBOL:" parse ] catch go-to-error
+    ] unit-test
+
+    [ t ] [
+        "i" get gadget-model doc-end
+        "i" get editor-caret* =
+    ] unit-test
+] with-grafted-gadget
diff --git a/extra/ui/tools/search/search-tests.factor b/extra/ui/tools/search/search-tests.factor
index fe3203b57e..47ae786f59 100755
--- a/extra/ui/tools/search/search-tests.factor
+++ b/extra/ui/tools/search/search-tests.factor
@@ -1,7 +1,7 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
 tools.test ui.gadgets ui.gestures vocabs
-vocabs.loader words ;
+vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 
 timers get [ init-timers ] unless
@@ -12,12 +12,16 @@ timers get [ init-timers ] unless
     T{ key-down f { C+ } "x" } swap search-gesture
 ] unit-test
 
+: assert-non-empty empty? f assert= ;
+
+: update-live-search ( search -- seq )
+    dup [
+        300 sleep do-timers
+        live-search-list control-value
+    ] with-grafted-gadget ;
+
 : test-live-search ( gadget quot -- ? )
-    >r dup graft 300 sleep do-timers
-    dup live-search-list control-value
-    dup empty? [ "Empty" throw ] when
-    r> all?
-    >r ungraft r> ;
+   >r update-live-search dup assert-non-empty r> all? ;
 
 [ t ] [
     "swp" all-words f <definition-search>
@@ -26,11 +30,12 @@ timers get [ init-timers ] unless
 
 [ t ] [
     "" all-words t <definition-search>
-    dup graft
-    { "set-word-prop" } over live-search-field set-control-value
-    300 sleep
-    do-timers
-    search-value \ set-word-prop eq?
+    dup [
+        { "set-word-prop" } over live-search-field set-control-value
+        300 sleep
+        do-timers
+        search-value \ set-word-prop eq?
+    ] with-grafted-gadget
 ] unit-test
 
 [ t ] [
diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor
index 8333392659..919d1705af 100755
--- a/extra/ui/tools/tools-tests.factor
+++ b/extra/ui/tools/tools-tests.factor
@@ -2,14 +2,14 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs ;
+ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: temporary
 
 [
     [ f ] [
         0 <model> <gadget> [ set-gadget-model ] keep gadget set
         <workspace-tabs> gadget-children empty?
-    ] unit-test 
+    ] unit-test
 ] with-scope
 
 timers get [ init-timers ] unless
@@ -31,24 +31,29 @@ timers get [ init-timers ] unless
     "w" get hide-popup
 ] unit-test
 
-[ ] [
-    <workspace> "w" set
-    "w" get graft
-    "w" get "kernel" vocab show-vocab-words
-] unit-test
+[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
 
-"w" get workspace-popup closable-gadget-content
-live-search-list gadget-child "p" set
+"w" get [
 
-[ t ] [ "p" get presentation? ] unit-test
+    [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
 
-"p" get <operations-menu> gadget-child gadget-child "c" set
+    [ ] [ notify-queued ] unit-test
 
-[ t ] [ "c" get button? ] unit-test
+    [ ] [ "w" get workspace-popup closable-gadget-content
+    live-search-list gadget-child "p" set ] unit-test
 
-[ ] [
-    "w" get workspace-listener listener-gadget-input
-    3 handle-parse-error
-] unit-test
+    [ t ] [ "p" get presentation? ] unit-test
 
-[ ] [ "w" get ungraft ] unit-test
+    [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
+
+    [ ] [ notify-queued ] unit-test
+
+    [ t ] [ "c" get button? ] unit-test
+
+    [ ] [
+        "w" get workspace-listener listener-gadget-input
+        3 handle-parse-error
+    ] unit-test
+
+    [ ] [ notify-queued ] unit-test
+] with-grafted-gadget
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index 9a9a155236..3b161c1d28 100755
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -12,15 +12,6 @@ vocabs.loader tools.test ui.gadgets.buttons
 ui.gadgets.status-bar mirrors ;
 IN: ui.tools
 
-: workspace-tabs ( -- seq )
-    {
-        <stack-display>
-        <browser-gadget>
-        <inspector-gadget>
-        <walker>
-        <profiler-gadget>
-    } ;
-
 : <workspace-tabs> ( -- tabs )
     g gadget-model
     "tool-switching" workspace command-map
@@ -28,7 +19,13 @@ IN: ui.tools
     <toggle-buttons> ;
 
 : <workspace-book> ( -- gadget )
-    workspace-tabs [ execute ] map g gadget-model <book> ;
+    [
+        <stack-display> ,
+        <browser-gadget> ,
+        <inspector-gadget> ,
+        <walker> ,
+        <profiler-gadget> ,
+    ] { } make g gadget-model <book> ;
 
 : <workspace> ( -- workspace )
     0 <model> { 0 1 } <track> workspace construct-control [
diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor
index 9979dd2df2..2a7dfe654c 100755
--- a/extra/ui/tools/traceback/traceback.factor
+++ b/extra/ui/tools/traceback/traceback.factor
@@ -5,15 +5,15 @@ ui.commands ui.gadgets ui.gadgets.labelled
 ui.gadgets.tracks ui.gestures ;
 IN: ui.tools.traceback
 
-: <callstack-display> ( model -- )
+: <callstack-display> ( model -- gadget )
     [ [ continuation-call callstack. ] when* ]
     "Call stack" <labelled-pane> ;
 
-: <datastack-display> ( model -- )
+: <datastack-display> ( model -- gadget )
     [ [ continuation-data stack. ] when* ]
     "Data stack" <labelled-pane> ;
 
-: <retainstack-display> ( model -- )
+: <retainstack-display> ( model -- gadget )
     [ [ continuation-retain stack. ] when* ]
     "Retain stack" <labelled-pane> ;
 
diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor
new file mode 100755
index 0000000000..957f38ca26
--- /dev/null
+++ b/extra/ui/tools/workspace/workspace-tests.factor
@@ -0,0 +1,4 @@
+IN: temporary
+USING: tools.test tools.test.inference ui.tools ;
+
+{ 0 1 } [ <workspace> ] unit-test-effect
diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor
old mode 100644
new mode 100755
index e9e3a05d62..231682ce6e
--- a/extra/ui/ui-docs.factor
+++ b/extra/ui/ui-docs.factor
@@ -18,11 +18,6 @@ HELP: find-window
 { $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
 { $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
 
-HELP: start-world
-{ $values { "world" world } }
-{ $description "Starts a world." }
-{ $notes "This word should be called by the UI backend after " { $link register-window } ", but before making the world's containing window visible on the screen." } ;
-
 HELP: register-window
 { $values { "world" world } { "handle" "a baackend-specific handle" } }
 { $description "Adds a window to the global " { $link windows } " variable." }
@@ -174,7 +169,6 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
 { $subsection open-world-window }
 "This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
 { $subsection register-window }
-{ $subsection start-world }
 "The following words must also be implemented:"
 { $subsection set-title }
 { $subsection raise-window }
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
old mode 100644
new mode 100755
index fc5777ab6a..810ccacf80
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -3,7 +3,8 @@
 USING: arrays assocs io kernel math models namespaces
 prettyprint dlists sequences threads sequences words timers
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init ;
+ui.gestures ui.backend ui.render continuations init
+combinators ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -53,25 +54,23 @@ SYMBOL: windows
     reset-world ;
 
 : open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim
-    dup (open-world-window)
-    draw-world ;
+    dup pref-dim over set-gadget-dim dup relayout graft ;
 
 : open-window ( gadget title -- )
     >r [ 1 track, ] { 0 1 } make-track r>
     f <world> open-world-window ;
 
 : find-window ( quot -- world )
-    windows get 1 <column>
+    windows get values
     [ gadget-child swap call ] curry* find-last nip ; inline
 
 : restore-windows ( -- )
-    windows get [ 1 <column> >array ] keep delete-all
+    windows get [ values ] keep delete-all
     [ dup reset-world (open-world-window) ] each
     forget-rollover ;
 
 : restore-windows? ( -- ? )
-    windows get [ empty? not ] [ f ] if* ;
+    windows get empty? not ;
 
 : update-hand ( world -- )
     dup hand-world get-global eq?
@@ -79,7 +78,8 @@ SYMBOL: windows
 
 : layout-queued ( -- seq )
     [
-        invalid [
+        in-layout? on
+        layout-queue [
             dup layout find-world [ , ] when*
         ] dlist-slurp
     ] { } make ;
@@ -87,24 +87,40 @@ SYMBOL: windows
 SYMBOL: ui-hook
 
 : init-ui ( -- )
-    <dlist> \ invalid set-global
+    <dlist> \ graft-queue set-global
+    <dlist> \ layout-queue set-global
     V{ } clone windows set-global ;
 
+: redraw-worlds ( seq -- )
+    [ dup update-hand draw-world ] each ;
+
+: notify ( gadget -- )
+    dup gadget-status {
+        { { f t } [ dup activate-control dup graft* ] }
+        { { t f } [ dup activate-control dup ungraft* ] }
+    } case
+    dup gadget-status first { f f } { t t } ?
+    swap set-gadget-status ;
+
+: notify-queued ( -- )
+    graft-queue [ notify ] dlist-slurp ;
+
+: ui-step ( -- )
+    [
+        do-timers
+        notify-queued
+        layout-queued
+        redraw-worlds
+        10 sleep
+    ] assert-depth ;
+
 : start-ui ( -- )
     init-timers
     restore-windows? [
         restore-windows
     ] [
         init-ui ui-hook get call
-    ] if ;
-
-: redraw-worlds ( seq -- )
-    [ dup update-hand draw-world ] each ;
-
-: ui-step ( -- )
-    [
-        do-timers layout-queued redraw-worlds 10 sleep
-    ] assert-depth ;
+    ] if ui-step ;
 
 : ui-running ( quot -- )
     t \ ui-running set-global
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 6b19085a1c..7c1b578981 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -340,17 +340,23 @@ SYMBOL: hWnd
         ] ui-try
      ] alien-callback ;
 
-: do-events ( -- )
-    msg-obj get f 0 0 PM_REMOVE PeekMessage 
-    zero? not [
-        msg-obj get MSG-message WM_QUIT = [
-            msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
-        ] unless
-    ] when ;
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+
+: do-events ( msg -- )
+    {
+        { [ windows get empty? ] [ drop ] }
+        { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] }
+        { [ dup MSG-message WM_QUIT = ] [ drop ] }
+        { [ t ] [
+            dup TranslateMessage drop
+            dup DispatchMessage drop
+            do-events
+        ] }
+    } cond ;
 
 : event-loop ( -- )
     windows get empty? [
-        [ do-events ui-step ] ui-try event-loop
+        msg-obj get do-events
     ] unless ;
 
 : register-wndclassex ( -- class )
@@ -414,8 +420,8 @@ M: windows-ui-backend (open-world-window) ( world -- )
     [ rect-dim first2 create-window dup setup-gl ] keep
     [ f <win> ] keep
     [ swap win-hWnd register-window ] 2keep
-    [ set-world-handle ] 2keep 
-    start-world win-hWnd show-window ;
+    dupd set-world-handle
+    win-hWnd show-window ;
 
 M: windows-ui-backend select-gl-context ( handle -- )
     [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
old mode 100644
new mode 100755
index fe0f1fa9eb..165989d86a
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -224,7 +224,6 @@ M: x11-ui-backend set-title ( string world -- )
 
 M: x11-ui-backend (open-world-window) ( world -- )
     dup gadget-window
-    dup start-world
     world-handle x11-handle-window dup set-closable map-window ;
 
 M: x11-ui-backend raise-window ( world -- )

From 9d7b1ac4dcaba406f810acce622cda436d62ece0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 01:43:29 -0500
Subject: [PATCH 08/23] Tweak alien.compiler

---
 core/alien/compiler/compiler.factor | 49 +++++++++++++----------------
 1 file changed, 21 insertions(+), 28 deletions(-)

diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 9c686bd4aa..7e0165cd64 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -196,31 +196,9 @@ M: alien-invoke alien-node-abi
     alien-invoke-library library
     [ library-abi ] [ "cdecl" ] if* ;
 
-: stdcall-mangle ( symbol node -- symbol )
-    "@"
-    swap alien-node-parameters parameter-sizes drop
-    number>string 3append ;
-
-: (alien-invoke-dlsym) ( node -- symbol dll )
-    dup alien-invoke-function
-    swap alien-invoke-library load-library ;
-
-TUPLE: no-such-symbol ;
-
-M: no-such-symbol summary
-    drop "Symbol not found" ;
-
-: no-such-symbol ( -- )
-    \ no-such-symbol inference-error ;
-
-: alien-invoke-dlsym ( node -- symbol dll )
-    dup (alien-invoke-dlsym) 2dup dlsym [
-        >r over stdcall-mangle r> 2dup dlsym
-        [ no-such-symbol ] unless
-    ] unless rot drop ;
-
 M: alien-invoke-error summary
-    drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
+    drop
+    "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
 
 : pop-parameters pop-literal nip [ expand-constants ] map ;
 
@@ -235,14 +213,29 @@ M: alien-invoke-error summary
     pop-literal nip over set-alien-invoke-return
     ! Quotation which coerces parameters to required types
     dup make-prep-quot recursive-state get infer-quot
-    ! If symbol doesn't resolve, no stack effect, no compile
-    dup alien-invoke-dlsym 2drop
     ! Add node to IR
     dup node,
     ! Magic #: consume exactly the number of inputs
     0 alien-invoke-stack
 ] "infer" set-word-prop
 
+: stdcall-mangle ( symbol node -- symbol )
+    "@"
+    swap alien-node-parameters parameter-sizes drop
+    number>string 3append ;
+
+: (alien-invoke-dlsym) ( node -- symbol dll )
+    dup alien-invoke-function
+    swap alien-invoke-library load-library ;
+
+: alien-invoke-dlsym ( node -- symbol dll )
+    dup (alien-invoke-dlsym)
+    >r over stdcall-mangle r> 2dup dlsym [
+        rot drop
+    ] [
+        2drop (alien-invoke-dlsym)
+    ] if ;
+
 M: alien-invoke generate-node
     dup alien-invoke-frame [
         end-basic-block
@@ -260,7 +253,7 @@ M: alien-indirect alien-node-return alien-indirect-return ;
 M: alien-indirect alien-node-abi alien-indirect-abi ;
 
 M: alien-indirect-error summary
-    drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ;
+    drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
 
 \ alien-indirect [
     ! Three literals and function pointer
@@ -309,7 +302,7 @@ M: alien-callback alien-node-return alien-callback-return ;
 M: alien-callback alien-node-abi alien-callback-abi ;
 
 M: alien-callback-error summary
-    drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
+    drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 
 : callback-bottom ( node -- )
     alien-callback-xt [ word-xt <alien> ] curry

From d6cf56162fc503936181f1fe8a880aef26f59341 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 01:54:13 -0500
Subject: [PATCH 09/23] UI fixes

---
 extra/ui/gadgets/editors/editors.factor       |  2 +-
 extra/ui/gadgets/gadgets-tests.factor         | 20 +++----
 extra/ui/gadgets/gadgets.factor               | 55 ++++++-------------
 .../ui/gadgets/incremental/incremental.factor |  2 +-
 extra/ui/render/render-docs.factor            |  2 +-
 extra/ui/ui.factor                            |  6 +-
 extra/ui/windows/windows.factor               | 13 ++---
 7 files changed, 38 insertions(+), 62 deletions(-)

diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index 2221cb2bfd..4250744ea5 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -128,7 +128,7 @@ M: editor model-changed
     line-height 0 swap 2array ;
 
 : scroll>caret ( editor -- )
-    dup gadget-status second [
+    dup gadget-graft-state second [
         dup caret-loc over caret-dim { 1 0 } v+ <rect>
         over scroll>rect
     ] when drop ;
diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor
index a5a5b36a1b..48bb3718cb 100755
--- a/extra/ui/gadgets/gadgets-tests.factor
+++ b/extra/ui/gadgets/gadgets-tests.factor
@@ -139,24 +139,24 @@ M: mock-gadget ungraft*
         <mock-gadget> "g" set
         [ ] [ "g" get queue-graft ] unit-test
         [ f ] [ graft-queue dlist-empty? ] unit-test
-        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ { f t } ] [ "g" get gadget-graft-state ] unit-test
         [ ] [ "g" get graft-later ] unit-test
-        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ { f t } ] [ "g" get gadget-graft-state ] unit-test
         [ ] [ "g" get ungraft-later ] unit-test
-        [ { f f } ] [ "g" get gadget-status ] unit-test
+        [ { f f } ] [ "g" get gadget-graft-state ] unit-test
         [ t ] [ graft-queue dlist-empty? ] unit-test
         [ ] [ "g" get ungraft-later ] unit-test
         [ ] [ "g" get graft-later ] unit-test
         [ ] [ notify-queued ] unit-test
-        [ { t t } ] [ "g" get gadget-status ] unit-test
+        [ { t t } ] [ "g" get gadget-graft-state ] unit-test
         [ t ] [ graft-queue dlist-empty? ] unit-test
         [ ] [ "g" get graft-later ] unit-test
         [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
         [ ] [ "g" get ungraft-later ] unit-test
-        [ { t f } ] [ "g" get gadget-status ] unit-test
+        [ { t f } ] [ "g" get gadget-graft-state ] unit-test
         [ ] [ notify-queued ] unit-test
         [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
-        [ { f f } ] [ "g" get gadget-status ] unit-test
+        [ { f f } ] [ "g" get gadget-graft-state ] unit-test
     ] with-variable
 
     : add-some-children
@@ -167,7 +167,7 @@ M: mock-gadget ungraft*
         ] each ;
 
     : status-flags
-        { "g" "1" "2" "3" } [ get gadget-status ] map prune ;
+        { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
 
     : notify-combo ( ? ? -- )
         nl "===== Combo: " write 2dup 2array . nl
@@ -182,9 +182,9 @@ M: mock-gadget ungraft*
             [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
             [ [ ] [ notify-queued ] unit-test ] when
             [ ] [ add-some-children ] unit-test
-            [ { f t } ] [ "1" get gadget-status ] unit-test
-            [ { f t } ] [ "2" get gadget-status ] unit-test
-            [ { f t } ] [ "3" get gadget-status ] unit-test
+            [ { f t } ] [ "1" get gadget-graft-state ] unit-test
+            [ { f t } ] [ "2" get gadget-graft-state ] unit-test
+            [ { f t } ] [ "3" get gadget-graft-state ] unit-test
             [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
             [ ] [ notify-queued ] unit-test
             [ V{ { t t } } ] [ status-flags ] unit-test
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index ed5c4b935b..fc28d16fdc 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -41,8 +41,8 @@ M: array rect-dim drop { 0 0 } ;
     (rect-union) <extent-rect> ;
 
 TUPLE: gadget
-pref-dim parent children orientation state focus
-visible? root? clipped? status
+pref-dim parent children orientation focus
+visible? root? clipped? layout-state graft-state
 interior boundary
 model ;
 
@@ -63,7 +63,7 @@ M: gadget model-changed drop ;
         set-delegate
         set-gadget-orientation
         set-gadget-visible?
-        set-gadget-status
+        set-gadget-graft-state
     } gadget construct ;
 
 : construct-gadget ( class -- tuple )
@@ -170,7 +170,7 @@ M: array gadget-text*
 : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
 
 : invalidate ( gadget -- )
-    \ invalidate swap set-gadget-state ;
+    \ invalidate swap set-gadget-layout-state ;
 
 : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
 
@@ -185,17 +185,17 @@ M: array gadget-text*
 DEFER: relayout
 
 : invalidate* ( gadget -- )
-    \ invalidate* over set-gadget-state
+    \ invalidate* over set-gadget-layout-state
     dup forget-pref-dim
     dup gadget-root?
     [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )
-    dup gadget-state \ invalidate* eq?
+    dup gadget-layout-state \ invalidate* eq?
     [ drop ] [ invalidate* ] if ;
 
 : relayout-1 ( gadget -- )
-    dup gadget-state
+    dup gadget-layout-state
     [ drop ] [ dup invalidate layout-later ] if ;
 
 : show-gadget t swap set-gadget-visible? ;
@@ -216,7 +216,8 @@ DEFER: relayout
 GENERIC: pref-dim* ( gadget -- dim )
 
 : ?set-gadget-pref-dim ( dim gadget -- )
-    dup gadget-state [ 2drop ] [ set-gadget-pref-dim ] if ;
+    dup gadget-layout-state
+    [ 2drop ] [ set-gadget-pref-dim ] if ;
 
 : pref-dim ( gadget -- dim )
     dup gadget-pref-dim [ ] [
@@ -233,10 +234,10 @@ M: gadget layout* drop ;
 
 : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
 
-: validate ( gadget -- ) f swap set-gadget-state ;
+: validate ( gadget -- ) f swap set-gadget-layout-state ;
 
 : layout ( gadget -- )
-    dup gadget-state [
+    dup gadget-layout-state [
         dup validate
         dup layout*
         dup [ layout ] each-child
@@ -246,19 +247,19 @@ M: gadget layout* drop ;
 
 : unqueue-graft ( gadget -- )
     dup graft-queue dlist-delete [ "Not queued" throw ] unless
-    dup gadget-status first { t t } { f f } ?
-    swap set-gadget-status ;
+    dup gadget-graft-state first { t t } { f f } ?
+    swap set-gadget-graft-state ;
 
 : queue-graft ( gadget -- )
-    { f t } over set-gadget-status
+    { f t } over set-gadget-graft-state
     graft-queue push-front ;
 
 : queue-ungraft ( gadget -- )
-    { t f } over set-gadget-status
+    { t f } over set-gadget-graft-state
     graft-queue push-front ;
 
 : graft-later ( gadget -- )
-    dup gadget-status {
+    dup gadget-graft-state {
         { { f t } [ drop ] }
         { { t t } [ drop ] }
         { { t f } [ unqueue-graft ] }
@@ -266,7 +267,7 @@ M: gadget layout* drop ;
     } case ;
 
 : ungraft-later ( gadget -- )
-    dup gadget-status {
+    dup gadget-graft-state {
         { { f f } [ drop ] }
         { { t f } [ drop ] }
         { { f t } [ unqueue-graft ] }
@@ -277,16 +278,6 @@ GENERIC: graft* ( gadget -- )
 
 M: gadget graft* drop ;
 
-! : graft ( gadget -- )
-!     dup gadget-grafted? [
-!         drop
-!     ] [
-!         t over set-gadget-grafted?
-!         dup graft*
-!         dup activate-control
-!         [ graft ] each-child
-!     ] if ;
-
 : graft ( gadget -- )
     dup graft-later [ graft ] each-child ;
 
@@ -294,16 +285,6 @@ GENERIC: ungraft* ( gadget -- )
 
 M: gadget ungraft* drop ;
 
-! : ungraft ( gadget -- )
-!     dup gadget-grafted? [
-!         dup [ ungraft ] each-child
-!         dup deactivate-control
-!         dup ungraft*
-!         f swap set-gadget-grafted?
-!     ] [
-!         drop ! "Fuck you" throw
-!     ] if ;
-
 : ungraft ( gadget -- )
     dup [ ungraft ] each-child ungraft-later ;
 
@@ -351,7 +332,7 @@ SYMBOL: in-layout?
     over unparent
     dup pick set-gadget-parent
     [ ((add-gadget)) ] 2keep
-    gadget-status second [ graft ] [ drop ] if ;
+    gadget-graft-state second [ graft ] [ drop ] if ;
 
 : add-gadget ( gadget parent -- )
     not-in-layout
diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor
index 5f213bc31a..2cd2c3d13c 100755
--- a/extra/ui/gadgets/incremental/incremental.factor
+++ b/extra/ui/gadgets/incremental/incremental.factor
@@ -21,7 +21,7 @@ TUPLE: incremental cursor ;
     dup delegate pref-dim over set-incremental-cursor ;
 
 M: incremental pref-dim*
-    dup gadget-state [
+    dup gadget-layout-state [
         dup delegate pref-dim over set-incremental-cursor
     ] when incremental-cursor ;
 
diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor
index 3c5ad22e30..2f82d983cc 100755
--- a/extra/ui/render/render-docs.factor
+++ b/extra/ui/render/render-docs.factor
@@ -9,7 +9,7 @@ HELP: gadget
         { { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
         { { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
         { { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." }
-        { { $link gadget-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+        { { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
         { { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
         { { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
         { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
index 810ccacf80..4d2101997e 100755
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -95,12 +95,12 @@ SYMBOL: ui-hook
     [ dup update-hand draw-world ] each ;
 
 : notify ( gadget -- )
-    dup gadget-status {
+    dup gadget-graft-state {
         { { f t } [ dup activate-control dup graft* ] }
         { { t f } [ dup activate-control dup ungraft* ] }
     } case
-    dup gadget-status first { f f } { t t } ?
-    swap set-gadget-status ;
+    dup gadget-graft-state first { f f } { t t } ?
+    swap set-gadget-graft-state ;
 
 : notify-queued ( -- )
     graft-queue [ notify ] dlist-slurp ;
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 7c1b578981..cd77dc0a98 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -342,23 +342,18 @@ SYMBOL: hWnd
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 
-: do-events ( msg -- )
+: event-loop ( msg -- )
     {
         { [ windows get empty? ] [ drop ] }
-        { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] }
+        { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] }
         { [ dup MSG-message WM_QUIT = ] [ drop ] }
         { [ t ] [
             dup TranslateMessage drop
             dup DispatchMessage drop
-            do-events
+            event-loop
         ] }
     } cond ;
 
-: event-loop ( -- )
-    windows get empty? [
-        msg-obj get do-events
-    ] unless ;
-
 : register-wndclassex ( -- class )
     "WNDCLASSEX" <c-object>
     f GetModuleHandle
@@ -448,7 +443,7 @@ M: windows-ui-backend ui
             init-clipboard
             init-win32-ui
             start-ui
-            event-loop
+            msg-obj get event-loop
         ] [ cleanup-win32-ui ] [ ] cleanup
     ] ui-running ;
 

From 57893118e066536decc093101714a1538e45e551 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 03:01:45 -0500
Subject: [PATCH 10/23] Clean up model-changed; no need for auxilliary tuples
 in editor and interactor

---
 extra/color-picker/color-picker.factor        |  2 +-
 extra/models/models-tests.factor              |  2 +-
 extra/models/models.factor                    | 52 +++++++++++------
 extra/ui/gadgets/books/books-tests.factor     |  4 ++
 extra/ui/gadgets/books/books.factor           |  7 +--
 extra/ui/gadgets/buttons/buttons.factor       |  4 +-
 extra/ui/gadgets/editors/editors-docs.factor  |  3 -
 extra/ui/gadgets/editors/editors-tests.factor | 40 ++++++-------
 extra/ui/gadgets/editors/editors.factor       | 55 +++++++++---------
 extra/ui/gadgets/gadgets.factor               |  4 +-
 .../ui/gadgets/incremental/incremental.factor | 15 +++--
 extra/ui/gadgets/labels/labels.factor         |  2 +-
 extra/ui/gadgets/lists/lists.factor           |  1 +
 extra/ui/gadgets/panes/panes.factor           |  2 +-
 extra/ui/gadgets/scrollers/scrollers.factor   |  2 +-
 extra/ui/gadgets/sliders/sliders.factor       |  2 +-
 extra/ui/gadgets/viewports/viewports.factor   |  1 +
 .../tools/interactor/interactor-tests.factor  |  4 ++
 extra/ui/tools/interactor/interactor.factor   | 24 ++++----
 extra/ui/tools/tools.factor                   |  1 +
 extra/ui/tools/walker/walker-tests.factor     | 57 ++++++++++---------
 extra/ui/tools/walker/walker.factor           |  5 +-
 22 files changed, 158 insertions(+), 131 deletions(-)
 mode change 100644 => 100755 extra/models/models-tests.factor
 mode change 100644 => 100755 extra/models/models.factor
 create mode 100755 extra/ui/gadgets/books/books-tests.factor
 create mode 100755 extra/ui/tools/interactor/interactor-tests.factor
 mode change 100644 => 100755 extra/ui/tools/walker/walker-tests.factor

diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index d8a18a6a8e..647c83d667 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -18,7 +18,7 @@ TUPLE: color-preview ;
     { 100 100 } over set-rect-dim ;
 
 M: color-preview model-changed
-    dup control-value over set-gadget-interior relayout-1 ;
+    swap model-value over set-gadget-interior relayout-1 ;
 
 : <color-model> ( model -- model )
     [ [ 256 /f ] map 1 add <solid> ] <filter> ;
diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor
old mode 100644
new mode 100755
index e47e1a66c3..ea615d2f9a
--- a/extra/models/models-tests.factor
+++ b/extra/models/models-tests.factor
@@ -6,7 +6,7 @@ TUPLE: model-tester hit? ;
 
 : <model-tester> model-tester construct-empty ;
 
-M: model-tester model-changed t swap set-model-tester-hit? ;
+M: model-tester model-changed nip t swap set-model-tester-hit? ;
 
 [ T{ model-tester f t } ]
 [
diff --git a/extra/models/models.factor b/extra/models/models.factor
old mode 100644
new mode 100755
index d76269eaf0..9c9ddd13e0
--- a/extra/models/models.factor
+++ b/extra/models/models.factor
@@ -3,10 +3,10 @@
 USING: generic kernel math sequences timers arrays assocs ;
 IN: models
 
-TUPLE: model value connections dependencies ref ;
+TUPLE: model value connections dependencies ref locked? ;
 
 : <model> ( value -- model )
-    V{ } clone V{ } clone 0 model construct-boa ;
+    V{ } clone V{ } clone 0 f model construct-boa ;
 
 M: model equal? 2drop f ;
 
@@ -49,7 +49,7 @@ DEFER: remove-connection
         drop
     ] if ;
 
-GENERIC: model-changed ( observer -- )
+GENERIC: model-changed ( model observer -- )
 
 : add-connection ( observer model -- )
     dup model-connections empty? [ dup activate-model ] when
@@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- )
     dup model-connections empty? [ dup deactivate-model ] when
     drop ;
 
-GENERIC: set-model ( value model -- )
+: with-locked-model ( model quot -- )
+    swap
+    t over set-model-locked?
+    slip
+    f swap set-model-locked? ; inline
 
-M: model set-model
-    [ set-model-value ] keep
-    model-connections [ model-changed ] each ;
+GENERIC: update-model ( model -- )
+
+M: model update-model drop ;
+
+: set-model ( value model -- )
+    dup model-locked? [
+        2drop
+    ] [
+        dup [
+            [ set-model-value ] keep
+            [ update-model ] keep
+            dup model-connections [ model-changed ] curry* each
+        ] with-locked-model
+    ] if ;
 
 : ((change-model)) ( model quot -- newvalue model )
     over >r >r model-value r> call r> ; inline
@@ -87,10 +102,10 @@ TUPLE: filter model quot ;
     [ add-dependency ] keep ;
 
 M: filter model-changed
-    dup filter-model model-value over filter-quot call
+    swap model-value over filter-quot call
     swap set-model ;
 
-M: filter model-activated model-changed ;
+M: filter model-activated dup filter-model swap model-changed ;
 
 TUPLE: compose ;
 
@@ -103,11 +118,13 @@ TUPLE: compose ;
 : set-composed-value >r model-dependencies r> 2each ; inline
 
 M: compose model-changed
+    nip
     dup [ model-value ] composed-value swap delegate set-model ;
 
-M: compose model-activated model-changed ;
+M: compose model-activated dup model-changed ;
 
-M: compose set-model [ set-model ] set-composed-value ;
+M: compose update-model
+    dup model-value swap [ set-model ] set-composed-value ;
 
 TUPLE: mapping assoc ;
 
@@ -117,13 +134,15 @@ TUPLE: mapping assoc ;
     tuck set-mapping-assoc ;
 
 M: mapping model-changed
+    nip
     dup mapping-assoc [ model-value ] assoc-map
     swap delegate set-model ;
 
-M: mapping model-activated model-changed ;
+M: mapping model-activated dup model-changed ;
 
-M: mapping set-model
-    mapping-assoc [ swapd at set-model ] curry assoc-each ;
+M: mapping update-model
+    dup model-value swap mapping-assoc
+    [ swapd at set-model ] curry assoc-each ;
 
 TUPLE: history back forward ;
 
@@ -161,10 +180,9 @@ TUPLE: delay model timeout ;
     f delay construct-model
     [ set-delay-timeout ] keep
     [ set-delay-model ] 2keep
-    [ add-dependency ] keep
-    dup update-delay-model ;
+    [ add-dependency ] keep ;
 
-M: delay model-changed 0 over delay-timeout add-timer ;
+M: delay model-changed nip 0 over delay-timeout add-timer ;
 
 M: delay model-activated update-delay-model ;
 
diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor
new file mode 100755
index 0000000000..a7226299ab
--- /dev/null
+++ b/extra/ui/gadgets/books/books-tests.factor
@@ -0,0 +1,4 @@
+IN: temporary
+USING: tools.test.inference ui.gadgets.books ;
+
+{ 2 1 } [ <book> ] unit-test-effect
diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor
index f9e3262e8e..95b1eed89d 100755
--- a/extra/ui/gadgets/books/books.factor
+++ b/extra/ui/gadgets/books/books.factor
@@ -10,15 +10,14 @@ TUPLE: book ;
 : current-page ( book -- gadget )
     [ control-value ] keep nth-gadget ;
 
-M: book model-changed ( book -- )
+M: book model-changed
+    nip
     dup hide-all
     dup current-page show-gadget
     relayout ;
 
 : <book> ( pages model -- book )
-    <gadget> book construct-control
-    [ add-gadgets ] keep
-    [ model-changed ] keep ;
+    <gadget> book construct-control [ add-gadgets ] keep ;
 
 M: book pref-dim* gadget-children pref-dims max-dim ;
 
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index 6c10a11d3c..a196173852 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -141,7 +141,7 @@ TUPLE: checkbox ;
     dup checkbox-theme ;
 
 M: checkbox model-changed
-    dup control-value over set-button-selected? relayout-1 ;
+    swap model-value over set-button-selected? relayout-1 ;
 
 TUPLE: radio-paint color ;
 
@@ -178,7 +178,7 @@ TUPLE: radio-control value ;
     tuck set-radio-control-value ; inline
 
 M: radio-control model-changed
-    dup control-value
+    swap model-value
     over radio-control-value =
     over set-button-selected?
     relayout-1 ;
diff --git a/extra/ui/gadgets/editors/editors-docs.factor b/extra/ui/gadgets/editors/editors-docs.factor
index 18e4e62ccc..42d300d330 100755
--- a/extra/ui/gadgets/editors/editors-docs.factor
+++ b/extra/ui/gadgets/editors/editors-docs.factor
@@ -16,9 +16,6 @@ $nl
     { { $link editor-focused? } " - a boolean." }
 } } ;
 
-HELP: loc-monitor
-{ $class-description "Instances of this class are used internally by " { $link editor } " controls to redraw the editor when the caret or mark is moved by calling " { $link set-model } " on " { $link editor-caret } " or " { $link editor-mark } "." } ;
-
 HELP: <editor>
 { $values { "editor" "a new " { $link editor } } }
 { $description "Creates a new " { $link editor } " with an empty document." } ;
diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor
index b7ddc8359c..fa4351b1b8 100755
--- a/extra/ui/gadgets/editors/editors-tests.factor
+++ b/extra/ui/gadgets/editors/editors-tests.factor
@@ -1,41 +1,41 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
 io.streams.string definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
-tools.test.inference ;
+tools.test.inference tools.test.ui ;
 
 [ t ] [
     <editor> "editor" set
-    "editor" get graft*
-    "editor" get <plain-writer> [ \ = see ] with-stream
-    "editor" get editor-string [ \ = see ] string-out =
-    "editor" get ungraft*
+    "editor" get [
+        "editor" get <plain-writer> [ \ = see ] with-stream
+        "editor" get editor-string [ \ = see ] string-out =
+    ] with-grafted-gadget
 ] unit-test
 
 [ "foo bar" ] [
     <editor> "editor" set
-    "editor" get graft*
-    "foo bar" "editor" get set-editor-string
-    "editor" get T{ one-line-elt } select-elt
-    "editor" get gadget-selection
-    "editor" get ungraft*
+    "editor" get [
+        "foo bar" "editor" get set-editor-string
+        "editor" get T{ one-line-elt } select-elt
+        "editor" get gadget-selection
+    ] with-grafted-gadget
 ] unit-test
 
 [ "baz quux" ] [
     <editor> "editor" set
-    "editor" get graft*
-    "foo bar\nbaz quux" "editor" get set-editor-string
-    "editor" get T{ one-line-elt } select-elt
-    "editor" get gadget-selection
-    "editor" get ungraft*
+    "editor" get [
+        "foo bar\nbaz quux" "editor" get set-editor-string
+        "editor" get T{ one-line-elt } select-elt
+        "editor" get gadget-selection
+    ] with-grafted-gadget
 ] unit-test
 
 [ ] [
     <editor> "editor" set
-    "editor" get graft*
-    "foo bar\nbaz quux" "editor" get set-editor-string
-    4 hand-click# set
-    "editor" get position-caret
-    "editor" get ungraft*
+    "editor" get [
+        "foo bar\nbaz quux" "editor" get set-editor-string
+        4 hand-click# set
+        "editor" get position-caret
+    ] with-grafted-gadget
 ] unit-test
 
 { 0 1 } [ <editor> ] unit-test-effect
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index 4250744ea5..65758ab54c 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -13,15 +13,11 @@ font color caret-color selection-color
 caret mark
 focused? ;
 
-TUPLE: loc-monitor editor ;
-
-: <loc> ( editor -- loc )
-    loc-monitor construct-boa
-    { 0 0 } <model> [ add-connection ] keep ;
+: <loc> ( -- loc ) { 0 0 } <model> ;
 
 : init-editor-locs ( editor -- )
-    dup <loc> over set-editor-caret
-    dup <loc> swap set-editor-mark ;
+    <loc> over set-editor-caret
+    <loc> swap set-editor-mark ;
 
 : editor-theme ( editor -- )
     black over set-editor-color
@@ -47,10 +43,14 @@ TUPLE: source-editor ;
 : <source-editor> source-editor construct-editor ;
 
 : activate-editor-model ( editor model -- )
-    dup activate-model swap gadget-model add-loc ;
+    2dup add-connection
+    dup activate-model
+    swap gadget-model add-loc ;
 
 : deactivate-editor-model ( editor model -- )
-    dup deactivate-model swap gadget-model remove-loc ;
+    2dup remove-connection
+    dup deactivate-model
+    swap gadget-model remove-loc ;
 
 M: editor graft*
     dup
@@ -62,12 +62,6 @@ M: editor ungraft*
     dup editor-caret deactivate-editor-model
     dup editor-mark deactivate-editor-model ;
 
-M: editor model-changed
-    dup gadget-model
-    over editor-caret [ over validate-loc ] (change-model)
-    over editor-mark [ over validate-loc ] (change-model)
-    drop editor-self relayout ;
-
 : editor-caret* ( editor -- loc ) editor-caret model-value ;
 
 : editor-mark* ( editor -- loc ) editor-mark model-value ;
@@ -133,10 +127,6 @@ M: editor model-changed
         over scroll>rect
     ] when drop ;
 
-M: loc-monitor model-changed
-    loc-monitor-editor editor-self
-    dup relayout-1 scroll>caret ;
-
 : draw-caret ( -- )
     editor get editor-focused? [
         editor get
@@ -218,6 +208,22 @@ M: editor draw-gadget*
 M: editor pref-dim*
     dup editor-font* swap control-value text-dim ;
 
+: contents-changed
+    editor-self swap
+    over editor-caret [ over validate-loc ] (change-model)
+    over editor-mark [ over validate-loc ] (change-model)
+    drop relayout ;
+
+: caret/mark-changed
+    nip editor-self dup relayout-1 scroll>caret ;
+
+M: editor model-changed
+    {
+        { [ 2dup gadget-model eq? ] [ contents-changed ] }
+        { [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
+        { [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
+    } cond ;
+
 M: editor gadget-selection?
     selection-start/end = not ;
 
@@ -420,16 +426,6 @@ editor "selection" f {
     { T{ key-down f { S+ C+ } "END" } select-end-of-document }
 } define-command-map
 
-! Editors support the stream output protocol
-M: editor stream-write1 >r 1string r> stream-write ;
-
-M: editor stream-write
-    editor-self dup end-of-document user-input ;
-
-M: editor stream-close drop ;
-
-M: editor stream-flush drop ;
-
 ! Fields are like editors except they edit an external model
 TUPLE: field model editor ;
 
@@ -452,5 +448,6 @@ M: field ungraft*
     dup field-editor gadget-model remove-connection ;
 
 M: field model-changed
+    nip
     dup field-editor editor-string
     swap field-model set-model ;
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index fc28d16fdc..9929cece29 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -50,7 +50,7 @@ M: gadget equal? 2drop f ;
 
 M: gadget hashcode* drop gadget hashcode* ;
 
-M: gadget model-changed drop ;
+M: gadget model-changed 2drop ;
 
 : gadget-child ( gadget -- child ) gadget-children first ;
 
@@ -71,7 +71,7 @@ M: gadget model-changed drop ;
 
 : activate-control ( gadget -- )
     dup gadget-model dup [ 2dup add-connection ] when drop
-    model-changed ;
+    dup gadget-model swap model-changed ;
 
 : deactivate-control ( gadget -- )
     dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor
index 2cd2c3d13c..a5c7431d36 100755
--- a/extra/ui/gadgets/incremental/incremental.factor
+++ b/extra/ui/gadgets/incremental/incremental.factor
@@ -11,14 +11,15 @@ IN: ui.gadgets.incremental
 ! pack-gap.
 
 ! The cursor is the current size of the incremental pack.
-! New gadgets are added at cursor-cursor*gadget-orientation.
+! New gadgets are added at
+!   incremental-cursor gadget-orientation v*
 
 TUPLE: incremental cursor ;
 
 : <incremental> ( pack -- incremental )
-    incremental construct-empty
-    [ set-gadget-delegate ] keep
-    dup delegate pref-dim over set-incremental-cursor ;
+    dup pref-dim
+    { set-gadget-delegate set-incremental-cursor }
+    incremental construct ;
 
 M: incremental pref-dim*
     dup gadget-layout-state [
@@ -39,7 +40,8 @@ M: incremental pref-dim*
     swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )
-    dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
+    dup forget-pref-dim dup pref-dim over set-rect-dim
+    layout ;
 
 : add-incremental ( gadget incremental -- )
     not-in-layout
@@ -52,6 +54,7 @@ M: incremental pref-dim*
 
 : clear-incremental ( incremental -- )
     not-in-layout
-    dup (clear-gadget) dup forget-pref-dim
+    dup (clear-gadget)
+    dup forget-pref-dim
     { 0 0 } over set-incremental-cursor
     gadget-parent [ relayout ] when* ;
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index 4e1a4712ba..2ac0240ed1 100755
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/extra/ui/gadgets/labels/labels.factor
@@ -40,7 +40,7 @@ M: label gadget-text* label-string % ;
 TUPLE: label-control ;
 
 M: label-control model-changed
-    dup control-value over set-label-text relayout ;
+    swap model-value over set-label-text relayout ;
 
 : <label-control> ( model -- gadget )
     "" <label> label-control construct-control ;
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index 358a344764..5fbe9ba0eb 100755
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -42,6 +42,7 @@ TUPLE: list index presenter color hook ;
     ] map 2nip ;
 
 M: list model-changed
+    nip
     dup clear-gadget
     dup <list-items> over add-gadgets
     bound-index ;
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 47198a6599..3cf257944a 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -140,7 +140,7 @@ M: duplex-stream write-gadget
 TUPLE: pane-control quot ;
 
 M: pane-control model-changed
-    dup control-value swap dup pane-control-quot with-pane ;
+    swap model-value swap dup pane-control-quot with-pane ;
 
 : <pane-control> ( model quot -- pane )
     >r <pane> pane-control construct-control r>
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index 83f8edc70e..56183bd0d4 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -131,4 +131,4 @@ M: scroller focusable-child*
     scroller-viewport ;
 
 M: scroller model-changed
-    f swap set-scroller-follows ;
+    nip f swap set-scroller-follows ;
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor
index 0d5c587a54..a420f59047 100755
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@@ -47,7 +47,7 @@ TUPLE: slider elevator thumb saved line ;
 
 : screen>slider slider-scale / ;
 
-M: slider model-changed slider-elevator relayout-1 ;
+M: slider model-changed nip slider-elevator relayout-1 ;
 
 TUPLE: thumb ;
 
diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor
index e879f32a02..7dd95d542d 100755
--- a/extra/ui/gadgets/viewports/viewports.factor
+++ b/extra/ui/gadgets/viewports/viewports.factor
@@ -32,6 +32,7 @@ M: viewport pref-dim* viewport-dim ;
     gadget-model range-value [ >fixnum ] map ;
 
 M: viewport model-changed
+    nip
     dup relayout-1
     dup scroller-value
     vneg viewport-gap v+
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
new file mode 100755
index 0000000000..4963df838c
--- /dev/null
+++ b/extra/ui/tools/interactor/interactor-tests.factor
@@ -0,0 +1,4 @@
+IN: temporary
+USING: ui.tools.interactor tools.test.inference ;
+
+{ 1 1 } [ <interactor> ] unit-test-effect
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 0d1052ca95..b603cc5eea 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -25,19 +25,8 @@ help ;
         2drop f
     ] if ;
 
-TUPLE: caret-help model gadget ;
-
-: <caret-help> ( interactor -- caret-help )
-    [ editor-caret 100 <delay> ] keep caret-help construct-boa
-    dup dup caret-help-model add-connection ;
-
-M: caret-help model-changed
-    dup caret-help-gadget
-    swap caret-help-model model-value over word-at-loc
-    swap show-summary ;
-
 : init-caret-help ( interactor -- )
-    dup <caret-help> swap set-interactor-help ;
+    dup editor-caret 100 <delay> swap set-interactor-help ;
 
 : init-interactor-history ( interactor -- )
     V{ } clone swap set-interactor-history ;
@@ -52,13 +41,20 @@ M: caret-help model-changed
 
 M: interactor graft*
     dup delegate graft*
-    dup interactor-help caret-help-model activate-model
+    dup dup interactor-help add-connection
     f swap set-interactor-busy? ;
 
 M: interactor ungraft*
-    dup interactor-help caret-help-model deactivate-model
+    dup dup interactor-help remove-connection
     delegate ungraft* ;
 
+M: interactor model-changed
+    2dup interactor-help eq? [
+        swap model-value over word-at-loc swap show-summary
+    ] [
+        delegate model-changed
+    ] if ;
+
 : write-input ( string input -- )
     <input> presented associate
     [ H{ { font-style bold } } format ] with-nesting ;
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index 3b161c1d28..4184591cec 100755
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -49,6 +49,7 @@ IN: ui.tools
     ] if relayout ;
 
 M: workspace model-changed
+    nip
     dup workspace-listener listener-gadget-output scroll>bottom
     dup resize-workspace
     request-focus ;
diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor
old mode 100644
new mode 100755
index 04af885eff..eea6d78f22
--- a/extra/ui/tools/walker/walker-tests.factor
+++ b/extra/ui/tools/walker/walker-tests.factor
@@ -2,27 +2,30 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
 listener tools.test ui ui.gadgets ui.gadgets.worlds
 ui.gadgets.packs vectors ui.tools tools.interpreter
-tools.interpreter.debug ;
+tools.interpreter.debug tools.test.inference tools.test.ui ;
 IN: temporary
 
+{ 0 1 } [ <walker> ] unit-test-effect
+
 [ ] [ <walker> "walker" set ] unit-test
 
-! Make sure the toolbar buttons don't throw if we're
-! not actually walking.
+"walker" get [
+    ! Make sure the toolbar buttons don't throw if we're
+    ! not actually walking.
 
-[ ] [ "walker" get com-step ] unit-test
-[ ] [ "walker" get com-into ] unit-test
-[ ] [ "walker" get com-out ] unit-test
-[ ] [ "walker" get com-back ] unit-test
-[ ] [ "walker" get com-inspect ] unit-test
-[ ] [ "walker" get reset-walker ] unit-test
-[ ] [ "walker" get com-continue ] unit-test
+    [ ] [ "walker" get com-step ] unit-test
+    [ ] [ "walker" get com-into ] unit-test
+    [ ] [ "walker" get com-out ] unit-test
+    [ ] [ "walker" get com-back ] unit-test
+    [ ] [ "walker" get com-inspect ] unit-test
+    [ ] [ "walker" get reset-walker ] unit-test
+    [ ] [ "walker" get com-continue ] unit-test
+] with-grafted-gadget
 
 : <test-world> ( gadget -- world )
     [ gadget, ] make-pile "Hi" f <world> ;
 
-[
-    f <workspace>
+f <workspace> dup [
     [ <test-world> 2array 1vector windows set ] keep
 
     "ok" off
@@ -37,38 +40,40 @@ IN: temporary
 
     [ t ] [ "ok" get ] unit-test
 
-    [ ] [ <walker> "w" set ] unit-test
+    [ ] [ walker get-tool "w" set ] unit-test
     continuation "c" set
-    
+
     [ ] [ "c" get "w" get call-tool* ] unit-test
 
     [ ] [
         [ "c" set f ] callcc1
         [ "q" set ] [ "w" get com-inspect stop ] if*
     ] unit-test
-    
+
     [ t ] [
         "q" get dup first continuation?
         swap second \ inspect eq? and
     ] unit-test
-] with-scope
+] with-grafted-gadget
 
 [
-    f <workspace> <test-world> 2array 1vector windows set
+    f <workspace> dup [
+        <test-world> 2array 1vector windows set
 
-    [ ] [
-        [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
-    ] unit-test
+        [ ] [
+            [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
+        ] unit-test
 
-    [ ] [ walker get-tool com-continue ] unit-test
+        [ ] [ walker get-tool com-continue ] unit-test
 
-    [ ] [ yield ] unit-test
+        [ ] [ yield ] unit-test
 
-    [ t ] [ walker get-tool walker-active? ] unit-test
+        [ t ] [ walker get-tool walker-active? ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
+    ] with-grafted-gadget
 ] with-scope
diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index 3ff9b284e5..4740ff86d4 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/extra/ui/tools/walker/walker.factor
@@ -46,12 +46,13 @@ TUPLE: walker model interpreter history ;
     V{ } clone over set-walker-history
     update-stacks ;
 
+M: walker graft* dup delegate graft* reset-walker ;
+
 : <walker> ( -- gadget )
     f <model> f f walker construct-boa [
         toolbar,
         g walker-model <traceback-gadget> 1 track,
-    ] { 0 1 } build-track
-    dup reset-walker ;
+    ] { 0 1 } build-track ;
 
 M: walker call-tool* ( continuation walker -- )
     [ restore ] with-walker ;

From 55c4abc39bdcdbac03088bd026c4e821eb25631b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 03:26:00 -0500
Subject: [PATCH 11/23] Fix editors unit tests

---
 extra/ui/gadgets/editors/editors-tests.factor | 10 +---------
 1 file changed, 1 insertion(+), 9 deletions(-)

diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor
index fa4351b1b8..a38ca6044e 100755
--- a/extra/ui/gadgets/editors/editors-tests.factor
+++ b/extra/ui/gadgets/editors/editors-tests.factor
@@ -1,16 +1,8 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
-io.streams.string definitions namespaces ui.gadgets
+definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
 tools.test.inference tools.test.ui ;
 
-[ t ] [
-    <editor> "editor" set
-    "editor" get [
-        "editor" get <plain-writer> [ \ = see ] with-stream
-        "editor" get editor-string [ \ = see ] string-out =
-    ] with-grafted-gadget
-] unit-test
-
 [ "foo bar" ] [
     <editor> "editor" set
     "editor" get [

From a90434696dd214de2d142d4fd1cde1ac62e629f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 03:27:05 -0500
Subject: [PATCH 12/23] Doc fix

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

diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 78f9209a18..08ca298d2c 100644
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -161,6 +161,7 @@ $nl
 { $subsection word? }
 { $subsection "interned-words" }
 { $subsection "word-definition" }
+{ $subsection "word-props" }
 { $subsection "word.private" }
 { $see-also "vocabularies" "vocabs.loader" "definitions" } ;
 

From 424ced9e2dc3820a4a94213d1357f77a59e19c3a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 18:40:57 -0500
Subject: [PATCH 13/23] Remove debugging messages

---
 extra/ui/gadgets/scrollers/scrollers.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index 56183bd0d4..b125104e4f 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -115,10 +115,10 @@ scroller H{
 
 : update-scroller ( scroller follows -- )
     {
-        { [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] }
-        { [ dup rect? ] [ swap (scroll>rect) "B" drop ] }
-        { [ dup ] [ swap (scroll>gadget)  "C" drop ] }
-        { [ t ] [ drop dup scroller-value swap scroll "D" drop ] }
+        { [ dup t eq? ] [ drop (scroll>bottom) ] }
+        { [ dup rect? ] [ swap (scroll>rect) ] }
+        { [ dup ] [ swap (scroll>gadget) ] }
+        { [ t ] [ drop dup scroller-value swap scroll ] }
     } cond ;
 
 M: scroller layout*

From 563a60cb8d5bc773a0e1fc9be2d21407d409887b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 21:07:18 -0500
Subject: [PATCH 14/23] Documentation updates

---
 core/system/system-docs.factor         |  39 ++++++---
 extra/help/handbook/handbook.factor    |   5 +-
 extra/io/launcher/launcher-docs.factor | 114 +++++++++++++++++++++++++
 3 files changed, 144 insertions(+), 14 deletions(-)
 create mode 100644 extra/io/launcher/launcher-docs.factor

diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 8c57d0c951..4e31fd4722 100644
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -1,5 +1,5 @@
 USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private io.files ;
+namespaces sequences kernel.private io.files strings ;
 IN: system
 
 ARTICLE: "os" "System interface"
@@ -21,23 +21,27 @@ ARTICLE: "os" "System interface"
 { $subsection cell-bits }
 "Reading environment variables:"
 { $subsection os-env }
+{ $subsection os-envs }
 "Getting the path to the Factor VM and image:"
 { $subsection vm }
 { $subsection image }
+"Getting the current time:"
+{ $subsection millis }
 "Exiting the Factor VM:"
-{ $subsection exit } ;
+{ $subsection exit }
+{ $see-also "file-streams" "network-streams" "io.launcher" } ;
 
 ABOUT: "os"
 
 HELP: cpu
-{ $values { "cpu" "a string" } }
+{ $values { "cpu" string } }
 { $description
     "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
     { $code "x86.32" "x86.64" "ppc" "arm" }
 } ;
 
 HELP: os
-{ $values { "os" "a string" } }
+{ $values { "os" string } }
 { $description
     "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
     { $code
@@ -87,17 +91,28 @@ HELP: exit ( n -- )
 { $description "Exits the Factor process." } ;
 
 HELP: millis ( -- n )
-{ $values { "n" "an integer" } }
-{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." } ;
+{ $values { "n" integer } }
+{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
+{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
 
 HELP: os-env ( key -- value )
-{ $values { "key" "a string" } { "value" "a string" } }
+{ $values { "key" string } { "value" string } }
 { $description "Looks up the value of a shell environment variable." }
 { $examples 
     "This is an operating system-specific feature. On Unix, you can do:"
     { $unchecked-example "\"USER\" os-env print" "jane" }
 }
-{ $errors "Windows CE has no concept of ``environment variables'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Outputs the current set of environment variables." }
+{ $notes 
+    "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+{ os-env os-envs } related-words
 
 HELP: win32?
 { $values { "?" "a boolean" } }
@@ -124,11 +139,11 @@ HELP: cell
 { $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
 
 HELP: cells
-{ $values { "m" "an integer" } { "n" "an integer" } }
+{ $values { "m" integer } { "n" integer } }
 { $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
 
 HELP: cell-bits
-{ $values { "n" "an integer" } }
+{ $values { "n" integer } }
 { $description "Outputs the number of bits in one CPU operand-sized cell." } ;
 
 HELP: bootstrap-cell
@@ -136,9 +151,9 @@ HELP: bootstrap-cell
 { $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
 
 HELP: bootstrap-cells
-{ $values { "m" "an integer" } { "n" "an integer" } }
+{ $values { "m" integer } { "n" integer } }
 { $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
 
 HELP: bootstrap-cell-bits
-{ $values { "n" "an integer" } }
+{ $values { "n" integer } }
 { $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 44f932abb2..c38023e544 100644
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -131,7 +131,7 @@ ARTICLE: "collections" "Collections"
 { $subsection "graphs" }
 { $subsection "buffers" } ;
 
-USE: io.sockets
+USING: io.sockets io.launcher ;
 
 ARTICLE: "io" "Input and output" 
 { $subsection "streams" }
@@ -144,7 +144,8 @@ ARTICLE: "io" "Input and output"
 "Advanced features:"
 { $subsection "stream-binary" }
 { $subsection "styles" }
-{ $subsection "network-streams" } ;
+{ $subsection "network-streams" }
+{ $subsection "io.launcher" } ;
 
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.annotations" }
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
new file mode 100644
index 0000000000..3ce7c65600
--- /dev/null
+++ b/extra/io/launcher/launcher-docs.factor
@@ -0,0 +1,114 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.launcher.private quotations
+kernel ;
+IN: io.launcher
+
+HELP: +command+
+{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
+
+HELP: +arguments+
+{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
+
+HELP: +detached+
+{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
+$nl
+"Default value is " { $link f } "." }
+{ $notes "Cannot be used with " { $link <process-stream> } "." }
+{ $see-also run-detached } ;
+
+HELP: +environment+
+{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
+$nl
+"Default value is an empty association." } ;
+
+HELP: +environment-mode+
+{ $description "Launch descriptor key. Must equal of the following:"
+    { $list
+        { $link prepend-environment }
+        { $link replace-environment }
+        { $link append-environment }
+    }
+"Default value is " { $link append-environment } "."
+} ;
+
+HELP: prepend-environment
+{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
+$nl
+"This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
+
+HELP: replace-environment
+{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
+$nl
+"This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
+
+HELP: append-environment
+{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
+$nl
+"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
+
+HELP: default-descriptor
+{ $description "Association storing default values for launch descriptor keys." } ;
+
+HELP: with-descriptor
+{ $values { "desc" "a launch descriptor" } { "quot" quotation } } 
+{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
+
+HELP: get-environment
+{ $values { "env" "an association" } }
+{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
+
+HELP: run-process*
+{ $values { "desc" "a launch descriptor" } }
+{ $contract "Launches a process using the launch descriptor." }
+{ $notes "User code should call " { $link run-process } " instead." } ;
+
+HELP: >descriptor
+{ $values { "obj" object } { "desc" "a launch descriptor" } }
+{ $description "Creates a launch descriptor from an object, which must be one of the following:"
+    { $list
+        { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
+        { "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
+        { "an association, used to set launch parameters for additional control" }
+    }
+} ;
+
+HELP: run-process
+{ $values { "obj" object } }
+{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
+
+HELP: run-detached
+{ $values { "obj" object } }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
+{ $notes
+    "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+} ;
+
+HELP: <process-stream>
+{ $values { "obj" object } { "stream" "a bidirectional stream" } }
+{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a stream." }
+{ $notes "Closing the stream will block until the process exits." } ;
+
+{ run-process run-detached <process-stream> } related-words
+
+ARTICLE: "io.launcher" "Launching OS processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+$nl
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
+{ $list
+    { "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" }
+    { "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
+    { "launch descriptors are associations, which can set extra launch parameters for finer control" }
+}
+"A launch descriptor is an association containing keys from the below set:"
+{ $subsection +command+ }
+{ $subsection +arguments+ }
+{ $subsection +detached+ }
+{ $subsection +environment+ }
+{ $subsection +environment-mode+ }
+"The following words are used to launch processes:"
+{ $subsection run-process }
+{ $subsection run-detached }
+{ $subsection <process-stream> } ;
+
+ABOUT: "io.launcher"

From 22fb002fd498cc20dee13a0b398d43ab8f2794e2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 16 Nov 2007 21:07:36 -0500
Subject: [PATCH 15/23] Ensure libc init hook is added before io init hook

---
 core/bootstrap/stage1.factor | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index df59afccb0..cda75fedf6 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -25,6 +25,10 @@ vocabs.loader system ;
     "math.integers" require
     "math.floats" require
     "memory" require
+
+    ! this must add its init hook before io.backend does
+    "libc" require
+
     "io.streams.c" require
     "vocabs.loader" require
     "syntax" require

From 014a3d486723543f0108c35e0ca5598a6748b688 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 00:45:58 -0500
Subject: [PATCH 16/23] Launcher doc fix

---
 extra/io/launcher/launcher-docs.factor | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 3ce7c65600..cade859a5c 100644
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.launcher.private quotations
-kernel ;
+USING: help.markup help.syntax io.launcher quotations kernel ;
 IN: io.launcher
 
 HELP: +command+

From 00d2d8802788fd3a2ee6e419ef4b7dd323f07447 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 01:43:15 -0500
Subject: [PATCH 17/23] Revert alien.compiler tweak, it was too clever

---
 core/alien/compiler/compiler.factor | 54 +++++++++++++++++------------
 1 file changed, 31 insertions(+), 23 deletions(-)

diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 7e0165cd64..992c7763f2 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -202,23 +202,6 @@ M: alien-invoke-error summary
 
 : pop-parameters pop-literal nip [ expand-constants ] map ;
 
-\ alien-invoke [
-    ! Four literals
-    4 ensure-values
-    \ alien-invoke empty-node
-    ! Compile-time parameters
-    pop-parameters over set-alien-invoke-parameters
-    pop-literal nip over set-alien-invoke-function
-    pop-literal nip over set-alien-invoke-library
-    pop-literal nip over set-alien-invoke-return
-    ! Quotation which coerces parameters to required types
-    dup make-prep-quot recursive-state get infer-quot
-    ! Add node to IR
-    dup node,
-    ! Magic #: consume exactly the number of inputs
-    0 alien-invoke-stack
-] "infer" set-word-prop
-
 : stdcall-mangle ( symbol node -- symbol )
     "@"
     swap alien-node-parameters parameter-sizes drop
@@ -228,13 +211,38 @@ M: alien-invoke-error summary
     dup alien-invoke-function
     swap alien-invoke-library load-library ;
 
+TUPLE: no-such-symbol ;
+
+M: no-such-symbol summary
+    drop "Symbol not found" ;
+
+: no-such-symbol ( -- )
+    \ no-such-symbol inference-error ;
+
 : alien-invoke-dlsym ( node -- symbol dll )
-    dup (alien-invoke-dlsym)
-    >r over stdcall-mangle r> 2dup dlsym [
-        rot drop
-    ] [
-        2drop (alien-invoke-dlsym)
-    ] if ;
+    dup (alien-invoke-dlsym) 2dup dlsym [
+        >r over stdcall-mangle r> 2dup dlsym
+        [ no-such-symbol ] unless
+    ] unless rot drop ;
+
+\ alien-invoke [
+    ! Four literals
+    4 ensure-values
+    \ alien-invoke empty-node
+    ! Compile-time parameters
+    pop-parameters over set-alien-invoke-parameters
+    pop-literal nip over set-alien-invoke-function
+    pop-literal nip over set-alien-invoke-library
+    pop-literal nip over set-alien-invoke-return
+    ! If symbol doesn't resolve, no stack effect, no compile
+    dup alien-invoke-dlsym 2drop
+    ! Quotation which coerces parameters to required types
+    dup make-prep-quot recursive-state get infer-quot
+    ! Add node to IR
+    dup node,
+    ! Magic #: consume exactly the number of inputs
+    0 alien-invoke-stack
+] "infer" set-word-prop
 
 M: alien-invoke generate-node
     dup alien-invoke-frame [

From 032fd57328e79314d3941c4dc025d22cde5fb776 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 01:49:06 -0500
Subject: [PATCH 18/23] Document io.mmap and add mapped-file-closed? flag check

---
 core/system/system-docs.factor      |  2 +-
 extra/help/handbook/handbook.factor |  5 ++--
 extra/io/mmap/mmap-docs.factor      | 38 +++++++++++++++++++++++++++++
 extra/io/mmap/mmap.factor           | 21 ++++++++++++----
 extra/io/unix/mmap/mmap.factor      |  2 +-
 extra/io/windows/mmap/mmap.factor   |  8 +++---
 6 files changed, 62 insertions(+), 14 deletions(-)
 create mode 100644 extra/io/mmap/mmap-docs.factor

diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 4e31fd4722..d91a84ec99 100644
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -29,7 +29,7 @@ ARTICLE: "os" "System interface"
 { $subsection millis }
 "Exiting the Factor VM:"
 { $subsection exit }
-{ $see-also "file-streams" "network-streams" "io.launcher" } ;
+{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ;
 
 ABOUT: "os"
 
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index c38023e544..749a5ed0ec 100644
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -131,7 +131,7 @@ ARTICLE: "collections" "Collections"
 { $subsection "graphs" }
 { $subsection "buffers" } ;
 
-USING: io.sockets io.launcher ;
+USING: io.sockets io.launcher io.mmap ;
 
 ARTICLE: "io" "Input and output" 
 { $subsection "streams" }
@@ -145,7 +145,8 @@ ARTICLE: "io" "Input and output"
 { $subsection "stream-binary" }
 { $subsection "styles" }
 { $subsection "network-streams" }
-{ $subsection "io.launcher" } ;
+{ $subsection "io.launcher" }
+{ $subsection "io.mmap" } ;
 
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.annotations" }
diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor
new file mode 100644
index 0000000000..22e403ed31
--- /dev/null
+++ b/extra/io/mmap/mmap-docs.factor
@@ -0,0 +1,38 @@
+USING: help.markup help.syntax alien math ;
+IN: io.mmap
+
+HELP: mapped-file
+{ $class-description "The class of memory-mapped files, opened by " { $link <mapped-file> } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:"
+    { $list
+        { { $link mapped-file-length } " - the length of the mapped file area, in bytes" }
+        { { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" }
+    }
+} ;
+
+HELP: <mapped-file>
+{ $values { "path" "a pathname string" } { "length" integer } { "mmap" mapped-file } }
+{ $contract "Opens a file and maps the first " { $snippet "length" } " bytes into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
+{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: (close-mapped-file)
+{ $values { "mmap" mapped-file } }
+{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: close-mapped-file
+{ $values { "mmap" mapped-file } }
+{ $description "Releases system resources associated with the mapped file." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+ARTICLE: "io.mmap" "Memory-mapped files"
+"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
+{ $subsection <mapped-file> }
+{ $subsection close-mapped-file }
+"A combinator which wraps the above two words:"
+{ $subsection with-mapped-file }
+"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
+{ $subsection mapped-file-address }
+"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
+
+ABOUT: "io.mmap"
diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor
index f9ccd61423..aaa786f6a4 100644
--- a/extra/io/mmap/mmap.factor
+++ b/extra/io/mmap/mmap.factor
@@ -4,20 +4,31 @@ USING: continuations io.backend kernel quotations sequences
 system alien sequences.private ;
 IN: io.mmap
 
-TUPLE: mapped-file length address handle ;
+TUPLE: mapped-file length address handle closed? ;
 
-M: mapped-file length mapped-file-length ;
+: check-closed ( mapped-file -- mapped-file )
+    dup mapped-file-closed? [
+        "Mapped file is closed" throw
+    ] when ; inline
+
+M: mapped-file length check-closed mapped-file-length ;
 
 M: mapped-file nth-unsafe
-    mapped-file-address swap alien-unsigned-1 ;
+    check-closed mapped-file-address swap alien-unsigned-1 ;
 
 M: mapped-file set-nth-unsafe
-    mapped-file-address swap set-alien-unsigned-1 ;
+    check-closed mapped-file-address swap set-alien-unsigned-1 ;
 
 INSTANCE: mapped-file sequence
 
 HOOK: <mapped-file> io-backend ( path length -- mmap )
-HOOK: close-mapped-file io-backend ( mmap -- )
+
+HOOK: (close-mapped-file) io-backend ( mmap -- )
+
+: close-mapped-file ( mmap -- )
+    check-closed
+    t over set-mapped-file-closed?
+    (close-mapped-file) ;
 
 : with-mapped-file ( path length quot -- )
     >r <mapped-file> r>
diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor
index 50e928f16d..d7dcad67d9 100644
--- a/extra/io/unix/mmap/mmap.factor
+++ b/extra/io/unix/mmap/mmap.factor
@@ -15,7 +15,7 @@ M: unix-io <mapped-file> ( path length -- obj )
     dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
     r> mmap-open \ mapped-file construct-boa ;
 
-M: unix-io close-mapped-file ( mmap -- )
+M: unix-io (close-mapped-file) ( mmap -- )
     [ mapped-file-address ] keep
     [ mapped-file-length munmap ] keep
     mapped-file-handle close
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index 2742d1b006..190b0b60bc 100644
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -75,13 +75,11 @@ M: windows-io <mapped-file> ( path length -- mmap )
             PAGE_READWRITE SEC_COMMIT bitor
             FILE_MAP_ALL_ACCESS r> mmap-open
         ] keep
-    -roll -rot 2array \ mapped-file construct-boa
+        -roll -rot 2array \ mapped-file construct-boa
     ] with-destructors ;
 
-M: windows-io close-mapped-file ( mapped-file -- )
+M: windows-io (close-mapped-file) ( mapped-file -- )
     [
-        dup mapped-file-handle [
-            close-always
-        ] each
+        dup mapped-file-handle [ close-always ] each
         mapped-file-address UnmapViewOfFile win32-error=0/f
     ] with-destructors ;

From f05f9199732895782740b1b5afef6ef733bcd72c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 04:31:26 -0500
Subject: [PATCH 19/23] Fix code heap compaction bug introduced recently

---
 vm/code_gc.c | 15 +++++++++++++++
 vm/cpu-arm.h | 17 -----------------
 vm/cpu-ppc.h | 17 -----------------
 vm/cpu-x86.h | 17 -----------------
 vm/layouts.h | 17 +++++++++++++++++
 5 files changed, 32 insertions(+), 51 deletions(-)
 mode change 100644 => 100755 vm/code_gc.c

diff --git a/vm/code_gc.c b/vm/code_gc.c
old mode 100644
new mode 100755
index 3d74ae0e4c..a088e56024
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -379,6 +379,8 @@ CELL compute_heap_forwarding(F_HEAP *heap)
 			scan->forwarding = (F_BLOCK *)address;
 			address += scan->size;
 		}
+		else if(scan->status == B_MARKED)
+			critical_error("Why is the block marked?",0);
 
 		scan = next_block(heap,scan);
 	}
@@ -391,6 +393,14 @@ F_COMPILED *forward_xt(F_COMPILED *compiled)
 	return block_to_compiled(compiled_to_block(compiled)->forwarding);
 }
 
+void forward_frame_xt(F_STACK_FRAME *frame)
+{
+	CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
+	F_COMPILED *forwarded = forward_xt(frame_code(frame));
+	frame->xt = (XT)(forwarded + 1);
+	FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
+}
+
 void forward_object_xts(void)
 {
 	begin_scan();
@@ -413,6 +423,11 @@ void forward_object_xts(void)
 			if(quot->compiledp != F)
 				set_quot_xt(quot,forward_xt(quot->code));
 		}
+		else if(type_of(obj) == CALLSTACK_TYPE)
+		{
+			F_CALLSTACK *stack = untag_object(obj);
+			iterate_callstack_object(stack,forward_frame_xt);
+		}
 	}
 
 	/* End the heap scan */
diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h
index 67dadb2906..8402824579 100755
--- a/vm/cpu-arm.h
+++ b/vm/cpu-arm.h
@@ -5,23 +5,6 @@ register CELL rs asm("r6");
 
 #define F_FASTCALL
 
-typedef struct
-{
-	/* In compiled quotation frames, position within the array.
-	In compiled word frames, unused. */
-	CELL scan;
-
-	/* In compiled quotation frames, the quot->array slot.
-	In compiled word frames, unused. */
-	CELL array;
-
-	/* In all compiled frames, the XT on entry. */
-	XT xt;
-
-	/* Frame size in bytes */
-	CELL size;
-} F_STACK_FRAME;
-
 #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
 
 void c_to_factor(CELL quot);
diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h
index dc9e0bbbf6..88bbde5661 100755
--- a/vm/cpu-ppc.h
+++ b/vm/cpu-ppc.h
@@ -1,20 +1,3 @@
-typedef struct
-{
-	/* In compiled quotation frames, position within the array.
-	In compiled word frames, unused. */
-	CELL scan;
-
-	/* In compiled quotation frames, the quot->array slot.
-	In compiled word frames, unused. */
-	CELL array;
-
-	/* In all compiled frames, the XT on entry. */
-	XT xt;
-
-	/* Frame size in bytes */
-	CELL size;
-} F_STACK_FRAME;
-
 #define FACTOR_CPU_STRING "ppc"
 #define F_FASTCALL
 
diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h
index f119db5761..7983c139af 100755
--- a/vm/cpu-x86.h
+++ b/vm/cpu-x86.h
@@ -1,22 +1,5 @@
 #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
 
-typedef struct
-{
-	/* In compiled quotation frames, position within the array.
-	In compiled word frames, unused. */
-	CELL scan;
-
-	/* In compiled quotation frames, the quot->array slot.
-	In compiled word frames, unused. */
-	CELL array;
-
-	/* In all compiled frames, the XT on entry. */
-	XT xt;
-
-	/* Frame size in bytes */
-	CELL size;
-} F_STACK_FRAME;
-
 INLINE void flush_icache(CELL start, CELL len) {}
 
 F_FASTCALL void c_to_factor(CELL quot);
diff --git a/vm/layouts.h b/vm/layouts.h
index 94a2fe3a1b..65d9fa4359 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -255,3 +255,20 @@ typedef struct {
 	/* tagged */
 	CELL length;
 } F_CALLSTACK;
+
+typedef struct
+{
+	/* In compiled quotation frames, position within the array.
+	In compiled word frames, unused. */
+	CELL scan;
+
+	/* In compiled quotation frames, the quot->array slot.
+	In compiled word frames, unused. */
+	CELL array;
+
+	/* In all compiled frames, the XT on entry. */
+	XT xt;
+
+	/* Frame size in bytes */
+	CELL size;
+} F_STACK_FRAME;

From 5c6a7120bb920328d12ce8a6152439d584b905f2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 23:06:34 -0500
Subject: [PATCH 20/23] Get io.mmap working on Windows CE

---
 extra/io/mmap/mmap.factor         |  0
 extra/io/windows/mmap/mmap.factor | 31 ++++++++++++++++---------------
 2 files changed, 16 insertions(+), 15 deletions(-)
 mode change 100644 => 100755 extra/io/mmap/mmap.factor
 mode change 100644 => 100755 extra/io/windows/mmap/mmap.factor

diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor
old mode 100644
new mode 100755
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
old mode 100644
new mode 100755
index 2742d1b006..b291bb6bcd
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -1,7 +1,7 @@
 USING: alien alien.c-types alien.syntax arrays continuations
 destructors generic io.mmap io.nonblocking io.windows
 kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 ;
+windows.advapi32 windows.kernel32 io.backend ;
 IN: io.windows.mmap
 
 TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@@ -51,12 +51,16 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
         dup length f f AdjustTokenPrivileges win32-error=0/f
     ] with-process-token ;
 
-: with-privileges ( seq quot -- )
+HOOK: with-privileges io-backend ( seq quot -- ) inline
+
+M: windows-nt-io with-privileges
     over [ [ t set-privilege ] each ] curry compose
     swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
 
-: mmap-open ( path access-mode create-mode flProtect access length -- handle handle address )
-    drop
+M: windows-ce-io with-privileges
+    nip call ;
+
+: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
     { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
         >r >r open-file dup f r> 0 0 f
         CreateFileMapping [ win32-error=0/f ] keep
@@ -68,20 +72,17 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
     
 M: windows-io <mapped-file> ( path length -- mmap )
     [
-        [
-            >r
-            GENERIC_WRITE GENERIC_READ bitor
-            OPEN_ALWAYS
-            PAGE_READWRITE SEC_COMMIT bitor
-            FILE_MAP_ALL_ACCESS r> mmap-open
-        ] keep
-    -roll -rot 2array \ mapped-file construct-boa
+        swap
+        GENERIC_WRITE GENERIC_READ bitor
+        OPEN_ALWAYS
+        PAGE_READWRITE SEC_COMMIT bitor
+        FILE_MAP_ALL_ACCESS mmap-open
+        -rot 2array
+        \ mapped-file construct-boa
     ] with-destructors ;
 
 M: windows-io close-mapped-file ( mapped-file -- )
     [
-        dup mapped-file-handle [
-            close-always
-        ] each
+        dup mapped-file-handle [ close-always ] each
         mapped-file-address UnmapViewOfFile win32-error=0/f
     ] with-destructors ;

From 4ee696882f0b8b570d0f407abcaa02ea5f9a322e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 17 Nov 2007 23:06:51 -0500
Subject: [PATCH 21/23] Get io.launcher working on Windows CE

---
 extra/io/windows/launcher/launcher.factor | 46 +++++++++++++++--------
 1 file changed, 30 insertions(+), 16 deletions(-)

diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index b7a32652f2..f586976bb6 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -1,8 +1,7 @@
-USING: alien alien.c-types arrays continuations
-destructors io io.windows libc
-io.nonblocking io.streams.duplex windows.types math
-windows.kernel32 windows namespaces io.launcher kernel
-sequences io.windows.nt.backend windows.errors assocs ;
+USING: alien alien.c-types arrays continuations destructors io
+io.windows libc io.nonblocking io.streams.duplex windows.types
+math windows.kernel32 windows namespaces io.launcher kernel
+sequences windows.errors assocs splitting system ;
 IN: io.windows.launcher
 
 ! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
@@ -52,19 +51,30 @@ TUPLE: CreateProcess-args
         CreateProcess-args-lpProcessInformation
     } get-slots CreateProcess win32-error=0/f ;
 
-: fill-lpCommandLine
+: join-arguments ( args -- cmd-line )
+    [ "\"" swap "\"" 3append ] map " " join ;
+
+: app-name/cmd-line ( -- app-name cmd-line )
     +command+ get [
-        [
-            +arguments+ get [ CHAR: \s , ] [
-                CHAR: " ,
-                [ dup CHAR: " = [ CHAR: \\ , ] when , ] each
-                CHAR: " ,
-            ] interleave
-        ] "" make
-    ] unless* over set-CreateProcess-args-lpCommandLine ;
+        " " split1
+    ] [
+        +arguments+ get unclip swap join-arguments
+    ] if* ;
+
+: cmd-line ( -- cmd-line )
+    +command+ get [ +arguments+ get join-arguments ] unless* ;
+
+: fill-lpApplicationName
+    app-name/cmd-line
+    pick set-CreateProcess-args-lpCommandLine
+    over set-CreateProcess-args-lpApplicationName ;
+
+: fill-lpCommandLine
+    cmd-line over set-CreateProcess-args-lpCommandLine ;
 
 : fill-dwCreateFlags
-    CREATE_UNICODE_ENVIRONMENT
+    0
+    pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
     +detached+ get [ DETACHED_PROCESS bitor ] when
     over set-CreateProcess-args-dwCreateFlags ;
 
@@ -86,7 +96,11 @@ TUPLE: CreateProcess-args
 M: windows-io run-process* ( desc -- )
     [
         default-CreateProcess-args
-        fill-lpCommandLine
+        wince? [
+            fill-lpApplicationName
+        ] [
+            fill-lpCommandLine
+        ] if
         fill-dwCreateFlags
         fill-lpEnvironment
         dup call-CreateProcess

From ddb85815ef5fc7370a078d10cfb407070562cf25 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 18 Nov 2007 01:10:58 -0500
Subject: [PATCH 22/23] stream-copy optimization

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

diff --git a/core/io/io.factor b/core/io/io.factor
index cc0d2cc8e5..50393f96bb 100644
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -25,7 +25,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
     [ stream-write ] keep stream-nl ;
 
 : (stream-copy) ( in out -- )
-    64 1024 * pick stream-read
+    64 1024 * pick stream-read-partial
     [ over stream-write (stream-copy) ] [ 2drop ] if* ;
 
 : stream-copy ( in out -- )

From 23369eecc9415de4f445f325f38872c70fc2c1e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 18 Nov 2007 01:11:06 -0500
Subject: [PATCH 23/23] Fix typo

---
 extra/help/cookbook/cookbook.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor
index ff8817cde9..854797254f 100644
--- a/extra/help/cookbook/cookbook.factor
+++ b/extra/help/cookbook/cookbook.factor
@@ -217,7 +217,7 @@ ARTICLE: "cookbook-io" "I/O cookbook"
 } ;
 
 ARTICLE: "cookbook-philosophy" "Factor philosophy"
-"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might me related to the amount of code you " { $emphasis "don't" } " have to write."
+"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
 $nl
 "If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps."
 $nl