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

2010-06-22 14:47:57 -04:00 · 2010-06-22 14:47:57 -04:00 · 2c8897c56b
parent 970f96c8b8 7d64fe50a1
commit 2c8897c56b
139 changed files with 1441 additions and 721 deletions
--- a/Factor.app/Contents/Resources/Factor.icns
+++ b/Factor.app/Contents/Resources/Factor.icns
--- a/2
+++ b/2
@ -5,7 +5,7 @@ BOOTIMAGE_VERSION = latest
 !IF DEFINED(PLATFORM)

 LINK_FLAGS = /nologo shell32.lib
-CL_FLAGS = /nologo /O2 /W3 /D_CRT_SECURE_NO_WARNINGS
+CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS

 !IF DEFINED(DEBUG)
 LINK_FLAGS = $(LINK_FLAGS) /DEBUG
--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@ -1,74 +0,0 @@
-USING: help.markup help.syntax calendar quotations system ;
-IN: alarms
-
-HELP: alarm
-{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;
-
-HELP: start-alarm
-{ $values { "alarm" alarm } }
-{ $description "Starts an alarm." } ;
-
-HELP: restart-alarm
-{ $values { "alarm" alarm } }
-{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;
-
-HELP: stop-alarm
-{ $values { "alarm" alarm } }
-{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
-
-HELP: every
-{ $values
-     { "quot" quotation } { "interval-duration" duration }
-     { "alarm" alarm } }
-{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }
-{ $examples
-    { $unchecked-example
-        "USING: alarms io calendar ;"
-        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
-        ""
-    }
-} ;
-
-HELP: later
-{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }
-{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }
-{ $examples
-    { $unchecked-example
-        "USING: alarms io calendar ;"
-        """[ "Break's over!" print flush ] 15 minutes later drop"""
-        ""
-    }
-} ;
-
-HELP: delayed-every
-{ $values
-     { "quot" quotation } { "duration" duration }
-     { "alarm" alarm } }
-{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }
-{ $examples
-    { $unchecked-example
-        "USING: alarms io calendar ;"
-        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
-        ""
-    }
-} ;
-
-ARTICLE: "alarms" "Alarms"
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl
-"The alarm class:"
-{ $subsections alarm }
-"Create an alarm before starting it:"
-{ $subsections <alarm> }
-"Starting an alarm:"
-{ $subsections start-alarm restart-alarm }
-"Stopping an alarm:"
-{ $subsections stop-alarm }
-
-"A recurring alarm without an initial delay:"
-{ $subsections every }
-"A one-time alarm with an initial delay:"
-{ $subsections later }
-"A recurring alarm with an initial delay:"
-{ $subsections delayed-every } ;
-
-ABOUT: "alarms"
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@ -1,119 +1,5 @@
-! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar combinators.short-circuit fry
-heaps init kernel math math.functions math.parser namespaces
-quotations sequences system threads ;
+USING: ;
 IN: alarms

-TUPLE: alarm
-    { quot callable initial: [ ] }
-    start-nanos 
-    delay-nanos
-    interval-nanos
-    iteration-start-nanos
-    quotation-running?
-    restart?
-    thread ;
-
-<PRIVATE
-
-GENERIC: >nanoseconds ( obj -- duration/f )
-M: f >nanoseconds ;
-M: real >nanoseconds >integer ;
-M: duration >nanoseconds duration>nanoseconds >integer ;
-
-: set-next-alarm-time ( alarm -- alarm )
-    ! start + delay + ceiling((now - (start + delay)) / interval) * interval
-    nano-count 
-    over start-nanos>> -
-    over delay-nanos>> [ - ] when*
-    over interval-nanos>> / ceiling
-    over interval-nanos>> *
-    over start-nanos>> +
-    over delay-nanos>> [ + ] when*
-    >>iteration-start-nanos ;
-
-: stop-alarm? ( alarm -- ? )
-    { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
-
-DEFER: call-alarm-loop
-
-: loop-alarm ( alarm -- )
-    nano-count over
-    [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
-    [ set-next-alarm-time ] dip
-    [ dup iteration-start-nanos>> ] [ 0 ] if
-    0 or sleep-until call-alarm-loop ;
-
-: maybe-loop-alarm ( alarm -- )
-    dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1||
-    [ drop ] [ loop-alarm ] if ;
-
-: call-alarm-loop ( alarm -- )
-    dup stop-alarm? [
-        drop
-    ] [
-        [
-            [ t >>quotation-running? drop ]
-            [ quot>> call( -- ) ]
-            [ f >>quotation-running? drop ] tri
-        ] keep
-        maybe-loop-alarm
-    ] if ;
-
-: sleep-delay ( alarm -- )
-    dup stop-alarm? [
-        drop
-    ] [
-        nano-count >>start-nanos
-        delay-nanos>> [ sleep ] when*
-    ] if ;
-
-: alarm-loop ( alarm -- )
-    [ sleep-delay ]
-    [ nano-count >>iteration-start-nanos call-alarm-loop ]
-    [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ;
-
-PRIVATE>
-
-: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
-    alarm new
-        swap >nanoseconds >>interval-nanos
-        swap >nanoseconds >>delay-nanos
-        swap >>quot ; inline
-
-: start-alarm ( alarm -- )
-    [
-        '[ _ alarm-loop ] "Alarm execution" spawn
-    ] keep thread<< ;
-
-: stop-alarm ( alarm -- )
-    dup quotation-running?>> [
-        f >>thread drop
-    ] [
-        [ [ interrupt ] when* f ] change-thread drop
-    ] if ;
-
-: restart-alarm ( alarm -- )
-    t >>restart?
-    dup quotation-running?>> [
-        drop
-    ] [
-        dup thread>> [ nip interrupt ] [ start-alarm ] if*
-    ] if ;
-
-<PRIVATE
-
-: (start-alarm) ( quot start-duration interval-duration -- alarm )
-    <alarm> [ start-alarm ] keep ;
-
-PRIVATE>
-
-: every ( quot interval-duration -- alarm )
-    [ f ] dip (start-alarm) ;
-
-: later ( quot delay-duration -- alarm )
-    f (start-alarm) ;
-
-: delayed-every ( quot duration -- alarm )
-    dup (start-alarm) ;
--- a/basis/alarms/authors.txt
+++ b/basis/alarms/authors.txt
--- a/basis/alarms/summary.txt
+++ b/basis/alarms/summary.txt
@ -1 +0,0 @@
-One-time and recurring events
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@ -140,7 +140,6 @@ IN: calendar.tests
 [ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
        2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test

-[ t ] [ now timestamp>micros system-micros - 1000000 < ] unit-test
 [ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
 [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
 [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@ -7,6 +7,8 @@ IN: calendar

 HOOK: gmt-offset os ( -- hours minutes seconds )

+HOOK: gmt os ( -- timestamp )
+
 TUPLE: duration
    { year real }
    { month real }
@ -371,10 +373,6 @@ M: duration time-
 : timestamp>micros ( timestamp -- n )
    unix-1970 (time-) 1000000 * >integer ;

-: gmt ( -- timestamp )
-    #! GMT time, right now
-    unix-1970 system-micros microseconds time+ ;
-
 : now ( -- timestamp ) gmt >local-time ;
 : hence ( duration -- timestamp ) now swap time+ ;
 : ago ( duration -- timestamp ) now swap time- ;
--- a/basis/calendar/unix/unix.factor
+++ b/basis/calendar/unix/unix.factor
@ -5,11 +5,11 @@ kernel math unix unix.time unix.types namespaces system
 accessors classes.struct ;
 IN: calendar.unix

-: timeval>seconds ( timeval -- seconds )
+: timeval>duration ( timeval -- duration )
    [ sec>> seconds ] [ usec>> microseconds ] bi time+ ;

 : timeval>unix-time ( timeval -- timestamp )
-    timeval>seconds since-1970 ;
+    timeval>duration since-1970 ;

 : timespec>seconds ( timespec -- seconds )
    [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
@ -28,3 +28,13 @@ IN: calendar.unix

 M: unix gmt-offset ( -- hours minutes seconds )
    get-time gmtoff>> 3600 /mod 60 /mod ;
+
+: current-timeval ( -- timeval )
+    timeval <struct> f [ gettimeofday io-error ] 2keep drop ;
+
+: system-micros ( -- n )
+    current-timeval
+    [ sec>> 1,000,000 * ] [ usec>> ] bi + ;
+
+M: unix gmt
+    current-timeval timeval>unix-time ;
--- a/basis/calendar/windows/windows.factor
+++ b/basis/calendar/windows/windows.factor
@ -1,8 +1,33 @@
 USING: calendar namespaces alien.c-types system
 windows.kernel32 kernel math combinators windows.errors
-accessors classes.struct ;
+accessors classes.struct calendar.format math.functions ;
 IN: calendar.windows

+: timestamp>SYSTEMTIME ( timestamp -- SYSTEMTIME )
+    {
+        [ year>> ]
+        [ month>> ]
+        [ day-of-week ]
+        [ day>> ]
+        [ hour>> ]
+        [ minute>> ]
+        [
+            second>> dup floor
+            [ nip >integer ]
+            [ - 1000 * >integer ] 2bi
+        ]
+    } cleave \ SYSTEMTIME <struct-boa> ;
+
+: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp )
+    {
+        [ wYear>> ]
+        [ wMonth>> ]
+        [ wDay>> ]
+        [ wHour>> ]
+        [ wMinute>> ]
+        [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
+    } cleave instant <timestamp> ;
+
 M: windows gmt-offset ( -- hours minutes seconds )
    TIME_ZONE_INFORMATION <struct>
    dup GetTimeZoneInformation {
@ -11,3 +36,6 @@ M: windows gmt-offset ( -- hours minutes seconds )
        { TIME_ZONE_ID_STANDARD [ Bias>> ] }
        { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
    } case neg 60 /mod 0 ;
+
+M: windows gmt
+    SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@ -474,4 +474,3 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ;
        7 >>a
        8 >>b
 ] unit-test
-
--- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
@ -42,13 +42,12 @@ V{

 [
    V{
-        T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
-        T{ ##call-gc }
+        T{ ##call-gc f T{ gc-map } }
        T{ ##branch }
    }
 ]
 [
-    V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+    <gc-call> instructions>>
 ] unit-test

 30 \ vreg-counter set-global
@ -82,7 +81,7 @@ V{

 [ ] [ cfg get needs-predecessors drop ] unit-test

-[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test

 [ t ] [ 1 get successors>> first gc-check? ] unit-test

@ -146,8 +145,7 @@ H{

 [
    V{
-        T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
-        T{ ##call-gc }
+        T{ ##call-gc f T{ gc-map } }
        T{ ##branch }
    }
 ] [ 2 get predecessors>> second instructions>> ] unit-test
--- a/basis/compiler/cfg/height/height-tests.factor
+++ b/basis/compiler/cfg/height/height-tests.factor
@ -0,0 +1,26 @@
+USING: compiler.cfg.height compiler.cfg.instructions
+compiler.cfg.registers tools.test ;
+IN: compiler.cfg.height.tests
+
+[
+    V{
+        T{ ##inc-r f -1 f }
+        T{ ##inc-d f 4 f }
+        T{ ##peek f 0 D 4 f }
+        T{ ##peek f 1 D 0 f }
+        T{ ##replace f 0 R -1 f }
+        T{ ##replace f 1 R 0 f }
+        T{ ##peek f 2 D 0 f }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##inc-d f 3 }
+        T{ ##peek f 1 D -1 }
+        T{ ##replace f 0 R 0 }
+        T{ ##inc-r f -1 }
+        T{ ##replace f 1 R 0 }
+        T{ ##inc-d f 1 }
+        T{ ##peek f 2 D 0 }
+    } height-step
+] unit-test
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
 compiler.cfg compiler.cfg.registers compiler.cfg.instructions
@ -11,19 +11,17 @@ IN: compiler.cfg.height
 SYMBOL: ds-height
 SYMBOL: rs-height

-GENERIC: compute-heights ( insn -- )
+: init-height ( -- )
+    0 ds-height set
+    0 rs-height set ;

-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
+GENERIC: visit-insn ( insn -- )

-GENERIC: normalize-height* ( insn -- insn' )
+: normalize-inc-d/r ( insn stack -- )
+    swap n>> '[ _ + ] change ; inline

-: normalize-inc-d/r ( insn stack -- insn' )
-    swap n>> '[ _ - ] change f ; inline
-
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+M: ##inc-d visit-insn ds-height normalize-inc-d/r ;
+M: ##inc-r visit-insn rs-height normalize-inc-d/r ;

 GENERIC: loc-stack ( loc -- stack )

@ -35,21 +33,23 @@ GENERIC: <loc> ( n stack -- loc )
 M: ds-loc <loc> drop <ds-loc> ;
 M: rs-loc <loc> drop <rs-loc> ;

-: normalize-peek/replace ( insn -- insn' )
-    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+: normalize-peek/replace ( insn -- )
+    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc
+    drop ; inline

-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
+M: ##peek visit-insn normalize-peek/replace ;
+M: ##replace visit-insn normalize-peek/replace ;

-M: insn normalize-height* ;
+M: insn visit-insn drop ;

 : height-step ( insns -- insns' )
-    0 ds-height set
-    0 rs-height set
-    [ [ compute-heights ] each ]
-    [ [ [ normalize-height* ] map sift ] with-scope ] bi
-    ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
-    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+    init-height
+    [ <reversed> [ visit-insn ] each ]
+    [
+        [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter!
+        ds-height get [ \ ##inc-d new-insn prefix ] unless-zero
+        rs-height get [ \ ##inc-r new-insn prefix ] unless-zero
+    ] bi ;

 : normalize-height ( cfg -- cfg' )
    dup [ height-step ] simple-optimization ;
--- a/basis/compiler/cfg/ssa/interference/interference-tests.factor
+++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor
@ -182,7 +182,7 @@ V{

 V{
    T{ ##save-context f 77 78 }
-    T{ ##call-gc f { } }
+    T{ ##call-gc f T{ gc-map } }
    T{ ##branch }
 } 2 test-bb

--- a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor
+++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor
@ -29,8 +29,8 @@ V{

 [ ] [ test-uninitialized ] unit-test

-[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
-[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test
+[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test

 ! When merging, if a location is uninitialized in one branch and
 ! initialized in another, we have to consider it uninitialized,
@ -57,4 +57,4 @@ V{

 [ ] [ test-uninitialized ] unit-test

-[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
+[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test
--- a/basis/concurrency/conditions/conditions.factor
+++ b/basis/concurrency/conditions/conditions.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: deques threads kernel arrays sequences alarms fry ;
+USING: deques threads kernel arrays sequences timers fry ;
 IN: concurrency.conditions

 : notify-1 ( deque -- )
@ -9,8 +9,8 @@ IN: concurrency.conditions
 : notify-all ( deque -- )
    [ resume-now ] slurp-deque ; inline

-: queue-timeout ( queue timeout -- alarm )
-    #! Add an alarm which removes the current thread from the
+: queue-timeout ( queue timeout -- timer )
+    #! Add an timer which removes the current thread from the
    #! queue, and resumes it, passing it a value of t.
    [
        [ self swap push-front* ] keep '[
@ -28,7 +28,7 @@ ERROR: wait-timeout ;
 : wait ( queue timeout status -- )
    over [
        [ queue-timeout ] dip suspend
-        [ wait-timeout ] [ stop-alarm ] if
+        [ wait-timeout ] [ stop-timer ] if
    ] [
        [ drop queue ] dip suspend drop
    ] if ; inline
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@ -1,10 +1,12 @@
 ! Copyright (C) 2008, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.syntax kernel math
-namespaces sequences destructors combinators threads heaps
-deques calendar system core-foundation core-foundation.strings
-core-foundation.file-descriptors core-foundation.timers
-core-foundation.time ;
+USING: accessors alien alien.c-types alien.syntax calendar
+classes.struct combinators core-foundation
+core-foundation.file-descriptors core-foundation.strings
+core-foundation.time core-foundation.timers deques destructors
+heaps kernel math namespaces sequences system threads unix
+unix.time ;
+FROM: calendar.unix => system-micros ;
 IN: core-foundation.run-loop

 CONSTANT: kCFRunLoopRunFinished 1
--- a/basis/core-foundation/timers/timers.factor
+++ b/basis/core-foundation/timers/timers.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax system math kernel calendar
-core-foundation core-foundation.time ;
+core-foundation core-foundation.time calendar.unix ;
 IN: core-foundation.timers

 TYPEDEF: void* CFRunLoopTimerRef
--- a/basis/furnace/alloy/alloy.factor
+++ b/basis/furnace/alloy/alloy.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences db.tuples alarms calendar db fry
+USING: kernel sequences db.tuples timers calendar db fry
 furnace.db
 furnace.cache
 furnace.asides
--- a/basis/furnace/cache/cache.factor
+++ b/basis/furnace/cache/cache.factor
@ -22,7 +22,7 @@ server-state f

 : expire-state ( class -- )
    new
-        -1/0. system-micros [a,b] >>expires
+        -1/0. gmt timestamp>micros [a,b] >>expires
    delete-tuples ;

 TUPLE: server-state-manager < filter-responder timeout ;
--- a/basis/furnace/sessions/sessions.factor
+++ b/basis/furnace/sessions/sessions.factor
@ -3,7 +3,7 @@
 USING: assocs kernel math.intervals math.parser namespaces
 strings random accessors quotations hashtables sequences
 continuations fry calendar combinators combinators.short-circuit
-destructors alarms io.sockets db db.tuples db.types
+destructors io.sockets db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
 furnace.cache furnace.scopes furnace.utilities ;
 IN: furnace.sessions
--- a/basis/hashtables/identity/authors.txt
+++ b/basis/hashtables/identity/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/basis/hashtables/identity/identity-tests.factor
+++ b/basis/hashtables/identity/identity-tests.factor
@ -0,0 +1,31 @@
+! (c)2010 Joe Groff bsd license
+USING: assocs hashtables.identity kernel literals tools.test ;
+IN: hashtables.identity.tests
+
+CONSTANT: the-real-slim-shady "marshall mathers"
+
+CONSTANT: will
+    IH{
+        { $ the-real-slim-shady t }
+        { "marshall mathers"    f }
+    }
+
+: please-stand-up ( assoc key -- value )
+    swap at ;
+
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test
+
+[ 2 ] [ will assoc-size ] unit-test
+[ { { "marshall mathers" f } } ] [
+    the-real-slim-shady will clone
+    [ delete-at ] [ >alist ] bi
+] unit-test
+[ t ] [
+    t the-real-slim-shady identity-associate
+    t the-real-slim-shady identity-associate =
+] unit-test
+[ f ] [
+    t the-real-slim-shady identity-associate
+    t "marshall mathers"  identity-associate =
+] unit-test
--- a/basis/hashtables/identity/identity.factor
+++ b/basis/hashtables/identity/identity.factor
@ -0,0 +1,62 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs fry hashtables kernel parser
+sequences vocabs.loader ;
+IN: hashtables.identity
+
+TUPLE: identity-wrapper
+    { underlying read-only } ;
+C: <identity-wrapper> identity-wrapper
+
+M: identity-wrapper equal?
+    over identity-wrapper?
+    [ [ underlying>> ] bi@ eq? ]
+    [ 2drop f ] if ; inline
+
+M: identity-wrapper hashcode*
+    nip underlying>> identity-hashcode ; inline
+
+TUPLE: identity-hashtable
+    { underlying hashtable read-only } ;
+
+: <identity-hashtable> ( n -- ihash )
+    <hashtable> identity-hashtable boa ; inline
+
+<PRIVATE
+: identity@ ( key ihash -- ikey hash )
+    [ <identity-wrapper> ] [ underlying>> ] bi* ; inline
+PRIVATE>
+
+M: identity-hashtable at*
+    identity@ at* ; inline
+
+M: identity-hashtable clear-assoc
+    underlying>> clear-assoc ; inline
+
+M: identity-hashtable delete-at
+    identity@ delete-at ; inline
+
+M: identity-hashtable assoc-size
+    underlying>> assoc-size ; inline
+
+M: identity-hashtable set-at
+    identity@ set-at ; inline
+
+: identity-associate ( value key -- hash )
+    2 <identity-hashtable> [ set-at ] keep ; inline
+
+M: identity-hashtable >alist
+    underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;
+    
+M: identity-hashtable clone
+    underlying>> clone identity-hashtable boa ; inline
+
+M: identity-hashtable equal?
+    over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;
+
+: >identity-hashtable ( assoc -- ihashtable )
+    dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;
+
+SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;
+
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when
--- a/basis/hashtables/identity/mirrors/mirrors.factor
+++ b/basis/hashtables/identity/mirrors/mirrors.factor
@ -0,0 +1,4 @@
+USING: hashtables.identity mirrors ;
+IN: hashtables.identity.mirrors
+
+M: identity-hashtable make-mirror ;
--- a/basis/hashtables/identity/prettyprint/prettyprint.factor
+++ b/basis/hashtables/identity/prettyprint/prettyprint.factor
@ -0,0 +1,12 @@
+! (c)2010 Joe Groff bsd license
+USING: assocs continuations hashtables.identity kernel
+namespaces prettyprint.backend prettyprint.config
+prettyprint.custom ;
+IN: hashtables.identity.prettyprint
+
+M: identity-hashtable >pprint-sequence >alist ;
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;
+
+M: identity-hashtable pprint*
+    nesting-limit inc
+    [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
--- a/basis/hashtables/identity/summary.txt
+++ b/basis/hashtables/identity/summary.txt
@ -0,0 +1 @@
+Hashtables keyed by object identity (eq?) rather than by logical value (=)
--- a/basis/io/files/unique/unique.factor
+++ b/basis/io/files/unique/unique.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators continuations fry io io.backend
 io.directories io.directories.hierarchy io.files io.pathnames
-kernel math math.bitwise math.parser namespaces random
+kernel locals math math.bitwise math.parser namespaces random
 sequences system vocabs.loader ;
 IN: io.files.unique

@ -78,9 +78,10 @@ PRIVATE>

 : temporary-file ( -- path ) "" unique-file ;

-: with-working-directory ( path quot -- )
-    over make-directories
-    dupd '[ _ _ with-temporary-directory ] with-directory ; inline
+:: cleanup-unique-working-directory ( quot -- )
+    unique-directory :> path
+    path [ path quot with-temporary-directory ] with-directory
+    path delete-tree ; inline

 {
    { [ os unix? ] [ "io.files.unique.unix" ] }
--- a/basis/io/pipes/pipes.factor
+++ b/basis/io/pipes/pipes.factor
@ -37,17 +37,22 @@ M: callable run-pipeline-element
        '[ _ call( -- result ) ] with-streams*
    ] with-destructors ;

-: <pipes> ( n -- pipes )
+GENERIC: <pipes> ( obj -- pipes )
+
+M: integer <pipes> ( n -- pipes )
    [
        [ (pipe) |dispose ] replicate
        T{ pipe } [ prefix ] [ suffix ] bi
        2 <clumps>
    ] with-destructors ;

+M: sequence <pipes>
+    [ { } ] [ length 1 - <pipes> ] if-empty ;
+
 PRIVATE>

 : run-pipeline ( seq -- results )
-    [ length dup zero? [ drop { } ] [ 1 - <pipes> ] if ] keep
+    [ <pipes> ] keep
    [
        [ [ first in>> ] [ second out>> ] bi ] dip
        run-pipeline-element
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@ -34,6 +34,10 @@ ARTICLE: "network-connection" "Connection-oriented networking"
    <client>
    with-client
 }
+"The local address of a client socket can be controlled with this word:"
+{ $subsections
+    with-local-address
+}
 "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
 { $subsections
    <server>
@ -215,3 +219,17 @@ HELP: send
 HELP: resolve-host
 { $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
 { $description "Resolves host names to IP addresses." } ;
+
+HELP: with-local-address
+{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } }
+{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." }
+{ $examples
+  { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1."
+    "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." }
+  { $code "\"127.0.0.1\" 0 <inet4> [ ] with-local-address" }
+  $nl
+  { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. "
+    "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown."
+  }
+  { $code "\"192.168.0.1\" 23000 <inet4> [ ] with-local-address" }
+} ;
--- a/basis/io/timeouts/timeouts.factor
+++ b/basis/io/timeouts/timeouts.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel calendar alarms io io.encodings accessors
+USING: kernel calendar timers io io.encodings accessors
 namespaces fry io.streams.null ;
 IN: io.timeouts

@ -13,11 +13,11 @@ M: encoder set-timeout stream>> set-timeout ;

 GENERIC: cancel-operation ( obj -- )

-: queue-timeout ( obj timeout -- alarm )
+: queue-timeout ( obj timeout -- timer )
    [ '[ _ cancel-operation ] ] dip later ;

 : with-timeout* ( obj timeout quot -- )
-    3dup drop queue-timeout [ nip call ] dip stop-alarm ;
+    3dup drop queue-timeout [ nip call ] dip stop-timer ;
    inline

 : with-timeout ( obj quot -- )
--- a/basis/logging/insomniac/insomniac.factor
+++ b/basis/logging/insomniac/insomniac.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: logging.analysis logging.server logging smtp kernel
-io.files io.streams.string namespaces make alarms assocs
+io.files io.streams.string namespaces make timers assocs
 io.encodings.utf8 accessors calendar sequences ;
 QUALIFIED: io.sockets
 IN: logging.insomniac
--- a/basis/math/quaternions/quaternions-tests.factor
+++ b/basis/math/quaternions/quaternions-tests.factor
@ -29,3 +29,6 @@ CONSTANT: qk { 0 0 0 1 }
 [ t ] [ qi qi q- q0 = ] unit-test
 [ t ] [ qi qj q+ qj qi q+ = ] unit-test
 [ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test
+
+[ { 2 2 2 2 } ] [ { 1 1 1 1 } 2 q*n ] unit-test
+[ { 2 2 2 2 } ] [ 2 { 1 1 1 1 } n*q ] unit-test
--- a/basis/math/quaternions/quaternions.factor
+++ b/basis/math/quaternions/quaternions.factor
@ -35,8 +35,8 @@ M: object qconjugate ( u -- u' )
 : q/ ( u v -- u/v )
    qrecip q* ; inline

-: n*q ( q n -- r )
-    v*n ; inline
+: n*q ( n q -- r )
+    n*v ; inline

 : q*n ( q n -- r )
    v*n ; inline
--- a/basis/math/vectors/simd/cords/cords-tests.factor
+++ b/basis/math/vectors/simd/cords/cords-tests.factor
@ -0,0 +1,4 @@
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;
+IN: math.vectors.simd.cords.tests
+
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test
--- a/basis/math/vectors/simd/cords/cords.factor
+++ b/basis/math/vectors/simd/cords/cords.factor
@ -28,8 +28,8 @@ BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
 WHERE

 : >A ( seq -- A )
-    [ N head >A/2 ]
-    [ N tail >A/2 ] bi cord-append ;
+    [ N head-slice >A/2 ]
+    [ N tail-slice >A/2 ] bi cord-append ;

 \ A-boa
 { N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
--- a/basis/models/delay/delay.factor
+++ b/basis/models/delay/delay.factor
@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms fry kernel models ;
+USING: accessors timers fry kernel models ;
 IN: models.delay

-TUPLE: delay < model model timeout alarm ;
+TUPLE: delay < model model timeout timer ;

 : update-delay-model ( delay -- )
    [ model>> value>> ] keep set-model ;
@ -15,13 +15,13 @@ TUPLE: delay < model model timeout alarm ;
        [ add-dependency ] keep ;

 : stop-delay ( delay -- )
-    alarm>> [ stop-alarm ] when* ;
+    timer>> [ stop-timer ] when* ;

 : start-delay ( delay -- )
    dup
-    [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi
+    [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi
    later
-    >>alarm drop ;
+    >>timer drop ;

 M: delay model-changed nip dup stop-delay start-delay ;

--- a/basis/serialize/serialize.factor
+++ b/basis/serialize/serialize.factor
@ -8,11 +8,11 @@
 !
 USING: namespaces sequences kernel math io math.functions
 io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables assocs help.syntax
-help.markup splitting io.streams.byte-array io.encodings.string
-io.encodings.utf8 io.encodings.binary combinators accessors
-locals prettyprint compiler.units sequences.private
-classes.tuple.private vocabs.loader ;
+vectors byte-arrays quotations hashtables hashtables.identity
+assocs help.syntax help.markup splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators accessors locals prettyprint compiler.units
+sequences.private classes.tuple.private vocabs.loader ;
 IN: serialize

 GENERIC: (serialize) ( obj -- )
@ -22,22 +22,14 @@ GENERIC: (serialize) ( obj -- )
 ! Variable holding a assoc of objects already serialized
 SYMBOL: serialized

-TUPLE: id obj ;
-
-C: <id> id
-
-M: id hashcode* nip obj>> identity-hashcode ;
-
-M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
-
 : add-object ( obj -- )
    #! Add an object to the sequence of already serialized
    #! objects.
-    serialized get [ assoc-size swap <id> ] keep set-at ;
+    serialized get [ assoc-size swap ] keep set-at ;

 : object-id ( obj -- id )
    #! Return the id of an already serialized object 
-    <id> serialized get at ;
+    serialized get at ;

 ! Numbers are serialized as follows:
 ! 0 => B{ 0 }
@ -289,7 +281,7 @@ PRIVATE>
    [ (deserialize) ] with-variable ;

 : serialize ( obj -- )
-    H{ } clone serialized [ (serialize) ] with-variable ;
+    IH{ } clone serialized [ (serialize) ] with-variable ;

 : bytes>object ( bytes -- obj )
    binary [ deserialize ] with-byte-reader ;
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@ -188,7 +188,7 @@ ERROR: invalid-header-string string ;
        "<" %
        64 random-bits #
        "-" %
-        system-micros #
+        gmt timestamp>micros #
        "@" %
        smtp-domain get [ host-name ] unless* %
        ">" %
--- a/basis/stack-checker/errors/prettyprint/prettyprint.factor
+++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor
@ -55,8 +55,10 @@ M: do-not-compile summary
    word>> name>> "Cannot compile call to “" "”" surround ;

 M: unbalanced-branches-error summary
-    word>> name>>
-    "The input quotations to “" "” don't match their expected effects" surround ;
+    [ word>> name>> ] [ quots>> length 1 = ] bi
+    [ "The input quotation to “" "” doesn't match its expected effect" ]
+    [ "The input quotations to “" "” don't match their expected effects" ] if
+    surround ;

 M: unbalanced-branches-error error.
    dup summary print
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@ -459,7 +459,6 @@ M: bad-executable summary
 \ special-object { fixnum } { object } define-primitive \ special-object make-flushable
 \ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
 \ strip-stack-traces { } { } define-primitive
-\ system-micros { } { integer } define-primitive \ system-micros make-flushable
 \ tag { object } { fixnum } define-primitive \ tag make-foldable
 \ unimplemented { } { } define-primitive
 \ word-code { word } { integer integer } define-primitive \ word-code make-flushable
--- a/basis/timers/authors.txt
+++ b/basis/timers/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/basis/timers/summary.txt
+++ b/basis/timers/summary.txt
@ -0,0 +1 @@
+One-time and recurring timers for relative time offsets
--- a/basis/timers/timers-docs.factor
+++ b/basis/timers/timers-docs.factor
@ -0,0 +1,74 @@
+USING: help.markup help.syntax calendar quotations system ;
+IN: timers
+
+HELP: timer
+{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;
+
+HELP: start-timer
+{ $values { "timer" timer } }
+{ $description "Starts a timer." } ;
+
+HELP: restart-timer
+{ $values { "timer" timer } }
+{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;
+
+HELP: stop-timer
+{ $values { "timer" timer } }
+{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;
+
+HELP: every
+{ $values
+     { "quot" quotation } { "interval-duration" duration }
+     { "timer" timer } }
+{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }
+{ $examples
+    { $unchecked-example
+        "USING: timers io calendar ;"
+        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+        ""
+    }
+} ;
+
+HELP: later
+{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }
+{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }
+{ $examples
+    { $unchecked-example
+        "USING: timers io calendar ;"
+        """[ "Break's over!" print flush ] 15 minutes later drop"""
+        ""
+    }
+} ;
+
+HELP: delayed-every
+{ $values
+     { "quot" quotation } { "duration" duration }
+     { "timer" timer } }
+{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }
+{ $examples
+    { $unchecked-example
+        "USING: timers io calendar ;"
+        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+        ""
+    }
+} ;
+
+ARTICLE: "timers" "Alarms"
+"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl
+"The timer class:"
+{ $subsections timer }
+"Create a timer before starting it:"
+{ $subsections <timer> }
+"Starting a timer:"
+{ $subsections start-timer restart-timer }
+"Stopping a timer:"
+{ $subsections stop-timer }
+
+"A recurring timer without an initial delay:"
+{ $subsections every }
+"A one-time timer with an initial delay:"
+{ $subsections later }
+"A recurring timer with an initial delay:"
+{ $subsections delayed-every } ;
+
+ABOUT: "timers"
--- a/basis/timers/timers-tests.factor
+++ b/basis/timers/timers-tests.factor
@ -1,12 +1,12 @@
-USING: alarms alarms.private calendar concurrency.count-downs
+USING: timers timers.private calendar concurrency.count-downs
 concurrency.promises fry kernel math math.order sequences
 threads tools.test tools.time ;
-IN: alarms.tests
+IN: timers.tests

 [ ] [
    1 <count-down>
    { f } clone 2dup
-    [ first stop-alarm count-down ] 2curry 1 seconds later
+    [ first stop-timer count-down ] 2curry 1 seconds later
    swap set-first
    await
 ] unit-test
@ -28,20 +28,20 @@ IN: alarms.tests
    { 3 } dup
    '[ 4 _ set-first ] 2 seconds later
    1/2 seconds sleep
-    stop-alarm
+    stop-timer
 ] unit-test

 [ { 1 } ] [
    { 0 }
    dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later
-    [ stop-alarm ] [ start-alarm ] bi
+    [ stop-timer ] [ start-timer ] bi
    4 seconds sleep
 ] unit-test

 [ { 0 } ] [
    { 0 }
    dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later
-    2 seconds sleep stop-alarm
+    2 seconds sleep stop-timer
    1/2 seconds sleep
 ] unit-test

@ -49,19 +49,19 @@ IN: alarms.tests
    { 0 }
    dup '[ 1 _ set-first ] 300 milliseconds later
    150 milliseconds sleep
-    [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi
+    [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi
 ] unit-test

 [ { 1 } ] [
    { 0 }
    dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
-    100 milliseconds sleep restart-alarm 300 milliseconds sleep
+    100 milliseconds sleep restart-timer 300 milliseconds sleep
 ] unit-test

 [ { 4 } ] [
    { 0 }
    dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds
-    <alarm> dup start-alarm
-    700 milliseconds sleep dup restart-alarm
-    700 milliseconds sleep stop-alarm 500 milliseconds sleep
+    <timer> dup start-timer
+    700 milliseconds sleep dup restart-timer
+    700 milliseconds sleep stop-timer 500 milliseconds sleep
 ] unit-test
--- a/basis/timers/timers.factor
+++ b/basis/timers/timers.factor
@ -0,0 +1,122 @@
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators.short-circuit fry
+heaps init kernel math math.functions math.parser namespaces
+quotations sequences system threads ;
+IN: timers
+
+TUPLE: timer
+    { quot callable initial: [ ] }
+    start-nanos 
+    delay-nanos
+    interval-nanos
+    iteration-start-nanos
+    quotation-running?
+    restart?
+    thread ;
+
+<PRIVATE
+
+GENERIC: >nanoseconds ( obj -- duration/f )
+M: f >nanoseconds ;
+M: real >nanoseconds >integer ;
+M: duration >nanoseconds duration>nanoseconds >integer ;
+
+: set-next-timer-time ( timer -- timer )
+    ! start + delay + ceiling((now - (start + delay)) / interval) * interval
+    nano-count 
+    over start-nanos>> -
+    over delay-nanos>> [ - ] when*
+    over interval-nanos>> / ceiling
+    over interval-nanos>> *
+    over start-nanos>> +
+    over delay-nanos>> [ + ] when*
+    >>iteration-start-nanos ;
+
+: stop-timer? ( timer -- ? )
+    { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
+
+DEFER: call-timer-loop
+
+: loop-timer ( timer -- )
+    nano-count over
+    [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
+    [ set-next-timer-time ] dip
+    [ dup iteration-start-nanos>> ] [ 0 ] if
+    0 or sleep-until call-timer-loop ;
+
+: maybe-loop-timer ( timer -- )
+    dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
+    [ drop ] [ loop-timer ] if ;
+
+: call-timer-loop ( timer -- )
+    dup stop-timer? [
+        drop
+    ] [
+        [
+            [ t >>quotation-running? drop ]
+            [ quot>> call( -- ) ]
+            [ f >>quotation-running? drop ] tri
+        ] keep
+        maybe-loop-timer
+    ] if ;
+
+: sleep-delay ( timer -- )
+    dup stop-timer? [
+        drop
+    ] [
+        nano-count >>start-nanos
+        delay-nanos>> [ sleep ] when*
+    ] if ;
+
+: timer-loop ( timer -- )
+    [ sleep-delay ]
+    [ nano-count >>iteration-start-nanos call-timer-loop ]
+    [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
+
+PRIVATE>
+
+: <timer> ( quot delay-duration/f interval-duration/f -- timer )
+    timer new
+        swap >nanoseconds >>interval-nanos
+        swap >nanoseconds >>delay-nanos
+        swap >>quot ; inline
+
+: start-timer ( timer -- )
+    [
+        '[ _ timer-loop ] "Alarm execution" spawn
+    ] keep thread<< ;
+
+: stop-timer ( timer -- )
+    dup quotation-running?>> [
+        f >>thread drop
+    ] [
+        [ [ interrupt ] when* f ] change-thread drop
+    ] if ;
+
+: restart-timer ( timer -- )
+    t >>restart?
+    dup quotation-running?>> [
+        drop
+    ] [
+        dup thread>> [ nip interrupt ] [ start-timer ] if*
+    ] if ;
+
+<PRIVATE
+
+: (start-timer) ( quot start-duration interval-duration -- timer )
+    <timer> [ start-timer ] keep ;
+
+PRIVATE>
+
+: every ( quot interval-duration -- timer )
+    [ f ] dip (start-timer) ;
+
+: later ( quot delay-duration -- timer )
+    f (start-timer) ;
+
+: delayed-every ( quot duration -- timer )
+    dup (start-timer) ;
+
+: nanos-since ( nano-count -- nanos )
+    [ nano-count ] dip - ;
--- a/basis/tools/deploy/config/config-docs.factor
+++ b/basis/tools/deploy/config/config-docs.factor
@ -64,7 +64,7 @@ $nl
 HELP: deploy-threads?
 { $description "Deploy flag. If set, thread support will be included in the final image."
 $nl
-"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, timers, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;

 HELP: deploy-ui?
 { $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@ -317,7 +317,7 @@ IN: tools.deploy.shaker
        strip-io? [ io-backend , ] when

        { } {
-            "alarms"
+            "timers"
            "tools"
            "io.launcher"
            "random"
--- a/basis/tools/disassembler/udis/udis-tests.factor
+++ b/basis/tools/disassembler/udis/udis-tests.factor
@ -2,8 +2,14 @@ IN: tools.disassembler.udis.tests
 USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;

 {
-    { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
-    { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] }
-    { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
+    {
+        [ cpu x86.32? ]
+        [
+            os windows?
+            [ [ 624 ] [ ud heap-size ] unit-test ]
+            [ [ 604 ] [ ud heap-size ] unit-test ] if
+        ]
+    }
+    { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] }
    [ ]
 } cond
--- a/basis/tools/disassembler/udis/udis.factor
+++ b/basis/tools/disassembler/udis/udis.factor
@ -67,7 +67,11 @@ STRUCT: ud
    { c3 uchar }
    { inp_cache uchar[256] }
    { inp_sess uchar[64] }
-    { itab_entry void* } ;
+    { have_modrm uchar }
+    { modrm uchar }
+    { user_opaque_data void* }
+    { itab_entry void* }
+    { le void* } ;

 FUNCTION: void ud_translate_intel ( ud* u ) ;
 FUNCTION: void ud_translate_att ( ud* u ) ;
--- a/basis/tools/errors/model/model.factor
+++ b/basis/tools/errors/model/model.factor
@ -15,5 +15,4 @@ M: updater errors-changed
    f <model> (error-list-model) set-global
    (error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
    updater add-error-observer
-] "ui.tools.error-list" add-startup-hook
-
+] "tools.errors.model" add-startup-hook
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
 vocabs.loader vocabs.metadata io combinators calendar accessors
 math.parser io.streams.string ui.tools.operations quotations
 strings arrays prettyprint words vocabs sorting sets classes
-math alien urls splitting ascii combinators.short-circuit alarms
+math alien urls splitting ascii combinators.short-circuit timers
 words.symbol system summary ;
 IN: tools.scaffold

@ -22,7 +22,9 @@ M: bad-developer-name summary

 <PRIVATE

-: vocab-root? ( string -- ? ) vocab-roots get member? ;
+: vocab-root? ( string -- ? )
+    trim-tail-separators
+    vocab-roots get member? ;

 : contains-dot? ( string -- ? ) ".." swap subseq? ;

@ -128,7 +130,7 @@ M: bad-developer-name summary
        { "ch" "a character" }
        { "word" word }
        { "array" array }
-        { "alarm" alarm }
+        { "timers" timer }
        { "duration" duration }
        { "path" "a pathname string" }
        { "vocab" "a vocabulary specifier" }
--- a/basis/tools/time/time-docs.factor
+++ b/basis/tools/time/time-docs.factor
@ -24,7 +24,7 @@ HELP: time
 { $values { "quot" quotation } }
 { $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;

-{ benchmark system-micros time } related-words
+{ benchmark time } related-words

 HELP: collect-gc-events
 { $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }
--- a/basis/ui/backend/cocoa/views/views.factor
+++ b/basis/ui/backend/cocoa/views/views.factor
@ -138,8 +138,8 @@ CONSTANT: selector>action H{
 }

 : validate-action ( world selector -- ? validated? )
-    selector>action at 
-    [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ; 
+    selector>action at
+    [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;

 CLASS: {
    { +superclass+ "NSOpenGLView" }
@ -305,8 +305,6 @@ CLASS: {
    ]
 }

-! "rotateWithEvent:" void { id SEL id }}
-
 { "acceptsFirstResponder" char { id SEL }
    [ 2drop 1 ]
 }
@ -408,10 +406,9 @@ CLASS: {
 { "dealloc" void { id SEL }
    [
        drop
-        [ unregister-window ]
        [ remove-observer ]
        [ SUPER-> dealloc ]
-        tri
+        bi
    ]
 } ;

@ -446,8 +443,8 @@ CLASS: {
    [
        forget-rollover
        2nip -> object -> contentView
-        dup -> isInFullScreenMode zero? 
-        [ window unfocus-world ]
+        dup -> isInFullScreenMode 0 =
+        [ window [ unfocus-world ] when* ]
        [ drop ] if
    ]
 }
@ -460,7 +457,8 @@ CLASS: {

 { "windowWillClose:" void { id SEL id }
    [
-        2nip -> object -> contentView window ungraft
+        2nip -> object -> contentView
+        [ window ungraft ] [ unregister-window ] bi
    ]
 } ;

--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@ -569,6 +569,9 @@ H{ } clone wm-handlers set-global
    [ [ execute( -- wm ) add-wm-handler ] with each ]
    [ wm-handlers get-global set-at ] if ;

+: remove-wm-handler ( wm -- )
+    wm-handlers get-global delete-at ;
+
 [ handle-wm-close 0                  ] WM_CLOSE add-wm-handler
 [ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler

--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays assocs calendar colors.constants
+USING: accessors timers arrays assocs calendar colors.constants
 combinators combinators.short-circuit documents
 documents.elements fry grouping kernel locals make math
 math.functions math.order math.ranges math.rectangles
@ -15,7 +15,7 @@ IN: ui.gadgets.editors
 TUPLE: editor < line-gadget
 caret-color
 caret mark
-focused? blink blink-alarm ;
+focused? blink blink-timer ;

 <PRIVATE

@ -60,11 +60,11 @@ SYMBOL: blink-interval
 750 milliseconds blink-interval set-global

 : stop-blinking ( editor -- )
-    blink-alarm>> [ stop-alarm ] when* ;
+    blink-timer>> [ stop-timer ] when* ;

 : start-blinking ( editor -- )
    t >>blink
-    blink-alarm>> [ restart-alarm ] when* ;
+    blink-timer>> [ restart-timer ] when* ;

 : restart-blinking ( editor -- )
    dup focused?>> [
@ -80,12 +80,12 @@ M: editor graft*
    [ dup mark>> activate-editor-model ]
    [
        [
-            '[ _ blink-caret ] blink-interval get dup <alarm>
-        ] keep blink-alarm<<
+            '[ _ blink-caret ] blink-interval get dup <timer>
+        ] keep blink-timer<<
    ] tri ;

 M: editor ungraft*
-    [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
+    [ [ stop-blinking ] [ f >>blink-timer drop ] bi ]
    [ dup caret>> deactivate-editor-model ]
    [ dup mark>> deactivate-editor-model ] tri ;

--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@ -1,10 +1,11 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.textures sequences io colors combinators
-combinators.short-circuit fry math.vectors math.rectangles cache
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.pixel-formats destructors literals strings ;
+USING: accessors arrays assocs cache colors combinators
+combinators.short-circuit concurrency.promises continuations
+destructors fry io kernel literals math math.rectangles
+math.vectors models namespaces opengl opengl.textures sequences
+strings ui.backend ui.gadgets ui.gadgets.tracks ui.gestures
+ui.pixel-formats ui.render ;
 IN: ui.gadgets.worlds

 SYMBOLS:
@ -40,6 +41,7 @@ TUPLE: world < track
    window-loc
    pixel-format-attributes
    background-color
+    promise
    window-controls
    window-resources ;

@ -118,7 +120,8 @@ M: world request-focus-on ( child gadget -- )
        f >>active?
        { 0 0 } >>window-loc
        f >>grab-input?
-        V{ } clone >>window-resources ;
+        V{ } clone >>window-resources
+        <promise> >>promise ;

 : initial-background-color ( attributes -- color )
    window-controls>> textured-background swap member-eq?
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@ -174,7 +174,7 @@ HELP: hand-last-button
 { $var-description "Global variable. The mouse button most recently pressed." } ;

 HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link system-micros } "." } ;
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link nano-count } "." } ;

 HELP: hand-buttons
 { $var-description "Global variable. A vector of mouse buttons currently held down." } ;
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs kernel math math.order models
 namespaces make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes boxes calendar alarms combinators
+math.vectors classes.tuple classes boxes calendar timers combinators
 sets columns fry deques ui.gadgets ui.gadgets.private ascii
 combinators.short-circuit ;
 FROM: namespaces => set ;
@ -188,15 +188,15 @@ SYMBOL: drag-timer
        [ drag-gesture ]
        300 milliseconds
        100 milliseconds
-        <alarm>
+        <timer>
        [ drag-timer get-global >box ]
-        [ start-alarm ] bi
+        [ start-timer ] bi
    ] when ;

 : stop-drag-timer ( -- )
    hand-buttons get-global empty? [
        drag-timer get-global ?box
-        [ stop-alarm ] [ drop ] if
+        [ stop-timer ] [ drop ] if
    ] when ;

 : fire-motion ( -- )
--- a/basis/ui/tools/error-list/error-list.factor
+++ b/basis/ui/tools/error-list/error-list.factor
@ -186,6 +186,8 @@ MEMO: error-list-gadget ( -- gadget )
    error-list-model get-global [ drop all-errors ] <arrow>
    <error-list-gadget> ;

+[ \ error-list-gadget reset-memoized ] "ui.tools.error-list" add-startup-hook
+
 : show-error-list ( -- )
    [ error-list-gadget eq? ] find-window
    [ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@ -1,12 +1,12 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs boxes io kernel math models namespaces make
-dlists deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables
-concurrency.flags sets accessors calendar fry destructors
-ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render strings
-classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
+USING: accessors arrays assocs boxes classes.tuple
+classes.tuple.parser combinators combinators.short-circuit
+concurrency.flags concurrency.promises continuations deques
+destructors dlists fry init kernel lexer make math namespaces
+parser sequences sets strings threads ui.backend ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser
+words ;
 IN: ui

 <PRIVATE
@ -94,6 +94,7 @@ M: world ungraft*
        [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
        [ [ (close-window) f ] change-handle drop ]
        [ unfocus-world ]
+        [ promise>> t swap fulfill ]
    } cleave ;

 : init-ui ( -- )
--- a/basis/unix/ffi/ffi.factor
+++ b/basis/unix/ffi/ffi.factor
@ -94,6 +94,7 @@ FUNCTION: int getpriority ( int which, id_t who ) ;
 FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
 FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
 FUNCTION: group* getgrent ;
+FUNCTION: void endgrent ( ) ;
 FUNCTION: int gethostname ( c-string name, int len ) ;
 FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
 FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
--- a/basis/unix/groups/groups-docs.factor
+++ b/basis/unix/groups/groups-docs.factor
@ -65,8 +65,8 @@ HELP: user-groups

 HELP: with-effective-group
 { $values
-     { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+     { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;

 HELP: with-group-cache
 { $values
@ -75,26 +75,55 @@ HELP: with-group-cache

 HELP: with-real-group
 { $values
-     { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+     { "string/id/f" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
+
+HELP: ?group-id
+{ $values
+    { "string" string }
+    { "id" "a group id" }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-group-names
+{ $values
+    
+    { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: group-exists?
+{ $values
+    { "name/id" "a name or a group id" }
+    { "?" boolean }
+}
+{ $description "Returns a boolean representing the group's existence." } ;

 ARTICLE: "unix.groups" "Unix groups"
 "The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
 $nl
-"Listing all groups:"
+"Listing all group structures:"
 { $subsections all-groups }
-"Real groups:"
+"Listing all group names:"
+{ $subsections all-group-names }
+"Checking if a group exists:"
+{ $subsections group-exists? }
+"Querying/setting the current real group:"
 { $subsections
    real-group-name
    real-group-id
    set-real-group
 }
-"Effective groups:"
+"Querying/setting the current effective group:"
 { $subsections
    effective-group-name
    effective-group-id
    set-effective-group
 }
+"Getting a group id from a group name or id:"
+{ $subsections
+    ?group-id
+}
 "Combinators to change groups:"
 { $subsections
    with-real-group
--- a/basis/unix/groups/groups-tests.factor
+++ b/basis/unix/groups/groups-tests.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.groups kernel strings math ;
+USING: kernel math sequences strings tools.test unix.groups ;
 IN: unix.groups.tests

 [ ] [ all-groups drop ] unit-test
@ -25,5 +25,15 @@ IN: unix.groups.tests
 [ ] [ real-group-id group-name drop ] unit-test

 [ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-exists? ] unit-test
+[ "please-oh-please-don't-have-a-group-named-this123lalala" ?group-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-group ] unit-test
+[ 3 ] [ f [ 3 ] with-real-group ] unit-test
+
 [ f ]
-[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ all-groups drop all-groups empty? ] unit-test
+
+[ f ]
+[ all-group-names drop all-group-names empty? ] unit-test
--- a/basis/unix/groups/groups.factor
+++ b/basis/unix/groups/groups.factor
@ -1,15 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities classes.struct unix ;
-IN: unix.groups
-
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry io.backend.unix
+io.encodings.utf8 kernel math math.parser namespaces sequences
+splitting strings unix unix.ffi unix.users unix.utilities ;
 QUALIFIED: unix.ffi
-
 QUALIFIED: grouping
+IN: unix.groups

 TUPLE: group id name passwd members ;

@ -61,6 +59,11 @@ PRIVATE>
 : group-id ( string -- id/f )
    group-struct dup [ gr_gid>> ] when ;

+ERROR: no-group string ;
+
+: ?group-id ( string -- id )
+    dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
+
 <PRIVATE

 : >groups ( byte-array n -- groups )
@ -83,7 +86,11 @@ M: integer user-groups ( id -- seq )
    user-name (user-groups) ;
    
 : all-groups ( -- seq )
-    [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
+    [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
+    endgrent ;
+
+: all-group-names ( -- seq )
+    all-groups [ name>> ] map ;

 : <group-cache> ( -- assoc )
    all-groups [ [ id>> ] keep ] H{ } map>assoc ;
@ -100,18 +107,26 @@ M: integer user-groups ( id -- seq )
 : effective-group-name ( -- string )
    effective-group-id group-name ; inline

+: group-exists? ( name/id -- ? ) group-id >boolean ;
+
 GENERIC: set-real-group ( obj -- )

 GENERIC: set-effective-group ( obj -- )

-: with-real-group ( string/id quot -- )
+: (with-real-group) ( string/id quot -- )
    '[ _ set-real-group @ ]
    real-group-id '[ _ set-real-group ] [ ] cleanup ; inline

-: with-effective-group ( string/id quot -- )
+: with-real-group ( string/id/f quot -- )
+    over [ (with-real-group) ] [ nip call ] if ; inline
+
+: (with-effective-group) ( string/id quot -- )
    '[ _ set-effective-group @ ]
    effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline

+: with-effective-group ( string/id/f quot -- )
+    over [ (with-effective-group) ] [ nip call ] if ; inline
+
 <PRIVATE

 : (set-real-group) ( id -- )
@ -122,14 +137,14 @@ GENERIC: set-effective-group ( obj -- )

 PRIVATE>
    
-M: string set-real-group ( string -- )
-    group-id (set-real-group) ;
-
 M: integer set-real-group ( id -- )
    (set-real-group) ;

+M: string set-real-group ( string -- )
+    ?group-id (set-real-group) ;
+
 M: integer set-effective-group ( id -- )    
    (set-effective-group) ;

 M: string set-effective-group ( string -- )
-    group-id (set-effective-group) ;
+    ?group-id (set-effective-group) ;
--- a/basis/unix/time/time.factor
+++ b/basis/unix/time/time.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types
-classes.struct accessors ;
+USING: accessors alien.c-types alien.syntax calendar
+classes.struct kernel math unix.types ;
 IN: unix.time

 STRUCT: timeval
@ -24,6 +24,15 @@ STRUCT: timespec
        swap >>nsec
        swap >>sec ;

+STRUCT: timezone
+    { tz_minuteswest int }
+    { tz_dsttime int } ;
+
+: timestamp>timezone ( timestamp -- timezone )
+    gmt-offset>> duration>minutes
+    1
+    \ timezone <struct-boa> ; inline
+
 STRUCT: tm
    { sec int }
    { min int }
@ -40,3 +49,5 @@ STRUCT: tm
 FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: tm* localtime ( time_t* clock ) ;
 FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
+FUNCTION: int settimeofday ( timeval* TP, timezone* TZP ) ;
+FUNCTION: int adjtime ( timeval* delta, timeval* olddelta ) ;
--- a/basis/unix/users/users-docs.factor
+++ b/basis/unix/users/users-docs.factor
@ -67,8 +67,8 @@ HELP: user-id

 HELP: with-effective-user
 { $values
-     { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+     { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;

 HELP: with-user-cache
 { $values
@ -77,8 +77,8 @@ HELP: with-user-cache

 HELP: with-real-user
 { $values
-     { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+     { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;

 {
    real-user-name real-user-id set-real-user
@ -86,18 +86,43 @@ HELP: with-real-user
    set-effective-user
 } related-words

+HELP: ?user-id
+{ $values
+    { "string" string }
+    { "id/f" "an integer or " { $link f } }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-user-names
+{ $values
+    
+    { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: user-exists?
+{ $values
+    { "name/id" "a string or an integer" }
+    { "?" boolean }
+}
+{ $description "Returns a boolean representing the user's existence." } ;
+
 ARTICLE: "unix.users" "Unix users"
 "The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
 $nl
 "Listing all users:"
 { $subsections all-users }
-"Real user:"
+"Listing all user names:"
+{ $subsections all-user-names }
+"Checking if a user exists:"
+{ $subsections user-exists? }
+"Querying/setting the current real user:"
 { $subsections
    real-user-name
    real-user-id
    set-real-user
 }
-"Effective user:"
+"Querying/setting the current effective user:"
 { $subsections
    effective-user-name
    effective-user-id
--- a/basis/unix/users/users-tests.factor
+++ b/basis/unix/users/users-tests.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.users kernel strings math ;
+USING: tools.test unix.users kernel strings math sequences ;
 IN: unix.users.tests

 [ ] [ all-users drop ] unit-test
@ -27,3 +27,14 @@ IN: unix.users.tests
 [ f ] [ 89898989898989898989898989898 user-passwd ] unit-test

 [ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-id ] unit-test
+[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-exists? ] unit-test
+[ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" ?user-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-user ] unit-test
+[ 3 ] [ f [ 3 ] with-real-user ] unit-test
+
+[ f ]
+[ all-users drop all-users empty? ] unit-test
+
+[ f ]
+[ all-user-names drop all-user-names empty? ] unit-test
--- a/basis/unix/users/users.factor
+++ b/basis/unix/users/users.factor
@ -40,6 +40,9 @@ PRIVATE>
        [ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
    ] with-pwent ;

+: all-user-names ( -- seq )
+    all-users [ user-name>> ] map ;
+
 SYMBOL: user-cache

 : <user-cache> ( -- assoc )
@ -64,6 +67,11 @@ M: string user-passwd ( string -- passwd/f )
 : user-id ( string -- id/f )
    user-passwd dup [ uid>> ] when ;

+ERROR: no-user string ;
+
+: ?user-id ( string -- id/f )
+    dup user-passwd [ nip uid>> ] [ no-user ] if* ;
+
 : real-user-id ( -- id )
    unix.ffi:getuid ; inline

@ -76,20 +84,28 @@ M: string user-passwd ( string -- passwd/f )
 : effective-user-name ( -- string )
    effective-user-id user-name ; inline

+: user-exists? ( name/id -- ? ) user-id >boolean ;
+
 GENERIC: set-real-user ( string/id -- )

 GENERIC: set-effective-user ( string/id -- )

-: with-real-user ( string/id quot -- )
+: (with-real-user) ( string/id quot -- )
    '[ _ set-real-user @ ]
    real-user-id '[ _ set-real-user ]
    [ ] cleanup ; inline

-: with-effective-user ( string/id quot -- )
+: with-real-user ( string/id/f quot -- )
+    over [ (with-real-user) ] [ nip call ] if ; inline
+
+: (with-effective-user) ( string/id quot -- )
    '[ _ set-effective-user @ ]
    effective-user-id '[ _ set-effective-user ]
    [ ] cleanup ; inline

+: with-effective-user ( string/id/f quot -- )
+    over [ (with-effective-user) ] [ nip call ] if ; inline
+
 <PRIVATE

 : (set-real-user) ( id -- )
@ -100,17 +116,17 @@ GENERIC: set-effective-user ( string/id -- )

 PRIVATE>

-M: string set-real-user ( string -- )
-    user-id (set-real-user) ;
-
 M: integer set-real-user ( id -- )
    (set-real-user) ;

+M: string set-real-user ( string -- )
+    ?user-id (set-real-user) ;
+
 M: integer set-effective-user ( id -- )
    (set-effective-user) ; 

 M: string set-effective-user ( string -- )
-    user-id (set-effective-user) ;
+    ?user-id (set-effective-user) ;

 os {
    { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
--- a/basis/uuid/uuid.factor
+++ b/basis/uuid/uuid.factor
@ -1,10 +1,9 @@
 ! Copyright (C) 2008 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
-USING: byte-arrays checksums checksums.md5 checksums.sha
-kernel math math.parser math.ranges random unicode.case 
-sequences strings system io.binary ;
-
-IN: uuid 
+USING: byte-arrays calendar checksums checksums.md5
+checksums.sha io.binary kernel math math.parser math.ranges
+random sequences strings system unicode.case ;
+IN: uuid

 <PRIVATE

@ -12,7 +11,7 @@ IN: uuid
    ! 0x01b21dd213814000L is the number of 100-ns intervals
    ! between the UUID epoch 1582-10-15 00:00:00 and the 
    ! Unix epoch 1970-01-01 00:00:00.
-    system-micros 10 * HEX: 01b21dd213814000 +
+    gmt timestamp>micros 10 * HEX: 01b21dd213814000 +
    [ -48 shift HEX: 0fff bitand ] 
    [ -32 shift HEX: ffff bitand ]
    [ HEX: ffffffff bitand ]
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@ -1800,7 +1800,7 @@ FUNCTION: BOOL SetProcessPriorityBoost ( HANDLE hProcess, BOOL disablePriorityBo
 ! FUNCTION: SetProcessWorkingSetSize
 ! FUNCTION: SetStdHandle
 ! FUNCTION: SetSystemPowerState
-! FUNCTION: SetSystemTime
+FUNCTION: BOOL SetSystemTime ( SYSTEMTIME* lpSystemTime ) ;
 ! FUNCTION: SetSystemTimeAdjustment
 ! FUNCTION: SetTapeParameters
 ! FUNCTION: SetTapePosition
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@ -536,7 +536,6 @@ tuple
    { "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
    { "(exit)" "system" "primitive_exit" (( n -- * )) }
    { "nano-count" "system" "primitive_nano_count" (( -- ns )) }
-    { "system-micros" "system" "primitive_system_micros" (( -- us )) }
    { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
    { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
    { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@ -14,10 +14,6 @@ ARTICLE: "system" "System interface"
    vm
    image
 }
-"Getting the current time:"
-{ $subsections
-    system-micros
-}
 "Getting a monotonically increasing nanosecond count:"
 { $subsections nano-count }
 "Exiting the Factor VM:"
@ -78,15 +74,10 @@ HELP: exit ( n -- )
 { $values { "n" "an integer exit code" } }
 { $description "Exits the Factor process." } ;

-HELP: system-micros ( -- us )
-{ $values { "us" integer } }
-{ $description "Outputs the number of microseconds elapsed since midnight January 1, 1970." }
-{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting. For timing code, use " { $link nano-count } "." } ;
-
 HELP: nano-count ( -- ns )
 { $values { "ns" integer } }
 { $description "Outputs a monotonically increasing count of nanoseconds elapsed since an arbitrary starting time. The difference of two calls to this word allows timing. This word is unaffected by system clock changes." }
-{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time. For system time, use " { $link system-micros } "." } ;
+{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time." } ;

 HELP: image
 { $values { "path" "a pathname string" } }
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@ -22,6 +22,7 @@ SYMBOL: add-vocab-root-hook
 ] "vocabs.loader" add-startup-hook

 : add-vocab-root ( root -- )
+    trim-tail-separators
    [ vocab-roots get adjoin ]
    [ add-vocab-root-hook get-global call( root -- ) ] bi ;

--- a/extra/alien/handles/authors.txt
+++ b/extra/alien/handles/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/alien/handles/handles-tests.factor
+++ b/extra/alien/handles/handles-tests.factor
@ -0,0 +1,45 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.handles alien.syntax
+destructors kernel math tools.test ;
+IN: alien.handles.tests
+
+TUPLE: thingy { x integer } ;
+C: <thingy> thingy
+
+CALLBACK: int thingy-callback ( uint thingy-handle ) ;
+CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ;
+
+: test-thingy-callback ( -- alien )
+    [ alien-handle> x>> 1 + ] thingy-callback ;
+
+: test-thingy-ptr-callback ( -- alien )
+    [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ;
+
+: invoke-test-thingy-callback ( thingy -- n )
+    test-thingy-callback int { uint } cdecl alien-indirect ;
+: invoke-test-thingy-ptr-callback ( thingy -- n )
+    test-thingy-ptr-callback int { void* } cdecl alien-indirect ;
+
+[ t f ] [
+    [ 5 <thingy> <alien-handle> &release-alien-handle [ alien-handle? ] keep ] with-destructors
+    alien-handle?
+] unit-test
+
+[ t f ] [
+    [ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors
+    alien-handle-ptr?
+] unit-test
+
+[ 6 ] [
+    [
+        5 <thingy> <alien-handle> &release-alien-handle
+        invoke-test-thingy-callback
+    ] with-destructors
+] unit-test
+
+[ 6 ] [
+    [
+        5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr
+        invoke-test-thingy-ptr-callback
+    ] with-destructors
+] unit-test
--- a/extra/alien/handles/handles.factor
+++ b/extra/alien/handles/handles.factor
@ -0,0 +1,49 @@
+! (c)2010 Joe Groff bsd license
+USING: alien alien.destructors assocs kernel math math.bitwise
+namespaces ;
+IN: alien.handles
+
+<PRIVATE
+
+SYMBOLS: alien-handle-counter alien-handles ;
+
+alien-handle-counter [ 0 ] initialize
+alien-handles [ H{ } clone ] initialize
+
+: biggest-handle ( -- n )
+    -1 32 bits ; inline
+
+: (next-handle) ( -- n )
+    alien-handle-counter [ 1 + biggest-handle bitand dup ] change-global ; inline
+
+: next-handle ( -- n )
+    [ (next-handle) dup alien-handles get-global key? ] [ drop ] while ;
+
+PRIVATE>
+
+: <alien-handle> ( object -- int )
+    next-handle [ alien-handles get-global set-at ] keep ; inline
+: alien-handle> ( int -- object )
+    alien-handles get-global at ; inline
+
+: alien-handle? ( int -- ? )
+    alien-handles get-global key? >boolean ; inline
+
+: release-alien-handle ( int -- )
+    alien-handles get-global delete-at ; inline
+
+DESTRUCTOR: release-alien-handle
+
+: <alien-handle-ptr> ( object -- void* )
+    <alien-handle> <alien> ; inline
+: alien-handle-ptr> ( void* -- object )
+    alien-address alien-handle> ; inline
+
+: alien-handle-ptr? ( alien -- ? )
+    alien-address alien-handle? ; inline
+
+: release-alien-handle-ptr ( alien -- )
+    alien-address release-alien-handle ; inline
+
+DESTRUCTOR: release-alien-handle-ptr
+
--- a/extra/alien/handles/summary.txt
+++ b/extra/alien/handles/summary.txt
@ -0,0 +1 @@
+Generate integer handle values to allow Factor object references to be passed through the FFI
--- a/extra/audio/engine/engine.factor
+++ b/extra/audio/engine/engine.factor
@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors alien audio classes.struct fry calendar alarms
+USING: accessors alien audio classes.struct fry calendar timers
 combinators combinators.short-circuit destructors generalizations
 kernel literals locals math openal sequences
 sequences.generalizations specialized-arrays strings ;
@ -70,7 +70,7 @@ TUPLE: audio-engine < disposable
    listener
    { next-source integer }
    clips
-    update-alarm ;
+    update-timer ;

 TUPLE: audio-clip < disposable
    { audio-engine audio-engine }
@ -226,20 +226,20 @@ DEFER: update-audio

 : start-audio ( audio-engine -- )
    dup start-audio*
-    dup '[ _ update-audio ] 20 milliseconds every >>update-alarm
+    dup '[ _ update-audio ] 20 milliseconds every >>update-timer
    drop ;

 : stop-audio ( audio-engine -- )
    dup al-sources>> [
        {
            [ make-engine-current ]
-            [ update-alarm>> [ stop-alarm ] when* ]
+            [ update-timer>> [ stop-timer ] when* ]
            [ clips>> clone [ dispose ] each ]
            [ al-sources>> free-sources ]
            [
                f >>al-sources
                f >>clips
-                f >>update-alarm
+                f >>update-timer
                drop
            ]
            [ al-context>> alcSuspendContext ]
--- a/extra/audio/engine/test/test.factor
+++ b/extra/audio/engine/test/test.factor
@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors alarms audio audio.engine audio.loader calendar
+USING: accessors timers audio audio.engine audio.loader calendar
 destructors io kernel locals math math.functions math.ranges specialized-arrays
 sequences random math.vectors ;
 FROM: alien.c-types => short ;
@ -41,10 +41,10 @@ M: noise-generator dispose
        ] when

        engine update-audio
-    ] 20 milliseconds every :> alarm
+    ] 20 milliseconds every :> timer
    "Press Enter to stop the test." print
    readln drop
-    alarm stop-alarm
+    timer stop-timer
    engine dispose ;

 MAIN: audio-engine-test
--- a/extra/benchmark/struct/authors.txt
+++ b/extra/benchmark/struct/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/extra/benchmark/struct/struct.factor
+++ b/extra/benchmark/struct/struct.factor
@ -0,0 +1,31 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types classes.struct kernel memory
+system vm ;
+IN: benchmark.struct
+
+STRUCT: benchmark-data
+    { time ulonglong }
+    { data-room data-heap-room }
+    { code-room mark-sweep-sizes } ;
+
+STRUCT: benchmark-data-pair
+    { start benchmark-data }
+    { stop benchmark-data } ;
+
+: <benchmark-data> ( -- benchmark-data )
+    \ benchmark-data <struct>
+        nano-count >>time
+        code-room >>code-room
+        data-room >>data-room ; inline
+
+: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
+    \ benchmark-data-pair <struct>
+        swap >>stop
+        swap >>start ; inline
+
+: with-benchmarking ( ... quot -- ... benchmark-data-pair )
+    <benchmark-data>
+    [ call ] dip
+    <benchmark-data> <benchmark-data-pair> ; inline
+
--- a/extra/bson/constants/constants.factor
+++ b/extra/bson/constants/constants.factor
@ -19,6 +19,16 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;

 TUPLE: dbref ref id db ;

+TUPLE: mongo-timestamp incr seconds ;
+
+: <mongo-timestamp> ( incr seconds -- mongo-timestamp )
+    mongo-timestamp boa ;
+
+TUPLE: mongo-scoped-code code object ;
+
+: <mongo-scoped-code> ( code object -- mongo-scoped-code )
+    mongo-scoped-code boa ;
+
 CONSTRUCTOR: dbref ( ref id -- dbref ) ;

 : dbref>assoc ( dbref -- assoc )
@ -47,30 +57,31 @@ TUPLE: mdbregexp { regexp string } { options string } ;
 CONSTANT: MDB_OID_FIELD "_id"
 CONSTANT: MDB_META_FIELD "_mfd"

-CONSTANT: T_EOO  0  
-CONSTANT: T_Double  1  
-CONSTANT: T_Integer  16  
-CONSTANT: T_Boolean  8  
-CONSTANT: T_String  2  
-CONSTANT: T_Object  3  
-CONSTANT: T_Array  4  
-CONSTANT: T_Binary  5  
-CONSTANT: T_Undefined  6  
-CONSTANT: T_OID  7  
-CONSTANT: T_Date  9  
-CONSTANT: T_NULL  10  
-CONSTANT: T_Regexp  11  
-CONSTANT: T_DBRef  12  
-CONSTANT: T_Code  13  
-CONSTANT: T_ScopedCode  17  
-CONSTANT: T_Symbol  14  
-CONSTANT: T_JSTypeMax  16  
-CONSTANT: T_MaxKey  127  
-
-CONSTANT: T_Binary_Function 1   
-CONSTANT: T_Binary_Bytes 2
-CONSTANT: T_Binary_UUID 3
-CONSTANT: T_Binary_MD5 5
-CONSTANT: T_Binary_Custom 128
+CONSTANT: T_EOO     0
+CONSTANT: T_Double  HEX: 1
+CONSTANT: T_String  HEX: 2
+CONSTANT: T_Object  HEX: 3
+CONSTANT: T_Array   HEX: 4
+CONSTANT: T_Binary  HEX: 5
+CONSTANT: T_Undefined  HEX: 6
+CONSTANT: T_OID     HEX: 7
+CONSTANT: T_Boolean HEX: 8
+CONSTANT: T_Date    HEX: 9
+CONSTANT: T_NULL    HEX: A
+CONSTANT: T_Regexp  HEX: B
+CONSTANT: T_DBRef   HEX: C
+CONSTANT: T_Code    HEX: D
+CONSTANT: T_Symbol  HEX: E
+CONSTANT: T_ScopedCode HEX: F
+CONSTANT: T_Integer HEX: 10
+CONSTANT: T_Timestamp HEX: 11
+CONSTANT: T_Integer64 HEX: 12
+CONSTANT: T_MinKey  HEX: FF
+CONSTANT: T_MaxKey  HEX: 7F

+CONSTANT: T_Binary_Function     HEX: 1
+CONSTANT: T_Binary_Bytes        HEX: 2
+CONSTANT: T_Binary_UUID         HEX: 3
+CONSTANT: T_Binary_MD5          HEX: 5
+CONSTANT: T_Binary_Custom       HEX: 80

--- a/extra/bson/reader/reader.factor
+++ b/extra/bson/reader/reader.factor
@ -10,65 +10,46 @@ FROM: typed => TYPED: ;

 IN: bson.reader

+SYMBOL: state
+
+DEFER: stream>assoc
+
 <PRIVATE

-TUPLE: element { type integer } name ;
+DEFER: read-elements

-TUPLE: state
-    { size initial: -1 }
-    { exemplar assoc }
-    result
-    { scope vector }
-    { elements vector } ;
-
-TYPED: (prepare-elements) ( -- elements-vector: vector )
-    V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
-
-: <state> ( exemplar -- state )
-    [ state new ] dip
-    {
-        [ clone >>exemplar ]
-        [ clone >>result ]
-        [ V{ } clone [ push ] keep >>scope ]
-    } cleave
-    (prepare-elements) >>elements ;
-
-TYPED: get-state ( -- state: state )
-    state get ; inline
-
-TYPED: read-int32 ( -- int32: integer )
+: read-int32 ( -- int32 )
    4 read signed-le> ; inline

-TYPED: read-longlong ( -- longlong: integer )
+: read-longlong ( -- longlong )
    8 read signed-le> ; inline

-TYPED: read-double ( -- double: float )
+: read-double ( -- double )
    8 read le> bits>double ; inline

-TYPED: read-byte-raw ( -- byte-raw: byte-array )
+: read-byte-raw ( -- byte-raw )
    1 read ; inline

-TYPED: read-byte ( -- byte: integer )
+: read-byte ( -- byte )
    read-byte-raw first ; inline

-TYPED: read-cstring ( -- string: string )
+: read-cstring ( -- string )
    "\0" read-until drop >string ; inline

-TYPED: read-sized-string ( length: integer -- string: string )
+: read-sized-string ( length -- string )
    read 1 head-slice* >string ; inline

-TYPED: push-element ( type: integer name: string state: state -- )
-    [ element boa ] dip elements>> push ; inline
+: read-timestamp ( -- timestamp )
+    8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;

-TYPED: pop-element ( state: state -- element: element )
-    elements>> pop ; inline
+: object-result ( quot -- object )
+    [
+        state get clone
+        [ clear-assoc ] [ ] [ ] tri state
+    ] dip with-variable ; inline

-TYPED: peek-scope ( state: state -- ht )
-    scope>> last ; inline
-
-: bson-object-data-read ( -- object )
-    read-int32 drop get-state 
-    [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
+: bson-object-data-read ( -- )
+    read-int32 drop read-elements ; inline recursive

 : bson-binary-read ( -- binary )
   read-int32 read-byte 
@ -86,68 +67,35 @@ TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
 TYPED: bson-oid-read ( -- oid: oid )
    read-longlong read-int32 oid boa ; inline

-TYPED: element-data-read ( type: integer -- object )
-    {
-        { T_OID [ bson-oid-read ] }
-        { T_String [ read-int32 read-sized-string ] }
-        { T_Integer [ read-int32 ] }
-        { T_Binary [ bson-binary-read ] }
-        { T_Object [ bson-object-data-read ] }
-        { T_Array [ bson-object-data-read ] }
-        { T_Double [ read-double ] }
-        { T_Boolean [ read-byte 1 = ] }
-        { T_Date [ read-longlong millis>timestamp ] }
-        { T_Regexp [ bson-regexp-read ] }
-        { T_NULL [ f ] }
-    } case ; inline
-
-TYPED: bson-array? ( type: integer -- ?: boolean )
-    T_Array = ; inline
-
-TYPED: bson-object? ( type: integer -- ?: boolean )
-    T_Object = ; inline
-
 : check-object ( assoc -- object )
    dup dbref-assoc? [ assoc>dbref ] when ; inline

-TYPED: fix-result ( assoc type: integer -- result )
+TYPED: element-data-read ( type: integer -- object )
    {
-        { T_Array [ values ] }
-        { T_Object [ check-object ] }
-    } case ; inline
+        { T_OID         [ bson-oid-read ] }
+        { T_String      [ read-int32 read-sized-string ] }
+        { T_Integer     [ read-int32 ] }
+        { T_Integer64   [ read-longlong ] }
+        { T_Binary      [ bson-binary-read ] }
+        { T_Object      [ [ bson-object-data-read ] object-result check-object ] }
+        { T_Array       [ [ bson-object-data-read ] object-result values ] }
+        { T_Double      [ read-double ] }
+        { T_Boolean     [ read-byte 1 = ] }
+        { T_Date        [ read-longlong millis>timestamp ] }
+        { T_Regexp      [ bson-regexp-read ] }
+        { T_Timestamp   [ read-timestamp ] }
+        { T_Code        [ read-int32 read-sized-string ] }
+        { T_ScopedCode  [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
+        { T_NULL        [ f ] }
+    } case ; inline recursive

-TYPED: end-element ( type: integer -- )
-    { [ bson-object? ] [ bson-array? ] } 1||
-    [ get-state pop-element drop ] unless ; inline
-
-TYPED: (>state<) ( -- state: state scope: vector element: element )
-    get-state [  ] [ scope>> ] [ pop-element ] tri ; inline
-
-TYPED: (prepare-result) ( scope: vector element: element -- result )
-    [ pop ] [ type>> ] bi* fix-result ; inline
-
-: bson-eoo-element-read ( -- cont?: boolean )
-    (>state<)
-    [ (prepare-result) ] [  ] [ drop empty? ] 2tri
-    [ 2drop >>result drop f ]
-    [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
-
-TYPED: (prepare-object) ( type: integer -- object )
-    [ element-data-read ] [ end-element ] bi ; inline
-
-:: (read-object) ( type name state -- )
-    state peek-scope :> scope
-    type (prepare-object) name scope set-at ; inline
-
-TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
-    read-cstring get-state
-    [ push-element ]
-    [ (read-object) t ] 3bi ; inline
+TYPED: (read-object) ( type: integer name: string -- )
+    [ element-data-read ] dip state get set-at ; inline recursive

 TYPED: (element-read) ( type: integer -- cont?: boolean )
    dup T_EOO > 
-    [ bson-not-eoo-element-read ]
-    [ drop bson-eoo-element-read ] if ; inline
+    [ read-cstring (read-object) t ]
+    [ drop f ] if ; inline recursive

 : read-elements ( -- )
    read-byte (element-read)
@ -156,6 +104,6 @@ TYPED: (element-read) ( type: integer -- cont?: boolean )
 PRIVATE>

 : stream>assoc ( exemplar -- assoc )
-    <state> read-int32 >>size
-    [ state [ read-elements ] with-variable ]
-    [ result>> ] bi ;
+    clone [
+        state [ bson-object-data-read ] with-variable
+    ] keep ;
--- a/extra/codebook/authors.txt
+++ b/extra/codebook/authors.txt
@ -0,0 +1,2 @@
+Joe Groff
+Doug Coleman
--- a/extra/codebook/codebook.factor
+++ b/extra/codebook/codebook.factor
@ -0,0 +1,245 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs calendar calendar.format
+combinators combinators.short-circuit fry io io.backend
+io.directories io.encodings.binary io.encodings.detect
+io.encodings.utf8 io.files io.files.info io.files.types
+io.files.unique io.launcher io.pathnames kernel locals math
+math.parser namespaces sequences sorting strings system
+unicode.categories xml.syntax xml.writer xmode.catalog
+xmode.marker xmode.tokens ;
+IN: codebook
+
+! Usage: "my/source/tree" codebook
+! Writes tree.opf, tree.ncx, and tree.html to a temporary directory
+! Writes tree.mobi to resource:codebooks
+! Requires kindlegen to compile tree.mobi for Kindle
+
+CONSTANT: codebook-style
+    {
+        { COMMENT1 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+        { COMMENT2 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+        { COMMENT3 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+        { COMMENT4 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+        { DIGIT    [ [XML    <font color="#333333"><-></font>     XML] ] }
+        { FUNCTION [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        { KEYWORD1 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        { KEYWORD2 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        { KEYWORD3 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        { KEYWORD4 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        { LABEL    [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+        { LITERAL1 [ [XML    <font color="#333333"><-></font>     XML] ] }
+        { LITERAL2 [ [XML    <font color="#333333"><-></font>     XML] ] }
+        { LITERAL3 [ [XML    <font color="#333333"><-></font>     XML] ] }
+        { LITERAL4 [ [XML    <font color="#333333"><-></font>     XML] ] }
+        { MARKUP   [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+        { OPERATOR [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+        [ drop ]
+    }
+
+: first-line ( filename encoding -- line )
+    [ readln ] with-file-reader ;
+
+TUPLE: code-file
+    name encoding mode ;
+
+: include-file-name? ( name -- ? )
+    {
+        [ path-components [ "." head? ] any? not ] 
+        [ link-info type>> +regular-file+ = ]
+    } 1&& ;
+
+: code-files ( dir -- files )
+    '[
+        [ include-file-name? ] filter [
+            dup detect-file dup binary?
+            [ f ] [ 2dup dupd first-line find-mode ] if
+            code-file boa
+        ] map [ mode>> ] filter [ name>> ] sort-with
+    ] with-directory-tree-files ;
+
+: html-name-char ( char -- str )
+    {
+        { [ dup alpha? ] [ 1string ] }
+        { [ dup digit? ] [ 1string ] }
+        [ >hex 6 CHAR: 0 pad-head "_" "_" surround ]
+    } cond ;
+
+: file-html-name ( name -- name )
+    [ html-name-char ] { } map-as concat ".html" append ;
+
+: toc-list ( files -- list )
+    [ name>> ] map natural-sort [
+        [ file-html-name ] keep
+        [XML <li><a href=<->><-></a></li> XML]
+    ] map ;
+
+! insert zero-width non-joiner between all characters so words can wrap anywhere
+: zwnj ( string -- s|t|r|i|n|g )
+    [ CHAR: \u00200c "" 2sequence ] { } map-as concat ;
+
+! We wrap every line in <tt> because Kindle tends to forget the font when
+! moving back pages
+: htmlize-tokens ( tokens line# -- html-tokens )
+    swap [
+        [ str>> zwnj ] [ id>> ] bi codebook-style case
+    ] map [XML <tt><font size="-2" color="#666666"><-></font> <-></tt> XML]
+    "\n" 2array ;
+
+: line#>string ( i line#len -- i-string )
+    [ number>string ] [ CHAR: \s pad-head ] bi* ;
+
+:: code>html ( dir file -- page )
+    file name>> :> name
+    "Generating HTML for " write name write "..." print flush
+    dir [ file [ name>> ] [ encoding>> ] bi file-lines ] with-directory :> lines
+    lines length 1 + number>string length :> line#len
+    file mode>> load-mode :> rules
+    f lines [| l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
+    map-index concat nip :> html-lines
+    <XML <html>
+        <head>
+            <title><-name-></title>
+            <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+        </head>
+        <body>
+            <h2><-name-></h2>
+            <pre><-html-lines-></pre>
+            <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+        </body>
+    </html> XML> ;
+
+:: code>toc-html ( dir name files -- html )
+    "Generating HTML table of contents" print flush
+
+    now timestamp>rfc822 :> timestamp
+    dir absolute-path :> source
+    dir [
+        files toc-list :> toc
+
+        <XML <html>
+            <head>
+                <title><-name-></title>
+                <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+            </head>
+            <body>
+                <h1><-name-></h1>
+                <font size="-2">Generated from<br/>
+                <b><tt><-source-></tt></b><br/>
+                at <-timestamp-></font><br/>
+                <br/>
+                <ul><-toc-></ul>
+                <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+            </body>
+        </html> XML>
+    ] with-directory ;
+
+:: code>ncx ( dir name files -- xml )
+    "Generating NCX table of contents" print flush
+
+    files [| file i |
+        file name>> :> name
+        name file-html-name :> filename
+        i 2 + number>string :> istr
+        
+        [XML <navPoint class="book" id=<-filename-> playOrder=<-istr->>
+            <navLabel><text><-name-></text></navLabel>
+            <content src=<-filename-> />
+        </navPoint> XML]
+    ] map-index :> file-nav-points
+
+    <XML <?xml version="1.0" encoding="UTF-8" ?>
+    <ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
+        <navMap>
+            <navPoint class="book" id="toc" playOrder="1">
+                <navLabel><text>Table of Contents</text></navLabel>
+                <content src="_toc.html" />
+            </navPoint>
+            <-file-nav-points->
+        </navMap>
+    </ncx> XML> ;
+    
+:: code>opf ( dir name files -- xml )
+    "Generating OPF manifest" print flush
+    name ".ncx"  append :> ncx-name
+
+    files [
+        name>> file-html-name dup
+        [XML <item id=<-> href=<-> media-type="text/html" /> XML]
+    ] map :> html-manifest
+
+    files [ name>> file-html-name [XML <itemref idref=<-> /> XML] ] map :> html-spine
+
+    <XML <?xml version="1.0" encoding="UTF-8" ?>
+    <package
+        version="2.0"
+        xmlns="http://www.idpf.org/2007/opf"
+        unique-identifier=<-name->>
+        <metadata xmlns:dc="http://purl.org/dc/elements/1.1/">
+            <dc:title><-name-></dc:title>
+            <dc:language>en</dc:language>
+            <meta name="cover" content="my-cover-image" />
+        </metadata>
+        <manifest>
+            <item href="cover.jpg" id="my-cover-image" media-type="image/jpeg" />
+            <item id="html-toc" href="_toc.html" media-type="text/html" />
+            <-html-manifest->
+            <item id="toc" href=<-ncx-name-> media-type="application/x-dtbncx+xml" />
+        </manifest>
+        <spine toc="toc">
+            <itemref idref="html-toc" />
+            <-html-spine->
+        </spine>
+        <guide>
+            <reference type="toc" title="Table of Contents" href="_toc.html" />
+        </guide>
+    </package> XML> ;
+
+: write-dest-file ( xml dest-dir name ext -- )
+    append append-path utf8 [ write-xml ] with-file-writer ;
+
+SYMBOL: kindlegen-path
+kindlegen-path [ "kindlegen" ] initialize
+
+SYMBOL: codebook-output-path
+codebook-output-path [ "resource:codebooks" ] initialize
+
+: kindlegen ( path -- )
+    [ kindlegen-path get "-unicode" ] dip 3array try-process ;
+
+: kindle-path ( directory name extension -- path )
+    [ append-path ] dip append ;
+
+:: codebook ( src-dir -- )
+    codebook-output-path get normalize-path :> dest-dir
+
+    "Generating ebook for " write src-dir write " in " write dest-dir print flush
+
+    dest-dir make-directories
+    [
+        current-temporary-directory get :> temp-dir
+        src-dir file-name :> name
+        src-dir code-files :> files
+
+        src-dir name files code>opf
+        temp-dir name ".opf" write-dest-file
+
+        "vocab:codebook/cover.jpg" temp-dir copy-file-into
+
+        src-dir name files code>ncx
+        temp-dir name ".ncx" write-dest-file
+
+        src-dir name files code>toc-html
+        temp-dir "_toc.html" "" write-dest-file
+
+        files [| file |
+            src-dir file code>html
+            temp-dir file name>> file-html-name "" write-dest-file
+        ] each
+
+        temp-dir name ".opf" kindle-path kindlegen
+        temp-dir name ".mobi" kindle-path dest-dir copy-file-into
+
+        dest-dir name ".mobi" kindle-path :> mobi-path
+
+        "Job's finished: " write mobi-path print flush
+    ] cleanup-unique-working-directory ;
--- a/extra/codebook/cover.jpg
+++ b/extra/codebook/cover.jpg
--- a/extra/game/input/demos/joysticks/joysticks.factor
+++ b/extra/game/input/demos/joysticks/joysticks.factor
@ -1,7 +1,7 @@
 USING: ui ui.gadgets sequences kernel arrays math colors
 colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
 accessors fry ui.gadgets.packs game.input ui.gadgets.labels
-ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
+ui.gadgets.borders timers calendar locals strings ui.gadgets.buttons
 combinators math.parser assocs threads ;
 IN: game.input.demos.joysticks

@ -73,7 +73,7 @@ CONSTANT: pov-polygons
    COLOR: red   <indicator-gadget> [ >>indicator   ] [ add-gadget ] bi
    dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;

-TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
+TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ;

 : add-gadget-with-border ( parent child -- parent )
    { 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
@ -108,7 +108,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;

 : kill-update-axes ( gadget -- )
    COLOR: gray <solid> >>interior
-    [ [ stop-alarm ] when* f ] change-alarm
+    [ [ stop-timer ] when* f ] change-timer
    relayout-1 ;

 : (update-axes) ( gadget controller-state -- )
@ -125,11 +125,11 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
    [ (update-axes) ] [ kill-update-axes ] if* ;

 M: joystick-demo-gadget graft*
-    dup '[ _ update-axes ] FREQUENCY every >>alarm
+    dup '[ _ update-axes ] FREQUENCY every >>timer
    drop ;

 M: joystick-demo-gadget ungraft*
-    alarm>> [ stop-alarm ] when* ;
+    timer>> [ stop-timer ] when* ;

 : joystick-window ( controller -- )
    [ <joystick-demo-gadget> ] [ product-string ] bi
--- a/extra/game/input/demos/key-caps/key-caps.factor
+++ b/extra/game/input/demos/key-caps/key-caps.factor
@ -1,6 +1,6 @@
 USING: game.input game.input.scancodes
 kernel ui.gadgets ui.gadgets.buttons sequences accessors
-words arrays assocs math calendar fry alarms ui
+words arrays assocs math calendar fry timers ui
 ui.gadgets.borders ui.gestures literals ;
 IN: game.input.demos.key-caps

@ -134,7 +134,7 @@ CONSTANT: key-locations H{
 CONSTANT: KEYBOARD-SIZE { 230 65 }
 CONSTANT: FREQUENCY $[ 1/30 seconds ]

-TUPLE: key-caps-gadget < gadget keys alarm ;
+TUPLE: key-caps-gadget < gadget keys timer ;

 : make-key-gadget ( scancode dim array -- )
    [ 
@ -163,11 +163,11 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;

 M: key-caps-gadget graft*
    open-game-input
-    dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
+    dup '[ _ update-key-caps-state ] FREQUENCY every >>timer
    drop ;

 M: key-caps-gadget ungraft*
-    alarm>> [ stop-alarm ] when*
+    timer>> [ stop-timer ] when*
    close-game-input ;

 M: key-caps-gadget handle-gesture
--- a/extra/game/loop/loop-docs.factor
+++ b/extra/game/loop/loop-docs.factor
@ -26,22 +26,6 @@ $nl

 { <game-loop> <game-loop*> } related-words

-HELP: benchmark-frames-per-second
-{ $values
-    { "loop" game-loop }
-    { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link draw* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-HELP: benchmark-ticks-per-second
-{ $values
-    { "loop" game-loop }
-    { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words
-
 HELP: draw*
 { $values
    { "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
@ -59,12 +43,6 @@ HELP: game-loop-error
 }
 { $description "If an uncaught error is thrown from inside a game loop delegate's " { $link tick* } " or " { $link draw* } ", the game loop will catch the error, stop the game loop, and rethrow an error of this class." } ;

-HELP: reset-loop-benchmark
-{ $values
-    { "loop" game-loop }
-}
-{ $description "Resets the benchmark counters on a " { $link game-loop } ". Subsequent calls to " { $link benchmark-frames-per-second } " and " { $link benchmark-ticks-per-second } " will measure their values from the point " { $snippet "reset-loop-benchmark" } " was called." } ;
-
 HELP: start-loop
 { $values
    { "loop" game-loop }
@ -109,12 +87,6 @@ ARTICLE: "game.loop" "Game loops"
    start-loop
    stop-loop
 }
-"The game loop maintains performance counters:"
-{ $subsections
-    reset-loop-benchmark
-    benchmark-frames-per-second
-    benchmark-ticks-per-second
-}
 "The game loop catches errors that occur in the delegate's methods during the course of the game loop:"
 { $subsections
    game-loop-error
--- a/extra/game/loop/loop.factor
+++ b/extra/game/loop/loop.factor
@ -1,34 +1,38 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors alarms calendar continuations destructors fry
-kernel math math.order namespaces system ui ui.gadgets.worlds ;
+USING: accessors timers alien.c-types calendar classes.struct
+continuations destructors fry kernel math math.order memory
+namespaces sequences specialized-vectors system
+tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays
+benchmark.struct locals ;
 IN: game.loop

 TUPLE: game-loop
    { tick-interval-nanos integer read-only }
    tick-delegate
    draw-delegate
-    { last-tick integer }
    { running? boolean }
-    { tick-number integer }
-    { frame-number integer }
-    { benchmark-time integer }
-    { benchmark-tick-number integer }
-    { benchmark-frame-number integer }
-    alarm ;
+    { tick# integer }
+    { frame# integer }
+    tick-timer
+    draw-timer
+    benchmark-data ;
+
+STRUCT: game-loop-benchmark
+    { benchmark-data-pair benchmark-data-pair }
+    { tick# ulonglong }
+    { frame# ulonglong } ;
+
+SPECIALIZED-VECTOR: game-loop-benchmark
+
+: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
+    \ game-loop-benchmark <struct>
+        swap >>frame#
+        swap >>tick#
+        swap >>benchmark-data-pair ; inline

 GENERIC: tick* ( delegate -- )
 GENERIC: draw* ( tick-slice delegate -- )

-SYMBOL: game-loop
-
-: since-last-tick ( loop -- nanos )
-    last-tick>> nano-count swap - ;
-
-: tick-slice ( loop -- slice )
-    [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
-
-CONSTANT: MAX-FRAMES-TO-SKIP 5
-
 DEFER: stop-loop

 TUPLE: game-loop-error game-loop error ;
@ -40,70 +44,69 @@ TUPLE: game-loop-error game-loop error ;
    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;

 : fps ( fps -- nanos )
-    1,000,000,000 swap /i ; inline
+    [ 1,000,000,000 ] dip /i ; inline

 <PRIVATE

+: record-benchmarking ( benchark-data-pair loop -- )
+    [ tick#>> ]
+    [ frame#>> <game-loop-benchmark> ]
+    [ benchmark-data>> ] tri push ;
+
+: last-tick-percent-offset ( loop -- float )
+    [ draw-timer>> iteration-start-nanos>> nano-count swap - ]
+    [ tick-interval-nanos>> ] bi /f 1.0 min ;
+
 : redraw ( loop -- )
-    [ 1 + ] change-frame-number
-    [ tick-slice ] [ draw-delegate>> ] bi draw* ;
+    [ 1 + ] change-frame#
+    [
+        [ last-tick-percent-offset ] [ draw-delegate>> ] bi
+        [ draw* ] with-benchmarking
+    ] keep record-benchmarking ;

 : tick ( loop -- )
-    tick-delegate>> tick* ;
+    [
+        [ tick-delegate>> tick* ] with-benchmarking
+    ] keep record-benchmarking ;

 : increment-tick ( loop -- )
-    [ 1 + ] change-tick-number
-    dup tick-interval-nanos>> [ + ] curry change-last-tick
+    [ 1 + ] change-tick#
    drop ;

-: ?tick ( loop count -- )
-    [ nano-count >>last-tick drop ] [
-        over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
-        [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
-        [ 2drop ] if
-    ] if-zero ;
-
-: benchmark-nanos ( loop -- nanos )
-    nano-count swap benchmark-time>> - ;
-
 PRIVATE>

-: reset-loop-benchmark ( loop -- loop )
-    nano-count >>benchmark-time
-    dup tick-number>> >>benchmark-tick-number
-    dup frame-number>> >>benchmark-frame-number ;
+:: when-running ( loop quot -- )
+    [
+        loop
+        dup running?>> quot [ drop ] if
+    ] [
+        loop game-loop-error
+    ] recover ; inline

-: benchmark-ticks-per-second ( loop -- n )
-    [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
-: benchmark-frames-per-second ( loop -- n )
-    [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
+: tick-iteration ( loop -- )
+    [ [ tick ] [ increment-tick ] bi ] when-running ;

-: (game-tick) ( loop -- )
-    dup running?>>
-    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
-    [ drop ] if ;
-    
-: game-tick ( loop -- )
-    dup game-loop [
-        [ (game-tick) ] [ game-loop-error ] recover
-    ] with-variable ;
+: frame-iteration ( loop -- )
+    [ redraw ] when-running ;

 : start-loop ( loop -- )
-    nano-count >>last-tick
    t >>running?
-    reset-loop-benchmark
-    [
-        [ '[ _ game-tick ] f ]
-        [ tick-interval-nanos>> nanoseconds ] bi
-        <alarm>
-    ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
+
+    dup
+    [ '[ _ tick-iteration ] f ]
+    [ tick-interval-nanos>> nanoseconds ] bi <timer> >>tick-timer
+
+    dup '[ _ frame-iteration ] f 1 milliseconds <timer> >>draw-timer
+
+    [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ;

 : stop-loop ( loop -- )
    f >>running?
-    alarm>> stop-alarm ;
+    [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;

 : <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
-    nano-count f 0 0 nano-count 0 0 f
+    f 0 0 f f
+    game-loop-benchmark-vector{ } clone
    game-loop boa ;

 : <game-loop> ( tick-interval-nanos delegate -- loop )
@ -112,6 +115,4 @@ PRIVATE>
 M: game-loop dispose
    stop-loop ;

-USE: vocabs.loader
-
 { "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
--- a/extra/game/worlds/worlds.factor
+++ b/extra/game/worlds/worlds.factor
@ -1,7 +1,8 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors combinators fry game.input game.loop generic kernel math
-parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads
-words audio.engine destructors ;
+USING: accessors audio.engine combinators concurrency.promises
+destructors fry game.input game.loop generic kernel math parser
+sequences threads ui ui.gadgets ui.gadgets.worlds ui.gestures
+words words.constant ;
 IN: game.worlds

 TUPLE: game-world < world
@ -48,7 +49,7 @@ M: game-world begin-world
    [ >>game-loop begin-game-world ] keep start-loop ;

 M: game-world end-world
-    [ [ stop-loop ] when* f ] change-game-loop
+    dup game-loop>> [ stop-loop ] when*
    [ end-game-world ]
    [ audio-engine>> [ dispose ] when* ]
    [ use-game-input?>> [ close-game-input ] when ] tri ;
@ -70,8 +71,18 @@ M: game-world apply-world-attributes
        [ call-next-method ]
    } cleave ;

+: start-game ( attributes -- game-world )
+    f swap open-window* ;
+
+: wait-game ( attributes -- game-world )
+    f swap open-window* dup promise>> ?promise drop ;
+
+: define-attributes-word ( word tuple -- )
+    [ name>> "-attributes" append create-in ] dip define-constant ;
+
 SYNTAX: GAME:
    CREATE
    game-attributes parse-main-window-attributes
+    2dup define-attributes-word
    parse-definition
    define-main-window ;
--- a/extra/irc/gitbot/gitbot.factor
+++ b/extra/irc/gitbot/gitbot.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry irc.client irc.client.chats kernel namespaces
 sequences threads io.launcher io splitting
-make mason.common mason.updates calendar math alarms
+make mason.common mason.updates calendar math timers
 io.encodings.8-bit.latin1 debugger ;
 IN: irc.gitbot

--- a/extra/key-logger/key-logger.factor
+++ b/extra/key-logger/key-logger.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms bit-arrays calendar game.input io
+USING: accessors timers bit-arrays calendar game.input io
 io.binary io.encodings.binary io.files kernel literals math
 namespaces system threads ;
 IN: key-logger
@ -28,7 +28,7 @@ SYMBOL: key-logger
    ] unless ;

 : stop-key-logger ( -- )
-    key-logger get-global [ stop-alarm ] when*
+    key-logger get-global [ stop-timer ] when*
    f key-logger set-global
    close-game-input ;

--- a/extra/mason/common/common-tests.factor
+++ b/extra/mason/common/common-tests.factor
@ -1,6 +1,7 @@
 IN: mason.common.tests
 USING: prettyprint mason.common mason.config
-namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
+namespaces calendar tools.test io.files
+io.files.temp io.encodings.utf8 sequences ;

 [ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test

@ -11,7 +12,7 @@ namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
    ] with-scope
 ] unit-test

-[ "/home/bobby/builds/2008-09-11-12-23" ] [
+[ t ] [
    [
        "/home/bobby/builds" builds-dir set
        T{ timestamp
@ -23,6 +24,7 @@ namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
        } datestamp stamp set
        build-dir
    ] with-scope
+    "/home/bobby/builds/2008-09-11-12-23" head?
 ] unit-test

 [ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@ -57,6 +57,7 @@ M: unix really-delete-tree delete-tree ;
            [ day>> , ]
            [ hour>> , ]
            [ minute>> , ]
+            [ drop nano-count , ]
        } cleave
    ] { } make [ pad-00 ] map "-" join ;

--- a/extra/mason/updates/updates.factor
+++ b/extra/mason/updates/updates.factor
@ -1,9 +1,17 @@
 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.launcher bootstrap.image.download
-mason.common mason.platform ;
+USING: bootstrap.image.download combinators.short-circuit
+io.directories io.launcher kernel mason.common mason.platform ;
 IN: mason.updates

+: git-reset-cmd ( -- cmd )
+    {
+        "git"
+        "reset"
+        "--hard"
+        "HEAD"
+    } ;
+
 : git-pull-cmd ( -- cmd )
    {
        "git"
@ -14,6 +22,8 @@ IN: mason.updates
    } ;

 : updates-available? ( -- ? )
+    ".git/index" delete-file
+    git-reset-cmd short-running-process
    git-id
    git-pull-cmd short-running-process
    git-id
@ -23,6 +33,4 @@ IN: mason.updates
    boot-image-name maybe-download-image ;

 : new-code-available? ( -- ? )
-    updates-available?
-    new-image-available?
-    or ;
+    { [ updates-available? ] [ new-image-available? ] } 0|| ;
--- a/extra/opengl/glu/glu.factor
+++ b/extra/opengl/glu/glu.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.libraries alien.syntax kernel
-sequences words system combinators opengl.gl ;
+sequences words system combinators opengl.gl alien.destructors ;
 IN: opengl.glu

 <<
@ -267,5 +267,21 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
 ! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
 ! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;

+DESTRUCTOR: gluDeleteNurbsRenderer
+DESTRUCTOR: gluDeleteQuadric
+DESTRUCTOR: gluDeleteTess
+
+CALLBACK: void GLUtessBeginCallback ( GLenum type ) ;
+CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ;
+CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ;
+CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ;
+CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ;
+CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ;
+CALLBACK: void GLUtessEndCallback ( ) ;
+CALLBACK: void GLUtessEndDataCallback ( void* data ) ;
+CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ;
+CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ;
+CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ;
+
 : gl-look-at ( eye focus up -- )
    [ first3 ] tri@ gluLookAt ;
--- a/extra/pop3/pop3-tests.factor
+++ b/extra/pop3/pop3-tests.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Elie Chaftari.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises namespaces kernel pop3 pop3.server
-sequences tools.test accessors ;
+sequences tools.test accessors calendar ;
 IN: pop3.tests

 FROM: pop3 => count delete ;
@ -12,7 +12,7 @@ FROM: pop3 => count delete ;
 [ ] [
        <pop3-account>
            "127.0.0.1" >>host
-            "p1" get ?promise >>port
+            "p1" get 5 seconds ?promise-timeout >>port
        connect
 ] unit-test
 [ ] [ "username@host.com" >user ] unit-test
@ -59,7 +59,7 @@ FROM: pop3 => count delete ;
 [ ] [
        <pop3-account>
            "127.0.0.1" >>host
-            "p2" get ?promise >>port
+            "p2" get 5 seconds ?promise-timeout >>port
            "username@host.com" >>user
            "password" >>pwd
        connect
--- a/Show More
+++ b/Show More
				`@ -0,0 +1 @@`
				`Hashtables keyed by object identity (eq?) rather than by logical value (=)`
				`@ -0,0 +1 @@`
				`One-time and recurring timers for relative time offsets`
				`@ -0,0 +1 @@`
				`Generate integer handle values to allow Factor object references to be passed through the FFI`