From 122be5b48ec22a69dd1afd0d2f441aacb9e4ed97 Mon Sep 17 00:00:00 2001
From: Matthew Willis <yuuki@kotatsu.local>
Date: Sat, 9 Feb 2008 00:17:24 -0800
Subject: [PATCH 01/33] Added set-fullscreen? and fullscreen? hooks along with
 their cocoa implementations.

---
 extra/cocoa/cocoa.factor                   |  1 +
 extra/ui/backend/backend.factor            |  4 ++++
 extra/ui/cocoa/cocoa.factor                | 14 +++++++++++++-
 extra/ui/gadgets/worlds/worlds-docs.factor |  9 +++++++++
 4 files changed, 27 insertions(+), 1 deletion(-)

diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index cbc6c9d762..c94984f00b 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
         "NSPasteboard"
         "NSResponder"
         "NSSavePanel"
+        "NSScreen"
         "NSView"
         "NSWindow"
         "NSWorkspace"
diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor
index a0646f35b0..cc1f5f7d05 100755
--- a/extra/ui/backend/backend.factor
+++ b/extra/ui/backend/backend.factor
@@ -7,6 +7,10 @@ SYMBOL: ui-backend
 
 HOOK: set-title ui-backend ( string world -- )
 
+HOOK: set-fullscreen? ui-backend ( ? world -- )
+
+HOOK: fullscreen? ui-backend ( world -- ? )
+
 HOOK: (open-window) ui-backend ( world -- )
 
 HOOK: (close-window) ui-backend ( handle -- )
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 1e46544180..184e6fd856 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cocoa cocoa.application command-line
+USING: math arrays cocoa cocoa.application command-line
 kernel memory namespaces cocoa.messages cocoa.runtime
 cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
 cocoa.classes cocoa.application sequences system ui ui.backend
@@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents
 M: cocoa-ui-backend set-title ( string world -- )
     world-handle second swap <NSString> -> setTitle: ;
 
