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

Conflicts: extra/io/unix/unix-tests.factor extra/ogg/player/player.factor
2008-02-26 00:31:34 -06:00 · 2008-02-26 00:31:34 -06:00 · f7a2bc066c
parent 4cfdc3de62 18a96f87ee
commit f7a2bc066c
56 changed files with 386 additions and 268 deletions
--- a/3
+++ b/3
@ -145,7 +145,8 @@ wince-arm:

 macosx.app: factor
 	mkdir -p $(BUNDLE)/Contents/MacOS
-	cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	ln -s Factor.app/Contents/MacOS/factor ./factor
 	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks

 	install_name_tool \
--- a/core/compiler/tests/curry.factor
+++ b/core/compiler/tests/curry.factor
@ -1,5 +1,5 @@
-USING: tools.test compiler quotations math kernel sequences
-assocs namespaces ;
+USING: tools.test quotations math kernel sequences
+assocs namespaces compiler.units ;
 IN: temporary

 [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
--- a/core/compiler/tests/float.factor
+++ b/core/compiler/tests/float.factor
@ -1,5 +1,5 @@
 IN: temporary
-USING: compiler kernel kernel.private memory math
+USING: compiler.units kernel kernel.private memory math
 math.private tools.test math.floats.private ;

 [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@ -1,10 +1,11 @@
 IN: temporary
-USING: arrays compiler kernel kernel.private math math.constants
-math.private sequences strings tools.test words continuations
-sequences.private hashtables.private byte-arrays strings.private
-system random layouts vectors.private sbufs.private
-strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc sequences.private ;
+USING: arrays compiler.units kernel kernel.private math
+math.constants math.private sequences strings tools.test words
+continuations sequences.private hashtables.private byte-arrays
+strings.private system random layouts vectors.private
+sbufs.private strings.private slots.private alien
+alien.accessors alien.c-types alien.syntax namespaces libc
+sequences.private ;

 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@ -1,4 +1,4 @@
-USING: compiler tools.test kernel kernel.private
+USING: compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings
 alien arrays memory ;
 IN: temporary
--- a/core/compiler/tests/tuples.factor
+++ b/core/compiler/tests/tuples.factor
@ -1,5 +1,5 @@
 IN: temporary
-USING: kernel tools.test compiler ;
+USING: kernel tools.test compiler.units ;

 TUPLE: color red green blue ;

--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables ;
+vocabs definitions hashtables init ;
 IN: compiler.units

 SYMBOL: old-definitions
@ -37,10 +37,11 @@ SYMBOL: recompile-hook

 SYMBOL: definition-observers

-definition-observers global [ V{ } like ] change-at
-
 GENERIC: definitions-changed ( assoc obj -- )

+[ V{ } clone definition-observers set-global ]
+"compiler.units" add-init-hook
+
 : add-definition-observer ( obj -- )
    definition-observers get push ;

--- a/core/inference/state/state-tests.factor
+++ b/core/inference/state/state-tests.factor
@ -1,5 +1,5 @@
 IN: temporary
-USING: tools.test inference.state ;
+USING: tools.test inference.state words ;

 SYMBOL: a
 SYMBOL: b
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@ -1,4 +1,4 @@
-USING: arrays compiler generic hashtables inference kernel
+USING: arrays compiler.units generic hashtables inference kernel
 kernel.private math optimizer prettyprint sequences sbufs
 strings tools.test vectors words sequences.private quotations
 optimizer.backend classes inference.dataflow tuples.private
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs
    #! If a class word had a compound definition which was
    #! removed, it must go back to being a symbol.
    new-definitions get first2 diff
-    [ nip define-symbol ] assoc-each ;
+    [ nip dup reset-generic define-symbol ] assoc-each ;

 : forget-smudged ( -- )
    smudged-usage forget-all
--- a/core/threads/threads-docs.factor
+++ b/core/threads/threads-docs.factor
@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
 { $subsection yield }
 "Sleeping for a period of time:"
 { $subsection sleep }
-"Interruptible sleep:"
-{ $subsection nap }
+"Interrupting sleep:"
 { $subsection interrupt }
 "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
 { $subsection suspend }
@ -106,14 +105,17 @@ HELP: stop
 HELP: yield
 { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;

+HELP: sleep-until
+{ $values { "time/f" "a non-negative integer or " { $link f } } }
+{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+
 HELP: sleep
 { $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
-{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
-
-HELP: nap
-{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
-{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;

 HELP: interrupt
 { $values { "thread" thread } }
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@ -75,14 +75,24 @@ PRIVATE>
 : sleep-queue 43 getenv ;

 : resume ( thread -- )
+    f over set-thread-state
    check-registered run-queue push-front ;

 : resume-now ( thread -- )
+    f over set-thread-state
    check-registered run-queue push-back ;

 : resume-with ( obj thread -- )
+    f over set-thread-state
    check-registered 2array run-queue push-front ;

+: sleep-time ( -- ms/f )
+    {
+        { [ run-queue dlist-empty? not ] [ 0 ] }
+        { [ sleep-queue heap-empty? ] [ f ] }
+        { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+    } cond ;
+
 <PRIVATE

 : schedule-sleep ( thread ms -- )
@ -103,23 +113,27 @@ PRIVATE>
    [ ] while
    drop ;

-: next ( -- )
+: next ( -- * )
    expire-sleep-loop
-    run-queue pop-back
-    dup array? [ first2 ] [ f swap ] if dup set-self
-    f over set-thread-state
-    thread-continuation box>
-    continue-with ;
+    run-queue dup dlist-empty? [
+        ! We should never be in a state where the only threads
+        ! are sleeping; the I/O wait thread is always runnable.
+        ! However, if it dies, we handle this case
+        ! semi-gracefully.
+        !
+        ! And if sleep-time outputs f, there are no sleeping
+        ! threads either... so WTF.
+        drop sleep-time [ die 0 ] unless* (sleep) next
+    ] [
+        pop-back
+        dup array? [ first2 ] [ f swap ] if dup set-self
+        f over set-thread-state
+        thread-continuation box>
+        continue-with
+    ] if ;

 PRIVATE>

-: sleep-time ( -- ms/f )
-    {
-        { [ run-queue dlist-empty? not ] [ 0 ] }
-        { [ sleep-queue heap-empty? ] [ f ] }
-        { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
-    } cond ;
-
 : stop ( -- )
    self dup thread-exit-handler call
    unregister-thread next ;
@ -131,34 +145,27 @@ PRIVATE>
        self swap call next
    ] callcc1 2nip ; inline

-: yield ( -- ) [ resume ] "yield" suspend drop ;
+: yield ( -- ) [ resume ] f suspend drop ;

-GENERIC: nap-until ( time -- ? )
+GENERIC: sleep-until ( time/f -- )

-M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ;
+M: integer sleep-until
+    [ schedule-sleep ] curry "sleep" suspend drop ;

-M: f nap-until drop [ drop ] "interrupt" suspend ;
+M: f sleep-until
+    drop [ drop ] "interrupt" suspend drop ;

-GENERIC: nap ( time -- ? )
+GENERIC: sleep ( ms -- )

-M: real nap millis + >integer nap-until ;
-
-M: f nap nap-until ;
-
-: sleep-until ( time -- )
-    nap-until [ "Sleep interrupted" throw ] when ;
-
-: sleep ( time -- )
-    nap [ "Sleep interrupted" throw ] when ;
+M: real sleep
+    millis + >integer sleep-until ;

 : interrupt ( thread -- )
-    dup self eq? [
-        drop
-    ] [
+    dup thread-state [
        dup thread-sleep-entry [ sleep-queue heap-delete ] when*
        f over set-thread-sleep-entry
-        t swap resume-with
-    ] if ;
+        dup resume
+    ] when drop ;

 : (spawn) ( thread -- )
    [
@ -204,6 +211,7 @@ M: f nap nap-until ;
    initial-thread global
    [ drop f "Initial" [ die ] <thread> ] cache
    <box> over set-thread-continuation
+    f over set-thread-state
    dup register-thread
    set-self ;

--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@ -153,16 +153,18 @@ SYMBOL: load-help?
    [ load-error. nl ] each ;

 SYMBOL: blacklist
+SYMBOL: failures

 : require-all ( vocabs -- failures )
    [
        V{ } clone blacklist set
+        V{ } clone failures set
        [
            [ require ]
-            [ >r vocab-name r> 2array blacklist get push ]
+            [ swap vocab-name failures get set-at ]
            recover
        ] each
-        blacklist get
+        failures get
    ] with-compiler-errors ;

 : do-refresh ( modified-sources modified-docs -- )
@ -176,12 +178,17 @@ SYMBOL: blacklist
 : refresh-all ( -- ) "" refresh ;

 GENERIC: (load-vocab) ( name -- vocab )
-!
+
+: add-to-blacklist ( error vocab -- )
+    vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
+
 M: vocab (load-vocab)
-    dup vocab-root [
-        dup vocab-source-loaded? [ dup load-source ] unless
-        dup vocab-docs-loaded? [ dup load-docs ] unless
-    ] when ;
+    [
+        dup vocab-root [
+            dup vocab-source-loaded? [ dup load-source ] unless
+            dup vocab-docs-loaded? [ dup load-docs ] unless
+        ] when
+    ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;

 M: string (load-vocab)
    [ ".private" ?tail drop reload ] keep vocab ;
@ -189,24 +196,14 @@ M: string (load-vocab)
 M: vocab-link (load-vocab)
    vocab-name (load-vocab) ;

-TUPLE: blacklisted-vocab name ;
-
-: blacklisted-vocab ( name -- * )
-    \ blacklisted-vocab construct-boa throw ;
-
-M: blacklisted-vocab error.
-    "This vocabulary depends on the " write
-    blacklisted-vocab-name write
-    " vocabulary which failed to load" print ;
-
 [
-    dup vocab-name blacklist get key? [
-        vocab-name blacklisted-vocab
+    dup vocab-name blacklist get at* [
+        rethrow
    ] [
-        [
-            dup vocab [ ] [ ] ?if (load-vocab)
-        ] with-compiler-errors
+        drop
+        [ dup vocab swap or (load-vocab) ] with-compiler-errors
    ] if
+
 ] load-vocab-hook set-global

 : vocab-where ( vocab -- loc )
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@ -1,6 +1,6 @@
 USING: arrays generic assocs kernel math namespaces
 sequences tools.test words definitions parser quotations
-vocabs continuations tuples compiler.units ;
+vocabs continuations tuples compiler.units io.streams.string ;
 IN: temporary

 [ 4 ] [
@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
 [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test

 [ ] [
-    "IN: temporary GENERIC: symbol-generic" eval
+    "IN: temporary GENERIC: symbol-generic" <string-reader>
+    "symbol-generic-test" parse-stream drop
 ] unit-test

 [ ] [
-    "IN: temporary TUPLE: symbol-generic ;" eval
+    "IN: temporary TUPLE: symbol-generic ;" <string-reader>
+    "symbol-generic-test" parse-stream drop
 ] unit-test

 [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
--- a/extra/alarms/alarms.factor
+++ b/extra/alarms/alarms.factor
@ -62,7 +62,7 @@ SYMBOL: alarm-thread

 : alarm-thread-loop ( -- )
    alarms get-global
-    dup next-alarm nap-until drop
+    dup next-alarm sleep-until
    dup trigger-alarms
    alarm-thread-loop ;

--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@ -65,15 +65,8 @@ IN: builder

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

-: factor-binary ( -- name )
-  os
-  { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
-    { "winnt"  [ "./factor-nt.exe" ] }
-    [ drop       "./factor" ] }
-  case ;
-
 : bootstrap-cmd ( -- cmd )
-  { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+  { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;

 : bootstrap ( -- desc )
  <process*>
@ -85,7 +78,7 @@ IN: builder
  >desc ;

 : builder-test-cmd ( -- cmd )
-  { factor-binary "-run=builder.test" } to-strings ;
+  { "./factor" "-run=builder.test" } to-strings ;

 : builder-test ( -- desc )
  <process*>
@ -149,6 +142,10 @@ SYMBOL: build-status

    "../benchmarks" "../../benchmarks" copy-file

+    ".." cd
+
+    maybe-release
+
  ] with-file-writer

  build-status on ;
@ -168,7 +165,7 @@ SYMBOL: builder-recipients
    builder-from get        >>from
    builder-recipients get  >>to
    subject                 >>subject
-    "../report" file>string >>body
+    "./report" file>string >>body
  send ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -177,11 +174,11 @@ SYMBOL: builder-recipients
  { "bzip2" my-boot-image-name } to-strings run-process drop ;

 : build ( -- )
-  [ (build) ] [ drop ] recover
-  maybe-release
+  [ (build) ] failsafe
+  builds cd stamp> cd
  [ send-builder-email ] [ drop "not sending mail" . ] recover
-  ".." cd { "rm" "-rf" "factor" } run-process drop
-  [ compress-image ] [ drop ] recover ;
+  { "rm" "-rf" "factor" } run-process drop
+  [ compress-image ] failsafe ;

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

@ -216,8 +213,7 @@ USE: bootstrap.image.download
      [ build ]
    when
  ]
-  [ drop ]
-  recover
+  failsafe
  5 minutes sleep
  build-loop ;

--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@ -64,6 +64,8 @@ USING: system sequences splitting ;

 : linux-release ( -- )

+  "factor" cd
+
  { "rm" "-rf" "Factor.app" } run-process drop

  { "rm" "-rf" common-files } to-strings run-process drop
@ -78,6 +80,8 @@ USING: system sequences splitting ;

 : windows-release ( -- )

+  "factor" cd
+
  { "rm" "-rf" "Factor.app" } run-process drop

  { "rm" "-rf" common-files } to-strings run-process drop
@ -92,6 +96,8 @@ USING: system sequences splitting ;

 : macosx-release ( -- )

+  "factor" cd
+
  { "rm" "-rf" common-files } to-strings run-process drop

  ".." cd
@ -120,8 +126,8 @@ USING: system sequences splitting ;

 : release? ( -- ? )
  {
-    "../load-everything-vocabs"
-    "../test-all-vocabs"
+    "./load-everything-vocabs"
+    "./test-all-vocabs"
  }
    [ eval-file empty? ]
  all? ;
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@ -105,3 +105,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
 USE: prettyprint

 : to-file ( object file -- ) [ . ] with-file-writer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: failsafe ( quot -- ) [ drop ] recover ;
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- )
 : seconds-since-midnight ( timestamp -- x )
    dup beginning-of-day timestamp- ;

-M: timestamp nap-until timestamp>millis nap-until ;
+M: timestamp sleep-until timestamp>millis sleep-until ;

-M: dt nap from-now nap-until ;
+M: dt sleep from-now sleep-until ;

 {
    { [ unix? ] [ "calendar.unix" ] }
--- a/extra/cocoa/cocoa-tests.factor
+++ b/extra/cocoa/cocoa-tests.factor
@ -1,6 +1,7 @@
 IN: temporary
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory ;
+compiler kernel namespaces cocoa.classes tools.test memory
+compiler.units ;

 CLASS: {
    { +superclass+ "NSObject" }
--- a/extra/concurrency/conditions/conditions.factor
+++ b/extra/concurrency/conditions/conditions.factor
@ -8,7 +8,7 @@ IN: concurrency.conditions
    dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;

 : notify-all ( dlist -- )
-    [ resume-now ] dlist-slurp yield ;
+    [ resume-now ] dlist-slurp ;

 : queue-timeout ( queue timeout -- alarm )
    #! Add an alarm which removes the current thread from the
--- a/extra/concurrency/flags/flags-docs.factor
+++ b/extra/concurrency/flags/flags-docs.factor
@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: concurrency.flags
+
+HELP: flag
+{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
+
+HELP: <flag>
+{ $values { "flag" flag } }
+{ $description "Creates a new flag." } ;
+
+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: 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." } ;
+
+ARTICLE: "concurrency.flags" "Flags"
+"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
+$nl
+"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if the flag has not been raised, it first waits for it to be raised."
+$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:"
+{ $subsection raise-flag }
+{ $subsection lower-flag } ;
+
+ABOUT: "concurrency.flags"
--- a/extra/concurrency/flags/flags.factor
+++ b/extra/concurrency/flags/flags.factor
@ -0,0 +1,21 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes kernel threads ;
+IN: concurrency.flags
+
+TUPLE: flag value? thread ;
+
+: <flag> ( -- flag ) f <box> flag construct-boa ;
+
+: raise-flag ( flag -- )
+    dup flag-value? [
+        dup flag-thread ?box
+        [ resume ] [ drop t over set-flag-value? ] if
+    ] unless drop ;
+
+: lower-flag ( flag -- )
+    dup flag-value? [
+        f swap set-flag-value?
+    ] [
+        [ flag-thread >box ] curry "flag" suspend drop
+    ] if ;
--- a/extra/concurrency/mailboxes/mailboxes.factor
+++ b/extra/concurrency/mailboxes/mailboxes.factor
@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;

 : mailbox-put ( obj mailbox -- )
    [ mailbox-data push-front ] keep
-    mailbox-threads notify-all ;
+    mailbox-threads notify-all yield ;

 : block-unless-pred ( pred mailbox timeout -- )
    2over mailbox-data dlist-contains? [
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@ -161,7 +161,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
    [
        [ create-table-sql , ] keep
        dup db-columns find-primary-key native-id?
-        [ create-function-sql , ] [ 2drop ] if
+        [ create-function-sql , ] [ drop ] if
    ] { } make ;

 : drop-function-sql ( class -- statement )
@ -176,13 +176,13 @@ M: postgresql-db create-sql-statement ( class -- seq )
 : drop-table-sql ( table -- statement )
    [
        "drop table " 0% 0% ";" 0% drop
-    ] postgresql-make dup . ;
+    ] postgresql-make ;

 M: postgresql-db drop-sql-statement ( class -- seq )
    [
        [ drop-table-sql , ] keep
        dup db-columns find-primary-key native-id?
-        [ drop-function-sql , ] [ 2drop ] if
+        [ drop-function-sql , ] [ drop ] if
    ] { } make ;

 M: postgresql-db <insert-native-statement> ( class -- statement )
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@ -16,29 +16,37 @@ TUPLE: person the-id the-name the-number the-real ;
 : <assigned-person> ( id name number the-real -- obj )
    <person> [ set-person-the-id ] keep ;

-SYMBOL: the-person
+SYMBOL: the-person1
+SYMBOL: the-person2

 : test-tuples ( -- )
    [ person drop-table ] [ drop ] recover
    [ ] [ person create-table ] unit-test
    
-    [  ] [ the-person get insert-tuple ] unit-test
+    [  ] [ the-person1 get insert-tuple ] unit-test

-    [ 1 ] [ the-person get person-the-id ] unit-test
+    [ 1 ] [ the-person1 get person-the-id ] unit-test

-    200 the-person get set-person-the-number
+    200 the-person1 get set-person-the-number

-    [ ] [ the-person get update-tuple ] unit-test
+    [ ] [ the-person1 get update-tuple ] unit-test

    [ T{ person f 1 "billy" 200 3.14 } ]
    [ T{ person f 1 } select-tuple ] unit-test
+    [ ] [ the-person2 get insert-tuple ] unit-test
+    [
+        {
+            T{ person f 1 "billy" 200 3.14 }
+            T{ person f 2 "johnny" 10 3.14 }
+        }
+    ] [ T{ person f f f f 3.14 } select-tuples ] unit-test

-    ! [ ] [ the-person get delete-tuple ] unit-test
-    ! [ ] [ person drop-table ] unit-test
-    ;
+    [ ] [ the-person1 get delete-tuple ] unit-test
+    [ f ] [ T{ person f 1 } select-tuple ] unit-test
+    [ ] [ person drop-table ] unit-test ;

 : test-sqlite ( -- )
-    "tuples-test.db" resource-path <sqlite-db> [
+    "tuples-test.db" resource-path sqlite-db [
        test-tuples
    ] with-db ;

@ -55,23 +63,25 @@ person "PERSON"
    { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
 } define-persistent

-"billy" 10 3.14 <person> the-person set
+"billy" 10 3.14 <person> the-person1 set
+"johnny" 10 3.14 <person> the-person2 set

 ! test-sqlite
 test-postgresql

-! person "PERSON"
-! {
-    ! { "the-id" "ID" INTEGER +assigned-id+ }
-    ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
-    ! { "the-number" "AGE" INTEGER { +default+ 0 } }
-    ! { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
-! } define-persistent
+person "PERSON"
+{
+    { "the-id" "ID" INTEGER +assigned-id+ }
+    { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+    { "the-number" "AGE" INTEGER { +default+ 0 } }
+    { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+} define-persistent

-! 1 "billy" 20 6.28 <assigned-person> the-person set
+1 "billy" 10 3.14 <assigned-person> the-person1 set
+2 "johnny" 10 3.14 <assigned-person> the-person2 set

 ! 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 ;
@ -98,11 +108,11 @@ annotation "ANNOTATION"
    { "contents" "CONTENTS" TEXT }
 } define-persistent

-! "localhost" "postgres" "" "factor-test" <postgresql-db> [
-    ! [ paste drop-table ] [ drop ] recover
-    ! [ annotation drop-table ] [ drop ] recover
-    ! [ paste drop-table ] [ drop ] recover
-    ! [ annotation drop-table ] [ drop ] recover
-    ! [ ] [ paste create-table ] unit-test
-    ! [ ] [ annotation create-table ] unit-test
-! ] with-db
+{ "localhost" "postgres" "" "factor-test" } postgresql-db [
+    [ paste drop-table ] [ drop ] recover
+    [ annotation drop-table ] [ drop ] recover
+    [ paste drop-table ] [ drop ] recover
+    [ annotation drop-table ] [ drop ] recover
+    [ ] [ paste create-table ] unit-test
+    [ ] [ annotation create-table ] unit-test
+] with-db
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@ -50,10 +50,7 @@ HOOK: insert-tuple* db ( tuple statement -- )

 : query-tuples ( statement -- seq )
    [ statement-out-params ] keep query-results [
-        ! out-parms result-set
-        [
-            sql-row swap resulting-tuple
-        ] with query-map
+        [ sql-row swap resulting-tuple ] with query-map
    ] with-disposal ;
 
 : query-modify-tuple ( tuple statement -- )
@ -91,13 +88,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
 : update-tuples ( seq -- )
    <update-tuples-statement> execute-statement ;

-: persist ( tuple -- )
-    dup class db-columns find-primary-key ;
-
+: delete-tuple ( tuple -- )
+    dup class <delete-tuple-statement>
+    [ bind-tuple ] keep execute-statement ;

 : setup-select ( tuple -- statement )
    dup dup class <select-by-slots-statement>
    [ bind-tuple ] keep ;

 : select-tuples ( tuple -- tuple ) setup-select query-tuples ;
-: select-tuple ( tuple -- tuple ) select-tuples first ;
+: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@ -204,4 +204,3 @@ SYMBOL: model
    ] [
        drop
    ] if ;
-
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@ -1,5 +1,5 @@
 USING: assocs calendar init kernel math.parser
-namespaces random boxes alarms ;
+namespaces random boxes alarms combinators.lib ;
 IN: furnace.sessions

 SYMBOL: sessions
@ -11,9 +11,8 @@ SYMBOL: sessions
 ] "furnace.sessions" add-init-hook

 : new-session-id ( -- str )
-    4 big-random >hex
-    dup sessions get-global key?
-    [ drop new-session-id ] when ;
+    [ 4 big-random >hex ]
+    [ sessions get-global key? not ] generate ;

 TUPLE: session id namespace alarm user-agent ;

--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@ -86,7 +86,8 @@ concurrency.futures
 concurrency.locks
 concurrency.semaphores
 concurrency.count-downs
-concurrency.exchangers ;
+concurrency.exchangers
+concurrency.flags ;

 ARTICLE: "concurrency" "Concurrency"
 "Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time."
@ -106,6 +107,7 @@ $nl
 { $subsection "concurrency.semaphores" }
 { $subsection "concurrency.count-downs" }
 { $subsection "concurrency.exchangers" }
+{ $subsection "concurrency.flags" }
 "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;

 ARTICLE: "objects" "Objects"
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@ -87,14 +87,14 @@ SYMBOL: html
    #! word.
    foo> [ ">" write-html ] empty-effect html-word ;

-: </foo> [ "</" % % ">" % ] "" make ;
+: </foo> "</" swap ">" 3append ;

 : def-for-html-word-</foo> ( name -- )
    #! Return the name and code for the </foo> patterned
    #! word.
    </foo> dup [ write-html ] curry empty-effect html-word ;

-: <foo/> [ "<" % % "/>" % ] "" make ;
+: <foo/> "<" swap "/>" 3append ;

 : def-for-html-word-<foo/> ( name -- )
    #! Return the name and code for the <foo/> patterned
--- a/extra/http/basic-authentication/basic-authentication.factor
+++ b/extra/http/basic-authentication/basic-authentication.factor
@ -61,5 +61,5 @@ SYMBOL: realms
  #! Check if the user is authenticated in the given realm
  #! to run the specified quotation. If not, use Basic
  #! Authentication to ask for authorization details.
-  over "Authorization" header-param authorization-ok?
+  over "authorization" header-param authorization-ok?
  [ nip call ] [ drop authentication-error ] if ;
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@ -77,7 +77,7 @@ SYMBOL: max-post-request
 1024 256 * max-post-request set-global

 : content-length ( header -- n )
-    "content-length" peek at string>number dup [
+    "content-length" swap peek-at string>number dup [
        dup max-post-request get > [
            "Content-Length > max-post-request" throw
        ] when
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )

 SYMBOL: port-override

-: (port) port-override get [ ] [ ] ?if ;
+: (port) port-override get swap or ;

 M: inet4 parse-sockaddr
    >r dup sockaddr-in-addr <uint> r> inet-ntop
--- a/extra/io/unix/unix-tests.factor
+++ b/extra/io/unix/unix-tests.factor
@ -4,12 +4,12 @@ sequences prettyprint system io.encodings.binary io.encodings.ascii ;
 IN: temporary

 ! Unix domain stream sockets
-[
-    [
-        "unix-domain-socket-test" temp-file delete-file
-    ] ignore-errors
+: socket-server "unix-domain-socket-test" temp-file ;

-    "unix-domain-socket-test" temp-file <local>
+[
+    [ socket-server delete-file ] ignore-errors
+
+    socket-server <local>
    ascii <server> [
        accept [
            "Hello world" print flush
@ -17,15 +17,15 @@ IN: temporary
        ] with-stream
    ] with-disposal

-    "unix-domain-socket-test" temp-file delete-file
+    socket-server delete-file
 ] "Test" spawn drop

 yield

 [ { "Hello world" "FOO" } ] [
    [
-        "unix-domain-socket-test" temp-file <local>
-        ascii <client> [
+        socket-server <local> ascii <client>
+        [
            readln ,
            "XYZ" print flush
            readln ,
@ -33,17 +33,16 @@ yield
    ] { } make
 ] unit-test

-! Unix domain datagram sockets
-[
-    "unix-domain-datagram-test" temp-file delete-file
-] ignore-errors
+: datagram-server "unix-domain-datagram-test" temp-file ;
+: datagram-client "unix-domain-datagram-test-2" temp-file ;

-: server-addr "unix-domain-datagram-test" temp-file <local> ;
-: client-addr "unix-domain-datagram-test-2" temp-file <local> ;
+! Unix domain datagram sockets
+[ datagram-server delete-file ] ignore-errors
+[ datagram-client delete-file ] ignore-errors

 [
    [
-        server-addr <datagram> "d" set
+        datagram-server <local> <datagram> "d" set

        "Receive 1" print

@ -67,59 +66,53 @@ yield

        "Done" print

-        "unix-domain-datagram-test" temp-file delete-file
+        datagram-server delete-file
    ] with-scope
 ] "Test" spawn drop

 yield

-[
-    "unix-domain-datagram-test-2" temp-file delete-file
-] ignore-errors
+[ datagram-client delete-file ] ignore-errors

-client-addr <datagram>
-"Four" print
+datagram-client <local> <datagram>
 "d" set

 [ ] [
    "hello" >byte-array
-    server-addr
+    datagram-server <local>
    "d" get send
 ] unit-test

 [ "olleh" t ] [
    "d" get receive
-    server-addr =
+    datagram-server <local> =
    >r >string r>
 ] unit-test

 [ ] [
    "hello" >byte-array
-    server-addr
+    datagram-server <local>
    "d" get send
 ] unit-test

 [ "hello world" t ] [
    "d" get receive
-    server-addr =
+    datagram-server <local> =
    >r >string r>
 ] unit-test

 [ ] [ "d" get dispose ] unit-test

 ! Test error behavior
+: another-datagram "unix-domain-datagram-test-3" temp-file ;

-[
-    "unix-domain-datagram-test-3" temp-file delete-file
-] ignore-errors
+[ another-datagram delete-file ] ignore-errors

-"unix-domain-datagram-test-2" temp-file delete-file
+datagram-client delete-file

-[ ] [ client-addr <datagram> "d" set ] unit-test
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test

-[
-    B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
-] must-fail
+[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail

 [ ] [ "d" get dispose ] unit-test

@ -127,7 +120,7 @@ client-addr <datagram>

 [ "d" get receive ] must-fail

-[ B{ 1 2 } server-addr "d" get send ] must-fail
+[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail

 ! Invalid parameter tests

--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- )

 : wait-loop ( -- )
    processes get dup assoc-empty?
-    [ drop f nap drop ]
-    [ wait-for-processes [ 100 nap drop ] when ] if ;
+    [ drop f sleep-until ]
+    [ wait-for-processes [ 100 sleep ] when ] if ;

 SYMBOL: wait-thread

--- a/extra/ogg/player/player.factor
+++ b/extra/ogg/player/player.factor
@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
       namespaces threads shuffle opengl arrays ui.gadgets.worlds
       combinators math.parser ui.gadgets ui.render opengl.gl ui
       continuations io.files hints combinators.lib sequences.lib
-       io.encodings.binary ;
+       io.encodings.binary debugger ;

 IN: ogg.player

@ -150,7 +150,7 @@ HINTS: yuv>rgb byte-array byte-array ;
    dup player-gadget [
        dup { player-td player-yuv } get-slots theora_decode_YUVout drop
        dup player-rgb over player-yuv yuv>rgb
-        dup player-gadget find-world draw-world
+        dup player-gadget relayout-1 yield
    ] when ;

 : num-audio-buffers-processed ( player -- player n )
@ -178,7 +178,7 @@ HINTS: yuv>rgb byte-array byte-array ;
 : append-audio ( player -- player bool )
    num-audio-buffers-processed {
        { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
-        { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
+        { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
        { [ t ] [ fill-processed-audio-buffer t ] }
    } cond ;

@ -603,8 +603,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
    parse-remaining-headers
    initialize-decoder
    dup player-gadget [ initialize-gui ] when*
-    [ decode ] [ drop ] recover
-!    decode
+    [ decode ] try
    wait-for-sound
    cleanup
    drop ;
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@ -306,9 +306,15 @@ MEMO: range ( min max -- parser )
 : seq ( seq -- parser )
  seq-parser construct-boa init-parser ;

+: seq* ( quot -- paser )
+  { } make seq ; inline 
+
 : choice ( seq -- parser )
  choice-parser construct-boa init-parser ;

+: choice* ( quot -- paser )
+  { } make choice ; inline 
+
 MEMO: repeat0 ( parser -- parser )
  repeat0-parser construct-boa init-parser ;

--- a/extra/random-tester/random-tester.factor
+++ b/extra/random-tester/random-tester.factor
@ -1,5 +1,6 @@
 USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors ;
+prettyprint quotations random sequences vectors
+compiler.units ;
 USING: random-tester.databank random-tester.safe-words ;
 IN: random-tester

--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@ -114,7 +114,7 @@ LOG: smtp-response DEBUG

 : extract-email ( recepient -- email )
    #! This could be much smarter.
-    " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
+    " " last-split1 swap or "<" ?head drop ">" ?tail drop ;

 : message-id ( -- string )
    [
--- a/extra/tools/threads/threads.factor
+++ b/extra/tools/threads/threads.factor
@ -8,7 +8,10 @@ heaps.private system math math.parser ;
 : thread. ( thread -- )
    dup thread-id pprint-cell
    dup thread-name over [ write-object ] with-cell
-    dup thread-state "running" or [ write ] with-cell
+    dup thread-state [
+        [ dup self eq? "running" "yield" ? ] unless*
+        write
+    ] with-cell
    [
        thread-sleep-entry [
            entry-key millis [-] number>string write
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
 : event-loop ( -- )
    event-loop? [
        [
-            [ NSApp do-events ui-step 10 sleep ] ui-try
+            [ NSApp do-events ui-wait ] ui-try
        ] with-autorelease-pool event-loop
    ] when ;

--- a/extra/ui/cocoa/views/views.factor
+++ b/extra/ui/cocoa/views/views.factor
@ -298,7 +298,6 @@ CLASS: {
    [
        [
            2drop dup view-dim swap window set-gadget-dim
-            ui-step
        ] ui-try
    ]
 }
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@ -2,9 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
 quotations math.vectors combinators sorting vectors dlists
-models ;
+models threads concurrency.flags ;
 IN: ui.gadgets

+SYMBOL: ui-notify-flag
+
+: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
+
 TUPLE: rect loc dim ;

 C: <rect> rect
@ -184,7 +188,7 @@ M: array gadget-text*
    #! When unit testing gadgets without the UI running, the
    #! invalid queue is not initialized and we simply ignore
    #! invalidation requests.
-    layout-queue [ push-front ] [ drop ] if* ;
+    layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;

 DEFER: relayout

@ -256,11 +260,11 @@ M: gadget layout* drop ;

 : queue-graft ( gadget -- )
    { f t } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;

 : queue-ungraft ( gadget -- )
    { t f } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;

 : graft-later ( gadget -- )
    dup gadget-graft-state {
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@ -133,7 +133,7 @@ M: stack-display tool-scroller

 : restart-listener ( listener -- )
    dup com-end dup clear-output
-    [ init-namespaces listener-thread ] curry
+    [ listener-thread ] curry
    "Listener" spawn drop ;

 : init-listener ( listener -- )
--- a/extra/ui/tools/search/search.factor
+++ b/extra/ui/tools/search/search.factor
@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
 tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
 ui.gestures ui.operations vocabs words vocabs.loader
-tools.browser unicode.case calendar ;
+tools.browser unicode.case calendar ui ;
 IN: ui.tools.search

 TUPLE: live-search field list ;
@ -45,7 +45,8 @@ search-field H{
 } set-gestures

 : <search-model> ( producer -- model )
-    >r g live-search-field gadget-model 1/5 seconds <delay>
+    >r g live-search-field gadget-model
+    ui-running? [ 1/5 seconds <delay> ] when
    [ "\n" join ] r> append <filter> ;

 : <search-list> ( seq limited? presenter -- gadget )
--- a/extra/ui/ui-docs.factor
+++ b/extra/ui/ui-docs.factor
@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
 { $subsection start-ui }
 "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
 $nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ;
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;

 ARTICLE: "ui-backend-windows" "UI backend window management"
 "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
 prettyprint dlists sequences threads sequences words
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
 ui.gestures ui.backend ui.render continuations init combinators
-hashtables ;
+hashtables concurrency.flags ;
 IN: ui

 ! Assoc mapping aliens to gadgets
@ -130,11 +130,36 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
    graft-queue [ notify ] dlist-slurp ;

-: ui-step ( -- )
+: update-ui ( -- )
    [ notify-queued layout-queued redraw-worlds ] assert-depth ;

+: ui-wait ( -- )
+    10 sleep ;
+
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+SYMBOL: ui-thread
+
+: ui-running ( quot -- )
+    t \ ui-running set-global
+    [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-running? ( -- ? )
+    \ ui-running get-global ;
+
+: update-ui-loop ( -- )
+    ui-running? ui-thread get-global self eq? [
+        ui-notify-flag get lower-flag
+        [ update-ui ] ui-try
+        update-ui-loop
+    ] when ;
+
+: start-ui-thread ( -- )
+    [ self ui-thread set-global update-ui-loop ]
+    "UI update" spawn drop ;
+
 : open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
+    dup pref-dim over set-gadget-dim dup relayout graft ;

 : open-window ( gadget title -- )
    >r [ 1 track, ] { 0 1 } make-track r>
@ -159,16 +184,13 @@ M: object close-window
        restore-windows
    ] [
        init-ui ui-hook get call
-    ] if ui-step ;
+    ] if
+    notify-ui-thread start-ui-thread ;

-: ui-running ( quot -- )
-    t \ ui-running set-global
-    [ f \ ui-running set-global ] [ ] cleanup ; inline
-
-: ui-running? ( -- ? )
-    \ ui-running get-global ;
-
-[ f \ ui-running set-global ] "ui" add-init-hook
+[
+    f \ ui-running set-global
+    <flag> ui-notify-flag set-global
+] "ui" add-init-hook

 HOOK: ui ui-backend ( -- )

@ -181,5 +203,3 @@ MAIN: ui
        f windows set-global
        ui-hook [ ui ] with-variable
    ] if ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
 : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;

 : enum-clipboard ( -- seq )
-    0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
-    { } unfold nip ;
+    0
+    [ EnumClipboardFormats win32-error dup dup 0 > ]
+    [ ]
+    [ drop ]
+    unfold nip ;

 : with-clipboard ( quot -- )
    f OpenClipboard win32-error=0/f
@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
 : copy ( str -- )
    lf>crlf [
        string>u16-alien
-        f OpenClipboard win32-error=0/f
        EmptyClipboard win32-error=0/f
        GMEM_MOVEABLE over length 1+ GlobalAlloc
            dup win32-error=0/f
    
        dup GlobalLock dup win32-error=0/f
-        rot dup length memcpy
+        swapd byte-array>memory
        dup GlobalUnlock win32-error=0/f
        CF_UNICODETEXT swap SetClipboardData win32-error=0/f
    ] with-clipboard ;
@ -72,30 +74,28 @@ SYMBOL: mouse-captured
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline

-: adjust-RECT ( RECT -- )
-    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( width height -- RECT )
-    "RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
-
-: make-adjusted-RECT ( width height -- RECT )
-    make-RECT dup adjust-RECT ;
-
-: get-RECT-dimensions ( RECT -- width height )
-    [ RECT-right ] keep [ RECT-left - ] keep
-    [ RECT-bottom ] keep RECT-top - ;
-
 : get-RECT-top-left ( RECT -- x y )
    [ RECT-left ] keep RECT-top ;

+: get-RECT-dimensions ( RECT -- x y width height )
+    [ get-RECT-top-left ] keep
+    [ RECT-right ] keep [ RECT-left - ] keep
+    [ RECT-bottom ] keep RECT-top - ;
+
 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
    #! wParam and lParam are unused
    #! only paint if width/height both > 0
-    3drop window draw-world ;
+    3drop window relayout-1 ;

 : handle-wm-size ( hWnd uMsg wParam lParam -- )
-    [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
-    dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
+    2nip
+    [ lo-word ] keep hi-word 2array
+    dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+    2nip
+    [ lo-word ] keep hi-word 2array
+    swap window set-world-loc ;

 : wm-keydown-codes ( -- key )
    H{
@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)

 : mouse-absolute>relative ( lparam handle -- array )
    >r >lo-hi r>
-    0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
+    "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
    get-RECT-top-left 2array v- ;

 : mouse-event>gesture ( uMsg -- button )
@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
                { [ dup WM_PAINT = ]
                      [ drop 4dup handle-wm-paint DefWindowProc ] }
                { [ dup WM_SIZE = ]      [ drop handle-wm-size 0 ] }
+                { [ dup WM_MOVE = ]      [ drop handle-wm-move 0 ] }

                ! Keyboard events
                { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@ -352,14 +353,12 @@ M: windows-ui-backend (close-window)
 : event-loop ( msg -- )
    {
        { [ windows get empty? ] [ drop ] }
-        { [ dup peek-message? ] [
-            >r [ ui-step 10 sleep ] ui-try
-            r> event-loop
-        ] }
+        { [ dup peek-message? ] [ ui-wait event-loop ] }
        { [ dup MSG-message WM_QUIT = ] [ drop ] }
        { [ t ] [
            dup TranslateMessage drop
            dup DispatchMessage drop
+            yield
            event-loop
        ] }
    } cond ;
@ -383,13 +382,26 @@ M: windows-ui-backend (close-window)
        RegisterClassEx dup win32-error=0/f
    ] when ;

-: create-window ( width height -- hwnd )
+: adjust-RECT ( RECT -- )
+    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+    dup world-loc { 40 40 } vmax dup rot rect-dim v+
+    "RECT" <c-object>
+    over first over set-RECT-right
+    swap second over set-RECT-bottom
+    over first over set-RECT-left
+    swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+    make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
    make-adjusted-RECT
    >r class-name-ptr get-global f r>
    >r >r >r ex-style r> r>
        { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
-        CW_USEDEFAULT dup r>
-    get-RECT-dimensions
+    r> get-RECT-dimensions
    f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;

 : show-window ( hWnd -- )
@ -424,7 +436,7 @@ M: windows-ui-backend (close-window)
    get-dc dup setup-pixel-format dup get-rc ;

 M: windows-ui-backend (open-window) ( world -- )
-    [ rect-dim first2 create-window dup setup-gl ] keep
+    [ create-window dup setup-gl ] keep
    [ f <win> ] keep
    [ swap win-hWnd register-window ] 2keep
    dupd set-world-handle
@ -445,8 +457,8 @@ M: windows-ui-backend raise-window* ( world -- )
 M: windows-ui-backend set-title ( string world -- )
    world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
    dup win-title [ free ] when*
-    >r malloc-u16-string r>
-    dupd set-win-title alien-address
+    >r malloc-u16-string dup r>
+    set-win-title alien-address
    SendMessage drop ;

 M: windows-ui-backend ui
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@ -178,7 +178,7 @@ M: world client-event
        next-event dup
        None XFilterEvent zero? [ drop wait-event ] unless
    ] [
-        ui-step 10 sleep wait-event
+        ui-wait wait-event
    ] if ;

 : do-events ( -- )
--- a/extra/webapps/cgi/cgi.factor
+++ b/extra/webapps/cgi/cgi.factor
@ -31,13 +31,13 @@ SYMBOL: cgi-root

        "method" get >upper "REQUEST_METHOD" set
        "raw-query" get "QUERY_STRING" set
-        "Cookie" header-param "HTTP_COOKIE" set 
+        "cookie" header-param "HTTP_COOKIE" set 

-        "User-Agent" header-param "HTTP_USER_AGENT" set
-        "Accept" header-param "HTTP_ACCEPT" set
+        "user-agent" header-param "HTTP_USER_AGENT" set
+        "accept" header-param "HTTP_ACCEPT" set

        post? [
-            "Content-Type" header-param "CONTENT_TYPE" set
+            "content-type" header-param "CONTENT_TYPE" set
            "raw-response" get length number>string "CONTENT_LENGTH" set
        ] when
    ] H{ } make-assoc ;
--- a/extra/webapps/file/file.factor
+++ b/extra/webapps/file/file.factor
@ -25,7 +25,7 @@ SYMBOL: doc-root

 : last-modified-matches? ( filename -- bool )
    file-http-date dup [
-        "If-Modified-Since" header-param = 
+        "if-modified-since" header-param = 
    ] when ;

 : not-modified-response ( -- )
--- a/extra/webapps/fjsc/fjsc.factor
+++ b/extra/webapps/fjsc/fjsc.factor
@ -25,7 +25,7 @@ IN: webapps.fjsc
 : compile-url ( url -- )
  #! Compile the factor code at the given url, return the javascript.
  dup "http:" head? [ "Unable to access remote sites." throw ] when
-  "http://" "Host" header-param rot 3append http-get compile "();" write flush ;
+  "http://" "host" header-param rot 3append http-get compile "();" write flush ;

 \ compile-url {
  { "url" v-required }
--- a/misc/factor.sh
+++ b/misc/factor.sh
@ -186,8 +186,8 @@ find_word_size() {

 set_factor_binary() {
        case $OS in
-                winnt) FACTOR_BINARY=factor-nt;;
-                macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
+                # winnt) FACTOR_BINARY=factor-nt;;
+                # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
                *) FACTOR_BINARY=factor;;
        esac
 }
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@ -229,7 +229,7 @@ CELL allot_code_block(CELL size)

 		/* Insufficient room even after code GC, give up */
 		if(start == 0)
-			critical_error("Out of memory in add-compiled-block",0);
+			fatal_error("Out of memory in add-compiled-block",0);
 	}

 	return start;
--- a/vm/factor.c
+++ b/vm/factor.c
@ -19,7 +19,7 @@ void default_parameters(F_PARAMETERS *p)
 	p->rs_size = 32 * CELLS;

 	p->gen_count = 3;
-	p->code_size = 4 * CELLS;
+	p->code_size = 8 * CELLS;
 	p->young_size = 2 * CELLS;
 	p->aging_size = 4 * CELLS;
 #endif