Merge branch 'master' of http://factorcode.org/git/factor into semantic-db

Conflicts:

	extra/db/sqlite/sqlite.factor

core/alien/compiler/compiler.factor

@@ -367,7 +367,7 @@ TUPLE: callback-context ;
     ] if ;
 
 : do-callback ( quot token -- )
-    init-error-handler
+    init-catchstack
     dup 2 setenv
     slip
     wait-to-return ; inline

core/bootstrap/stage1.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: bootstrap.stage1
 USING: arrays debugger generic hashtables io assocs
 kernel.private kernel math memory namespaces parser
 prettyprint sequences vectors words system splitting
 init io.files bootstrap.image bootstrap.image.private vocabs
-vocabs.loader system ;
+vocabs.loader system debugger continuations ;
 
 { "resource:core" } vocab-roots set
 
@@ -40,7 +40,14 @@ vocabs.loader system ;
     [
         "resource:core/bootstrap/stage2.factor"
         dup resource-exists? [
-            run-file
+            [ run-file ]
+            [
+                :c
+                dup print-error flush
+                "listener" vocab
+                [ restarts. vocab-main execute ]
+                [ die ] if*
+            ] recover
         ] [
             "Cannot find " write write "." print
             "Please move " write image write " to the same directory as the Factor sources," print

core/bootstrap/stage2.factor

@@ -51,7 +51,7 @@ SYMBOL: bootstrap-time
 ! Wrap everything in a catch which starts a listener so
 ! you can see what went wrong, instead of dealing with a
 ! fep
-[
+
 ! We time bootstrap
 millis >r
 
@@ -108,9 +108,3 @@ SYMBOL: bootstrap-time
 
     "output-image" get resource-path save-image-and-exit
 ] if
-] [
-    :c
-    print-error restarts.
-    "listener" vocab-main execute
-    1 exit
-] recover

core/continuations/continuations-docs.factor

@@ -193,6 +193,3 @@ HELP: save-error
 { $values { "error" "an error" } }
 { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
 $low-level-note ;
-
-HELP: init-error-handler
-{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;

core/continuations/continuations.factor

@@ -6,6 +6,7 @@ IN: continuations
 
 SYMBOL: error
 SYMBOL: error-continuation
+SYMBOL: error-thread
 SYMBOL: restarts
 
 <PRIVATE
@@ -24,6 +25,8 @@ SYMBOL: restarts
     #! with a declaration.
     f { object } declare ;
 
+: init-catchstack V{ } clone 1 setenv ;
+
 PRIVATE>
 
 : catchstack ( -- catchstack ) catchstack* clone ; inline
@@ -169,17 +172,3 @@ M: condition compute-restarts
     condition-continuation
     [ <restart> ] curry { } assoc>map
     append ;
-
-<PRIVATE
-
-: init-error-handler ( -- )
-    V{ } clone set-catchstack
-    ! VM calls on error
-    [
-        continuation error-continuation set-global rethrow
-    ] 5 setenv
-    ! VM adds this to kernel errors, so that user-space
-    ! can identify them
-    "kernel-error" 6 setenv ;
-
-PRIVATE>

core/debugger/debugger-docs.factor

@@ -1,6 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system ;
+help generic.standard continuations system debugger.private ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"
@@ -80,9 +80,6 @@ HELP: print-error
 HELP: restarts.
 { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
 
-HELP: debug-help
-{ $description "Print a synopsis of useful debugger words." } ;
-
 HELP: error-hook
 { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
 { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
@@ -169,3 +166,6 @@ HELP: depth
 HELP: assert-depth
 { $values { "quot" "a quotation" } }
 { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
+
+HELP: init-debugger
+{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;

core/debugger/debugger.factor

@@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private
 strings io.styles vectors words system splitting math.parser
 tuples continuations continuations.private combinators
 generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs ;
+generic.standard vocabs threads threads.private init
+kernel.private libc ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -57,19 +58,6 @@ M: string error. print ;
         dup length [ restart. ] 2each
     ] if ;
 
-: debug-help ( -- )
-    nl
-    "Debugger commands:" print
-    nl
-    ":help - documentation for this error" print
-    ":s    - data stack at exception time" print
-    ":r    - retain stack at exception time" print
-    ":c    - call stack at exception time" print
-    ":edit - jump to source location (parse errors only)" print
-
-    ":get  ( var -- value ) accesses variables at time of the error" print
-    flush ;
-
 : print-error ( error -- )
     [ error. flush ] curry
     [ global [ "Error in print-error!" print drop ] bind ]
@@ -77,7 +65,12 @@ M: string error. print ;
 
 SYMBOL: error-hook
 
-[ print-error restarts. debug-help ] error-hook set-global
+[
+    print-error
+    restarts.
+    nl
+    "Type :help for debugging help." print flush
+] error-hook set-global
 
 : try ( quot -- )
     [ error-hook get call ] recover ;
@@ -260,3 +253,49 @@ M: no-compilation-unit error.
 
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
+
+M: check-ptr summary
+    drop "Memory allocation failed" ;
+
+M: double-free summary
+    drop "Free failed since memory is not allocated" ;
+
+M: realloc-error summary
+    drop "Memory reallocation failed" ;
+
+: error-in-thread. ( -- )
+    error-thread get-global
+    "Error in thread " write
+    [
+        dup thread-id #
+        " (" % dup thread-name %
+        ", " % dup thread-quot unparse-short % ")" %
+    ] "" make swap write-object ":" print nl ;
+
+! Hooks
+M: thread error-in-thread ( error thread -- )
+    initial-thread get-global eq? [
+        die drop
+    ] [
+        global [
+            error-in-thread. print-error flush
+        ] bind
+    ] if ;
+
+<PRIVATE
+
+: init-debugger ( -- )
+    V{ } clone set-catchstack
+    ! VM calls on error
+    [
+        self error-thread set-global
+        continuation error-continuation set-global
+        rethrow
+    ] 5 setenv
+    ! VM adds this to kernel errors, so that user-space
+    ! can identify them
+    "kernel-error" 6 setenv ;
+
+PRIVATE>
+
+[ init-debugger ] "debugger" add-init-hook

core/init/init-tests.factor

@@ -0,0 +1,7 @@
+IN: temporary
+USING: init namespaces sequences math tools.test kernel ;
+
+[ t ] [
+    init-hooks get [ first "libc" = ] find drop
+    init-hooks get [ first "io.backend" = ] find drop <
+] unit-test

core/init/init.factor

@@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop
     dup init-hooks get at [ over call ] unless
     init-hooks get set-at ;
 
-: boot ( -- ) init-namespaces init-error-handler ;
+: boot ( -- ) init-namespaces init-catchstack ;
 
 : boot-quot ( -- quot ) 20 getenv ;
 

core/io/files/files.factor

@@ -142,7 +142,6 @@ DEFER: copy-tree-to
 
 : copy-tree ( from to -- )
     over directory? [
-        dup make-directories
         >r dup directory swap r> [
             >r swap first path+ r> copy-tree-to
         ] 2curry each

core/libc/libc.factor

@@ -2,7 +2,7 @@
 ! Copyright (C) 2007 Slava Pestov
 ! Copyright (C) 2007 Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations init inspector kernel namespaces ;
+USING: alien assocs continuations init kernel namespaces ;
 IN: libc
 
 <PRIVATE
@@ -25,28 +25,22 @@ PRIVATE>
 
 TUPLE: check-ptr ;
 
-M: check-ptr summary drop "Memory allocation failed" ;
-
 : check-ptr ( c-ptr -- c-ptr )
     [ \ check-ptr construct-boa throw ] unless* ;
 
 TUPLE: double-free ;
 
-M: double-free summary drop "Free failed since memory is not allocated" ;
-
 : double-free ( -- * )
     \ double-free construct-empty throw ;
 
 TUPLE: realloc-error ptr size ;
 
-M: realloc-error summary drop "Memory reallocation failed" ;
-
 : realloc-error ( alien size -- * )
     \ realloc-error construct-boa throw ;
 
 <PRIVATE
 
-[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
+[ H{ } clone mallocs set-global ] "libc" add-init-hook
 
 : add-malloc ( alien -- )
     dup mallocs get-global set-at ;

core/sequences/sequences-docs.factor

@@ -429,7 +429,7 @@ HELP: collect
 
 HELP: each
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
-{ $description "Applies the quotation to each element of the sequence in turn." } ;
+{ $description "Applies the quotation to each element of the sequence in order." } ;
 
 HELP: reduce
 { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
@@ -447,7 +447,7 @@ HELP: accumulate
 
 HELP: map
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ;
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
 
 HELP: change-nth
 { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }

core/threads/threads.factor

@@ -4,13 +4,12 @@
 IN: threads
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators debugger prettyprint io init
+dlists assocs system combinators init boxes ;
-boxes ;
 
 SYMBOL: initial-thread
 
 TUPLE: thread
-name quot error-handler exit-handler
+name quot exit-handler
 id
 continuation state
 mailbox variables sleep-entry ;
@@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at
 
 PRIVATE>
 
-: <thread> ( quot name error-handler -- thread )
+: <thread> ( quot name -- thread )
     \ thread counter <box> [ ] {
         set-thread-quot
         set-thread-name
-        set-thread-error-handler
         set-thread-id
         set-thread-continuation
         set-thread-exit-handler
@@ -179,20 +177,8 @@ M: real sleep
         ] 1 (throw)
     ] "spawn" suspend 2drop ;
 
-: default-thread-error-handler ( error thread -- )
-    global [
-        "Error in thread " write
-        dup thread-id pprint
-        " (" write
-        dup thread-name pprint ")" print
-        "spawned to call " write
-        thread-quot short.
-        nl
-        print-error flush
-    ] bind ;
-
 : spawn ( quot name -- thread )
-    [ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
+    <thread> [ (spawn) ] keep ;
 
 : spawn-server ( quot name -- thread )
     >r [ [ ] [ ] while ] curry r> spawn ;
@@ -202,6 +188,8 @@ M: real sleep
     [ >r set-namestack set-datastack r> call ] 3curry
     "Thread" spawn drop ;
 
+GENERIC: error-in-thread ( error thread -- )
+
 <PRIVATE
 
 : init-threads ( -- )
@@ -209,13 +197,13 @@ M: real sleep
     <dlist> 42 setenv
     <min-heap> 43 setenv
     initial-thread global
-    [ drop f "Initial" [ die ] <thread> ] cache
+    [ drop f "Initial" <thread> ] cache
     <box> over set-thread-continuation
     f over set-thread-state
     dup register-thread
     set-self ;
 
-[ self dup thread-error-handler call stop ]
+[ self error-in-thread stop ]
 thread-error-hook set-global
 
 PRIVATE>

extra/benchmark/crc32/crc32.factor

@@ -0,0 +1,10 @@
+USING: io.crc32 io.files kernel math ;
+IN: benchmark.crc32
+
+: crc32-primes-list ( -- )
+    10 [
+        "extra/math/primes/list/list.factor" resource-path
+        file-contents crc32 drop
+    ] times ;
+
+MAIN: crc32-primes-list

extra/benchmark/md5/md5.factor

@@ -0,0 +1,7 @@
+USING: crypto.md5 io.files kernel ;
+IN: benchmark.md5
+
+: md5-primes-list ( -- )
+    "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+
+MAIN: md5-primes-list

extra/benchmark/random/random.factor

@@ -0,0 +1,14 @@
+USING: io.files random math.parser io math ;
+IN: benchmark.random
+
+: random-numbers-path "random-numbers.txt" temp-file ;
+
+: write-random-numbers ( n -- )
+    random-numbers-path [
+        [ 200 random 100 - number>string print ] times
+    ] with-file-writer ;
+
+: random-main ( -- )
+    1000000 write-random-numbers ;
+
+MAIN: random-main

extra/benchmark/sort/sort.factor

@@ -1,7 +1,8 @@
-USING: kernel sequences sorting random ;
+USING: kernel sequences sorting benchmark.random math.parser
+io.files ;
 IN: benchmark.sort
 
 : sort-benchmark
-    100000 [ drop 100000 random ] map natural-sort drop ;
+    random-numbers-path file-lines [ string>number ] map natural-sort drop ;
 
 MAIN: sort-benchmark

extra/benchmark/sum-file/sum-file.factor

@@ -1,4 +1,5 @@
-USING: io io.files math math.parser kernel prettyprint ;
+USING: io io.files math math.parser kernel prettyprint
+benchmark.random ;
 IN: benchmark.sum-file
 
 : sum-file-loop ( n -- n' )
@@ -8,6 +9,6 @@ IN: benchmark.sum-file
     [ 0 sum-file-loop ] with-file-reader . ;
 
 : sum-file-main ( -- )
-    home "sum-file-in.txt" path+ sum-file ;
+    random-numbers-path sum-file ;
 
 MAIN: sum-file-main

extra/combinators/lib/lib.factor

@@ -3,7 +3,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel combinators namespaces quotations hashtables
 sequences assocs arrays inference effects math math.ranges
-arrays.lib shuffle macros bake combinators.cleave ;
+arrays.lib shuffle macros bake combinators.cleave
+continuations ;
 
 IN: combinators.lib
 
@@ -167,3 +168,6 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 
 : and? ( obj quot1 quot2 -- ? )
     >r keep r> rot [ call ] [ 2drop f ] if ; inline
+
+: retry ( quot n -- )
+    swap [ drop ] swap compose attempt-all ;

extra/concurrency/combinators/combinators-tests.factor

@@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
 [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
 
 [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
-[ linked-error "Even" = ] must-fail-with
+[ delegate "Even" = ] must-fail-with
 
 [ V{ 0 3 6 9 } ]
 [ 10 [ 3 mod zero? ] parallel-subset ] unit-test

extra/concurrency/flags/flags-docs.factor

@@ -14,6 +14,10 @@ HELP: raise-flag
 { $values { "flag" flag } }
 { $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
 
+HELP: wait-for-flag
+{ $values { "flag" flag } }
+{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ;
+
 HELP: lower-flag
 { $values { "flag" flag } }
 { $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
@@ -26,8 +30,9 @@ $nl
 "Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
 { $subsection flag }
 { $subsection flag? }
-"Raising and lowering flags:"
+"Waiting for a flag to be raised:"
 { $subsection raise-flag }
+{ $subsection wait-for-flag }
 { $subsection lower-flag } ;
 
 ABOUT: "concurrency.flags"

extra/concurrency/flags/flags.factor

@@ -13,9 +13,14 @@ TUPLE: flag value? thread ;
         [ resume ] [ drop t over set-flag-value? ] if
     ] unless drop ;
 
+: wait-for-flag ( flag -- )
+    dup flag-value? [ drop ] [
+        [ flag-thread >box ] curry "flag" suspend drop
+    ] if ;
+
 : lower-flag ( flag -- )
     dup flag-value? [
         f swap set-flag-value?
     ] [
-        [ flag-thread >box ] curry "flag" suspend drop
+        wait-for-flag
     ] if ;

extra/concurrency/locks/locks-tests.factor

@@ -174,5 +174,5 @@ threads sequences calendar ;
     ] ;
 
 [ lock-timeout-test ] [
-    linked-thread thread-name "Lock timeout-er" =
+    linked-error-thread thread-name "Lock timeout-er" =
 ] must-fail-with

extra/concurrency/mailboxes/mailboxes.factor

@@ -65,12 +65,23 @@ TUPLE: mailbox threads data ;
 : mailbox-get? ( pred mailbox -- obj )
     f mailbox-get-timeout? ; inline
 
-TUPLE: linked error thread ;
+TUPLE: linked-error thread ;
 
-C: <linked> linked
+: <linked-error> ( error thread -- linked )
+    { set-delegate set-linked-error-thread }
+    linked-error construct ;
 
-: ?linked dup linked? [ rethrow ] when ;
+: ?linked dup linked-error? [ rethrow ] when ;
+
+TUPLE: linked-thread supervisor ;
+
+M: linked-thread error-in-thread
+    [ <linked-error> ] keep
+    linked-thread-supervisor mailbox-put ;
+
+: <linked-thread> ( quot name mailbox -- thread' )
+    >r <thread> linked-thread construct-delegate r>
+    over set-linked-thread-supervisor ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
-    [ >r <linked> r> mailbox-put ] curry <thread>
+    <linked-thread> [ (spawn) ] keep ;
-    [ (spawn) ] keep ;

extra/concurrency/messaging/messaging-tests.factor

@@ -29,7 +29,7 @@ IN: temporary
         "crash" throw
     ] "Linked test" spawn-linked drop
     receive
-] [ linked-error "crash" = ] must-fail-with
+] [ delegate "crash" = ] must-fail-with
 
 MATCH-VARS: ?from ?to ?value ;
 SYMBOL: increment

extra/concurrency/messaging/messaging.factor

@@ -32,7 +32,7 @@ M: thread send ( message thread -- )
     my-mailbox swap mailbox-get-timeout? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    >r <linked> r> send ;
+    >r <linked-error> r> send ;
 
 : spawn-linked ( quot name -- thread )
     my-mailbox spawn-linked-to ;

extra/db/db.factor

@@ -5,29 +5,36 @@ namespaces sequences sequences.lib tuples words strings
 tools.walker ;
 IN: db
 
-TUPLE: db handle ;
+TUPLE: db
-! TUPLE: db handle insert-statements update-statements delete-statements ;
+    handle
+    insert-statements
+    update-statements
+    delete-statements ;
+
 : <db> ( handle -- obj )
-    ! H{ } clone H{ } clone H{ } clone
+    H{ } clone H{ } clone H{ } clone
     db construct-boa ;
 
 GENERIC: make-db* ( seq class -- db )
-: make-db ( seq class -- db ) construct-empty make-db* ;
 GENERIC: db-open ( db -- )
 HOOK: db-close db ( handle -- )
+: make-db ( seq class -- db ) construct-empty make-db* ;
 
 : dispose-statements ( seq -- )
     [ dispose drop ] assoc-each ;
 
 : dispose-db ( db -- ) 
     dup db [
-        ! dup db-insert-statements dispose-statements
+        dup db-insert-statements dispose-statements
-        ! dup db-update-statements dispose-statements
+        dup db-update-statements dispose-statements
-        ! dup db-delete-statements dispose-statements
+        dup db-delete-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
+TUPLE: simple-statement ;
+TUPLE: prepared-statement ;
+TUPLE: result-set sql params handle n max ;
 : <statement> ( sql in out -- statement )
     {
         set-statement-sql
@@ -35,17 +42,11 @@ TUPLE: statement handle sql in-params out-params bind-params bound? ;
         set-statement-out-params
     } statement construct ;
 
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-
 HOOK: <simple-statement> db ( str in out -- statement )
 HOOK: <prepared-statement> db ( str in out -- statement )
 GENERIC: prepare-statement ( statement -- )
-GENERIC: bind-statement* ( obj statement -- )
+GENERIC: bind-statement* ( statement -- )
-GENERIC: reset-statement ( statement -- )
 GENERIC: bind-tuple ( tuple statement -- )
-
-TUPLE: result-set sql params handle n max ;
 GENERIC: query-results ( query -- result-set )
 GENERIC: #rows ( result-set -- n )
 GENERIC: #columns ( result-set -- n )
@@ -61,9 +62,8 @@ GENERIC: more-rows? ( result-set -- ? )
     ] if ;
 
 : bind-statement ( obj statement -- )
-    dup statement-bound? [ dup reset-statement ] when
-    [ bind-statement* ] 2keep
     [ set-statement-bind-params ] keep
+    [ bind-statement* ] keep
     t swap set-statement-bound? ;
 
 : init-result-set ( result-set -- )
@@ -104,7 +104,6 @@ GENERIC: more-rows? ( result-set -- ? )
 : do-bound-command ( obj query -- )
     [ bind-statement ] keep execute-statement ;
 
-
 SYMBOL: in-transaction
 HOOK: begin-transaction db ( -- )
 HOOK: commit-transaction db ( -- )

extra/db/postgresql/postgresql.factor

@@ -38,10 +38,7 @@ M: postgresql-db db-open ( db -- )
 M: postgresql-db dispose ( db -- )
     db-handle PQfinish ;
 
-M: postgresql-statement bind-statement* ( seq statement -- )
+M: postgresql-statement bind-statement* ( statement -- )
-    set-statement-bind-params ;
-
-M: postgresql-statement reset-statement ( statement -- )
     drop ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )

extra/db/sqlite/sqlite.factor

@@ -4,7 +4,8 @@ USING: alien arrays assocs classes compiler db
 hashtables io.files io.files.tmp kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types combinators tools.walker ;
+words combinators.lib db.types combinators tools.walker
+combinators.cleave ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -37,14 +38,13 @@ M: sqlite-db <simple-statement> ( str in out -- obj )
     <prepared-statement> ;
 
 M: sqlite-db <prepared-statement> ( str in out -- obj )
-    db get db-handle 
     {
         set-statement-sql
         set-statement-in-params
         set-statement-out-params
-        set-statement-handle
     } statement construct
-    dup statement-handle over statement-sql sqlite-prepare over set-statement-handle
+    db get db-handle over statement-sql sqlite-prepare
+    over set-statement-handle
     sqlite-statement construct-delegate ;
 
 M: sqlite-statement dispose ( statement -- )
@@ -53,20 +53,32 @@ M: sqlite-statement dispose ( statement -- )
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
 
-: sqlite-bind ( specs handle -- )
+: sqlite-bind ( triples handle -- )
-    swap [ sqlite-bind-type ] with each ;
+    swap [ first3 sqlite-bind-type ] with each ;
 
-M: sqlite-statement bind-statement* ( obj statement -- )
+: reset-statement ( statement -- )
-    statement-handle sqlite-bind ;
-
-M: sqlite-statement reset-statement ( statement -- )
     statement-handle sqlite-reset ;
 
+M: sqlite-statement bind-statement* ( statement -- )
+    dup statement-bound? [ dup reset-statement ] when
+    [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ;
+
+M: sqlite-statement bind-tuple ( tuple statement -- )
+    [
+        statement-in-params
+        [
+            [ sql-spec-column-name ":" swap append ]
+            [ sql-spec-slot-name rot get-slot-named ]
+            [ sql-spec-type ] tri 3array
+        ] with map
+    ] keep
+    [ set-statement-bind-params ] keep bind-statement* ;
+
 : last-insert-id ( -- id )
     db get db-handle sqlite3_last_insert_rowid
     dup zero? [ "last-id failed" throw ] when ;
 
-M: sqlite-statement insert-tuple* ( tuple statement -- )
+M: sqlite-db insert-tuple* ( tuple statement -- )
     execute-statement last-insert-id swap set-primary-key ;
 
 M: sqlite-result-set #columns ( result-set -- n )
@@ -134,7 +146,7 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
 
 : where-primary-key% ( specs -- )
     " where " 0%
-    find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
+    find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
 
 M: sqlite-db <update-tuple-statement> ( class -- statement )
     [
@@ -142,7 +154,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
         0%
         " set " 0%
         dup remove-id
-        [ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
+        [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
         where-primary-key%
     ] sqlite-make ;
 
@@ -151,7 +163,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
         "delete from " 0% 0%
         " where " 0%
         find-primary-key
-        sql-spec-column-name dup 0% " = " 0% bind%
+        dup sql-spec-column-name 0% " = " 0% bind%
     ] sqlite-make ;
 
 ! : select-interval ( interval name -- ) ;
@@ -159,8 +171,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
 
 M: sqlite-db bind% ( spec -- )
     dup 1, sql-spec-column-name ":" swap append 0% ;
-    ! dup 1, sql-spec-column-name
-    ! dup 0% " = " 0% ":" swap append 0% ;
 
 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
@@ -208,7 +218,3 @@ M: sqlite-db type-table ( -- assoc )
 
 M: sqlite-db create-type-table
     type-table ;
-
-! HOOK: get-column-value ( n result-set type -- )
-! M: sqlite get-column-value { { "TEXT" get-text-column } { 
-! "INTEGER" get-integer-column } ... } case ;

extra/db/tuples/tuples-tests.factor

@@ -22,6 +22,7 @@ SYMBOL: the-person2
 : test-tuples ( -- )
     [ person drop-table ] [ drop ] recover
     [ ] [ person create-table ] unit-test
+    [ person create-table ] must-fail
     
     [ ] [ the-person1 get insert-tuple ] unit-test
 
@@ -66,8 +67,8 @@ person "PERSON"
 "billy" 10 3.14 <person> the-person1 set
 "johnny" 10 3.14 <person> the-person2 set
 
-! test-sqlite
+test-sqlite
-test-postgresql
+! test-postgresql
 
 person "PERSON"
 {
@@ -80,8 +81,8 @@ person "PERSON"
 1 "billy" 10 3.14 <assigned-person> the-person1 set
 2 "johnny" 10 3.14 <assigned-person> the-person2 set
 
-! test-sqlite
+test-sqlite
-test-postgresql
+! test-postgresql
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
@@ -108,11 +109,11 @@ annotation "ANNOTATION"
     { "contents" "CONTENTS" TEXT }
 } define-persistent
 
-{ "localhost" "postgres" "" "factor-test" } postgresql-db [
+! { "localhost" "postgres" "" "factor-test" } postgresql-db [
-    [ paste drop-table ] [ drop ] recover
+    ! [ paste drop-table ] [ drop ] recover
-    [ annotation drop-table ] [ drop ] recover
+    ! [ annotation drop-table ] [ drop ] recover
-    [ paste drop-table ] [ drop ] recover
+    ! [ paste drop-table ] [ drop ] recover
-    [ annotation drop-table ] [ drop ] recover
+    ! [ annotation drop-table ] [ drop ] recover
-    [ ] [ paste create-table ] unit-test
+    ! [ ] [ paste create-table ] unit-test
-    [ ] [ annotation create-table ] unit-test
+    ! [ ] [ annotation create-table ] unit-test
-] with-db
+! ] with-db

extra/db/tuples/tuples.factor

@@ -26,14 +26,14 @@ IN: db.tuples
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
-HOOK: <insert-native-statement> db ( tuple -- obj )
+HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( tuple -- obj )
+HOOK: <insert-assigned-statement> db ( class -- obj )
 
-HOOK: <update-tuple-statement> db ( tuple -- obj )
+HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <update-tuples-statement> db ( tuple -- obj )
+HOOK: <update-tuples-statement> db ( class -- obj )
 
-HOOK: <delete-tuple-statement> db ( tuple -- obj )
+HOOK: <delete-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuples-statement> db ( tuple -- obj )
+HOOK: <delete-tuples-statement> db ( class -- obj )
 
 HOOK: <select-by-slots-statement> db ( tuple -- tuple )
 
@@ -63,15 +63,27 @@ HOOK: insert-tuple* db ( tuple statement -- )
 : sql-props ( class -- columns table )
     dup db-columns swap db-table ;
 
-: create-table ( class -- ) create-sql-statement execute-statement ;
+: with-disposals ( seq quot -- )
-: drop-table ( class -- ) drop-sql-statement execute-statement ;
+    over sequence? [
+        [ with-disposal ] curry each
+    ] [
+        with-disposal
+    ] if ;
+
+: create-table ( class -- )
+    create-sql-statement [ execute-statement ] with-disposals ;
+
+: drop-table ( class -- )
+    drop-sql-statement [ execute-statement ] with-disposals ;
 
 : insert-native ( tuple -- )
-    dup class <insert-native-statement>
+    dup class
+    db get db-insert-statements [ <insert-native-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
 : insert-assigned ( tuple -- )
-    dup class <insert-assigned-statement>
+    dup class
+    db get db-insert-statements [ <insert-assigned-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
@@ -83,19 +95,18 @@ HOOK: insert-tuple* db ( tuple statement -- )
     ] if ;
 
 : update-tuple ( tuple -- )
-    dup class <update-tuple-statement>
+    dup class
+    db get db-update-statements [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: update-tuples ( seq -- )
-    <update-tuples-statement> execute-statement ;
-
 : delete-tuple ( tuple -- )
-    dup class <delete-tuple-statement>
+    dup class
+    db get db-delete-statements [ <delete-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: setup-select ( tuple -- statement )
+: select-tuples ( tuple -- tuple )
-    dup dup class <select-by-slots-statement>
+    dup dup class <select-by-slots-statement> [
-    [ bind-tuple ] keep ;
+        [ bind-tuple ] keep query-tuples
+    ] with-disposal ;
 
-: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
 : select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

extra/hello-world/deploy.factor

@@ -1,13 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-c-types? f }
+    { deploy-io 2 }
-    { deploy-ui? f }
-    { deploy-reflection 1 }
     { deploy-math? f }
+    { deploy-threads? f }
+    { deploy-compiler? f }
     { deploy-word-props? f }
     { deploy-word-defs? f }
     { deploy-name "Hello world (console)" }
+    { deploy-reflection 2 }
+    { deploy-c-types? f }
+    { deploy-ui? f }
     { "stop-after-last-window?" t }
-    { deploy-compiler? f }
-    { deploy-io 2 }
 }

extra/help/handbook/handbook.factor

@@ -199,6 +199,7 @@ ARTICLE: "tools" "Developer tools"
 "Debugging tools:"
 { $subsection "tools.annotations" }
 { $subsection "tools.test" }
+{ $subsection "tools.threads" }
 "Performance tools:"
 { $subsection "tools.memory" }
 { $subsection "profiling" }

extra/help/help.factor

@@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
 
 : (:help-multi)
     "This error has multiple delegates:" print
-    ($index) nl ;
+    ($index) nl
+    "Use \\ ... help to get help about a specific delegate." print ;
 
 : (:help-none)
     drop "No help for this error. " print ;
 
+: (:help-debugger)
+    nl
+    "Debugger commands:" print
+    nl
+    ":help - documentation for this error" print
+    ":s    - data stack at exception time" print
+    ":r    - retain stack at exception time" print
+    ":c    - call stack at exception time" print
+    ":edit - jump to source location (parse errors only)" print
+
+    ":get  ( var -- value ) accesses variables at time of the error" print ;
+
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset
     {
         { [ dup empty? ] [ (:help-none) ] }
         { [ dup length 1 = ] [ first help ] }
         { [ t ] [ (:help-multi) ] }
-    } cond ;
+    } cond (:help-debugger) ;
 
 : remove-article ( name -- )
     dup articles get key? [

extra/io/files/temporary/backend/backend.factor

@@ -0,0 +1,5 @@
+USING: io.backend ;
+IN: io.files.temporary.backend
+
+HOOK: (temporary-file) io-backend ( path prefix suffix -- stream path )
+HOOK: temporary-path io-backend ( -- path )

extra/io/files/temporary/temporary.factor

@@ -0,0 +1,36 @@
+USING: kernel math math.bitfields combinators.lib math.parser
+random sequences sequences.lib continuations namespaces
+io.files io.backend io.nonblocking io arrays
+io.files.temporary.backend system combinators vocabs.loader ;
+USE: tools.walker
+IN: io.files.temporary
+
+: random-letter ( -- ch )
+    26 random { CHAR: a CHAR: A } random + ;
+
+: random-ch ( -- ch )
+    { t f } random
+    [ 10 random CHAR: 0 + ] [ random-letter ] if ;
+
+: random-name ( n -- string )
+    [ drop random-ch ] "" map-as ;
+
+: <temporary-file> ( prefix suffix -- path duplex-stream )
+    temporary-path -rot
+    [ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry
+    10 retry ;
+
+: with-temporary-file ( quot -- path )
+    >r f f <temporary-file> r> with-stream ;
+
+: temporary-directory ( -- path )
+    [ temporary-path 10 random-name path+ dup make-directory ] 10 retry ;
+
+: with-temporary-directory ( quot -- )
+    >r temporary-directory r>
+    [ with-directory ] 2keep drop delete-tree ;
+
+{
+    { [ unix? ] [ "io.unix.files.temporary" ] }
+    { [ windows? ] [ "io.windows.files.temporary" ] }
+} cond require

extra/io/monitors/monitors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend kernel continuations namespaces sequences
-assocs hashtables sorting arrays threads boxes ;
+assocs hashtables sorting arrays threads boxes io.timeouts ;
 IN: io.monitors
 
 <PRIVATE
@@ -32,7 +32,11 @@ M: monitor dispose
 
 ! Simple monitor; used on Linux and Mac OS X. On Windows,
 ! monitors are full-fledged ports.
-TUPLE: simple-monitor handle callback ;
+TUPLE: simple-monitor handle callback timeout ;
+
+M: simple-monitor timeout simple-monitor-timeout ;
+
+M: simple-monitor set-timeout set-simple-monitor-timeout ;
 
 : <simple-monitor> ( handle -- simple-monitor )
     f (monitor) <box> {
@@ -47,9 +51,14 @@ TUPLE: simple-monitor handle callback ;
 : notify-callback ( simple-monitor -- )
     simple-monitor-callback ?box [ resume ] [ drop ] if ;
 
+M: simple-monitor timed-out
+    notify-callback ;
+
 M: simple-monitor fill-queue ( monitor -- )
+    [
         [ swap simple-monitor-callback >box ]
         "monitor" suspend drop
+    ] with-timeout
     check-monitor ;
 
 M: simple-monitor dispose ( monitor -- )

extra/io/unix/files/files.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend io.nonblocking io.unix.backend io.files io
-unix kernel math continuations math.bitfields byte-arrays
+unix unix.stat kernel math continuations math.bitfields byte-arrays
 alien ;
+
 IN: io.unix.files
 
 M: unix-io cwd

extra/io/unix/files/temporary/temporary.factor

@@ -0,0 +1,12 @@
+USING: kernel io.nonblocking io.unix.backend math.bitfields
+unix io.files.temporary.backend ;
+IN: io.unix.files.temporary
+
+: open-temporary-flags ( -- flags )
+    { O_RDWR O_CREAT O_EXCL } flags ;
+
+M: unix-io (temporary-file) ( path -- duplex-stream )
+    open-temporary-flags file-mode open dup io-error
+    <writer> ;
+
+M: unix-io temporary-path ( -- path ) "/tmp" ;

extra/io/windows/files/temporary/temporary.factor

@@ -0,0 +1,8 @@
+USING: kernel system ;
+IN: io.windows.files.temporary
+
+M: windows-io (temporary-file) ( path -- stream )
+    GENERIC_WRITE CREATE_NEW 0 open-file 0 <writer> ;
+
+M: windows-io temporary-path ( -- path )
+    "TEMP" os-env ;

extra/math/primes/primes.factor

@@ -47,3 +47,5 @@ PRIVATE>
   primes-upto
   >r 1- next-prime r>
   [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+
+: coprime? ( a b -- ? ) gcd nip 1 = ; foldable

extra/opengl/gl/extensions/extensions.factor

@@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+
 : reset-gl-function-pointers ( -- )
     100 <hashtable> +gl-function-pointers+ set-global ;
     
-[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook
+[ reset-gl-function-pointers ] "opengl.gl" add-init-hook
 reset-gl-function-pointers
 reset-gl-function-number-counter
 

extra/tools/deploy/config/config-docs.factor

@@ -66,6 +66,11 @@ HELP: deploy-math?
 $nl
 "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
+HELP: deploy-threads?
+{ $description "Deploy flag. If set, the deployed image will contain support for threads."
+$nl
+"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
+
 HELP: deploy-compiler?
 { $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
 $nl

extra/tools/deploy/config/config.factor

@@ -10,6 +10,7 @@ SYMBOL: deploy-name
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
+SYMBOL: deploy-threads?
 
 SYMBOL: deploy-io
 
@@ -55,6 +56,7 @@ SYMBOL: deploy-image
         { deploy-io                 2 }
         { deploy-reflection         1 }
         { deploy-compiler?          t }
+        { deploy-threads?           t }
         { deploy-math?              t }
         { deploy-word-props?        f }
         { deploy-word-defs?         f }

extra/tools/deploy/deploy-tests.factor

@@ -0,0 +1,22 @@
+IN: temporary
+USING: tools.test system io.files kernel tools.deploy.config
+tools.deploy.backend math ;
+
+: shake-and-bake
+    "." resource-path [
+        vm
+        "hello.image" temp-file
+        rot dup deploy-config make-deploy-image
+    ] with-directory ;
+
+[ ] [ "hello-world" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 500000 <=
+] unit-test
+
+[ ] [ "hello-ui" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 2000000 <=
+] unit-test

extra/tools/deploy/shaker/shaker.factor

@@ -11,8 +11,16 @@ IN: tools.deploy.shaker
 : strip-init-hooks ( -- )
     "Stripping startup hooks" show
     "command-line" init-hooks get delete-at
-    "mallocs" init-hooks get delete-at
+    "libc" init-hooks get delete-at
-    strip-io? [ "io.backend" init-hooks get delete-at ] when ;
+    deploy-threads? get [
+        "threads" init-hooks get delete-at
+    ] unless
+    native-io? [
+        "io.thread" init-hooks get delete-at
+    ] unless
+    strip-io? [
+        "io.backend" init-hooks get delete-at
+    ] when ;
 
 : strip-debugger ( -- )
     strip-debugger? [
@@ -85,6 +93,7 @@ IN: tools.deploy.shaker
     { } set-retainstack
     V{ } set-namestack
     V{ } set-catchstack
+    
     "Saving final image" show
     [ save-image-and-exit ] call-clear ;
 

extra/tools/deploy/shaker/strip-debugger.factor

@@ -1,6 +1,8 @@
-USING: kernel ;
+USING: kernel threads threads.private ;
 IN: debugger
 
 : print-error die ;
 
 : error. die ;
+
+M: thread error-in-thread ( error thread -- ) die 2drop ;

extra/tools/deploy/windows/windows.factor

@@ -10,10 +10,10 @@ IN: tools.deploy.windows
     vm over copy-file ;
 
 : copy-fonts ( bundle-name -- )
-    "fonts/" resource-path swap copy-tree ;
+    "fonts/" resource-path swap copy-tree-to ;
 
 : copy-dlls ( bundle-name -- )
-    { "freetype6.dll" "zlib1.dll" "factor-nt.dll" }
+    { "freetype6.dll" "zlib1.dll" "factor.dll" }
     [ resource-path ] map
     swap copy-files-to ;
 
@@ -30,10 +30,11 @@ TUPLE: windows-deploy-implementation ;
 T{ windows-deploy-implementation } deploy-implementation set-global
 
 M: windows-deploy-implementation deploy*
-    "." resource-path cd
+    "." resource-path [
         dup deploy-config [
             [ deploy-name get create-exe-dir ] keep
             [ deploy-name get image-name ] keep
             [ namespace make-deploy-image ] keep
             open-in-explorer
-    ] bind ;
+        ] bind
+    ] with-directory ;

extra/tools/disassembler/disassembler.factor

@@ -27,7 +27,7 @@ M: pair make-disassemble-cmd
         +closed+ +stdin+ set
         out-file +stdout+ set
         [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
-    ] { } make-assoc run-process drop
+    ] { } make-assoc try-process
     out-file file-lines ;
 
 : tabs>spaces ( str -- str' )

extra/tools/threads/threads-docs.factor

@@ -0,0 +1,17 @@
+IN: tools.threads
+USING: help.markup help.syntax threads ;
+
+HELP: threads.
+{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
+    { $list
+        "``running'' if the thread is the current thread"
+        "``yield'' if the thread is waiting to run"
+        { "the string given to " { $link suspend } " if the thread is suspended" }
+    }
+} ;
+
+ARTICLE: "tools.threads" "Listing threads"
+"Printing a list of running threads:"
+{ $subsection threads. } ;
+
+ABOUT: "tools.threads"

extra/ui/gadgets/buttons/buttons.factor

@@ -88,7 +88,6 @@ TUPLE: repeat-button ;
 
 repeat-button H{
     { T{ drag } [ button-clicked ] }
-    { T{ button-down } [ button-clicked ] }
 } set-gestures
 
 : <repeat-button> ( label quot -- button )

extra/ui/tools/deploy/deploy.factor

@@ -34,9 +34,10 @@ TUPLE: deploy-gadget vocab settings ;
     "Advanced:" <label> gadget,
     deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
     deploy-math? get "Rational and complex number support" <checkbox> gadget,
-    deploy-word-props? get "Include word properties" <checkbox> gadget,
+    deploy-threads? get "Threading support" <checkbox> gadget,
-    deploy-word-defs? get "Include word definitions" <checkbox> gadget,
+    deploy-word-props? get "Retain all word properties" <checkbox> gadget,
-    deploy-c-types? get "Include C types" <checkbox> gadget, ;
+    deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
+    deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
 
 : deploy-settings-theme
     { 10 10 } over set-pack-gap

extra/ui/tools/interactor/interactor.factor

@@ -1,18 +1,15 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators continuations documents
-ui.tools.workspace hashtables io io.styles kernel math
+ hashtables io io.styles kernel math
 math.vectors models namespaces parser prettyprint quotations
 sequences sequences.lib strings threads listener
 tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar ;
+definitions boxes calendar concurrency.flags ui.tools.workspace ;
 IN: ui.tools.interactor
 
-TUPLE: interactor
+TUPLE: interactor history output flag thread help ;
-history output
-thread quot
-help ;
 
 : interactor-continuation ( interactor -- continuation )
     interactor-thread box-value
@@ -35,12 +32,16 @@ help ;
 : init-interactor-history ( interactor -- )
     V{ } clone swap set-interactor-history ;
 
+: init-interactor-state ( interactor -- )
+    <flag> over set-interactor-flag
+    <box> swap set-interactor-thread ;
+
 : <interactor> ( output -- gadget )
     <source-editor>
     interactor construct-editor
     tuck set-interactor-output
-    <box> over set-interactor-thread
     dup init-interactor-history
+    dup init-interactor-state
     dup init-caret-help ;
 
 M: interactor graft*
@@ -97,7 +98,10 @@ M: interactor model-changed
     ] unless drop ;
 
 : interactor-yield ( interactor -- obj )
-    [ interactor-thread >box ] curry "input" suspend ;
+    [
+        [ interactor-thread >box ] keep
+        interactor-flag raise-flag
+    ] curry "input" suspend ;
 
 M: interactor stream-readln
     [ interactor-yield ] keep interactor-finish ?first ;

extra/ui/tools/listener/listener.factor

@@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
 ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
 ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes ;
+prettyprint listener debugger threads boxes concurrency.flags ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget input output stack ;
@@ -40,9 +40,14 @@ M: listener-gadget call-tool* ( input listener -- )
 M: listener-gadget tool-scroller
     listener-gadget-output find-scroller ;
 
+: wait-for-listener ( listener -- )
+    #! Wait for the listener to start.
+    listener-gadget-input interactor-flag wait-for-flag ;
+
 : workspace-busy? ( workspace -- ? )
-    workspace-listener listener-gadget-input
+    workspace-listener
-    interactor-busy? ;
+    dup wait-for-listener
+    listener-gadget-input interactor-busy? ;
 
 : get-listener ( -- listener )
     [ workspace-busy? not ] get-workspace* workspace-listener ;
@@ -131,10 +136,14 @@ M: stack-display tool-scroller
         listener
     ] with-stream* ;
 
+: start-listener-thread ( listener -- )
+    [ listener-thread ] curry "Listener" spawn drop ;
+
 : restart-listener ( listener -- )
+    #! Returns when listener is ready to receive input.
     dup com-end dup clear-output
-    [ listener-thread ] curry
+    dup start-listener-thread
-    "Listener" spawn drop ;
+    wait-for-listener ;
 
 : init-listener ( listener -- )
     f <model> swap set-listener-gadget-stack ;

extra/ui/tools/tools.factor

@@ -1,15 +1,14 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.browser ui.tools.inspector
+ui.tools.operations ui.tools.traceback ui.tools.browser
-ui.tools.listener ui.tools.profiler
+ui.tools.inspector ui.tools.listener ui.tools.profiler
 ui.tools.operations inspector io kernel math models namespaces
 prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
+ui.gadgets.presentations ui.gestures words vocabs.loader
-vocabs.loader tools.test ui.gadgets.buttons
+tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
-ui.gadgets.status-bar mirrors ;
 IN: ui.tools
 
 : <workspace-tabs> ( -- tabs )
@@ -85,3 +84,11 @@ workspace "workflow" f {
 [
     <workspace> "Factor workspace" open-status-window
 ] workspace-window-hook set-global
+
+: inspect-continuation ( traceback -- )
+    control-value [ inspect ] curry call-listener ;
+
+traceback-gadget "toolbar" f {
+    { T{ key-down f f "v" } variables }
+    { T{ key-down f f "n" } inspect-continuation }
+} define-command-map

extra/ui/tools/traceback/traceback.factor

@@ -1,8 +1,10 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations kernel models namespaces prettyprint ui
 ui.commands ui.gadgets ui.gadgets.labelled assocs
-ui.gadgets.tracks ui.gestures sequences hashtables inspector ;
+ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ui.gadgets.status-bar ui.gadgets.scrollers
+ui.gestures sequences hashtables inspector ;
 IN: ui.tools.traceback
 
 : <callstack-display> ( model -- gadget )
@@ -17,10 +19,6 @@ IN: ui.tools.traceback
     [ [ continuation-retain stack. ] when* ]
     t "Retain stack" <labelled-pane> ;
 
-: <namestack-display> ( model -- gadget )
-    [ [ continuation-name namestack. ] when* ]
-    f "Dynamic variables" <labelled-pane> ;
-
 TUPLE: traceback-gadget ;
 
 M: traceback-gadget pref-dim* drop { 550 600 } ;
@@ -31,11 +29,28 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
             [
                 g gadget-model <datastack-display> 1/2 track,
                 g gadget-model <retainstack-display> 1/2 track,
-            ] { 1 0 } make-track 1/5 track,
+            ] { 1 0 } make-track 1/3 track,
-            g gadget-model <callstack-display> 2/5 track,
+            g gadget-model <callstack-display> 2/3 track,
-            g gadget-model <namestack-display> 2/5 track,
+            toolbar,
         ] with-gadget
     ] keep ;
 
+: <namestack-display> ( model -- gadget )
+    [ [ continuation-name namestack. ] when* ]
+    <pane-control> ;
+
+TUPLE: variables-gadget ;
+
+: <variables-gadget> ( model -- gadget )
+    <namestack-display> <scroller>
+    variables-gadget construct-empty
+    [ set-gadget-delegate ] keep ;
+
+M: variables-gadget pref-dim* drop { 400 400 } ;
+
+: variables ( traceback -- )
+    gadget-model <variables-gadget>
+    "Dynamic variables" open-status-window ;
+
 : traceback-window ( continuation -- )
     <model> <traceback-gadget> "Traceback" open-window ;

extra/ui/tools/walker/walker-docs.factor

@@ -7,5 +7,4 @@ ARTICLE: "ui-walker" "UI walker"
 $nl
 "The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
 { $command-map walker-gadget "toolbar" }
-{ $command-map walker-gadget "other" }
 "Walkers are instances of " { $link walker-gadget } "." ;

extra/ui/tools/walker/walker.factor

@@ -7,7 +7,7 @@ ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
 namespaces tools.walker assocs ;
 IN: ui.tools.walker
 
-TUPLE: walker-gadget status continuation thread ;
+TUPLE: walker-gadget status continuation thread traceback ;
 
 : walker-command ( walker msg -- )
     over walker-gadget-thread thread-registered?
@@ -26,13 +26,12 @@ TUPLE: walker-gadget status continuation thread ;
 
 : com-abandon ( walker -- ) abandon walker-command ;
 
-: com-inspect ( walker -- )
-    walker-continuation model-value
-    [ inspect ] curry call-listener ;
-
 M: walker-gadget ungraft*
     dup delegate ungraft* detach walker-command ;
 
+M: walker-gadget focusable-child*
+    walker-gadget-traceback ;
+
 : walker-state-string ( status thread -- string )
     [
         "Thread: " %
@@ -52,10 +51,10 @@ M: walker-gadget ungraft*
     [ walker-state-string ] curry <filter> <label-control> ;
 
 : <walker-gadget> ( status continuation thread -- gadget )
-    walker-gadget construct-boa [
+    over <traceback-gadget> walker-gadget construct-boa [
         toolbar,
         g walker-gadget-status self <thread-status> f track,
-        g walker-gadget-continuation <traceback-gadget> 1 track,
+        g walker-gadget-traceback 1 track,
     ] { 0 1 } build-track ;
 
 : walker-help "ui-walker" help-window ;
@@ -69,12 +68,8 @@ walker-gadget "toolbar" f {
     { T{ key-down f f "b" } com-back }
     { T{ key-down f f "c" } com-continue }
     { T{ key-down f f "a" } com-abandon }
-    { T{ key-down f f "F1" } walker-help }
-} define-command-map
-
-walker-gadget "other" f {
-    { T{ key-down f f "n" } com-inspect }
     { T{ key-down f f "d" } close-window }
+    { T{ key-down f f "F1" } walker-help }
 } define-command-map
 
 : walker-window ( -- )

extra/unix/stat/linux/32/32.factor

@@ -24,31 +24,10 @@ C-STRUCT: stat
     { "ulong"     "unused4" }
     { "ulong"     "unused5" } ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 FUNCTION: int __xstat  ( int ver, char* pathname, stat* buf ) ;
 FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
 
 :  stat ( pathname buf -- int ) 3 -rot __xstat ;
 : lstat ( pathname buf -- int ) 3 -rot __lxstat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: S_IFMT   OCT: 170000 ; ! These bits determine file type.
-
-: S_IFDIR  OCT:  40000 ;    ! Directory.
-: S_IFCHR  OCT:  20000 ;    ! Character device.
-: S_IFBLK  OCT:  60000 ;    ! Block device.
-: S_IFREG  OCT: 100000 ;    ! Regular file.
-: S_IFIFO  OCT: 010000 ;    ! FIFO.
-: S_IFLNK  OCT: 120000 ;    ! Symbolic link.
-: S_IFSOCK OCT: 140000 ;    ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG  ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR  ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR  ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK  ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK  ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
-

extra/unix/stat/linux/64/64.factor

@@ -29,26 +29,3 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
 
 :  stat ( pathname buf -- int ) 3 -rot __xstat ;
 : lstat ( pathname buf -- int ) 3 -rot __lxstat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: S_IFMT   OCT: 170000 ; ! These bits determine file type.
-
-: S_IFDIR  OCT:  40000 ;    ! Directory.
-: S_IFCHR  OCT:  20000 ;    ! Character device.
-: S_IFBLK  OCT:  60000 ;    ! Block device.
-: S_IFREG  OCT: 100000 ;    ! Regular file.
-: S_IFIFO  OCT: 010000 ;    ! FIFO.
-: S_IFLNK  OCT: 120000 ;    ! Symbolic link.
-: S_IFSOCK OCT: 140000 ;    ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG  ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR  ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR  ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK  ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK  ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
-

extra/unix/stat/macosx/macosx.factor

@@ -27,26 +27,3 @@ C-STRUCT: stat
 
 FUNCTION: int stat  ( char* pathname, stat* buf ) ;
 FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: S_IFMT   OCT: 170000 ; ! These bits determine file type.
-
-: S_IFDIR  OCT:  40000 ;    ! Directory.
-: S_IFCHR  OCT:  20000 ;    ! Character device.
-: S_IFBLK  OCT:  60000 ;    ! Block device.
-: S_IFREG  OCT: 100000 ;    ! Regular file.
-: S_IFIFO  OCT: 010000 ;    ! FIFO.
-: S_IFLNK  OCT: 120000 ;    ! Symbolic link.
-: S_IFSOCK OCT: 140000 ;    ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG  ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR  ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR  ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK  ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK  ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
-

extra/unix/stat/stat.factor

@@ -1,8 +1,62 @@
 
-USING: system combinators vocabs.loader ;
+USING: kernel system combinators alien.syntax math vocabs.loader ;
 
 IN: unix.stat
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! File Types
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: S_IFMT   OCT: 170000 ; ! These bits determine file type.
+
+: S_IFDIR  OCT:  40000 ;    ! Directory.
+: S_IFCHR  OCT:  20000 ;    ! Character device.
+: S_IFBLK  OCT:  60000 ;    ! Block device.
+: S_IFREG  OCT: 100000 ;    ! Regular file.
+: S_IFIFO  OCT: 010000 ;    ! FIFO.
+: S_IFLNK  OCT: 120000 ;    ! Symbolic link.
+: S_IFSOCK OCT: 140000 ;    ! Socket.
+
+: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
+
+: S_ISREG  ( mode -- value ) S_IFREG S_ISTYPE ;
+: S_ISDIR  ( mode -- value ) S_IFDIR S_ISTYPE ;
+: S_ISCHR  ( mode -- value ) S_IFCHR S_ISTYPE ;
+: S_ISBLK  ( mode -- value ) S_IFBLK S_ISTYPE ;
+: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
+: S_ISLNK  ( mode -- value ) S_IFLNK S_ISTYPE ;
+: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! File Access Permissions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Read, write, execute/search by owner
+: S_IRWXU OCT: 0000700 ; inline    ! rwx mask owner
+: S_IRUSR OCT: 0000400 ; inline    ! r owner
+: S_IWUSR OCT: 0000200 ; inline    ! w owner
+: S_IXUSR OCT: 0000100 ; inline    ! x owner
+! Read, write, execute/search by group
+: S_IRWXG OCT: 0000070 ; inline    ! rwx mask group
+: S_IRGRP OCT: 0000040 ; inline    ! r group
+: S_IWGRP OCT: 0000020 ; inline    ! w group
+: S_IXGRP OCT: 0000010 ; inline    ! x group
+! Read, write, execute/search by others
+: S_IRWXO OCT: 0000007 ; inline    ! rwx mask other
+: S_IROTH OCT: 0000004 ; inline    ! r other
+: S_IWOTH OCT: 0000002 ; inline    ! w other
+: S_IXOTH OCT: 0000001 ; inline    ! x other
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION: int chmod ( char* path, mode_t mode ) ;
+
+FUNCTION: int fchmod ( int fd, mode_t mode ) ;
+
+FUNCTION: int mkdir ( char* path, mode_t mode ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 {
   { [ linux? ] [ "unix.stat.linux" require ] }
   { [ t      ] [                           ] }

extra/unix/types/linux/linux.factor

@@ -7,9 +7,9 @@ IN: unix.types
 
 TYPEDEF: ulonglong __uquad_type
 TYPEDEF: ulong     __ulongword_type
-TYPEDEF: uint      __uword_type
+TYPEDEF: long      __sword_type
+TYPEDEF: ulong     __uword_type
 TYPEDEF: long      __slongword_type
-TYPEDEF: int       __sword_type
 TYPEDEF: uint      __u32_type
 TYPEDEF: int       __s32_type 
 

extra/unix/types/macosx/macosx.factor

@@ -1,4 +1,6 @@
 
+USING: alien.syntax ;
+
 IN: unix.types
 
 ! Darwin 9.1.0 ppc

extra/unix/unix.factor

@@ -1,37 +1,15 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: unix
+
 USING: alien alien.c-types alien.syntax kernel libc structs
-math namespaces system combinators vocabs.loader ;
+math namespaces system combinators vocabs.loader unix.types ;
 
-! ! ! Unix types
+IN: unix
 
-TYPEDEF:  long  word
-TYPEDEF: ulong uword
-
-TYPEDEF:  long longword
-TYPEDEF: ulong ulongword
-
-TYPEDEF: long ssize_t
-TYPEDEF: longword blksize_t
-TYPEDEF: longword blkcnt_t
-TYPEDEF: longlong quad_t
-TYPEDEF: ulonglong dev_t
-TYPEDEF: uint gid_t
 TYPEDEF: uint in_addr_t
-TYPEDEF: ulong ino_t
-TYPEDEF: int pid_t
 TYPEDEF: uint socklen_t
 TYPEDEF: uint time_t
-TYPEDEF: uint uid_t
 TYPEDEF: ulong size_t
-TYPEDEF: ulong u_long
-TYPEDEF: uint mode_t
-TYPEDEF: uword nlink_t
-TYPEDEF: void* caddr_t
-
-TYPEDEF: ulong off_t
-TYPEDEF-IF: bsd? ulonglong off_t
 
 C-STRUCT: tm
     { "int" "sec" }    ! Seconds: 0-59 (K&R says 0-61?)
@@ -56,41 +34,6 @@ C-STRUCT: timespec
     [ set-timespec-nsec ] keep
     [ set-timespec-sec ] keep ;
 
-! ! ! Unix constants
-
-! File type
-: S_IFMT    OCT: 0170000 ; inline ! type of file
-: S_IFIFO   OCT: 0010000 ; inline ! named pipe (fifo)
-: S_IFCHR   OCT: 0020000 ; inline ! character special
-: S_IFDIR   OCT: 0040000 ; inline ! directory
-: S_IFBLK   OCT: 0060000 ; inline ! block special
-: S_IFREG   OCT: 0100000 ; inline ! regular
-: S_IFLNK   OCT: 0120000 ; inline ! symbolic link
-: S_IFSOCK  OCT: 0140000 ; inline ! socket
-: S_IFWHT   OCT: 0160000 ; inline ! whiteout
-: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
-
-! File mode
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline    ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline    ! r owner
-: S_IWUSR OCT: 0000200 ; inline    ! w owner
-: S_IXUSR OCT: 0000100 ; inline    ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline    ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline    ! r group
-: S_IWGRP OCT: 0000020 ; inline    ! w group
-: S_IXGRP OCT: 0000010 ; inline    ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline    ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline    ! r other
-: S_IWOTH OCT: 0000002 ; inline    ! w other
-: S_IXOTH OCT: 0000001 ; inline    ! x other
-
-: S_ISUID OCT: 0004000 ; inline    ! set user id on execution
-: S_ISGID OCT: 0002000 ; inline    ! set group id on execution
-: S_ISVTX OCT: 0001000 ; inline    ! sticky bit
-
 : PROT_NONE   0 ; inline
 : PROT_READ   1 ; inline
 : PROT_WRITE  2 ; inline
@@ -113,7 +56,6 @@ LIBRARY: libc
 FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
 FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
 FUNCTION: int chdir ( char* path ) ;
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
 FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
 FUNCTION: int chroot ( char* path ) ;
 FUNCTION: void close ( int fd ) ;
@@ -124,7 +66,6 @@ FUNCTION: int execv ( char* path, char** argv ) ;
 FUNCTION: int execvp ( char* path, char** argv ) ;
 FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
 FUNCTION: int fchdir ( int fd ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
 FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
 FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
 FUNCTION: int flock ( int fd, int operation ) ;
@@ -150,7 +91,6 @@ FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
 FUNCTION: int listen ( int s, int backlog ) ;
 FUNCTION: tm* localtime ( time_t* clock ) ;
 FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
 FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
 FUNCTION: int munmap ( void* addr, size_t len ) ;
 FUNCTION: uint ntohl ( uint n ) ;

vm/image.c

@@ -161,6 +161,9 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 	for(i = 0; i < FIRST_SAVE_ENV; i++)
 		userenv[i] = F;
 
+	for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
+		userenv[i] = F;
+
 	/* do a full GC + code heap compaction */
 	compact_code_heap();
 

vm/run.h

@@ -64,6 +64,7 @@ typedef enum {
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV
+#define LAST_SAVE_ENV STAGE2_ENV
 
 /* TAGGED user environment data; see getenv/setenv prims */
 DLLEXPORT CELL userenv[USER_ENV];