+: enter-fullscreen ( world -- )
+    world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
+
+: exit-fullscreen ( world -- )
+    world-handle first f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen? ( ? world -- )
+    swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen? ( world -- ? )
+    world-handle first -> isInFullScreenMode zero? not ;
+
 : auto-position ( world -- )
     dup world-loc { 0 0 } = [
         world-handle second -> center
diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor
index a47717329d..8a64750751 100755
--- a/extra/ui/gadgets/worlds/worlds-docs.factor
+++ b/extra/ui/gadgets/worlds/worlds-docs.factor
@@ -13,6 +13,15 @@ HELP: set-title
 { $description "Sets the title bar of the native window containing the world." }
 { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
 
+HELP: set-fullscreen?
+{ $values { "?" "a boolean" } { "world" world } }
+{ $description "Sets and unsets fullscreen mode for the world." }
+{ $notes "Find a world using " { $link find-world } "." } ;
+
+HELP: fullscreen?
+{ $values { "world" world } { "?" "a boolean" } }
+{ $description "Queries the world to see if it is running in fullscreen mode." } ;
+
 HELP: raise-window
 { $values { "world" world } }
 { $description "Makes the native window containing the given world the front-most window." }

From e9a63d7a2c2d080e778a3f3e8bd4b99d2867588f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:10:52 -0600
Subject: [PATCH 02/33] Arrggh

---
 extra/concurrency/concurrency.factor | 34 ++++++++++++++++++----------
 1 file changed, 22 insertions(+), 12 deletions(-)

diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index b46439b583..3c8011cc6b 100755
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -264,26 +264,36 @@ PRIVATE>
     #! so the server continuation gets its new self updated.
     self swap call ;
 
-TUPLE: future status value processes ;
+TUPLE: future value processes ;
 
+: notify-future ( value future -- )
+    tuck set-future-value
+    dup future-processes [ schedule-thread ] each
+    f swap set-future-processes ;
+ 
 : future ( quot -- future )
-    #! Spawn a process to call the quotation and immediately return
-    #! a 'future' on the stack. The future can later be queried with
-    #! ?future. If the quotation has completed the result will be returned.
-    #! If not, the process will block until the quotation completes.
-    #! 'quot' must have stack effect ( -- X ).
+    #! Spawn a process to call the quotation and immediately return.
+    \ future construct-empty [
     [
         [
+            >r [ t 2array ] compose [ f 2array ] recover r>
+            notify-future
+        ] 2curry spawn drop
+    ] keep ;
             t 
         ] compose
     ] spawn drop
     [ self send ] compose spawn ;
-
-: ?future ( future -- result )
-    #! Block the process until the future has completed and then
-    #! place the result on the stack. Return the result
-    #! immediately if the future has completed.
-    process-mailbox mailbox-get ;
+ 
+ : ?future ( future -- result )
+     #! Block the process until the future has completed and then
+     #! place the result on the stack. Return the result
+     #! immediately if the future has completed.
+    dup future-value [
+        first2 [ throw ] unless
+    ] [
+        dup [ future-processes push stop ] curry callcc0 ?future
+    ] ?if ;
 
 : parallel-map ( seq quot -- newseq )
     #! Spawn a process to apply quot to each element of seq,

From 3121e740f2838d6d29ef0e1291fd8da670bb2416 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:12:14 -0600
Subject: [PATCH 03/33] Fix typo

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

diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 2977d02c6f..7cf15394ef 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -169,7 +169,7 @@ HELP: rethrow
 
 HELP: throw-restarts
 { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." }
+{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
 { $examples
     "Try invoking one of the two restarts which are offered after the below code throws an error:"
     { $code

From 25c64c8ac713cc94bf706124900f3658e3e34167 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:13:06 -0600
Subject: [PATCH 04/33] Arrghh!!!

---
 extra/concurrency/concurrency.factor | 10 +++-------
 1 file changed, 3 insertions(+), 7 deletions(-)

diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index 3c8011cc6b..50abee8418 100755
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -280,15 +280,11 @@ TUPLE: future value processes ;
             notify-future
         ] 2curry spawn drop
     ] keep ;
-            t 
-        ] compose
-    ] spawn drop
-    [ self send ] compose spawn ;
  
  : ?future ( future -- result )
-     #! Block the process until the future has completed and then
-     #! place the result on the stack. Return the result
-     #! immediately if the future has completed.
+    #! Block the process until the future has completed and then
+    #! place the result on the stack. Return the result
+    #! immediately if the future has completed.
     dup future-value [
         first2 [ throw ] unless
     ] [

From a21781e3807d1c89cba88989cb694e65d81d0ee3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:14:37 -0600
Subject: [PATCH 05/33] Concurrency fix

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

diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index 50abee8418..a8e0bc6eeb 100755
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -270,11 +270,10 @@ TUPLE: future value processes ;
     tuck set-future-value
     dup future-processes [ schedule-thread ] each
     f swap set-future-processes ;
- 
+
 : future ( quot -- future )
     #! Spawn a process to call the quotation and immediately return.
     \ future construct-empty [
-    [
         [
             >r [ t 2array ] compose [ f 2array ] recover r>
             notify-future

From 5ca99b0105c82b881ccb023fee8b502e5a2651ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:17:15 -0600
Subject: [PATCH 06/33] Fix 'class' in early bootstrap

---
 core/classes/classes.factor           | 4 +++-
 core/generic/math/math.factor         | 2 +-
 core/generic/standard/standard.factor | 2 +-
 3 files changed, 5 insertions(+), 3 deletions(-)

diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 151429bf69..345676e106 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -20,7 +20,9 @@ PREDICATE: class tuple-class
 
 : classes ( -- seq ) class<map get keys ;
 
-: type>class ( n -- class ) builtins get nth ;
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 8cf83b0ba7..21a7857646 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
 : math-vtable* ( picker max quot -- quot )
     [
         rot , \ tag ,
-        [ >r [ type>class ] map r> map % ] { } make ,
+        [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
         \ dispatch ,
     ] [ ] make ; inline
 
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 88f6a05bc2..7f4f423d8b 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
     [ small-generic ] picker class-hash-dispatch-quot ;
 
 : vtable-class ( n -- class )
-    type>class [ hi-tag bootstrap-word ] unless* ;
+    bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
 
 : group-methods ( assoc -- vtable )
     #! Input is a predicate -> method association.

From ee912c5996e9342d921c51051cd71001d94b2048 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:17:40 -0600
Subject: [PATCH 07/33] Walker cleanup

---
 extra/ui/tools/walker/walker.factor | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index 4740ff86d4..a23345d214 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/extra/ui/tools/walker/walker.factor
@@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ;
 : walker-active? ( walker -- ? )
     walker-interpreter interpreter-continuation >boolean ;
 
-: walker-command ( gadget quot -- )
-    over walker-active? [ with-walker ] [ 2drop ] if ; inline
-
 : save-interpreter ( walker -- )
     dup walker-interpreter interpreter-continuation clone
     swap walker-history push ;
 
-: com-step ( walker -- )
-    dup save-interpreter [ step ] walker-command ;
+: walker-command ( gadget quot -- )
+    over walker-active? [
+        over save-interpreter
+        with-walker
+    ] [ 2drop ] if ; inline
 
-: com-into ( walker -- )
-    dup save-interpreter [ step-into ] walker-command ;
+: com-step ( walker -- ) [ step ] walker-command ;
 
-: com-out ( walker -- )
-    dup save-interpreter [ step-out ] walker-command ;
+: com-into ( walker -- ) [ step-into ] walker-command ;
+
+: com-out ( walker -- ) [ step-out ] walker-command ;
 
 : com-back ( walker -- )
     dup walker-history

From ef63333980d03f963bb50b076ec52c10923cbcff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 18:12:07 -0600
Subject: [PATCH 08/33] Fix another bug with futures

---
 extra/concurrency/concurrency-tests.factor | 5 +++++
 extra/concurrency/concurrency.factor       | 6 +++---
 2 files changed, 8 insertions(+), 3 deletions(-)

diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor
index 1a19ce7096..8908506d51 100755
--- a/extra/concurrency/concurrency-tests.factor
+++ b/extra/concurrency/concurrency-tests.factor
@@ -133,4 +133,9 @@ SYMBOL: value
 [ 3 3 ] [
     [ 3 ] future
     dup ?future swap ?future
+] unit-test
+
+! Another race
+[ 3 ] [
+    [ 3 yield ] future ?future
 ] unit-test
\ No newline at end of file
diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index a8e0bc6eeb..1c5f6322a8 100755
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -273,14 +273,14 @@ TUPLE: future value processes ;
 
 : future ( quot -- future )
     #! Spawn a process to call the quotation and immediately return.
-    \ future construct-empty [
+    f V{ } clone \ future construct-boa [
         [
             >r [ t 2array ] compose [ f 2array ] recover r>
             notify-future
         ] 2curry spawn drop
     ] keep ;
- 
- : ?future ( future -- result )
+
+: ?future ( future -- result )
     #! Block the process until the future has completed and then
     #! place the result on the stack. Return the result
     #! immediately if the future has completed.

From f655a25762173982ee894d61f7ca755524127aa1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:08:47 -0600
Subject: [PATCH 09/33] Fixing compiler test

---
 core/bootstrap/compiler/compiler.factor       | 11 +++++++++++
 core/compiler/test/simple/simple-tests.factor |  4 +++-
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index ff9d5c5e1e..2b278ac458 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -77,3 +77,14 @@ nl
 [ compiled-usages recompile ] recompile-hook set-global
 
 " done" print flush
+
+! Load empty test vocabs
+USE: compiler.test.curry
+USE: compiler.test.float
+USE: compiler.test.intrinsics
+USE: compiler.test.redefine
+USE: compiler.test.simple
+USE: compiler.test.stack-trace
+USE: compiler.test.templates
+USE: compiler.test.templates-early
+USE: compiler.test.tuples
diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor
index 3f4f6451a3..743fb713d9 100755
--- a/core/compiler/test/simple/simple-tests.factor
+++ b/core/compiler/test/simple/simple-tests.factor
@@ -1,6 +1,6 @@
 USING: compiler tools.test kernel kernel.private
 combinators.private math.private math combinators strings
-alien arrays ;
+alien arrays memory ;
 IN: temporary
 
 ! Test empty word
@@ -48,6 +48,8 @@ IN: temporary
 [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
 [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
 
+[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+
 ! Labels
 
 : recursive ( ? -- ) [ f recursive ] when ; inline

From 93e10566bef56950add23087e64af1e3da3f2575 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:12:00 -0600
Subject: [PATCH 10/33] Simpler compilation of dispatch

---
 core/cpu/architecture/architecture.factor     |  4 +-
 core/cpu/ppc/architecture/architecture.factor | 23 +++++------
 core/cpu/x86/architecture/architecture.factor | 39 ++++++++++---------
 core/generator/generator.factor               | 29 +++++++++-----
 4 files changed, 50 insertions(+), 45 deletions(-)

diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 4da22ff38a..4bb10b23a2 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
 ! Test if vreg is 'f' or not
 HOOK: %jump-t compiler-backend ( label -- )
 
-HOOK: %call-dispatch compiler-backend ( -- label )
-
-HOOK: %jump-dispatch compiler-backend ( -- )
+HOOK: %dispatch compiler-backend ( -- )
 
 HOOK: %dispatch-label compiler-backend ( word -- )
 
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 7444c21a8c..1daf3ac622 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
 M: ppc-backend %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
-: (%dispatch) ( len -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
-    "offset" operand "n" operand 1 SRAWI
-    11 11 "offset" operand ADD
-    11 dup rot cells LWZ ;
-
-M: ppc-backend %call-dispatch ( word-table# -- )
-    [ 7 (%dispatch) (%call) <label> dup B ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-    } with-template ;
-
-M: ppc-backend %jump-dispatch ( -- )
-    [ %epilogue-later 6 (%dispatch) (%jump) ] H{
+M: ppc-backend %dispatch ( -- )
+    [
+        %epilogue-later
+        0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
+        "offset" operand "n" operand 1 SRAWI
+        11 11 "offset" operand ADD
+        11 dup 6 cells LWZ
+        (%jump)
+    ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "offset" } } }
     } with-template ;
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 8c5d5c1dc0..20564bbde3 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
 M: x86-backend %jump-t ( label -- )
     "flag" operand f v>operand CMP JNE ;
 
-: (%dispatch) ( n -- operand )
-    ! Load jump table base. We use a temporary register
-    ! since on AMD64 we have to load a 64-bit immediate. On
-    ! x86, this is redundant.
-    ! Untag and multiply to get a jump table offset
-    "n" operand fixnum>slot@
-    ! Add jump table base
-    "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
-    "n" operand "offset" operand ADD
-    "n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
+: code-alignment ( -- n )
+    building get length dup cell align swap - ;
 
-M: x86-backend %call-dispatch ( word-table# -- )
-    [ 5 (%dispatch) CALL <label> dup JMP ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-        { +clobber+ { "n" } }
-    } with-template ;
+: align-code ( n -- )
+    0 <repetition> % ;
 
-M: x86-backend %jump-dispatch ( -- )
-    [ %epilogue-later 0 (%dispatch) JMP ] H{
+M: x86-backend %dispatch ( -- )
+    [
+        %epilogue-later
+        ! Load jump table base. We use a temporary register
+        ! since on AMD64 we have to load a 64-bit immediate. On
+        ! x86, this is redundant.
+        ! Untag and multiply to get a jump table offset
+        "n" operand fixnum>slot@
+        ! Add jump table base
+        "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
+        "n" operand "offset" operand ADD
+        "n" operand HEX: 7f [+] JMP
+        ! Fix up the displacement above
+        code-alignment dup bootstrap-cell 8 = 14 9 ? +
+        building get dup pop* push
+        align-code
+    ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "offset" } } }
         { +clobber+ { "n" } }
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 3883fb6e35..d8164fdce7 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
 : generate-nodes ( node -- )
     [ node@ generate-node ] iterate-nodes end-basic-block ;
 
+: init-generate-nodes ( -- )
+    init-templates
+    %save-word-xt
+    %prologue-later
+    current-label-start define-label
+    current-label-start resolve-label ;
+    
 : generate ( word label node -- )
     [
-        init-templates
-        %save-word-xt
-        %prologue-later
-        current-label-start define-label
-        current-label-start resolve-label
+        init-generate-nodes
         [ generate-nodes ] with-node-iterator
     ] generate-1 ;
 
@@ -168,17 +171,23 @@ M: #if generate-node
         ] if %dispatch-label
     ] each ;
 
+: generate-dispatch ( node -- )
+    %dispatch dispatch-branches init-templates ;
+
 M: #dispatch generate-node
     #! The order here is important, dispatch-branches must
     #! run after %dispatch, so that each branch gets the
     #! correct register state
     tail-call? [
-        %jump-dispatch dispatch-branches
+        generate-dispatch iterate-next
     ] [
-        0 frame-required
-        %call-dispatch >r dispatch-branches r> resolve-label
-    ] if
-    init-templates iterate-next ;
+        compiling-word get gensym [
+            rot [
+                init-generate-nodes
+                generate-dispatch
+            ] generate-1
+        ] keep generate-call
+    ] if ;
 
 ! #call
 : define-intrinsics ( word intrinsics -- )

From 9d1977eeee3ffd71bf7f7de6a59e6c56eb333bdc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:12:21 -0600
Subject: [PATCH 11/33] Obsolete file

---
 core/compiler/compiler-tests.factor | 7 -------
 1 file changed, 7 deletions(-)
 delete mode 100755 core/compiler/compiler-tests.factor

diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor
deleted file mode 100755
index 7e4e79437d..0000000000
--- a/core/compiler/compiler-tests.factor
+++ /dev/null
@@ -1,7 +0,0 @@
-IN: temporary
-USING: tools.browser tools.test kernel sequences vocabs ;
-
-"compiler.test" child-vocabs empty? [
-    "compiler.test" load-children
-    "compiler.test" test
-] when

From c8f042aef4c9e9d41eb9d81fab7ad2a074f0037e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:34:42 -0600
Subject: [PATCH 12/33] Redo timeouts

---
 core/inference/inference-tests.factor        |  3 +-
 core/io/io-docs.factor                       |  9 +--
 core/io/io.factor                            |  1 -
 core/io/streams/duplex/duplex.factor         |  5 --
 extra/delegate/protocols/protocols.factor    |  2 +-
 extra/http/client/client.factor              |  4 +-
 extra/http/server/server.factor              |  2 +-
 extra/io/launcher/launcher.factor            | 26 +++++---
 extra/io/nonblocking/nonblocking-docs.factor |  2 -
 extra/io/nonblocking/nonblocking.factor      | 56 ++++------------
 extra/io/streams/null/null.factor            |  4 +-
 extra/io/timeouts/timeouts.factor            | 67 ++++++++++++++++++++
 extra/io/unix/backend/backend.factor         |  4 +-
 extra/io/windows/ce/sockets/sockets.factor   |  2 +-
 extra/io/windows/nt/backend/backend.factor   |  2 +-
 extra/io/windows/nt/files/files.factor       | 12 ++--
 extra/io/windows/nt/monitors/monitors.factor |  7 +-
 extra/io/windows/nt/sockets/sockets.factor   |  6 +-
 extra/smtp/server/server.factor              |  4 +-
 extra/smtp/smtp.factor                       |  9 +--
 20 files changed, 129 insertions(+), 98 deletions(-)
 create mode 100755 extra/io/timeouts/timeouts.factor
 mode change 100644 => 100755 extra/smtp/server/server.factor

diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index c5bc3b5fda..2691be8c3a 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
 sequences strings vectors words quotations effects tools.test
 continuations generic.standard sorting assocs definitions
 prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string combinators.private ;
+debugger threads.private io.streams.string io.timeouts
+combinators.private ;
 IN: temporary
 
 { 0 2 } [ 2 "Hello" ] must-infer-as
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index 208e2a2ba7..aff2c6d099 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -21,9 +21,7 @@ $nl
 { $subsection make-span-stream }
 { $subsection make-block-stream }
 { $subsection make-cell-stream }
-{ $subsection stream-write-table }
-"Optional word for network streams:"
-{ $subsection set-timeout } ;
+{ $subsection stream-write-table } ;
 
 ARTICLE: "stdio" "The default stream"
 "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@@ -73,11 +71,6 @@ ARTICLE: "streams" "Streams"
 
 ABOUT: "streams"
 
-HELP: set-timeout
-{ $values { "n" "an integer" } { "stream" "a stream" } }
-{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
-{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
-
 HELP: stream-readln
 { $values { "stream" "an input stream" } { "str" string } }
 { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
diff --git a/core/io/io.factor b/core/io/io.factor
index e0c890c0e3..2d927d088a 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
     continuations assocs io.styles sbufs ;
 IN: io
 
-GENERIC: set-timeout ( n stream -- )
 GENERIC: stream-readln ( stream -- str )
 GENERIC: stream-read1 ( stream -- ch/f )
 GENERIC: stream-read ( n stream -- str/f )
diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor
index 86660b2752..97e60b4a60 100755
--- a/core/io/streams/duplex/duplex.factor
+++ b/core/io/streams/duplex/duplex.factor
@@ -74,8 +74,3 @@ M: duplex-stream dispose
         [ dup duplex-stream-out dispose ]
         [ dup duplex-stream-in dispose ] [ ] cleanup
     ] unless drop ;
-
-M: duplex-stream set-timeout
-    2dup
-    duplex-stream-in set-timeout
-    duplex-stream-out set-timeout ;
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index 1121883b7c..37f3812d2d 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -18,7 +18,7 @@ PROTOCOL: stream-protocol
     stream-read1 stream-read stream-read-until
     stream-flush stream-write1 stream-write stream-format
     stream-nl make-span-stream make-block-stream stream-readln
-    make-cell-stream stream-write-table set-timeout ;
+    make-cell-stream stream-write-table ;
 
 PROTOCOL: definition-protocol
     where set-where forget uses redefined*
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 109bf17c40..679d603708 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
-io io.sockets io.streams.string io.files strings splitting
-continuations assocs.lib ;
+io io.sockets io.streams.string io.files io.timeouts strings
+splitting continuations assocs.lib ;
 IN: http.client
 
 : parse-host ( url -- host port )
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index eca2253e2a..957a82d09f 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces io strings splitting
+USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http http.server.responders sequences prettyprint
 io.server logging ;
 
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 4a6bbf46fb..efcecd50bc 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend system kernel namespaces strings hashtables
-sequences assocs combinators vocabs.loader init threads
-continuations math ;
+USING: io io.backend io.timeouts system kernel namespaces
+strings hashtables sequences assocs combinators vocabs.loader
+init threads continuations math ;
 IN: io.launcher
 
 ! Non-blocking process exit notification facility
@@ -10,14 +10,14 @@ SYMBOL: processes
 
 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
 
-TUPLE: process handle status ;
+TUPLE: process handle status killed? lapse ;
 
 HOOK: register-process io-backend ( process -- )
 
 M: object register-process drop ;
 
 : <process> ( handle -- process )
-    f process construct-boa
+    f f <lapse> process construct-boa
     V{ } clone over processes get set-at
     dup register-process ;
 
@@ -25,6 +25,8 @@ M: process equal? 2drop f ;
 
 M: process hashcode* process-handle hashcode* ;
 
+: process-running? ( process -- ? ) process-status not ;
+
 SYMBOL: +command+
 SYMBOL: +arguments+
 SYMBOL: +detached+
@@ -34,6 +36,7 @@ SYMBOL: +stdin+
 SYMBOL: +stdout+
 SYMBOL: +stderr+
 SYMBOL: +closed+
+SYMBOL: +timeout+
 
 SYMBOL: +prepend-environment+
 SYMBOL: +replace-environment+
@@ -72,13 +75,17 @@ M: assoc >descriptor >hashtable ;
 HOOK: run-process* io-backend ( desc -- handle )
 
 : wait-for-process ( process -- status )
-    dup process-handle [
-        dup [ processes get at push stop ] curry callcc0
-    ] when process-status ;
+    [
+        dup process-handle
+        [ dup [ processes get at push stop ] curry callcc0 ] when
+        dup process-killed?
+        [ "Process was killed" throw ] [ process-status ] if
+    ] with-timeout ;
 
 : run-process ( desc -- process )
     >descriptor
     dup run-process*
+    +timeout+ pick at [ over set-timeout ] when*
     +detached+ rot at [ dup wait-for-process drop ] unless ;
 
 : run-detached ( desc -- process )
@@ -96,8 +103,11 @@ TUPLE: process-failed code ;
 HOOK: kill-process* io-backend ( handle -- )
 
 : kill-process ( process -- )
+    t over set-process-killed?
     process-handle [ kill-process* ] when* ;
 
+M: process timed-out kill-process ;
+
 HOOK: process-stream* io-backend ( desc -- stream process )
 
 TUPLE: process-stream process ;
diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor
index af73a47030..d8d2cf5479 100755
--- a/extra/io/nonblocking/nonblocking-docs.factor
+++ b/extra/io/nonblocking/nonblocking-docs.factor
@@ -38,8 +38,6 @@ $nl
 { $list
     { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
     { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
-    { { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
-    { { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
     { { $link port-type } " - a symbol identifying the port's intended purpose" }
     { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
 } } ;
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 5dbd3d1490..4d8634bde9 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.nonblocking
-USING: math kernel io sequences io.buffers generic sbufs system
-io.streams.lines io.streams.plain io.streams.duplex io.backend
-continuations debugger classes byte-arrays namespaces splitting
-dlists assocs ;
+USING: math kernel io sequences io.buffers io.timeouts generic
+sbufs system io.streams.lines io.streams.plain io.streams.duplex
+io.backend continuations debugger classes byte-arrays namespaces
+splitting dlists assocs ;
 
 SYMBOL: default-buffer-size
 64 1024 * default-buffer-size set-global
@@ -13,9 +13,12 @@ SYMBOL: default-buffer-size
 TUPLE: port
 handle
 error
-timeout-entry timeout cutoff
+lapse
 type eof? ;
 
+! Ports support the lapse protocol
+M: port lapse port-lapse ;
+
 SYMBOL: closed
 
 PREDICATE: port input-port port-type input-port eq? ;
@@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- )
 
 : <port> ( handle buffer type -- port )
     pick init-handle
-    0 0 {
+    <lapse> {
         set-port-handle
         set-delegate
         set-port-type
-        set-port-timeout
-        set-port-cutoff
+        set-port-lapse
     } port construct ;
 
 : <buffered-port> ( handle type -- port )
@@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- )
     [ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
     cleanup ;
 
-: timeout? ( port -- ? )
-    port-cutoff dup zero? not swap millis < and ;
-
 : pending-error ( port -- )
     dup port-error f rot set-port-error [ throw ] when* ;
 
-SYMBOL: timeout-queue
-
-timeout-queue global [ [ <dlist> ] unless* ] change-at
-
-: unqueue-timeout ( port -- )
-    port-timeout-entry [
-        timeout-queue get-global swap delete-node
-    ] when* ;
-
-: queue-timeout ( port -- )
-    dup timeout-queue get-global push-front*
-    swap set-port-timeout-entry ;
-
 HOOK: cancel-io io-backend ( port -- )
 
 M: object cancel-io drop ;
 
-: expire-timeouts ( -- )
-    timeout-queue get-global dup dlist-empty? [ drop ] [
-        dup peek-back timeout?
-        [ pop-back cancel-io expire-timeouts ] [ drop ] if
-    ] if ;
-
-: begin-timeout ( port -- )
-    dup port-timeout dup zero? [
-        2drop
-    ] [
-        millis + over set-port-cutoff
-        dup unqueue-timeout queue-timeout
-    ] if ;
-
-: end-timeout ( port -- )
-    unqueue-timeout ;
-
-: with-port-timeout ( port quot -- )
-    over begin-timeout keep end-timeout ; inline
-
-M: port set-timeout set-port-timeout ;
+M: port timed-out cancel-io ;
 
 GENERIC: (wait-to-read) ( port -- )
 
diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor
index f76b0cbce3..d747fa0a29 100755
--- a/extra/io/streams/null/null.factor
+++ b/extra/io/streams/null/null.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.streams.null
-USING: kernel io continuations ;
+USING: kernel io io.timeouts continuations ;
 
 TUPLE: null-stream ;
 
 M: null-stream dispose drop ;
-M: null-stream set-timeout 2drop ;
+M: null-stream set-timeout drop ;
 M: null-stream stream-readln drop f ;
 M: null-stream stream-read1 drop f ;
 M: null-stream stream-read-until 2drop f f ;
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
new file mode 100755
index 0000000000..67bc3a4783
--- /dev/null
+++ b/extra/io/timeouts/timeouts.factor
@@ -0,0 +1,67 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math system dlists namespaces assocs init threads
+io.streams.duplex ;
+IN: io.timeouts
+
+TUPLE: lapse entry timeout cutoff ;
+
+: <lapse> f 0 0 \ lapse construct-boa ;
+
+GENERIC: lapse ( obj -- lapse )
+GENERIC: set-timeout ( ms obj -- )
+
+M: object set-timeout lapse set-lapse-timeout ;
+
+M: duplex-stream set-timeout
+    2dup
+    duplex-stream-in set-timeout
+    duplex-stream-out set-timeout ;
+
+: timeout ( obj -- ms ) lapse lapse-timeout ;
+: entry ( obj -- dlist-node ) lapse lapse-entry ;
+: set-entry ( dlist-node -- obj ) lapse set-lapse-entry ;
+: cutoff ( obj -- ms ) lapse lapse-cutoff ;
+: set-cutoff ( ms obj -- ) lapse set-lapse-cutoff ;
+
+SYMBOL: timeout-queue
+
+: timeout? ( lapse -- ? )
+    cutoff dup zero? not swap millis < and ;
+
+timeout-queue global [ [ <dlist> ] unless* ] change-at
+
+: unqueue-timeout ( obj -- )
+    entry [
+        timeout-queue get-global swap delete-node
+    ] when* ;
+
+: queue-timeout ( obj -- )
+    dup timeout-queue get-global push-front*
+    swap set-entry ;
+
+GENERIC: timed-out ( obj -- )
+
+M: object timed-out drop ;
+
+: expire-timeouts ( -- )
+    timeout-queue get-global dup dlist-empty? [ drop ] [
+        dup peek-back timeout?
+        [ pop-back timed-out expire-timeouts ] [ drop ] if
+    ] if ;
+
+: begin-timeout ( obj -- )
+    dup timeout dup zero? [
+        2drop
+    ] [
+        millis + over set-cutoff
+        dup unqueue-timeout queue-timeout
+    ] if ;
+
+: with-timeout ( obj quot -- )
+    over begin-timeout keep unqueue-timeout ; inline
+
+: expiry-thread ( -- )
+    expire-timeouts 5000 sleep expire-timeouts ;
+
+[ expiry-thread ] "io.timeouts" add-init-hook
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 7112c48551..1547ecec65 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- )
     mx get-global register-io-task stop ;
 
 : with-port-continuation ( port quot -- port )
-    [ callcc0 ] curry with-port-timeout ; inline
+    [ callcc0 ] curry with-timeout ; inline
 
 M: mx unregister-io-task ( task mx -- )
     fd/container delete-at drop ;
@@ -178,7 +178,7 @@ M: port port-flush ( port -- )
     dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
 
 M: unix-io io-multiplex ( ms -- )
-    expire-timeouts mx get-global wait-for-events ;
+    mx get-global wait-for-events ;
 
 M: unix-io init-stdio ( -- )
     0 1 handle>duplex-stream io:stdio set-global
diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor
index 9114dceb75..e9ca6220af 100755
--- a/extra/io/windows/ce/sockets/sockets.factor
+++ b/extra/io/windows/ce/sockets/sockets.factor
@@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client )
             ] keep
         ] keep server-port-addr parse-sockaddr swap
         <win32-socket> dup handle>duplex-stream <client-stream>
-    ] with-port-timeout ;
+    ] with-timeout ;
 
 M: windows-ce-io <datagram> ( addrspec -- datagram )
     [
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 760bcec457..597bc99be2 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -91,7 +91,7 @@ M: windows-nt-io cancel-io
     port-handle win32-file-handle CancelIo drop ;
 
 M: windows-nt-io io-multiplex ( ms -- )
-    expire-timeouts drain-overlapped ;
+    drain-overlapped ;
 
 M: windows-nt-io init-io ( -- )
     <master-completion-port> master-completion-port set-global
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index a1c331816c..ecc989530e 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,8 +1,8 @@
 USING: continuations destructors io.buffers io.files io.backend
-io.nonblocking io.windows io.windows.nt.backend kernel libc math
-threads windows windows.kernel32 alien.c-types alien.arrays
-sequences combinators combinators.lib sequences.lib ascii
-splitting alien strings ;
+io.timeouts io.nonblocking io.windows io.windows.nt.backend
+kernel libc math threads windows windows.kernel32 alien.c-types
+alien.arrays sequences combinators combinators.lib sequences.lib
+ascii splitting alien strings ;
 IN: io.windows.nt.files
 
 M: windows-nt-io cwd
@@ -98,7 +98,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     ] if ;
 
 : flush-output ( port -- )
-    [ [ (flush-output) ] with-port-timeout ] with-destructors ;
+    [ [ (flush-output) ] with-timeout ] with-destructors ;
 
 M: port port-flush
     dup buffer-empty? [ dup flush-output ] unless drop ;
@@ -122,4 +122,4 @@ M: port port-flush
     ] [ 2drop ] if ;
 
 M: input-port (wait-to-read) ( port -- )
-    [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ;
+    [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index a593e829fe..a7a1e2f485 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -3,8 +3,9 @@
 USING: alien.c-types destructors io.windows
 io.windows.nt.backend kernel math windows windows.kernel32
 windows.types libc assocs alien namespaces continuations
-io.monitors io.monitors.private io.nonblocking io.buffers io.files
-io sequences hashtables sorting arrays combinators ;
+io.monitors io.monitors.private io.nonblocking io.buffers
+io.files io.timeouts io sequences hashtables sorting arrays
+combinators ;
 IN: io.windows.nt.monitors
 
 : open-directory ( path -- handle )
@@ -52,7 +53,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
             swap [ save-callback ] 2keep
             dup check-monitor ! we may have closed it...
             get-overlapped-result
-        ] with-port-timeout
+        ] with-timeout
     ] with-destructors ;
 
 : parse-action ( action -- changed )
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index 77249df9f1..eef7476dd5 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -1,6 +1,6 @@
 USING: alien alien.accessors alien.c-types byte-arrays
-continuations destructors io.nonblocking io io.sockets
-io.sockets.impl namespaces io.streams.duplex io.windows
+continuations destructors io.nonblocking io.timeouts io.sockets
+io.sockets.impl io namespaces io.streams.duplex io.windows
 io.windows.nt.backend windows.winsock kernel libc math sequences
 threads tuples.lib ;
 IN: io.windows.nt.sockets
@@ -139,7 +139,7 @@ M: windows-nt-io accept ( server -- client )
             AcceptEx-args-port pending-error
             dup duplex-stream-in pending-error
             dup duplex-stream-out pending-error
-        ] with-port-timeout
+        ] with-timeout
     ] with-destructors ;
 
 M: windows-nt-io <server> ( addrspec -- server )
diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor
old mode 100644
new mode 100755
index 2cfc1e65e4..275deee994
--- a/extra/smtp/server/server.factor
+++ b/extra/smtp/server/server.factor
@@ -27,8 +27,8 @@
 ! bye
 ! Connection closed by foreign host.
 
-USING: combinators kernel prettyprint io io.server sequences
-namespaces io.sockets continuations ;
+USING: combinators kernel prettyprint io io.timeouts io.server
+sequences namespaces io.sockets continuations ;
 
 SYMBOL: data-mode
 
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 211fbbcabd..27aac1202e 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
+! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
+! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces io kernel logging io.sockets sequences
-combinators sequences.lib splitting assocs strings math.parser
-random system calendar ;
+USING: namespaces io io.timeouts kernel logging io.sockets
+sequences combinators sequences.lib splitting assocs strings
+math.parser random system calendar ;
 
 IN: smtp
 

From dd8e38a7f01e8531bcca8fd1e63d7097d5b63d00 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:56:50 -0600
Subject: [PATCH 13/33] Fixing some issues

---
 extra/io/launcher/launcher.factor       |  2 ++
 extra/io/nonblocking/nonblocking.factor |  2 +-
 extra/io/timeouts/timeouts.factor       | 18 +++++++++---------
 3 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index efcecd50bc..17a3e6fd23 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -106,6 +106,8 @@ HOOK: kill-process* io-backend ( handle -- )
     t over set-process-killed?
     process-handle [ kill-process* ] when* ;
 
+M: process get-lapse process-lapse ;
+
 M: process timed-out kill-process ;
 
 HOOK: process-stream* io-backend ( desc -- stream process )
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 4d8634bde9..72507f26b6 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -17,7 +17,7 @@ lapse
 type eof? ;
 
 ! Ports support the lapse protocol
-M: port lapse port-lapse ;
+M: port get-lapse port-lapse ;
 
 SYMBOL: closed
 
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index 67bc3a4783..ddc92a4bdd 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -8,21 +8,21 @@ TUPLE: lapse entry timeout cutoff ;
 
 : <lapse> f 0 0 \ lapse construct-boa ;
 
-GENERIC: lapse ( obj -- lapse )
+GENERIC: get-lapse ( obj -- lapse )
 GENERIC: set-timeout ( ms obj -- )
 
-M: object set-timeout lapse set-lapse-timeout ;
+M: object set-timeout get-lapse set-lapse-timeout ;
 
 M: duplex-stream set-timeout
     2dup
     duplex-stream-in set-timeout
     duplex-stream-out set-timeout ;
 
-: timeout ( obj -- ms ) lapse lapse-timeout ;
-: entry ( obj -- dlist-node ) lapse lapse-entry ;
-: set-entry ( dlist-node -- obj ) lapse set-lapse-entry ;
-: cutoff ( obj -- ms ) lapse lapse-cutoff ;
-: set-cutoff ( ms obj -- ) lapse set-lapse-cutoff ;
+: timeout ( obj -- ms ) get-lapse lapse-timeout ;
+: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
+: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
+: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
+: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
 
 SYMBOL: timeout-queue
 
@@ -62,6 +62,6 @@ M: object timed-out drop ;
     over begin-timeout keep unqueue-timeout ; inline
 
 : expiry-thread ( -- )
-    expire-timeouts 5000 sleep expire-timeouts ;
+    expire-timeouts 5000 sleep expiry-thread ;
 
-[ expiry-thread ] "io.timeouts" add-init-hook
+[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook

From be28fbd45dbd46b8c1393bdaf64947cd67c50d7e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 22:28:22 -0600
Subject: [PATCH 14/33] Document io.timeouts

---
 core/io/io-docs.factor                 |  3 +-
 extra/help/handbook/handbook.factor    |  3 +-
 extra/io/launcher/launcher-docs.factor | 40 +++++++++++++-------------
 extra/io/launcher/launcher.factor      | 12 +++++---
 extra/io/timeouts/timeouts-docs.factor | 32 +++++++++++++++++++++
 extra/io/unix/linux/linux.factor       |  9 +++---
 6 files changed, 69 insertions(+), 30 deletions(-)
 create mode 100755 extra/io/timeouts/timeouts-docs.factor

diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index aff2c6d099..9c73a3b2b1 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -21,7 +21,8 @@ $nl
 { $subsection make-span-stream }
 { $subsection make-block-stream }
 { $subsection make-cell-stream }
-{ $subsection stream-write-table } ;
+{ $subsection stream-write-table }
+{ $see-also "io.timeouts" } ;
 
 ARTICLE: "stdio" "The default stream"
 "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index d6b4ec7ffe..9472e1f519 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -157,7 +157,8 @@ ARTICLE: "io" "Input and output"
 "Advanced features:"
 { $subsection "io.launcher" }
 { $subsection "io.mmap" }
-{ $subsection "io.monitors" } ;
+{ $subsection "io.monitors" }
+{ $subsection "io.timeouts" } ;
 
 ARTICLE: "tools" "Developer tools"
 { $subsection "tools.annotations" }
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index e414d98d65..4f5a85244b 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -76,6 +76,9 @@ HELP: +append-environment+
 $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
+HELP: +timeout+
+{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+
 HELP: default-descriptor
 { $description "Association storing default values for launch descriptor keys." } ;
 
@@ -94,22 +97,16 @@ HELP: run-process*
 
 HELP: >descriptor
 { $values { "desc" "a launch descriptor" } { "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" }
-    }
-} ;
+{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
 
 HELP: run-process
 { $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
 { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
 
 HELP: run-detached
 { $values { "desc" "a launch descriptor" } { "process" process } }
-{ $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." }
+{ $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 "io.launcher.descriptors" } " for details." }
 { $notes
     "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
     $nl
@@ -162,25 +159,27 @@ HELP: wait-for-process
 { $values { "process" process } { "status" integer } }
 { $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
 
-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:"
+ARTICLE: "io.launcher.descriptors" "Launch descriptors"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
 { $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" }
+    { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
+    { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
+    { "associations can be passed in, which allows finer control over launch parameters" }
 }
-"A launch descriptor is an association containing keys from the below set:"
+"The associations can contain the following keys:"
 { $subsection +command+ }
 { $subsection +arguments+ }
 { $subsection +detached+ }
 { $subsection +environment+ }
 { $subsection +environment-mode+ }
-"Redirecting standard input and output to files:"
+{ $subsection +timeout+ }
 { $subsection +stdin+ }
 { $subsection +stdout+ }
-{ $subsection +stderr+ }
+{ $subsection +stderr+ } ;
+
+ARTICLE: "io.launcher" "Launching OS processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.descriptors" }
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
@@ -193,6 +192,7 @@ $nl
 "A class representing an active or finished process:"
 { $subsection process }
 "Waiting for a process to end, or getting the exit code of a finished process:"
-{ $subsection wait-for-process } ;
+{ $subsection wait-for-process }
+"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
 
 ABOUT: "io.launcher"
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 17a3e6fd23..350743affa 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -66,11 +66,15 @@ SYMBOL: +append-environment+
         { +replace-environment+ [ ] }
     } case ;
 
-GENERIC: >descriptor ( desc -- desc )
+: string-array? ( obj -- ? )
+    dup sequence? [ [ string? ] all? ] [ drop f ] if ;
 
-M: string >descriptor +command+ associate ;
-M: sequence >descriptor +arguments+ associate ;
-M: assoc >descriptor >hashtable ;
+: >descriptor ( desc -- desc )
+    {
+        { [ dup string? ] [ +command+ associate ] }
+        { [ dup string-array? ] [ +arguments+ associate ] }
+        { [ dup assoc? ] [ >hashtable ] }
+    } cond ;
 
 HOOK: run-process* io-backend ( desc -- handle )
 
diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor
new file mode 100755
index 0000000000..a704e3473a
--- /dev/null
+++ b/extra/io/timeouts/timeouts-docs.factor
@@ -0,0 +1,32 @@
+IN: io.timeouts
+USING: help.markup help.syntax math kernel ;
+
+HELP: get-lapse
+{ $values { "obj" object } { "lapse" lapse } }
+{ $contract "Outputs an object's timeout lapse descriptor." } ;
+
+HELP: set-timeout
+{ $values { "ms" integer } { "obj" object } }
+{ $contract "Sets an object's timeout, in milliseconds." }
+{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
+
+HELP: timed-out
+{ $values { "obj" object } }
+{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
+
+HELP: with-timeout
+{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
+
+ARTICLE: "io.timeouts" "I/O timeout protocol"
+"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
+{ $subsection set-timeout }
+"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
+{ $subsection get-lapse }
+{ $subsection timed-out }
+"A combinator to be used in operations which can time out:"
+{ $subsection with-timeout }
+{ $see-also "stream-protocol" "io.launcher" }
+;
+
+ABOUT: "io.timeouts"
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 55f5f01abc..b3bd2eee4e 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.private io.files
-io.buffers io.nonblocking io.unix.backend io.unix.select
-io.unix.launcher unix.linux.inotify assocs namespaces threads
-continuations init math alien.c-types alien vocabs.loader ;
+USING: kernel io.backend io.monitors io.monitors.private
+io.files io.buffers io.nonblocking io.timeouts io.unix.backend
+io.unix.select io.unix.launcher unix.linux.inotify assocs
+namespaces threads continuations init math alien.c-types alien
+vocabs.loader ;
 IN: io.unix.linux
 
 TUPLE: linux-io ;

From b02f42e0d30261bf5706e8b4b16d2f3e633e39c5 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@joy.internal.stack-effects.com>
Date: Sat, 9 Feb 2008 17:18:57 -0600
Subject: [PATCH 15/33] Fix load issue on Unix

---
 extra/io/unix/backend/backend.factor | 2 +-
 extra/io/unix/unix.factor            | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 1547ecec65..7d9f76c686 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -3,7 +3,7 @@
 USING: alien generic assocs kernel kernel.private math
 io.nonblocking sequences strings structs sbufs threads unix
 vectors io.buffers io.backend io.streams.duplex math.parser
-continuations system libc qualified namespaces ;
+continuations system libc qualified namespaces io.timeouts ;
 QUALIFIED: io
 IN: io.unix.backend
 
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 7dc66a05ad..9013df29aa 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,4 +1,4 @@
-USING: io.unix.backend io.unix.files io.unix.sockets
+USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
 io.unix.launcher io.unix.mmap io.backend combinators namespaces
 system vocabs.loader ;
 

From d0ec99ecb6480c571f83f4436a39fc8e5e9e924a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 9 Feb 2008 20:21:41 -0600
Subject: [PATCH 16/33] factor.el: factor-send-region and factor-send-string
 insert the input into the listener

---
 misc/factor.el | 28 ++++++++++++++++++++++++++--
 1 file changed, 26 insertions(+), 2 deletions(-)

diff --git a/misc/factor.el b/misc/factor.el
index a5ba44357f..19b7f28e22 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -131,10 +131,30 @@
   (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
   (comint-send-string "*factor*" " run-file\n"))
 
+;; (defun factor-send-region (start end)
+;;   (interactive "r")
+;;   (comint-send-region "*factor*" start end)
+;;   (comint-send-string "*factor*" "\n"))
+
+(defun factor-send-string (str)
+  (let ((n (length (split-string str "\n"))))
+    (save-excursion
+      (set-buffer "*factor*")
+      (goto-char (point-max))
+      (if (> n 1) (newline))
+      (insert str)
+      (comint-send-input))))
+
 (defun factor-send-region (start end)
   (interactive "r")
-  (comint-send-region "*factor*" start end)
-  (comint-send-string "*factor*" "\n"))
+  (let ((str (buffer-substring start end))
+        (n   (count-lines      start end)))
+    (save-excursion
+      (set-buffer "*factor*")
+      (goto-char (point-max))
+      (if (> n 1) (newline))
+      (insert str)
+      (comint-send-input))))
 
 (defun factor-see ()
   (interactive)
@@ -153,6 +173,10 @@
   (comint-send-string "*factor*" "\\ ")
   (comint-send-string "*factor*" (thing-at-point 'sexp))
   (comint-send-string "*factor*" " edit\n"))
+
+(defun factor-clear ()
+  (interactive)
+  (factor-send-string "clear"))
   
 (defun factor-comment-line ()
   (interactive)

From bf2efa3ecccc79c20d2a0bfce7d458ca6a4b81e2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 9 Feb 2008 20:47:45 -0600
Subject: [PATCH 17/33] io.launcher: fix segmentation fault bug

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

diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 4a6bbf46fb..3f0df4ed18 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -87,7 +87,7 @@ HOOK: run-process* io-backend ( desc -- handle )
 TUPLE: process-failed code ;
 
 : process-failed ( code -- * )
-    process-failed construct-boa throw ;
+    \ process-failed construct-boa throw ;
 
 : try-process ( desc -- )
     run-process wait-for-process dup zero?

From 72313d0b4fd72f6260e1ad705131ed0905436c19 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 00:35:18 -0600
Subject: [PATCH 18/33] io.unix.launcher: Fix io bug which caused problems
 during bootstrap

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

diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 93278e2b1a..c0861788b6 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -49,7 +49,7 @@ MEMO: 'arguments' ( -- parser )
 
 : redirect ( obj mode fd -- )
     {
-        { [ pick not ] [ 3drop ] }
+        { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
         { [ pick +closed+ eq? ] [ close 2drop ] }
         { [ pick string? ] [ (redirect) ] }
     } cond ;

From e0a19714aecd1e5395b166a8ea8425b4aacd20f0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 01:04:14 -0600
Subject: [PATCH 19/33] builder: refactor

---
 extra/builder/builder.factor | 132 +++++++++++++++++++----------------
 1 file changed, 71 insertions(+), 61 deletions(-)

diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 1c5f5ff3fd..7f69f3ef00 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -1,8 +1,9 @@
 
-USING: kernel io io.files io.launcher hashtables
+USING: kernel io io.files io.launcher io.sockets hashtables
        system continuations namespaces sequences splitting math.parser
        prettyprint tools.time calendar bake vars http.client
-       combinators bootstrap.image bootstrap.image.download ;
+       combinators bootstrap.image bootstrap.image.download
+       combinators.cleave ;
 
 IN: builder
 
@@ -29,16 +30,32 @@ IN: builder
 
 SYMBOL: builder-recipients
 
+: tag-subject ( str -- str ) `{ "builder@" ,[ host-name ] ": " , } concat ;
+
+: email-string ( subject -- )
+  `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
+  [ ] with-process-stream drop ;
+
 : email-file ( subject file -- )
   `{
     { +stdin+ , }
-    { +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
+    { +arguments+
+      { "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
   }
   >hashtable run-process drop ;
 
-: email-string ( subject -- )
-  `{ "mutt" "-s" , %[ builder-recipients get ] }
-  [ ] with-process-stream drop ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-or-notify ( desc message -- )
+  [ [ try-process ]        curry ]
+  [ [ email-string throw ] curry ]
+  bi*
+  recover ;
+
+: run-or-send-file ( desc message file -- )
+  >r >r [ try-process ]         curry
+  r> r> [ email-string throw ] 2curry
+  recover ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -59,71 +76,44 @@ VAR: stamp
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: build-status
-
-: build ( -- )
-
-  "running" build-status set-global
-
-  datestamp >stamp
-
-  "/builds/factor" cd
-  
+: git-pull ( -- desc )
   {
     "git"
     "pull"
     "--no-summary"
     "git://factorcode.org/git/factor.git"
     "master"
-  }
-  run-process process-status
-  0 =
-  [ ]
-  [
-    "builder: git pull" email-string
-    "builder: git pull" throw
-  ]
-  if
+  } ;
 
-  {
-    "git" "pull" "--no-summary"
-    "http://dharmatech.onigirihouse.com/factor.git" "master"
-  } run-process drop
+: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
-  "/builds/" stamp> append make-directory
-  "/builds/" stamp> append cd
-
-  { "git" "clone" "../factor" } run-process drop
-
-  "factor" cd
+: enter-build-dir ( -- )
+  datestamp >stamp
+  "/builds" cd
+  stamp> make-directory
+  stamp> cd ;
 
+: record-git-id ( -- )
   { "git" "show" } <process-stream> [ readln ] with-stream " " split second
-  "../git-id" log-object
+  "../git-id" log-object ;
 
-  { "make" "clean" } run-process drop
-
-  ! "vm" build-status set-global
+: make-clean ( -- desc ) { "make" "clean" } ;
 
+: make-vm ( -- )
   `{
      { +arguments+ { "make" ,[ target ] } }
      { +stdout+    "../compile-log" }
      { +stderr+    +stdout+ }
    }
-  >hashtable run-process process-status
-  0 =
-  [ ]
-  [
-    "builder: vm compile" "../compile-log" email-file
-    "builder: vm compile" throw
-  ] if
+  >hashtable ;
 
+: retrieve-boot-image ( -- )
   [ my-arch download-image ]
   [ ]
   [ "builder: image download" email-string ]
-  cleanup
-
-  ! "bootstrap" build-status set-global
+  cleanup ;
 
+: bootstrap ( -- desc )
   `{
      { +arguments+ {
                      ,[ factor-binary ]
@@ -133,17 +123,39 @@ SYMBOL: build-status
      { +stdout+   "../boot-log" }
      { +stderr+   +stdout+ }
    }
-  >hashtable [ run-process ] "../boot-time" log-runtime process-status
-  0 =
-  [ ]
-  [
-    "builder: bootstrap" "../boot-log" email-file
-    "builder: bootstrap" throw
-  ] if
+  >hashtable ;
 
-  ! "test" build-status set-global
+: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
+  
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-  `{ ,[ factor-binary ] "-run=builder.test" } run-process drop
+SYMBOL: build-status
+
+: build ( -- )
+
+  "running" build-status set-global
+
+  "/builds/factor" cd
+
+  git-pull "git pull error" run-or-notify
+
+  enter-build-dir
+  
+  git-clone "git clone error" run-or-notify
+
+  "factor" cd
+
+  record-git-id
+
+  make-clean "make clean error" run-or-notify
+
+  make-vm "vm compile error" "../compile-log" run-or-send-file
+
+  retrieve-boot-image
+
+  bootstrap "bootstrap error" "../boot-log" run-or-send-file
+
+  builder-test "builder.test fatal error" run-or-notify
   
   "../load-everything-log" exists?
   [ "builder: load-everything" "../load-everything-log" email-file ]
@@ -153,9 +165,7 @@ SYMBOL: build-status
   [ "builder: failing tests" "../failing-tests" email-file ]
   when
 
-  ! "ready" build-status set-global
-
-  ;
+  "ready" build-status set-global ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

From 4231bdb55849cac662d7d762511f17e833e087cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 23:13:55 -0800
Subject: [PATCH 20/33] Fix 64-bit port

---
 core/cpu/x86/64/64.factor                     | 3 ++-
 core/cpu/x86/architecture/architecture.factor | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 745b6efd2d..2996a3feeb 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
 namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting assocs ;
+alien alien.accessors alien.compiler alien.structs slots
+splitting assocs ;
 IN: cpu.x86.64
 
 PREDICATE: x86-backend amd64-backend
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 20564bbde3..49b05ea48f 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -96,7 +96,7 @@ M: x86-backend %dispatch ( -- )
         "n" operand "offset" operand ADD
         "n" operand HEX: 7f [+] JMP
         ! Fix up the displacement above
-        code-alignment dup bootstrap-cell 8 = 14 9 ? +
+        code-alignment dup bootstrap-cell 8 = 15 9 ? +
         building get dup pop* push
         align-code
     ] H{

From ce1602bc2c989fe6257998a61af0cba61624c502 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:16 -0600
Subject: [PATCH 21/33] Fix 64-bit bootstrap

---
 core/bootstrap/image/image.factor | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 7452e31cf8..9fb80da948 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,8 +135,10 @@ SYMBOL: undefined-quot
 
 : here-as ( tag -- pointer ) here swap bitor ;
 
+USE: continuations
+
 : align-here ( -- )
-    here 8 mod 4 = [ 0 emit ] when ;
+    here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
@@ -177,6 +179,7 @@ GENERIC: ' ( obj -- ptr )
     [ dup bignum-bits neg shift swap bignum-radix bitand ]
     [ ] unfold nip ;
 
+USE: continuations
 : emit-bignum ( n -- )
     dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
     dup length 1+ emit-fixnum
@@ -215,8 +218,8 @@ M: f '
 : -1, -1 >bignum ' -1-offset fixup ;
 
 ! Beginning of the image
-
-: begin-image ( -- ) emit-header t, 0, 1, -1, ;
+: begin-image ( -- )
+    emit-header t, 0, 1, -1, ;
 
 ! Words
 
@@ -426,8 +429,8 @@ PRIVATE>
 : make-image ( arch -- )
     architecture [
         prepare-image
-        begin-image
         "resource:/core/bootstrap/stage1.factor" run-file
+        begin-image
         end-image
         image get
         architecture get boot-image-name resource-path

From 765f9bfb43f122210e93ab27e82a3ceb0141be80 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:26 -0600
Subject: [PATCH 22/33] Fix regression

---
 core/inference/backend/backend.factor | 1 +
 core/inference/inference-tests.factor | 5 +++++
 2 files changed, 6 insertions(+)

diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index b839b047d6..ba65d2508c 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
             init-inference
             dependencies off
             dup word-def over dup infer-quot-recursive
+            end-infer
             finish-word
             current-effect
         ] with-scope
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 2691be8c3a..7a4176abfb 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -537,3 +537,8 @@ TUPLE: custom-error ;
 ! This was a false trigger of the undecidable quotation
 ! recursion bug
 { 2 1 } [ find-last-sep ] must-infer-as
+
+! Regression
+: missing->r-check >r ;
+
+[ [ missing->r-check ] infer ] must-fail

From 6bf808172b707e8b13a295796db6bdf9f807e335 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:51 -0600
Subject: [PATCH 23/33] Add watch-vars

---
 extra/tools/annotations/annotations.factor | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor
index 6dee51cbc0..eed23e8bc1 100755
--- a/extra/tools/annotations/annotations.factor
+++ b/extra/tools/annotations/annotations.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words parser io inspector quotations sequences
-prettyprint continuations effects definitions compiler.units ;
+prettyprint continuations effects definitions compiler.units
+namespaces assocs ;
 IN: tools.annotations
 
 : reset ( word -- )
@@ -49,6 +50,16 @@ IN: tools.annotations
 : watch ( word -- )
     dup [ (watch) ] annotate ;
 
+: (watch-vars) ( quot word vars -- newquot )
+    [
+        "--- Entering: " write swap .
+        "--- Variable values:" print
+        [ dup get ] H{ } map>assoc describe
+    ] 2curry swap compose ;
+
+: watch-vars ( word vars -- )
+    dupd [ (watch-vars) ] 2curry annotate ;
+
 : breakpoint ( word -- )
     [ \ break add* ] annotate ;
 

From f052852a274092f89cd682e2174b6173004946b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:58 -0600
Subject: [PATCH 24/33] Fix must-fail-with

---
 extra/tools/test/test.factor | 8 +-------
 1 file changed, 1 insertion(+), 7 deletions(-)

diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 0b5e436e44..5673e41c62 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -40,14 +40,8 @@ SYMBOL: this-test
     dup word? [ 1quotation ] when
     [ infer drop ] curry [ ] swap unit-test ;
 
-TUPLE: expected-error ;
-
-M: expected-error summary
-    drop
-    "The unit test expected the quotation to throw an error" ;
-
 : must-fail-with ( quot pred -- )
-    >r [ expected-error construct-empty throw ] compose r>
+    >r [ f ] compose r>
     [ recover ] 2curry
     [ t ] swap unit-test ;
 

From b120abcee28427e014800ea50825d66e632fa260 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:21 -0600
Subject: [PATCH 25/33] Fix duplex-stream set-timeout

---
 extra/io/timeouts/timeouts.factor | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index ddc92a4bdd..001f59368e 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -8,15 +8,14 @@ TUPLE: lapse entry timeout cutoff ;
 
 : <lapse> f 0 0 \ lapse construct-boa ;
 
+! Won't need this with new slot accessors
 GENERIC: get-lapse ( obj -- lapse )
+
 GENERIC: set-timeout ( ms obj -- )
 
-M: object set-timeout get-lapse set-lapse-timeout ;
+M: object set-timeout get-lapse set-timeout ;
 
-M: duplex-stream set-timeout
-    2dup
-    duplex-stream-in set-timeout
-    duplex-stream-out set-timeout ;
+M: lapse set-timeout set-lapse-timeout ;
 
 : timeout ( obj -- ms ) get-lapse lapse-timeout ;
 : entry ( obj -- dlist-node ) get-lapse lapse-entry ;
@@ -24,6 +23,16 @@ M: duplex-stream set-timeout
 : cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
 : set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
 
+! Won't need this with inheritance
+TUPLE: duplex-stream-lapse stream ;
+
+M: duplex-stream-lapse set-timeout
+    duplex-stream-lapse-stream 2dup
+    duplex-stream-in set-timeout
+    duplex-stream-out set-timeout ;
+
+M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
+
 SYMBOL: timeout-queue
 
 : timeout? ( lapse -- ? )

From 619d676af6baae569e33ff4fa981d997bdc130a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:37 -0600
Subject: [PATCH 26/33] logging.server fixes

---
 extra/logging/insomniac/insomniac.factor |  2 +-
 extra/logging/logging.factor             | 10 +++++++---
 extra/logging/server/server.factor       |  2 +-
 3 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor
index d79eca3495..09c6763657 100755
--- a/extra/logging/insomniac/insomniac.factor
+++ b/extra/logging/insomniac/insomniac.factor
@@ -42,7 +42,7 @@ SYMBOL: insomniac-recipients
 : email-log-report ( service word-names -- )
     "logging.insomniac" [ (email-log-report) ] with-logging ;
 
-: schedule-insomniac ( alist -- )
+: schedule-insomniac ( service word-names -- )
     { 25 } { 6 } f f f <when> -rot [
         [ email-log-report ] assoc-each rotate-logs
     ] 2curry schedule ;
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index d4f0bd1fbf..fec0c3660f 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency
 words kernel arrays shuffle tools.annotations
 prettyprint.config prettyprint debugger io.streams.string
 splitting continuations effects arrays.lib parser strings
-combinators.lib ;
+combinators.lib quotations ;
 IN: logging
 
 SYMBOL: DEBUG
@@ -112,9 +112,13 @@ PRIVATE>
 
 : log-critical ( error word -- ) CRITICAL (log-error) ;
 
+: stack-balancer ( effect word -- quot )
+    >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+    swap effect-out length f <repetition> append >quotation ;
+
 : error-logging-quot ( quot word -- quot' )
-    dup stack-effect effect-in length
-    [ >r log-error r> ndrop ] 2curry
+    [ [ log-error ] curry ] keep
+    [ stack-effect ] keep stack-balancer compose
     [ recover ] 2curry ;
 
 : add-error-logging ( word level -- )
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 198ae47a79..05029df1d0 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -84,7 +84,7 @@ SYMBOL: log-files
     (close-logs)
     log-root directory [ drop rotate-log ] assoc-each ;
 
-: log-server-loop
+: log-server-loop ( -- )
     [
         receive unclip {
             { "log-message" [ (log-message) ] }

From 4514971c7bc8d9d4aa6a40a774ab4c5fcf8de73b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:48 -0600
Subject: [PATCH 27/33] webapps.planet fix

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

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index a9fd443fe6..3e008d049d 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -86,8 +86,8 @@ SYMBOL: last-update
 \ fetch-feed DEBUG add-error-logging
 
 : fetch-blogroll ( blogroll -- entries )
-    dup 0 <column>
-    swap [ fetch-feed ] parallel-map
+    dup 0 <column> swap 1 <column>
+    [ fetch-feed ] parallel-map
     [ [ <posting> ] with map ] 2map concat ;
 
 : sort-entries ( entries -- entries' )
@@ -120,9 +120,6 @@ SYMBOL: last-update
     { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
     { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
     { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
-    { "Kevin Marshall"
-    "http://blog.botfu.com/?cat=9&feed=atom"
-    "http://blog.botfu.com/" }
     { "Kio M. Smallwood"
     "http://sekenre.wordpress.com/feed/atom/"
     "http://sekenre.wordpress.com/" }

From ab63c7254cf44275f216dc048905158fcc1b3bca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:02 -0600
Subject: [PATCH 28/33] Improved left/right arrow keys in editor gadget

---
 extra/ui/gadgets/editors/editors.factor | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index e2df6a343b..a6674aef5f 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -363,9 +363,21 @@ editor "clipboard" f {
     { T{ cut-action } cut }
 } define-command-map
 
-: previous-character T{ char-elt } editor-prev ;
+: previous-character ( editor -- )
+    dup gadget-selection? [
+        dup selection-start/end drop
+        over set-caret mark>caret
+    ] [
+        T{ char-elt } editor-prev
+    ] if ;
 
-: next-character T{ char-elt } editor-next ;
+: next-character ( editor -- )
+    dup gadget-selection? [
+        dup selection-start/end nip
+        over set-caret mark>caret
+    ] [
+        T{ char-elt } editor-next
+    ] if ;
 
 : previous-line T{ line-elt } editor-prev ;
 

From 2ecd1ba127ab1144448c553aef6984bef89d6219 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:17 -0600
Subject: [PATCH 29/33] Improve ratio syntax

---
 core/math/parser/parser.factor        | 11 +++++++----
 extra/math/ratios/ratios-tests.factor |  2 +-
 2 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 64ce296a0b..68c4768c87 100755
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -41,6 +41,9 @@ DEFER: base>
 <PRIVATE
 
 SYMBOL: radix
+SYMBOL: negative?
+
+: sign negative? get "-" "+" ? ;
 
 : with-radix ( radix quot -- )
     radix swap with-variable ; inline
@@ -48,7 +51,7 @@ SYMBOL: radix
 : (base>) ( str -- n ) radix get base> ;
 
 : whole-part ( str -- m n )
-    "+" split1 >r (base>) r>
+    sign split1 >r (base>) r>
     dup [ (base>) ] [ drop 0 swap ] if ;
 
 : string>ratio ( str -- a/b )
@@ -70,7 +73,7 @@ PRIVATE>
 
 : base> ( str radix -- n/f )
     [
-        "-" ?head >r
+        "-" ?head dup negative? set >r
         {
             { [ CHAR: / over member? ] [ string>ratio ] }
             { [ CHAR: . over member? ] [ string>float ] }
@@ -114,9 +117,9 @@ M: integer >base
 M: ratio >base
     [
         [
-            dup 0 < [ "-" % neg ] when
+            dup 0 < dup negative? set [ "-" % neg ] when
             1 /mod
-            >r dup zero? [ drop ] [ (>base) % "+" % ] if r>
+            >r dup zero? [ drop ] [ (>base) % sign % ] if r>
             dup numerator (>base) %
             "/" %
             denominator (>base) %
diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor
index 858a7b0544..4dba49b908 100755
--- a/extra/math/ratios/ratios-tests.factor
+++ b/extra/math/ratios/ratios-tests.factor
@@ -107,6 +107,6 @@ unit-test
 unit-test
 
 [ 3 ] [ "1+1/2" string>number 2 * ] unit-test
-[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
+[ -3 ] [ "-1-1/2" string>number 2 * ] unit-test
 [ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
 [ "1/8" ] [ 1 8 / number>string ] unit-test

From 125e949200e296865587036f3afa154d85714885 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:51 -0600
Subject: [PATCH 30/33] Add new "refs" command to FEP, finds references to an
 object

---
 vm/debug.c  | 91 +++++++++++++++++++++++++++++++++++++++--------------
 vm/debug.h  |  2 +-
 vm/factor.c |  4 +--
 3 files changed, 70 insertions(+), 27 deletions(-)
 mode change 100644 => 100755 vm/debug.h

diff --git a/vm/debug.c b/vm/debug.c
index 01e1ab0f43..a080a6cab2 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -21,7 +21,7 @@ void print_word(F_WORD* word, CELL nesting)
 	else
 	{
 		printf("#<not a string: ");
-		print_nested_obj(word->name,nesting - 1);
+		print_nested_obj(word->name,nesting);
 		printf(">");
 	}
 }
@@ -44,13 +44,13 @@ void print_array(F_ARRAY* array, CELL nesting)
 	for(i = 0; i < length; i++)
 	{
 		printf(" ");
-		print_nested_obj(array_nth(array,i),nesting - 1);
+		print_nested_obj(array_nth(array,i),nesting);
 	}
 }
 
-void print_nested_obj(CELL obj, CELL nesting)
+void print_nested_obj(CELL obj, F_FIXNUM nesting)
 {
-	if(nesting == 0)
+	if(nesting <= 0)
 	{
 		printf(" ... ");
 		return;
@@ -204,7 +204,7 @@ void dump_objects(F_FIXNUM type)
 		if(type == -1 || type_of(obj) == type)
 		{
 			printf("%lx ",obj);
-			print_nested_obj(obj,1);
+			print_nested_obj(obj,2);
 			printf("\n");
 		}
 	}
@@ -213,36 +213,58 @@ void dump_objects(F_FIXNUM type)
 	gc_off = false;
 }
 
-CELL obj;
-CELL look_for;
-
-void find_references_step(CELL *scan)
+void find_data_references(CELL look_for)
 {
-	if(look_for == *scan)
+	CELL obj;
+
+	void find_references_step(CELL *scan)
 	{
-		printf("%lx ",obj);
-		print_nested_obj(obj,1);
-		printf("\n");
+		if(look_for == *scan)
+		{
+			printf("%lx ",obj);
+			print_nested_obj(obj,2);
+			printf("\n");
+		}
 	}
-}
-
-void find_references(CELL look_for_)
-{
-	look_for = look_for_;
 
 	begin_scan();
 
-	CELL obj_;
-	while((obj_ = next_object()) != F)
-	{
-		obj = obj_;
-		do_slots(obj_,find_references_step);
-	}
+	while((obj = next_object()) != F)
+		do_slots(UNTAG(obj),find_references_step);
 
 	/* end scan */
 	gc_off = false;
 }
 
+void find_code_references(CELL look_for)
+{
+	void find_references_step(F_COMPILED *compiled, CELL code_start,
+		CELL reloc_start, CELL literals_start)
+	{
+		CELL scan;
+		CELL literal_end = literals_start + compiled->literals_length;
+
+		for(scan = literals_start; scan < literal_end; scan += CELLS)
+		{
+			CELL code_start = (CELL)(compiled + 1);
+			CELL literal_start = code_start
+				+ compiled->code_length
+				+ compiled->reloc_length;
+
+			CELL obj = get(literal_start);
+
+			if(look_for == get(scan))
+			{
+				printf("%lx ",obj);
+				print_nested_obj(obj,2);
+				printf("\n");
+			}
+		}
+	}
+
+	iterate_code_heap(find_references_step);
+}
+
 void factorbug(void)
 {
 	reset_stdio();
@@ -265,6 +287,9 @@ void factorbug(void)
 	printf("addr <card>      -- print address containing card\n");
 	printf("data             -- data heap dump\n");
 	printf("words            -- words dump\n");
+	printf("tuples           -- tuples dump\n");
+	printf("refs <addr>      -- find data heap references to object\n");
+	printf("push <addr>      -- push object on data stack - NOT SAFE\n");
 	printf("code             -- code heap dump\n");
 
 	for(;;)
@@ -335,8 +360,26 @@ void factorbug(void)
 			save_image(STR_FORMAT("fep.image"));
 		else if(strcmp(cmd,"data") == 0)
 			dump_objects(-1);
+		else if(strcmp(cmd,"refs") == 0)
+		{
+			CELL addr;
+			scanf("%lx",&addr);
+			printf("Data heap references:\n");
+			find_data_references(addr);
+			printf("Code heap references:\n");
+			find_code_references(addr);
+			printf("\n");
+		}
 		else if(strcmp(cmd,"words") == 0)
 			dump_objects(WORD_TYPE);
+		else if(strcmp(cmd,"tuples") == 0)
+			dump_objects(TUPLE_TYPE);
+		else if(strcmp(cmd,"push") == 0)
+		{
+			CELL addr;
+			scanf("%lx",&addr);
+			dpush(addr);
+		}
 		else if(strcmp(cmd,"code") == 0)
 			dump_heap(&code_heap);
 		else
diff --git a/vm/debug.h b/vm/debug.h
old mode 100644
new mode 100755
index cfd928bb51..ff8075c457
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -1,5 +1,5 @@
 void print_obj(CELL obj);
-void print_nested_obj(CELL obj, CELL nesting);
+void print_nested_obj(CELL obj, F_FIXNUM nesting);
 void dump_generations(void);
 void factorbug(void);
 
diff --git a/vm/factor.c b/vm/factor.c
index 0754067b95..826ad65324 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -154,6 +154,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 
 	init_factor(&p);
 
+	nest_stacks();
+
 	F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
 
 	for(i = 1; i < argc; i++)
@@ -173,8 +175,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 	userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
 	userenv[EMBEDDED_ENV] = (embedded ? T : F);
 
-	nest_stacks();
-
 	if(p.console)
 		open_console();
 

From d8edd7b0d4e3360ded930d2d8ab78d9aa02b8723 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:49:27 -0600
Subject: [PATCH 31/33] Clean up bootstrap.image

---
 core/bootstrap/image/image.factor | 41 +++++++++++++------------------
 1 file changed, 17 insertions(+), 24 deletions(-)

diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 9fb80da948..4468ecf7d1 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,10 +135,8 @@ SYMBOL: undefined-quot
 
 : here-as ( tag -- pointer ) here swap bitor ;
 
-USE: continuations
-
 : align-here ( -- )
-    here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
+    here 8 mod 4 = [ heap-size drop 0 emit ] when ;
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
@@ -217,10 +215,6 @@ M: f '
 :  1,  1 >bignum '  1-offset fixup ;
 : -1, -1 >bignum ' -1-offset fixup ;
 
-! Beginning of the image
-: begin-image ( -- )
-    emit-header t, 0, 1, -1, ;
-
 ! Words
 
 : emit-word ( word -- )
@@ -388,7 +382,10 @@ M: curry '
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
 
-: end-image ( -- )
+: build-image ( -- image )
+    800000 <vector> image set
+    20000 <hashtable> objects set
+    emit-header t, 0, 1, -1,
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush
@@ -403,7 +400,8 @@ M: curry '
     fixup-header
     "Image length: " write image get length .
     "Object cache size: " write objects get assoc-size .
-    \ word global delete-at ;
+    \ word global delete-at
+    image get ;
 
 ! Image output
 
@@ -414,28 +412,23 @@ M: curry '
         [ >le write ] curry each
     ] if ;
 
-: write-image ( image filename -- )
-    "Writing image to " write dup write "..." print flush
+: write-image ( image -- )
+    "Writing image to " write
+    architecture get boot-image-name resource-path
+    dup write "..." print flush
     <file-writer> [ (write-image) ] with-stream ;
 
-: prepare-image ( -- )
-    bootstrapping? on
-    load-help? off
-    800000 <vector> image set
-    20000 <hashtable> objects set ;
-
 PRIVATE>
 
 : make-image ( arch -- )
-    architecture [
-        prepare-image
+    [
+        architecture set
+        bootstrapping? on
+        load-help? off
         "resource:/core/bootstrap/stage1.factor" run-file
-        begin-image
-        end-image
-        image get
-        architecture get boot-image-name resource-path
+        build-image
         write-image
-    ] with-variable ;
+    ] with-scope ;
 
 : make-images ( -- )
     images [ make-image ] each ;

From ad7ec00c29bcf298b6ad0a8e7f4ac0de55e6527e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 03:01:20 -0600
Subject: [PATCH 32/33] builder: use base portion of hostname

---
 extra/builder/builder.factor | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 7f69f3ef00..8f44093141 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -30,7 +30,9 @@ IN: builder
 
 SYMBOL: builder-recipients
 
-: tag-subject ( str -- str ) `{ "builder@" ,[ host-name ] ": " , } concat ;
+: host-name* ( -- name ) host-name "." split first ;
+
+: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
 
 : email-string ( subject -- )
   `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
@@ -158,11 +160,11 @@ SYMBOL: build-status
   builder-test "builder.test fatal error" run-or-notify
   
   "../load-everything-log" exists?
-  [ "builder: load-everything" "../load-everything-log" email-file ]
+  [ "load-everything" "../load-everything-log" email-file ]
   when
 
   "../failing-tests" exists?
-  [ "builder: failing tests" "../failing-tests" email-file ]
+  [ "failing tests" "../failing-tests" email-file ]
   when
 
   "ready" build-status set-global ;

From e7bf56ad57398e586e109b51b20a1e576d866d27 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 03:05:34 -0600
Subject: [PATCH 33/33] builder: fix run-or-send-file bug

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

diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 8f44093141..a17afb9d55 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -56,7 +56,7 @@ SYMBOL: builder-recipients
 
 : run-or-send-file ( desc message file -- )
   >r >r [ try-process ]         curry
-  r> r> [ email-string throw ] 2curry
+  r> r> [ email-file throw ] 2curry
   recover ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!