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

2010-06-07 23:12:23 +06:00 · 2010-06-07 23:12:23 +06:00 · e174b7a070
parent 33996ca1d6 90537038ea
commit e174b7a070
100 changed files with 17248 additions and 1134 deletions
--- a/19
+++ b/19
@ -1,3 +1,7 @@
+!IF !DEFINED(BOOTIMAGE_VERSION)
+BOOTIMAGE_VERSION = latest
+!ENDIF
+
 !IF DEFINED(PLATFORM)

 LINK_FLAGS = /nologo shell32.lib
@ -102,18 +106,19 @@ default:
 	@exit 1

 x86-32:
-	nmake PLATFORM=x86-32 /f Nmakefile all
+	nmake /nologo PLATFORM=x86-32 /f Nmakefile all

 x86-64:
-	nmake PLATFORM=x86-64 /f Nmakefile all
+	nmake /nologo PLATFORM=x86-64 /f Nmakefile all

 clean:
 	del vm\*.obj
-	del factor.lib
-	del factor.com
-	del factor.exe
-	del factor.dll
-	del factor.dll.lib
+	if exist factor.lib del factor.lib
+	if exist factor.res del factor.res
+	if exist factor.com del factor.com
+	if exist factor.exe del factor.exe
+	if exist factor.dll del factor.dll
+	if exist factor.dll.lib del factor.dll.lib

 .PHONY: all default x86-32 x86-64 clean

--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@ -8,6 +8,10 @@ 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." } ;
@ -56,7 +60,7 @@ ARTICLE: "alarms" "Alarms"
 "Create an alarm before starting it:"
 { $subsections <alarm> }
 "Starting an alarm:"
-{ $subsections start-alarm }
+{ $subsections start-alarm restart-alarm }
 "Stopping an alarm:"
 { $subsections stop-alarm }

--- a/basis/alarms/alarms-tests.factor
+++ b/basis/alarms/alarms-tests.factor
@ -44,3 +44,24 @@ IN: alarms.tests
    2 seconds sleep stop-alarm
    1/2 seconds sleep
 ] unit-test
+
+[ { 0 } ] [
+    { 0 }
+    dup '[ 1 _ set-first ] 300 milliseconds later
+    150 milliseconds sleep
+    [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi
+] unit-test
+
+[ { 1 } ] [
+    { 0 }
+    dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
+    100 milliseconds sleep restart-alarm 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
+] unit-test
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@ -12,6 +12,7 @@ TUPLE: alarm
    interval-nanos
    iteration-start-nanos
    quotation-running?
+    restart?
    thread ;

 <PRIVATE
@ -33,7 +34,7 @@ M: duration >nanoseconds duration>nanoseconds >integer ;
    >>iteration-start-nanos ;

 : stop-alarm? ( alarm -- ? )
-    thread>> self eq? not ;
+    { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;

 DEFER: call-alarm-loop

@ -60,6 +61,19 @@ DEFER: call-alarm-loop
        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 )
@ -70,11 +84,7 @@ PRIVATE>

 : start-alarm ( alarm -- )
    [
-        '[
-            _ nano-count >>start-nanos
-            [ delay-nanos>> [ sleep ] when* ]
-            [ nano-count >>iteration-start-nanos call-alarm-loop ] bi
-        ] "Alarm execution" spawn
+        '[ _ alarm-loop ] "Alarm execution" spawn
    ] keep thread<< ;

 : stop-alarm ( alarm -- )
@ -84,6 +94,14 @@ PRIVATE>
        [ [ 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 )
--- a/basis/alien/prettyprint/prettyprint-tests.factor
+++ b/basis/alien/prettyprint/prettyprint-tests.factor
@ -0,0 +1,55 @@
+USING: alien.c-types alien.prettyprint alien.syntax
+io.streams.string see tools.test prettyprint ;
+IN: alien.prettyprint.tests
+
+CONSTANT: FOO 10
+
+FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION: int function_test
+    ( float x, int[4][FOO] y, char* z, ushort* w ) ;
+" ] [
+    [ \ function_test see ] with-string-writer
+] unit-test
+
+FUNCTION-ALIAS: function-test int function_test
+    ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION-ALIAS: function-test int function_test
+    ( float x, int[4][FOO] y, char* z, ushort* w ) ;
+" ] [
+    [ \ function-test see ] with-string-writer
+] unit-test
+
+C-TYPE: opaque-c-type
+
+[ "USING: alien.syntax ;
+IN: alien.prettyprint.tests
+C-TYPE: opaque-c-type
+" ] [
+    [ \ opaque-c-type see ] with-string-writer
+] unit-test
+
+TYPEDEF: pointer: int pint
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+TYPEDEF: int* pint
+" ] [
+    [ \ pint see ] with-string-writer
+] unit-test
+
+[ "pointer: int" ] [ pointer: int unparse ] unit-test
+
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+" ] [
+    [ \ callback-test see ] with-string-writer
+] unit-test
--- a/basis/alien/prettyprint/prettyprint.factor
+++ b/basis/alien/prettyprint/prettyprint.factor
@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel combinators alien alien.enums
 alien.strings alien.c-types alien.parser alien.syntax arrays
-assocs effects math.parser prettyprint.backend prettyprint.custom
-prettyprint.sections definitions see see.private sequences
-strings words ;
+assocs effects math.parser prettyprint prettyprint.backend
+prettyprint.custom prettyprint.sections definitions see
+see.private sequences strings words ;
 IN: alien.prettyprint

 M: alien pprint*
@ -23,21 +23,26 @@ M: c-type-word declarations. drop ;
 <PRIVATE
 GENERIC: pointer-string ( pointer -- string/f )
 M: object pointer-string drop f ;
-M: word pointer-string name>> ;
+M: word pointer-string [ record-vocab ] [ name>> ] bi ;
 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
+
+GENERIC: c-type-string ( c-type -- string )
+
+M: word c-type-string [ record-vocab ] [ name>> ] bi ;
+M: pointer c-type-string dup pointer-string [ ] [ unparse ] ?if ;
+M: wrapper c-type-string wrapped>> c-type-string ;
+M: array c-type-string
+    unclip
+    [ [ unparse "[" "]" surround ] map ]
+    [ c-type-string ] bi*
+    prefix "" join ;
 PRIVATE>

-GENERIC: pprint-c-type ( c-type -- )
-M: word pprint-c-type pprint-word ;
-M: pointer pprint-c-type
-    dup pointer-string
-    [ swap present-text ]
-    [ pprint* ] if* ;
-M: wrapper pprint-c-type wrapped>> pprint-word ;
-M: string pprint-c-type text ;
-M: array pprint-c-type pprint* ;
+: pprint-c-type ( c-type -- )
+    [ c-type-string ] keep present-text ;

-M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
+M: pointer pprint*
+    <flow \ pointer: pprint-word to>> pprint* block> ;

 M: typedef-word definer drop \ TYPEDEF: f ;

@ -102,11 +107,11 @@ M: alien-callback-type-word synopsis*
        [ seeing-word ]
        [ "callback-library" word-prop pprint-library ]
        [ definer. ]
-        [ def>> first pprint-c-type ]
+        [ def>> first first pprint-c-type ]
        [ pprint-word ]
        [
            <block "(" text 
-            [ def>> second ] [ "callback-effect" word-prop in>> ] bi
+            [ def>> first second ] [ "callback-effect" word-prop in>> ] bi
            pprint-function-args
            ")" text block>
        ]
--- a/basis/bootstrap/image/download/download.factor
+++ b/basis/bootstrap/image/download/download.factor
@ -18,20 +18,19 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
        bi = not
    ] [ drop t ] if ;

-: download-image ( arch -- )
-    url swap boot-image-name >url derive-url download ;
+: verify-image ( image -- )
+    need-new-image? [ "Boot image corrupt" throw ] when ;

-: maybe-download-image ( arch -- )
-    dup boot-image-name need-new-image? [
-         dup download-image
-         need-new-image? [
-             "Boot image corrupt, or checksums.txt on server out of date" throw
-         ] when
-    ] [
-        "Boot image up to date" print
-        drop
-    ] if ;
+: download-image ( image -- )
+    [ url swap >url derive-url download ]
+    [ verify-image ]
+    bi ;

-: download-my-image ( -- ) my-arch maybe-download-image ;
+: maybe-download-image ( image -- ? )
+    dup need-new-image?
+    [ download-image t ] [ drop f ] if ;
+
+: download-my-image ( -- )
+    my-arch boot-image-name maybe-download-image drop ;

 MAIN: download-my-image
--- a/basis/calendar/model/model.factor
+++ b/basis/calendar/model/model.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar namespaces models threads kernel init ;
 IN: calendar.model
@ -15,5 +15,7 @@ SYMBOL: time
        (time-thread)
    ] "Time model update" spawn drop ;

-f <model> time set-global
-[ time-thread ] "calendar.model" add-startup-hook
+[
+    f <model> time set-global
+    time-thread
+] "calendar.model" add-startup-hook
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@ -28,7 +28,7 @@ SYMBOL: command-line
 : load-vocab-roots ( -- )
    "user-init" get [
        "factor-roots" rc-path dup exists? [
-            utf8 file-lines [ add-vocab-root ] each
+            utf8 file-lines harvest [ add-vocab-root ] each
        ] [ drop ] if
    ] when ;

--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@ -345,6 +345,11 @@ def: dst
 use: src1 src2
 literal: rep ;

+PURE-INSN: ##float-pack-vector
+def: dst
+use: src
+literal: rep ;
+
 PURE-INSN: ##signed-pack-vector
 def: dst
 use: src1 src2
--- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
+++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
@ -28,6 +28,7 @@ M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
 M: ##shuffle-vector-halves-imm insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
 M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
 M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
+M: ##float-pack-vector insn-available? rep>> %float-pack-vector-reps member? ;
 M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
 M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
 M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@ -570,7 +570,12 @@ PREDICATE: fixnum-vector-rep < int-vector-rep

 : emit-simd-vpack-signed ( node -- )
    {
-        [ ^^signed-pack-vector ]
+        { double-2-rep [| src1 src2 rep |
+            src1 double-2-rep ^^float-pack-vector :> dst-head
+            src2 double-2-rep ^^float-pack-vector :> dst-tail
+            dst-head dst-tail { 0 1 0 1 } float-4-rep ^^shuffle-vector-halves-imm
+        ] }
+        { int-vector-rep [ ^^signed-pack-vector ] }
    } emit-vv-vector-op ;

 : emit-simd-vpack-unsigned ( node -- )
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@ -191,6 +191,7 @@ CODEGEN: ##shuffle-vector %shuffle-vector
 CODEGEN: ##tail>head-vector %tail>head-vector
 CODEGEN: ##merge-vector-head %merge-vector-head
 CODEGEN: ##merge-vector-tail %merge-vector-tail
+CODEGEN: ##float-pack-vector %float-pack-vector
 CODEGEN: ##signed-pack-vector %signed-pack-vector
 CODEGEN: ##unsigned-pack-vector %unsigned-pack-vector
 CODEGEN: ##unpack-vector-head %unpack-vector-head
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@ -314,6 +314,7 @@ HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- )
 HOOK: %tail>head-vector cpu ( dst src rep -- )
 HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
 HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
+HOOK: %float-pack-vector cpu ( dst src rep -- )
 HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- )
 HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- )
 HOOK: %unpack-vector-head cpu ( dst src rep -- )
@ -371,6 +372,7 @@ HOOK: %shuffle-vector-reps cpu ( -- reps )
 HOOK: %shuffle-vector-imm-reps cpu ( -- reps )
 HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps )
 HOOK: %merge-vector-reps cpu ( -- reps )
+HOOK: %float-pack-vector-reps cpu ( -- reps )
 HOOK: %signed-pack-vector-reps cpu ( -- reps )
 HOOK: %unsigned-pack-vector-reps cpu ( -- reps )
 HOOK: %unpack-vector-head-reps cpu ( -- reps )
@ -423,6 +425,7 @@ M: object %shuffle-vector-reps { } ;
 M: object %shuffle-vector-imm-reps { } ;
 M: object %shuffle-vector-halves-imm-reps { } ;
 M: object %merge-vector-reps { } ;
+M: object %float-pack-vector-reps { } ;
 M: object %signed-pack-vector-reps { } ;
 M: object %unsigned-pack-vector-reps { } ;
 M: object %unpack-vector-head-reps { } ;
--- a/basis/cpu/x86/sse/sse.factor
+++ b/basis/cpu/x86/sse/sse.factor
@ -298,6 +298,14 @@ M: x86 %merge-vector-reps
        { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
    } available-reps ;

+M: x86 %float-pack-vector
+    drop CVTPD2PS ;
+
+M: x86 %float-pack-vector-reps
+    {
+        { sse2? { double-2-rep } }
+    } available-reps ;
+
 M: x86 %signed-pack-vector
    [ two-operand ] keep
    {
--- a/basis/images/png/png.factor
+++ b/basis/images/png/png.factor
@ -290,14 +290,6 @@ ERROR: invalid-color-type/bit-depth loading-png ;
 : validate-truecolor-alpha ( loading-png -- loading-png )
    { 8 16 } validate-bit-depth ;

-: pad-bitmap ( image -- image )
-    dup dim>> second 4 divisor? [
-        dup [ bytes-per-pixel ]
-        [ dim>> first * ]
-        [ dim>> first 4 mod ] tri
-        '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
-    ] unless ;
-
 : loading-png>bitmap ( loading-png -- bytes component-order )
    dup color-type>> {
        { greyscale [
@ -323,7 +315,7 @@ ERROR: invalid-color-type/bit-depth loading-png ;
        [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
        [ [ width>> ] [ height>> ] bi 2array >>dim ]
        [ png-component >>component-type ]
-    } cleave pad-bitmap ;
+    } cleave ;

 : load-png ( stream -- loading-png )
    [
--- a/basis/io/thread/thread.factor
+++ b/basis/io/thread/thread.factor
@ -14,6 +14,9 @@ SYMBOL: io-thread-running?
    [ [ io-thread-running? get-global ] [ io-thread ] while ]
    "I/O wait" spawn drop ;

+: stop-io-thread ( -- )
+    f io-thread-running? set-global ;
+
 [
    t io-thread-running? set-global
    start-io-thread
--- a/basis/json/reader/reader-docs.factor
+++ b/basis/json/reader/reader-docs.factor
@ -1,14 +1,18 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax kernel ;
 IN: json.reader

 HELP: json>
 { $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
 { $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;

+HELP: read-jsons
+{ $values { "objects" "a vector of deserialized objects" } }
+{ $description "Reads JSON formatted strings into a vector of Factor object until the end of the stream is reached. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
+
 ARTICLE: "json.reader" "JSON reader"
 "The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format."
-{ $subsections json> } ;
+{ $subsections json> read-jsons } ;

 ABOUT: "json.reader"
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@ -1,5 +1,5 @@
 USING: assocs arrays json.reader kernel strings tools.test
-hashtables json ;
+hashtables json io.streams.string ;
 IN: json.reader.tests

 { f } [ "false" json> ] unit-test
@ -59,5 +59,8 @@ IN: json.reader.tests
 { 0 } [ "0      " json> ] unit-test
 { 0 } [ "   0   " json> ] unit-test

+{ V{ H{ { "a" "b" } } H{ { "c" "d" } } } }
+[ """{"a": "b"} {"c": "d"}""" [ read-jsons ] with-string-reader ] unit-test
+
 ! empty objects are allowed as values in objects
 { H{ { "foo" H{ } } } } [ "{ \"foo\" : {}}" json> ] unit-test
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@ -78,7 +78,7 @@ DEFER: j-string
            { CHAR: {  [ 2 [ V{ } clone over push ] times ] }
            { CHAR: :  [ v-pick-push ] }
            { CHAR: }  [ (close-hash) ] }
-            { CHAR: \u000020 [ ] }
+            { CHAR: \s [ ] }
            { CHAR: \t [ ] }
            { CHAR: \r [ ] }
            { CHAR: \n [ ] }
@ -89,10 +89,10 @@ DEFER: j-string
        } case
    ] when* ;

-: (json-parser>) ( string -- object )
-    [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
-
 PRIVATE>

+: read-jsons ( -- objects )
+    V{ } clone [ read1 dup ] [ scan ] while drop ;
+
 : json> ( string -- object )
-    (json-parser>) ;
+    [ read-jsons first ] with-string-reader ;
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@ -100,5 +100,7 @@ FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;

 FUNCTION: size_t strlen ( c-string alien ) ;

+FUNCTION: int system ( c-string command ) ;
+
 DESTRUCTOR: free
 DESTRUCTOR: (free)
--- a/basis/math/vectors/simd/intrinsics/intrinsics.factor
+++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor
@ -1,9 +1,10 @@
 ! (c)2009 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data combinators
+USING: accessors alien alien.data combinators
 sequences.cords cpu.architecture fry generalizations grouping
-kernel libc locals math math.libm math.order math.ranges
-math.vectors sequences sequences.generalizations
-sequences.private specialized-arrays vocabs.loader ;
+kernel libc locals macros math math.libm math.order
+math.ranges math.vectors sequences sequences.generalizations
+sequences.private sequences.unrolled sequences.unrolled.private
+specialized-arrays vocabs.loader words effects.parser locals.parser ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAYS:
    c:char c:short c:int c:longlong
@ -11,6 +12,20 @@ SPECIALIZED-ARRAYS:
    c:float c:double ;
 IN: math.vectors.simd.intrinsics

+<<
+: simd-intrinsic-body ( def effect -- def' )
+    '[ _ _ call-effect ] ;
+
+: define-simd-intrinsic ( word def effect -- )
+    [ simd-intrinsic-body ] keep define-declared ;
+
+SYNTAX: SIMD-INTRINSIC:
+    (:) define-declared ;
+SYNTAX: SIMD-INTRINSIC::
+    (::) define-declared ;
+
+>>
+
 : assert-positive ( x -- y ) ;

 <PRIVATE
@ -45,16 +60,16 @@ IN: math.vectors.simd.intrinsics

 : [byte>rep-array] ( rep -- class )
    {
-        { char-16-rep      [ [ char-array-cast      ] ] }
-        { uchar-16-rep     [ [ uchar-array-cast     ] ] }
-        { short-8-rep      [ [ short-array-cast     ] ] }
-        { ushort-8-rep     [ [ ushort-array-cast    ] ] }
-        { int-4-rep        [ [ int-array-cast       ] ] }
-        { uint-4-rep       [ [ uint-array-cast      ] ] }
-        { longlong-2-rep   [ [ longlong-array-cast  ] ] }
-        { ulonglong-2-rep  [ [ ulonglong-array-cast ] ] }
-        { float-4-rep      [ [ float-array-cast     ] ] }
-        { double-2-rep     [ [ double-array-cast    ] ] }
+        { char-16-rep      [ [ 16 <direct-char-array>      ] ] }
+        { uchar-16-rep     [ [ 16 <direct-uchar-array>     ] ] }
+        { short-8-rep      [ [  8 <direct-short-array>     ] ] }
+        { ushort-8-rep     [ [  8 <direct-ushort-array>    ] ] }
+        { int-4-rep        [ [  4 <direct-int-array>       ] ] }
+        { uint-4-rep       [ [  4 <direct-uint-array>      ] ] }
+        { longlong-2-rep   [ [  2 <direct-longlong-array>  ] ] }
+        { ulonglong-2-rep  [ [  2 <direct-ulonglong-array> ] ] }
+        { float-4-rep      [ [  4 <direct-float-array>     ] ] }
+        { double-2-rep     [ [  2 <direct-double-array>    ] ] }
    } case ; foldable

 : [>rep-array] ( rep -- class )
@ -96,27 +111,31 @@ IN: math.vectors.simd.intrinsics
    [<rep-array>] call( -- a' ) ; inline

 : components-map ( a rep quot -- c )
-    [ >rep-array ] dip map underlying>> ; inline
+    [ [ >rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
 : components-2map ( a b rep quot -- c )
-    [ 2>rep-array ] dip 2map underlying>> ; inline
+    [ [ 2>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
+! XXX
 : components-reduce ( a rep quot -- x )
    [ >rep-array [ ] ] dip map-reduce ; inline

 : bitwise-components-map ( a rep quot -- c )
-    [ >bitwise-vector-rep >rep-array ] dip map underlying>> ; inline
+    [ >bitwise-vector-rep [ >rep-array ] [ rep-length ] bi ] dip
+    unrolled-map-unsafe underlying>> ; inline
 : bitwise-components-2map ( a b rep quot -- c )
-    [ >bitwise-vector-rep 2>rep-array ] dip 2map underlying>> ; inline
+    [ >bitwise-vector-rep [ 2>rep-array ] [ rep-length ] bi ] dip
+    unrolled-2map-unsafe underlying>> ; inline
+! XXX
 : bitwise-components-reduce ( a rep quot -- x )
    [ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline

 :: (vshuffle) ( a elts rep -- c )
    a rep >rep-array :> a'
    rep <rep-array> :> c'
-    elts [| from to |
+    elts rep rep-length [| from to |
        from rep rep-length 1 - bitand
           a' nth-unsafe
        to c' set-nth-unsafe
-    ] each-index
+    ] unrolled-each-index-unsafe
    c' underlying>> ; inline

 :: (vshuffle2) ( a b elts rep -- c )
@ -124,39 +143,44 @@ IN: math.vectors.simd.intrinsics
    b rep >rep-array :> b'
    a' b' cord-append :> ab'
    rep <rep-array> :> c'
-    elts [| from to |
+    elts rep rep-length [| from to |
        from rep rep-length dup + 1 - bitand
           ab' nth-unsafe
        to c' set-nth-unsafe
-    ] each-index
+    ] unrolled-each-index-unsafe
    c' underlying>> ; inline

+GENERIC: native/ ( x y -- x/y )
+
+M: integer native/ /i ; inline
+M: float native/ /f ; inline
+
 PRIVATE>

-: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
-: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
-: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
-:: (simd-v+-)              ( a b rep -- c ) 
+SIMD-INTRINSIC: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
+SIMD-INTRINSIC: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
+SIMD-INTRINSIC: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
+SIMD-INTRINSIC:: (simd-v+-)              ( a b rep -- c ) 
    a b rep 2>rep-array :> ( a' b' )
    rep <rep-array> :> c'
-    0  rep rep-length 1 -  2 <range> [| n |
+    0  rep rep-length [ 1 -  2 <range> ] [ 2 /i ] bi [| n |
        n     a' nth-unsafe n     b' nth-unsafe -
        n     c' set-nth-unsafe

        n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
        n 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-unsafe
    c' underlying>> ;
-: (simd-vs+)               ( a b rep -- c )
-    dup rep-component-type '[ + _ c-type-clamp ] components-2map ;
-: (simd-vs-)               ( a b rep -- c )
-    dup rep-component-type '[ - _ c-type-clamp ] components-2map ;
-: (simd-vs*)               ( a b rep -- c )
-    dup rep-component-type '[ * _ c-type-clamp ] components-2map ;
-: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
-: (simd-v*high)            ( a b rep -- c )
-    dup rep-component-type heap-size -8 * '[ * _ shift ] components-2map ;
-:: (simd-v*hs+)            ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vs+)               ( a b rep -- c )
+    dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
+SIMD-INTRINSIC: (simd-vs-)               ( a b rep -- c )
+    dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
+SIMD-INTRINSIC: (simd-vs*)               ( a b rep -- c )
+    dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
+SIMD-INTRINSIC: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
+SIMD-INTRINSIC: (simd-v*high)            ( a b rep -- c )
+    dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
+SIMD-INTRINSIC:: (simd-v*hs+)            ( a b rep -- c )
    rep { char-16-rep uchar-16-rep } member-eq?
    [ uchar-16-rep char-16-rep ]
    [ rep rep ] if :> ( a-rep b-rep )
@ -164,102 +188,110 @@ PRIVATE>
    wide-rep rep-component-type :> wide-type
    a a-rep >rep-array 2 <groups> :> a'
    b b-rep >rep-array 2 <groups> :> b'
-    a' b' [
+    a' b' rep rep-length 2 /i [
        [ [ first  ] bi@ * ]
        [ [ second ] bi@ * ] 2bi +
-        wide-type c-type-clamp
-    ] wide-rep <rep-array> 2map-as underlying>> ;
-: (simd-v/)                ( a b rep -- c ) [ / ] components-2map ;
-: (simd-vavg)              ( a b rep -- c )
+        wide-type c:c-type-clamp
+    ] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
+SIMD-INTRINSIC: (simd-v/)                ( a b rep -- c ) [ native/ ] components-2map ;
+SIMD-INTRINSIC: (simd-vavg)              ( a b rep -- c )
    [ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
-: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
-: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
-: (simd-v.)                ( a b rep -- n )
+SIMD-INTRINSIC: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
+SIMD-INTRINSIC: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
+! XXX
+SIMD-INTRINSIC: (simd-v.)                ( a b rep -- n )
    [ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep
    1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
-: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
-: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
-: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
-: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
-: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
-: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
-: (simd-hlshift)           ( a n rep -- c )
+SIMD-INTRINSIC: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
+SIMD-INTRINSIC: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
+SIMD-INTRINSIC: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
+SIMD-INTRINSIC: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
+SIMD-INTRINSIC: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
+! XXX
+SIMD-INTRINSIC: (simd-hlshift)           ( a n rep -- c )
    drop head-slice* 16 0 pad-head ;
-: (simd-hrshift)           ( a n rep -- c )
+! XXX
+SIMD-INTRINSIC: (simd-hrshift)           ( a n rep -- c )
    drop tail-slice 16 0 pad-tail ;
-: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
-: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
-: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
-:: (simd-vmerge-head)      ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
+SIMD-INTRINSIC: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
+SIMD-INTRINSIC: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
+SIMD-INTRINSIC:: (simd-vmerge-head)      ( a b rep -- c )
    a b rep 2>rep-array :> ( a' b' )
    rep <rep-array> :> c'
-    rep rep-length 2 /i iota [| n |
+    rep rep-length 2 /i [| n |
        n a' nth-unsafe n 2 *     c' set-nth-unsafe
        n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-integer
    c' underlying>> ;
-:: (simd-vmerge-tail)      ( a b rep -- c )
+SIMD-INTRINSIC:: (simd-vmerge-tail)      ( a b rep -- c )
    a b rep 2>rep-array :> ( a' b' )
    rep <rep-array> :> c'
    rep rep-length 2 /i :> len
-    len iota [| n |
+    len [| n |
        n len + a' nth-unsafe n 2 *     c' set-nth-unsafe
        n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-integer
    c' underlying>> ;
-: (simd-v<=)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v<=)               ( a b rep -- c )
    dup rep-tf-values '[ <= _ _ ? ] components-2map ; 
-: (simd-v<)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v<)                ( a b rep -- c )
    dup rep-tf-values '[ <  _ _ ? ] components-2map ;
-: (simd-v=)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v=)                ( a b rep -- c )
    dup rep-tf-values '[ =  _ _ ? ] components-2map ;
-: (simd-v>)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v>)                ( a b rep -- c )
    dup rep-tf-values '[ >  _ _ ? ] components-2map ;
-: (simd-v>=)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v>=)               ( a b rep -- c )
    dup rep-tf-values '[ >= _ _ ? ] components-2map ;
-: (simd-vunordered?)       ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vunordered?)       ( a b rep -- c )
    dup rep-tf-values '[ unordered? _ _ ? ] components-2map ;
-: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
-: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
-: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
-: (simd-v>float)           ( a   rep -- c )
-    [ >rep-array [ >float ] ] [ >float-vector-rep <rep-array> ] bi map-as underlying>> ;
-: (simd-v>integer)         ( a   rep -- c )
-    [ >rep-array [ >integer ] ] [ >int-vector-rep <rep-array> ] bi map-as underlying>> ;
-: (simd-vpack-signed)      ( a b rep -- c )
-    [ 2>rep-array cord-append ]
+SIMD-INTRINSIC: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
+SIMD-INTRINSIC: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
+SIMD-INTRINSIC: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
+SIMD-INTRINSIC: (simd-v>float)           ( a   rep -- c )
+    [ [ >rep-array ] [ rep-length ] bi [ >float ] ]
+    [ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
+SIMD-INTRINSIC: (simd-v>integer)         ( a   rep -- c )
+    [ [ >rep-array ] [ rep-length ] bi [ >integer ] ]
+    [ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
+SIMD-INTRINSIC: (simd-vpack-signed)      ( a b rep -- c )
+    [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
    [ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as underlying>> ;
-: (simd-vpack-unsigned)    ( a b rep -- c )
-    [ 2>rep-array cord-append ]
+    '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
+SIMD-INTRINSIC: (simd-vpack-unsigned)    ( a b rep -- c )
+    [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
    [ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as underlying>> ;
-: (simd-vunpack-head)      ( a   rep -- c ) 
+    '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
+! XXX
+SIMD-INTRINSIC: (simd-vunpack-head)      ( a   rep -- c ) 
    [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
    [ head-slice ] dip call( a' -- c' ) underlying>> ;
-: (simd-vunpack-tail)      ( a   rep -- c )
+! XXX
+SIMD-INTRINSIC: (simd-vunpack-tail)      ( a   rep -- c )
    [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
    [ tail-slice ] dip call( a' -- c' ) underlying>> ;
-: (simd-with)              (   n rep -- v )
+! XXX
+SIMD-INTRINSIC: (simd-with)              (   n rep -- v )
    [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as 
    underlying>> ;
-: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
-: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
-: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
+SIMD-INTRINSIC: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
+SIMD-INTRINSIC: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
+SIMD-INTRINSIC: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;

-: alien-vector     (       c-ptr n rep -- value )
+SIMD-INTRINSIC: alien-vector     (       c-ptr n rep -- value )
    [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
-: set-alien-vector ( value c-ptr n rep --       )
+SIMD-INTRINSIC: set-alien-vector ( value c-ptr n rep --       )
    [ swap <displaced-alien> swap ] dip rep-size memcpy ;

 "compiler.cfg.intrinsics.simd" require
--- a/basis/nibble-arrays/nibble-arrays.factor
+++ b/basis/nibble-arrays/nibble-arrays.factor
@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sequences.private byte-arrays
-alien prettyprint.custom parser accessors ;
+alien prettyprint.custom parser accessors locals ;
 IN: nibble-arrays

 TUPLE: nibble-array
@ -20,8 +20,10 @@ CONSTANT: nibble BIN: 1111
 : get-nibble ( n byte -- nibble )
    swap neg shift nibble bitand ; inline

-: set-nibble ( value n byte -- byte' )
-    nibble pick shift bitnot bitand -rot shift bitor ; inline
+:: set-nibble ( value n byte -- byte' )
+    byte nibble n shift bitnot bitand
+    value n shift
+    bitor ; inline

 : nibble@ ( n nibble-array -- shift n' byte-array )
    [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
--- a/basis/sequences/unrolled/unrolled-docs.factor
+++ b/basis/sequences/unrolled/unrolled-docs.factor
@ -5,70 +5,70 @@ IN: sequences.unrolled

 HELP: unrolled-collect
 { $values
-    { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "into" sequence }
+    { "n" integer } { "quot" { $quotation "( n -- value )" } } { "into" sequence }
 }
 { $description "Unrolled version of " { $link collect } ". " { $snippet "n" } " must be a compile-time constant." } ;

 HELP: unrolled-each
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- )" } }
 }
 { $description "Unrolled version of " { $link each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-2each
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... )" } }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- )" } }
 }
 { $description "Unrolled version of " { $link 2each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-each-index
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- )" } }
 }
 { $description "Unrolled version of " { $link each-index } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-each-integer
 { $values
-    { "n" integer } { "quot" { $quotation "( ... i -- ... )" } }
+    { "n" integer } { "quot" { $quotation "( i -- )" } }
 }
 { $description "Unrolled version of " { $link each-integer } ". " { $snippet "n" } " must be a compile-time constant." } ;

 HELP: unrolled-map
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } }
    { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-map-as
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } } { "exemplar" sequence }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } } { "exemplar" sequence }
    { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-as } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-2map
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "newseq" sequence }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link 2map } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-2map-as
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "exemplar" sequence } { "newseq" sequence }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "exemplar" sequence } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link 2map-as } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-map-index
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... newx )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- newx )" } }
    { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-index } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;

 HELP: unrolled-map-integers
 { $values
-    { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "exemplar" sequence } { "newseq" sequence }
+    { "n" integer } { "quot" { $quotation "( n -- value )" } } { "exemplar" sequence } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-integers } ". " { $snippet "n" } " must be a compile-time constant." } ;

--- a/basis/sequences/unrolled/unrolled-tests.factor
+++ b/basis/sequences/unrolled/unrolled-tests.factor
@ -1,5 +1,5 @@
 ! (c)2010 Joe Groff bsd license
-USING: compiler.test make math.parser sequences
+USING: compiler.test compiler.tree.debugger kernel make math.parser sequences
 sequences.unrolled tools.test ;
 IN: sequences.unrolled.tests

@ -7,18 +7,46 @@ IN: sequences.unrolled.tests
 [ { "0" "1" "2" } ] [ { 0 1 2 } [ 3 [ number>string ] unrolled-map ] compile-call ] unit-test

 [ { "0" "1" "2" } ] [ [ { 0 1 2 } 3 [ number>string , ] unrolled-each ] { } make ] unit-test
+[ { "0" "1" "2" } ] [ [ { 0 1 2 } [ 3 [ number>string , ] unrolled-each ] compile-call ] { } make ] unit-test

 [ { "a0" "b1" "c2" } ]
 [ [ { "a" "b" "c" } 3 [ number>string append , ] unrolled-each-index ] { } make ] unit-test

+[ { "a0" "b1" "c2" } ]
+[ [ { "a" "b" "c" } [ 3 [ number>string append , ] unrolled-each-index ] compile-call ] { } make ] unit-test
+
 [ { "aI" "bII" "cIII" } ]
-[ [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append , ] unrolled-2each ] { } make ] unit-test
+[ [ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append , ] unrolled-2each ] compile-call ] { } make ] unit-test

 [ { "aI" "bII" "cIII" } ]
 [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append ] unrolled-2map ] unit-test

+[ { "aI" "bII" "cIII" } ]
+[ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append ] unrolled-2map ] compile-call ] unit-test
+
 [ { "a0" "b1" "c2" } ]
 [ { "a" "b" "c" } 3 [ number>string append ] unrolled-map-index ] unit-test

+[ { "a0" "b1" "c2" } ]
+[ { "a" "b" "c" } [ 3 [ number>string append ] unrolled-map-index ] compile-call ] unit-test
+
 [ { 0 1 2 } 4 [ number>string ] unrolled-map ] [ unrolled-bounds-error? ] must-fail-with
 [ { 0 1 2 3 } { 0 1 2 } 4 [ number>string append ] unrolled-2map ] [ unrolled-2bounds-error? ] must-fail-with
+
+[ t ]
+[ [ 3 [ number>string ] unrolled-map ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string , ] unrolled-each ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string append , ] unrolled-each-index ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ append , ] unrolled-2each ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ append ] unrolled-2map ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string append ] unrolled-map-index ] { call } inlined? ] unit-test
--- a/basis/sequences/unrolled/unrolled.factor
+++ b/basis/sequences/unrolled/unrolled.factor
@ -1,21 +1,29 @@
 ! (c)2010 Joe Groff bsd license
-USING: combinators.short-circuit fry generalizations kernel
-locals macros math quotations sequences ;
-FROM: sequences.private => (each) (each-index) (collect) (2each) ;
+USING: combinators combinators.short-circuit fry generalizations kernel
+locals macros math quotations sequences compiler.tree.propagation.transforms ;
+FROM: sequences.private => (each) (each-index) (2each) nth-unsafe set-nth-unsafe ;
 IN: sequences.unrolled

 <PRIVATE
-MACRO: (unrolled-each-integer) ( n -- )
-    [ iota >quotation ] keep '[ _ dip _ napply ] ;
+: (unrolled-each-integer) ( quot n -- )
+    swap '[ _ call( i -- ) ] each-integer ;
+
+<< \ (unrolled-each-integer) [
+    iota [ '[ _ swap call( i -- ) ] ] [ ] map-as '[ _ cleave ]
+] 1 define-partial-eval >>
+
+: (unrolled-collect) ( quot into -- quot' )
+    '[ dup @ swap _ set-nth-unsafe ] ; inline
+
 PRIVATE>

-: unrolled-each-integer ( ... n quot: ( ... i -- ... ) -- ... )
+: unrolled-each-integer ( n quot: ( i -- ) -- )
    swap (unrolled-each-integer) ; inline

-: unrolled-collect ( ... n quot: ( ... n -- ... value ) into -- ... )
-    (collect) unrolled-each-integer ; inline
+: unrolled-collect ( n quot: ( n -- value ) into -- )
+    (unrolled-collect) unrolled-each-integer ; inline

-: unrolled-map-integers ( ... n quot: ( ... n -- ... value ) exemplar -- ... newseq )
+: unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq )
    [ over ] dip [ [ unrolled-collect ] keep ] new-like ; inline

 ERROR: unrolled-bounds-error
@ -34,52 +42,58 @@ ERROR: unrolled-2bounds-error
    [ xseq yseq len quot ] if ; inline

 : (unrolled-each) ( seq len quot -- len quot )
-    swapd (each) nip ; inline
+    swapd '[ _ nth-unsafe @ ] ; inline

 : (unrolled-each-index) ( seq len quot -- len quot )
-    swapd (each-index) nip ; inline
+    swapd '[ dup _ nth-unsafe swap @ ] ; inline

 : (unrolled-2each) ( xseq yseq len quot -- len quot )
    [ '[ _ ] 2dip ] dip (2each) nip ; inline

-: unrolled-each-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each-unsafe ( seq len quot: ( x -- ) -- )
    (unrolled-each) unrolled-each-integer ; inline

-: unrolled-2each-unsafe ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+: unrolled-2each-unsafe ( xseq yseq len quot: ( x y -- ) -- )
    (unrolled-2each) unrolled-each-integer ; inline

-: unrolled-each-index-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each-index-unsafe ( seq len quot: ( x -- ) -- )
    (unrolled-each-index) unrolled-each-integer ; inline

-: unrolled-map-as-unsafe ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+: unrolled-map-as-unsafe ( seq len quot: ( x -- newx ) exemplar -- newseq )
    [ (unrolled-each) ] dip unrolled-map-integers ; inline

-: unrolled-2map-as-unsafe ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+: unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
    [ (unrolled-2each) ] dip unrolled-map-integers ; inline

+: unrolled-map-unsafe ( seq len quot: ( x -- newx ) -- newseq )
+    pick unrolled-map-as-unsafe ; inline
+
+: unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
+    4 npick unrolled-2map-as-unsafe ; inline
+
 PRIVATE>

-: unrolled-each ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each ( seq len quot: ( x -- ) -- )
    unrolled-bounds-check unrolled-each-unsafe ; inline

-: unrolled-2each ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+: unrolled-2each ( xseq yseq len quot: ( x y -- ) -- )
    unrolled-2bounds-check unrolled-2each-unsafe ; inline

-: unrolled-each-index ( ... seq len quot: ( ... x i -- ... ) -- ... )
+: unrolled-each-index ( seq len quot: ( x i -- ) -- )
    unrolled-bounds-check unrolled-each-index-unsafe ; inline

-: unrolled-map-as ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+: unrolled-map-as ( seq len quot: ( x -- newx ) exemplar -- newseq )
    [ unrolled-bounds-check ] dip unrolled-map-as-unsafe ; inline

-: unrolled-2map-as ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+: unrolled-2map-as ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
    [ unrolled-2bounds-check ] dip unrolled-2map-as-unsafe ; inline

-: unrolled-map ( ... seq len quot: ( ... x -- ... newx ) -- ... newseq )
+: unrolled-map ( seq len quot: ( x -- newx ) -- newseq )
    pick unrolled-map-as ; inline

-: unrolled-2map ( ... xseq yseq len quot: ( ... x y -- ... newx ) -- ... newseq )
+: unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq )
    4 npick unrolled-2map-as ; inline

-: unrolled-map-index ( ... seq len quot: ( ... x i -- ... newx ) -- ... newseq )
+: unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
    [ dup length iota ] 2dip unrolled-2map ; inline

--- a/basis/tools/deploy/macosx/macosx.factor
+++ b/basis/tools/deploy/macosx/macosx.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.files io.files.info.unix io.pathnames
 io.directories io.directories.hierarchy kernel namespaces make
@ -10,7 +10,10 @@ combinators vocabs.metadata vocabs.loader ;
 IN: tools.deploy.macosx

 : bundle-dir ( -- dir )
-    vm parent-directory parent-directory ;
+    running.app?
+    [ vm parent-directory parent-directory ]
+    [ "resource:Factor.app" ]
+    if ;

 : copy-bundle-dir ( bundle-name dir -- )
    [ bundle-dir prepend-path swap ] keep
@ -70,7 +73,6 @@ IN: tools.deploy.macosx
    -> selectFile:inFileViewerRootedAtPath: drop ;

 M: macosx deploy* ( vocab -- )
-    ".app deploy tool" assert.app
    "resource:" [
        dup deploy-config [
            bundle-name dup exists? [ delete-tree ] [ drop ] if
--- a/basis/tools/errors/model/model.factor
+++ b/basis/tools/errors/model/model.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: models source-files.errors namespaces models.delay init
 kernel calendar ;
@ -6,13 +6,14 @@ IN: tools.errors.model

 SYMBOLS: (error-list-model) error-list-model ;

-(error-list-model) [ f <model> ] initialize
-
-error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
-
 SINGLETON: updater

-M: updater errors-changed drop f (error-list-model) get-global set-model ;
+M: updater errors-changed
+    drop f (error-list-model) get-global set-model ;

-[ updater add-error-observer ] "ui.tools.error-list" add-startup-hook
+[
+    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

--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@ -252,7 +252,7 @@ M: cocoa-ui-backend (with-ui)
            init-clipboard
            cocoa-startup-hook get call( -- )
            start-ui
-            f io-thread-running? set-global
+            stop-io-thread
            init-thread-timer
            reset-run-loop
            NSApp -> run
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@ -248,7 +248,7 @@ CONSTANT: window-control>ex-style
        { minimize-button 0 }
        { maximize-button 0 }
        { resize-handles $ WS_EX_WINDOWEDGE }
-        { small-title-bar $ WS_EX_TOOLWINDOW }
+        { small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] }
        { normal-title-bar $ WS_EX_APPWINDOW }
    }

@ -832,24 +832,25 @@ CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
    } cleave ;

 : exit-fullscreen ( world -- )
-    dup handle>> hWnd>>
+    [ handle>> hWnd>> ] [ world>style ] bi
    {
-        [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
+        [ [ GWL_STYLE ] dip SetWindowLong win32-error=0/f ]
        [
+            drop
            f
            over hwnd>RECT get-RECT-dimensions
            flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
            SetWindowPos win32-error=0/f
        ]
-        [ SW_RESTORE ShowWindow win32-error=0/f ]
-    } cleave ;
+        [ drop SW_RESTORE ShowWindow win32-error=0/f ]
+    } 2cleave ;

 M: windows-ui-backend (set-fullscreen) ( ? world -- )
    [ enter-fullscreen ] [ exit-fullscreen ] if ;

 M: windows-ui-backend (fullscreen?) ( world -- ? )
-    [ handle>> hWnd>> hwnd>RECT ]
-    [ handle>> hWnd>> fullscreen-RECT ] bi
+    handle>> hWnd>>
+    [ hwnd>RECT ] [ fullscreen-RECT ] bi
    [ get-RECT-dimensions 2array 2nip ] bi@ = ;

 windows-ui-backend ui-backend set-global
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@ -1,20 +1,52 @@
-! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data ascii assocs classes.struct
-combinators combinators.short-circuit command-line environment
-io.encodings.ascii io.encodings.string io.encodings.utf8 kernel
-literals locals math namespaces sequences specialized-arrays
-strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
-ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
-ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
-x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
-FROM: unix.ffi => system ;
-SPECIALIZED-ARRAY: uchar
+USING: accessors arrays alien.c-types alien.data alien.syntax ascii
+assocs classes.struct combinators combinators.short-circuit
+command-line environment io.encodings.ascii io.encodings.string
+io.encodings.utf8 kernel literals locals math namespaces
+sequences specialized-arrays strings ui ui.backend ui.clipboards
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private
+x11 x11.clipboard x11.constants x11.events x11.glx x11.io
+x11.windows x11.xim x11.xlib ;
+FROM: libc => system ;
+SPECIALIZED-ARRAYS: uchar ulong ;
 IN: ui.backend.x11

 SINGLETON: x11-ui-backend

+: XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+: XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
+: XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
+: XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
+
+: supported-net-wm-hints ( -- seq )
+    { Atom int ulong ulong pointer: Atom }
+    [| type format n-atoms bytes-after atoms |
+        dpy get
+        root get
+        XA_NET_SUPPORTED
+        0
+        ulong c-type-interval nip
+        0
+        XA_ATOM
+        type
+        format
+        n-atoms
+        bytes-after
+        atoms
+        XGetWindowProperty
+        Success assert=
+    ]
+    [| type format n-atoms bytes-after atoms |
+        atoms n-atoms <direct-ulong-array> >array
+        atoms XFree
+    ]
+    with-out-parameters ;
+
+: net-wm-hint-supported? ( atom -- ? )
+    supported-net-wm-hints member? ;

 TUPLE: x11-handle-base glx ;
 TUPLE: x11-handle < x11-handle-base window xic ;
@ -30,7 +62,7 @@ M: world configure-event
    ! In case dimensions didn't change
    relayout-1 ;

-PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
+PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_RGBA } H{
    { double-buffered { $ GLX_DOUBLEBUFFER } }
    { stereo { $ GLX_STEREO } }
    { color-bits { $ GLX_BUFFER_SIZE } }
@ -172,8 +204,7 @@ M: world selection-notify-event
    user-input ;

 : supported-type? ( atom -- ? )
-    { "UTF8_STRING" "STRING" "TEXT" }
-    [ x-atom = ] with any? ;
+    XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;

 : clipboard-for-atom ( atom -- clipboard )
    {
@ -196,8 +227,8 @@ M: world selection-notify-event
 M: world selection-request-event
    drop dup target>> {
        { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
-        { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
-        { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+        { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
+        { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
        [ drop send-notify-failure ]
    } cond ;

@ -258,31 +289,57 @@ M: x11-ui-backend set-title ( string world -- )
    handle>> window>> swap
    [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;

-: make-fullscreen-msg ( world ? -- msg )
+: make-fullscreen-msg ( window ? -- msg )
    XClientMessageEvent <struct>
-    ClientMessage >>type
-    dpy get >>display
-    "_NET_WM_STATE" x-atom >>message_type
-    swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
-    swap handle>> window>> >>window
-    32 >>format
-    "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+        ClientMessage >>type
+        dpy get >>display
+        XA_NET_WM_STATE >>message_type
+        swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+        swap >>window
+        32 >>format
+        XA_NET_WM_STATE_FULLSCREEN >>data1 ;
+
+: send-event ( event -- )
+    [
+        dpy get
+        root get
+        0
+        SubstructureNotifyMask SubstructureRedirectMask bitor
+    ] dip XSendEvent drop ;

 M: x11-ui-backend (set-fullscreen) ( world ? -- )
-    [ dpy get root get 0 SubstructureNotifyMask ] 2dip
-    make-fullscreen-msg XSendEvent drop ;
+    [ handle>> window>> ] dip make-fullscreen-msg send-event ;

 M: x11-ui-backend (open-window) ( world -- )
-    dup gadget-window
-    handle>> window>>
-    [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
+    dup gadget-window handle>> window>>
+    [ set-closable ]
+    [ [ dpy get ] dip set-class ]
+    [ map-window ]
+    tri ;
+
+: make-raise-window-msg ( window -- msg )
+    XClientMessageEvent <struct>
+        ClientMessage >>type
+        1 >>send_event
+        dpy get >>display
+        swap >>window
+        XA_NET_ACTIVE_WINDOW >>message_type
+        32 >>format ;
+
+: raise-window-new ( window -- )
+    make-raise-window-msg send-event ;
+
+: raise-window-old ( window -- )
+    [ dpy get ] dip
+    [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+    [ XRaiseWindow drop ]
+    2bi ;

 M: x11-ui-backend raise-window* ( world -- )
    handle>> [
-        dpy get swap window>>
-        [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
-        [ XRaiseWindow drop ]
-        2bi
+        window>>
+        XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
+        [ raise-window-new ] [ raise-window-old ] if
    ] when* ;

 M: x11-handle select-gl-context ( handle -- )
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@ -60,14 +60,11 @@ SYMBOL: blink-interval
 750 milliseconds blink-interval set-global

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

 : start-blinking ( editor -- )
-    [ stop-blinking ] [
-        t >>blink
-        dup '[ _ blink-caret ] blink-interval get delayed-every
-        >>blink-alarm drop
-    ] bi ;
+    t >>blink
+    blink-alarm>> [ restart-alarm ] when* ;

 : restart-blinking ( editor -- )
    dup focused?>> [
@ -80,10 +77,15 @@ PRIVATE>

 M: editor graft*
    [ dup caret>> activate-editor-model ]
-    [ dup mark>> activate-editor-model ] bi ;
+    [ dup mark>> activate-editor-model ]
+    [
+        [
+            '[ _ blink-caret ] blink-interval get dup <alarm>
+        ] keep blink-alarm<<
+    ] tri ;

 M: editor ungraft*
-    [ stop-blinking ]
+    [ [ stop-blinking ] [ f >>blink-alarm 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
@ -20,7 +20,6 @@ CONSTANT: default-world-pixel-format-attributes
    {
        windowed
        double-buffered
-        T{ depth-bits { value 16 } }
    }

 CONSTANT: default-world-window-controls
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@ -35,6 +35,8 @@ SLOT: background-color
    GL_BLEND glEnable
    GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
    GL_VERTEX_ARRAY glEnableClientState
+    GL_PACK_ALIGNMENT 1 glPixelStorei
+    GL_UNPACK_ALIGNMENT 1 glPixelStorei
    init-matrices
    [ init-clip ]
    [
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@ -195,6 +195,7 @@ TUPLE: listener-gadget < tool error-summary output scroller input ;
        H{ { table-gap { 3 3 } } } [
            [ [ [ icon>> write-image ] with-cell ] each ] with-row
        ] tabular-output
+        last-element off
        { "Press " { $command tool "common" show-error-list } " to view errors." }
        print-element
    ] unless-empty ;
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@ -5,10 +5,7 @@ ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
 ui.tools.walker ui.commands ui.gestures ui ui.private ;
 IN: ui.tools

-: main ( -- )
-    restore-windows? [ restore-windows ] [ listener-window ] if ;
-
-MAIN: main
+MAIN: listener-window

 \ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command

--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@ -1,11 +1,12 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs 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: 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 ;
 IN: ui

 <PRIVATE
@ -82,12 +83,7 @@ M: world graft*
        [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
    ] bi ;

-: reset-world ( world -- )
-    #! This is used when a window is being closed, but also
-    #! when restoring saved worlds on image startup.
-    f >>handle unfocus-world ;
-
-: (ungraft-world) ( world -- )
+M: world ungraft*
    {
        [ set-gl-context ]
        [ text-handle>> [ dispose ] when* ]
@ -96,38 +92,21 @@ M: world graft*
        [ hand-gadget close-global ]
        [ end-world ]
        [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
+        [ [ (close-window) f ] change-handle drop ]
+        [ unfocus-world ]
    } cleave ;

-M: world ungraft*
-    [ (ungraft-world) ]
-    [ handle>> (close-window) ]
-    [ reset-world ] tri ;
-
 : init-ui ( -- )
+    <box> drag-timer set-global
+    f hand-gadget set-global
+    f hand-clicked set-global
+    f hand-world set-global
+    f world set-global
    <dlist> \ graft-queue set-global
    <dlist> \ layout-queue set-global
    <dlist> \ gesture-queue set-global
    V{ } clone windows set-global ;

-: restore-gadget-later ( gadget -- )
-    dup graft-state>> {
-        { { f f } [ ] }
-        { { f t } [ ] }
-        { { t t } [ { f f } >>graft-state ] }
-        { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
-    } case graft-later ;
-
-: restore-gadget ( gadget -- )
-    dup restore-gadget-later
-    children>> [ restore-gadget ] each ;
-
-: restore-world ( world -- )
-    {
-        [ reset-world ]
-        [ f >>text-handle f >>images drop ]
-        [ restore-gadget ]
-    } cleave ;
-
 : update-hand ( world -- )
    dup hand-world get-global eq?
    [ hand-loc get-global swap move-hand ] [ drop ] if ;
@ -188,16 +167,6 @@ PRIVATE>
 : start-ui ( quot -- )
    call( -- ) notify-ui-thread start-ui-thread ;

-: restore-windows ( -- )
-    [
-        windows get [ values ] [ delete-all ] bi
-        [ restore-world ] each
-        forget-rollover
-    ] (with-ui) ;
-
-: restore-windows? ( -- ? )
-    windows get empty? not ;
-
 : ?attributes ( gadget title/attributes -- attributes )
    dup string? [ world-attributes new swap >>title ] [ clone ] if
    swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
--- a/basis/unix/ffi/ffi.factor
+++ b/basis/unix/ffi/ffi.factor
@ -151,7 +151,6 @@ FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
 FUNCTION: int symlink ( c-string path1, c-string path2 ) ;
 FUNCTION: int link ( c-string path1, c-string path2 ) ;
-FUNCTION: int system ( c-string command ) ;
 FUNCTION: int unlink ( c-string path ) ;
 FUNCTION: int utimes ( c-string path, timeval[2] times ) ;
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
--- a/basis/vocabs/refresh/monitor/monitor.factor
+++ b/basis/vocabs/refresh/monitor/monitor.factor
@ -1,59 +1,58 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs command-line concurrency.messaging
-continuations init io.backend io.files io.monitors io.pathnames
-kernel namespaces sequences sets splitting threads
-tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
-IN: vocabs.refresh.monitor
-
-TR: convert-separators "/\\" ".." ;
-
-: vocab-dir>vocab-name ( path -- vocab )
-    trim-head-separators
-    trim-tail-separators
-    convert-separators ;
-
-: path>vocab-name ( path -- vocab )
-    dup ".factor" tail? [ parent-directory ] when ;
-
-: chop-vocab-root ( path -- path' )
-    "resource:" prepend-path normalize-path
-    dup vocab-roots get
-    [ normalize-path ] map
-    [ head? ] with find nip
-    ?head drop ;
-
-: path>vocab ( path -- vocab )
-    chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
-
-: monitor-loop ( -- )
-    #! On OS X, monitors give us the full path, so we chop it
-    #! off if its there.
-    receive path>> path>vocab changed-vocab
-    reset-cache
-    monitor-loop ;
-
-: add-monitor-for-path ( path -- )
-    dup exists? [ t my-mailbox (monitor) ] when drop ;
-
-: monitor-thread ( -- )
-    [
-        [
-            vocab-roots get [ add-monitor-for-path ] each
-
-            H{ } clone changed-vocabs set-global
-            vocabs [ changed-vocab ] each
-
-            monitor-loop
-        ] with-monitors
-    ] ignore-errors ;
-
-: start-monitor-thread ( -- )
-    #! Silently ignore errors during monitor creation since
-    #! monitors are not supported on all platforms.
-    [ monitor-thread ] "Vocabulary monitor" spawn drop ;
-
-[
-    "-no-monitors" (command-line) member?
-    [ start-monitor-thread ] unless
-] "vocabs.refresh.monitor" add-startup-hook
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs command-line concurrency.messaging
+continuations init io.backend io.files io.monitors io.pathnames
+kernel namespaces sequences sets splitting threads fry
+tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
+IN: vocabs.refresh.monitor
+
+TR: convert-separators "/\\" ".." ;
+
+: vocab-dir>vocab-name ( path -- vocab )
+    trim-head-separators
+    trim-tail-separators
+    convert-separators ;
+
+: path>vocab-name ( path -- vocab )
+    dup ".factor" tail? [ parent-directory ] when ;
+
+: chop-vocab-root ( path -- path' )
+    "resource:" prepend-path normalize-path
+    dup vocab-roots get
+    [ normalize-path ] map
+    [ head? ] with find nip
+    ?head drop ;
+
+: path>vocab ( path -- vocab )
+    chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
+
+: monitor-loop ( monitor -- )
+    #! On OS X, monitors give us the full path, so we chop it
+    #! off if its there.
+    [ next-change path>> path>vocab changed-vocab reset-cache ]
+    [ monitor-loop ]
+    bi ;
+
+: (start-vocab-monitor) ( vocab-root -- )
+    dup exists?
+    [ [ t <monitor> monitor-loop ] with-monitors ] [ drop ] if ;
+
+: start-vocab-monitor ( vocab-root -- )
+    [ '[ [ _ (start-vocab-monitor) ] ignore-errors ] ]
+    [ "Root monitor: " prepend ]
+    bi spawn drop ;
+
+: init-vocab-monitor ( -- )
+    H{ } clone changed-vocabs set-global
+    vocabs [ changed-vocab ] each ;
+
+[
+    "-no-monitors" (command-line) member? [
+        [ drop ] add-vocab-root-hook set-global
+        f changed-vocabs set-global
+    ] [
+        init-vocab-monitor
+        vocab-roots get [ start-vocab-monitor ] each
+        [ start-vocab-monitor ] add-vocab-root-hook set-global
+    ] if
+] "vocabs.refresh.monitor" add-startup-hook
--- a/basis/x11/clipboard/clipboard.factor
+++ b/basis/x11/clipboard/clipboard.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types alien.strings classes.struct
 io.encodings.utf8 kernel namespaces sequences
@ -10,8 +10,10 @@ IN: x11.clipboard
 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.

 : XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
-
 : XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
+: XA_TARGETS ( -- atom ) "TARGETS" x-atom ;
+: XA_TIMESTAMP ( -- atom ) "TIMESTAMP" x-atom ;
+: XA_TEXT ( -- atom ) "TEXT" x-atom ;

 TUPLE: x-clipboard atom contents ;

@ -43,16 +45,14 @@ TUPLE: x-clipboard atom contents ;

 : set-targets-prop ( evt -- )
    [ dpy get ] dip [ requestor>> ] [ property>> ] bi
-    "TARGETS" x-atom 32 PropModeReplace
-    {
-        "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
-    } [ x-atom ] int-array{ } map-as
+    XA_TARGETS 32 PropModeReplace
+    XA_UTF8_STRING XA_STRING XA_TARGETS XA_TIMESTAMP int-array{ } 4sequence
    4 XChangeProperty drop ;

 : set-timestamp-prop ( evt -- )
    [ dpy get ] dip
    [ requestor>> ]
-    [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
+    [ property>> XA_TIMESTAMP 32 PropModeReplace ]
    [ time>> <int> ] tri
    1 XChangeProperty drop ;

--- a/basis/x11/events/events.factor
+++ b/basis/x11/events/events.factor
@ -1,7 +1,8 @@
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.struct combinators kernel
-math.order namespaces x11 x11.xlib ;
+USING: accessors arrays classes.struct combinators
+combinators.short-circuit kernel math.order namespaces
+x11 x11.xlib ;
 IN: x11.events

 GENERIC: expose-event ( event window -- )
@ -75,7 +76,11 @@ GENERIC: client-event ( event window -- )
 : event-dim ( event -- dim )
    [ width>> ] [ height>> ] bi 2array ;

+: XA_WM_PROTOCOLS ( -- atom ) "WM_PROTOCOLS" x-atom ;
+: XA_WM_DELETE_WINDOW ( -- atom ) "WM_DELETE_WINDOW" x-atom ;
+
 : close-box? ( event -- ? )
-    [ message_type>> "WM_PROTOCOLS" x-atom = ]
-    [ data0>> "WM_DELETE_WINDOW" x-atom = ]
-    bi and ;
+    {
+        [ message_type>> XA_WM_PROTOCOLS = ]
+        [ data0>> XA_WM_DELETE_WINDOW = ]
+    } 1&& ;
--- a/basis/x11/windows/platforms.txt
+++ b/basis/x11/windows/platforms.txt
@ -1 +0,0 @@
-unix
--- a/basis/x11/windows/windows.factor
+++ b/basis/x11/windows/windows.factor
@ -1,8 +1,9 @@
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math math.bitwise math.vectors
-namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct literals ;
+namespaces sequences arrays fry classes.struct literals
+x11 x11.xlib x11.constants x11.events
+x11.glx ;
 IN: x11.windows

 CONSTANT: create-window-mask
@ -78,7 +79,7 @@ CONSTANT: event-mask
    dpy get swap XDestroyWindow drop ;

 : set-closable ( win -- )
-    dpy get swap "WM_DELETE_WINDOW" x-atom <Atom> 1
+    dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
    XSetWMProtocols drop ;

 : map-window ( win -- ) dpy get swap XMapWindow drop ;
--- a/basis/xmode/catalog/catalog.factor
+++ b/basis/xmode/catalog/catalog.factor
@ -1,7 +1,8 @@
 USING: xmode.loader xmode.utilities xmode.rules namespaces
 strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors xml.data
-xml.traversal xml.syntax ;
+words globs combinators io.encodings.utf8 io.pathnames sorting
+accessors regexp unicode.case xml.data xml.traversal
+xml.syntax ;
 IN: xmode.catalog

 TUPLE: mode file file-name-glob first-line-glob ;
@ -15,6 +16,8 @@ TAG: MODE parse-mode-tag
            { "FILE_NAME_GLOB" f file-name-glob<< }
            { "FIRST_LINE_GLOB" f first-line-glob<< }
        } init-from-tag
+        [ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
+        [ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
    ] dip
    rot set-at ;

@ -106,14 +109,18 @@ ERROR: mutually-recursive-rulesets ruleset ;
 : reset-modes ( -- )
    \ (load-mode) reset-memoized ;

-: ?glob-matches ( string glob/f -- ? )
-    dup [ glob-matches? ] [ 2drop f ] if ;
+: ?matches ( string glob/f -- ? )
+    [ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;

 : suitable-mode? ( file-name first-line mode -- ? )
-    [ nip ] 2keep first-line-glob>> ?glob-matches
-    [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
+    [ nip ] 2keep first-line-glob>> ?matches
+    [ 2drop t ] [ file-name-glob>> ?matches ] if ;

-: find-mode ( file-name first-line -- mode )
+: ?find-mode ( file-name first-line -- mode/f )
+    [ file-name ] dip
    modes
    [ nip [ 2dup ] dip suitable-mode? ] assoc-find
-    2drop [ 2drop ] dip [ "text" ] unless* ;
+    2drop [ 2drop ] dip ;
+
+: find-mode ( file-name first-line -- mode )
+    ?find-mode "text" or ; inline
--- a/build-support/factor.cmd
+++ b/build-support/factor.cmd
@ -0,0 +1,87 @@
+@echo off
+setlocal
+
+if "%1"=="/?" (
+    goto usage
+) else if "%1"=="" (
+    set _bootimage_version=latest
+) else if "%1"=="latest" (
+    set _bootimage_version=latest
+) else if "%1"=="clean" (
+    set _bootimage_version=clean
+) else goto usage
+
+if not exist Nmakefile goto wrongdir
+
+call cl 2>&1 | find "x86" >nul
+if not errorlevel 1 (
+    echo x86-32 cl.exe detected.
+    set _target=x86-32
+    set _bootimage=boot.winnt-x86.32.image
+) else (
+    call cl 2>&1 | find "x64" >nul
+    if not errorlevel 1 (
+        echo x86-64 cl.exe detected.
+        set _target=x86-64
+        set _bootimage=boot.winnt-x86.64.image
+    ) else goto nocl
+)
+
+if %_bootimage_version%==clean (
+    set _git_branch=clean-winnt-%_target%
+    set _bootimage_path=clean/winnt-%_target%
+) else (
+    set _git_branch=master
+    set _bootimage_path=latest
+)
+
+echo Updating working copy from %_git_branch%...
+call git pull http://factorcode.org/git/factor.git %_git_branch%
+if errorlevel 1 goto fail
+
+echo Building vm...
+nmake /nologo /f Nmakefile clean
+if errorlevel 1 goto fail
+nmake /nologo /f Nmakefile %_target%
+if errorlevel 1 goto fail
+
+echo Fetching %_bootimage_version% boot image...
+cscript /nologo build-support\http-get.vbs http://factorcode.org/images/%_bootimage_path%/%_bootimage% %_bootimage%
+if errorlevel 1 goto fail
+
+echo Bootstrapping...
+.\factor.com -i=%_bootimage%
+if errorlevel 1 goto fail
+
+echo Copying fresh factor.image to factor.image.fresh.
+copy factor.image factor.image.fresh
+if errorlevel 1 goto fail
+
+echo Build complete.
+goto :EOF
+
+:fail
+echo Build failed.
+goto :EOF
+
+:wrongdir
+echo build-support\factor.cmd must be run from the root of the Factor source tree.
+goto :EOF
+
+:nocl
+echo Unable to detect cl.exe target platform.
+echo Make sure you're running within the Visual Studio or Windows SDK environment.
+goto :EOF
+
+:usage
+echo Usage: build-support\factor.cmd [latest/clean]
+echo     Updates the working copy, cleans and builds the vm using nmake,
+echo     fetches a boot image, and bootstraps factor.
+echo     If latest is specified, then the working copy is updated to the
+echo     upstream "master" branch and the boot image corresponding to the
+echo     most recent factor build is downloaded. This is the default.
+echo     If clean is specified, then the working copy is updated to the
+echo     upstream "clean-winnt-*" branch corresponding to the current
+echo     platform and the corresponding boot image is downloaded.
+goto :EOF
+
--- a/build-support/http-get.vbs
+++ b/build-support/http-get.vbs
@ -0,0 +1,41 @@
+on error resume next
+
+if WScript.Arguments.Count < 2 then
+    WScript.Echo "usage: http-get.vbs source-url dest-file"
+    WScript.Quit 1
+else
+    source_url = WScript.Arguments.Item(0)
+    dest_filename = WScript.Arguments.Item(1)
+
+    dim http, source_data
+    set http = CreateObject("WinHttp.WinHttpRequest.5.1")
+
+    Err.Clear
+    http.Open "GET", source_url, false
+    http.Send
+
+    if Err.Number = 0 then
+        if http.Status = 200 then
+            dim dest_stream
+            set dest_stream = CreateObject("ADODB.Stream")
+
+            Err.Clear
+            dest_stream.Type = 1 ' adTypeBinary
+            dest_stream.Open
+            dest_stream.Write http.ResponseBody
+            dest_stream.SaveToFile dest_filename, 2 ' adSaveCreateOverWrite
+            if Err.Number <> 0 then
+                WScript.Echo "Error " + CStr(Err.Number) + " when writing " + dest_filename + ":"
+                WScript.Echo Err.Description
+                WScript.Quit 1
+            end if
+        else
+            WScript.Echo CStr(http.Status) + " " + http.StatusText + " when fetching " + source_url
+            WScript.Quit 1
+        end if
+    else
+        WScript.Echo "Error " + CStr(Err.Number) + " when fetching " + source_url + ":"
+        WScript.Echo Err.Description
+        WScript.Quit 1
+    end if
+end if
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@ -65,9 +65,9 @@ ARTICLE: "apply-combinators" "Apply combinators"
 "All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;

 ARTICLE: "dip-keep-combinators" "Preserving combinators"
-"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:"
+"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values:"
 { $subsections dip 2dip 3dip 4dip }
-"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:"
+"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack:"
 { $subsections keep 2keep 3keep } ;

 ARTICLE: "curried-dataflow" "Curried dataflow combinators"
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@ -15,7 +15,7 @@ ABOUT: "sets"

 ARTICLE: "set-operations" "Operations on sets"
 "To test if an object is a member of a set:"
-{ $subsections member? }
+{ $subsections in? }
 "All sets can be represented as a sequence, without duplicates, of their members:"
 { $subsections members }
 "Sets can have members added or removed destructively:"
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@ -8,15 +8,22 @@ IN: vocabs.loader

 SYMBOL: vocab-roots

-V{
-    "resource:core"
-    "resource:basis"
-    "resource:extra"
-    "resource:work"
-} clone vocab-roots set-global
+SYMBOL: add-vocab-root-hook
+
+[
+    V{
+        "resource:core"
+        "resource:basis"
+        "resource:extra"
+        "resource:work"
+    } clone vocab-roots set-global
+
+    [ drop ] add-vocab-root-hook set-global
+] "vocabs.loader" add-startup-hook

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

 SYMBOL: root-cache

--- a/extra/benchmark/binary-trees/binary-trees.factor
+++ b/extra/benchmark/binary-trees/binary-trees.factor
@ -1,5 +1,7 @@
-USING: kernel math accessors prettyprint io locals sequences
-math.ranges math.order ;
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math math.ranges math.order math.parser
+io locals sequences ;
 IN: benchmark.binary-trees

 TUPLE: tree-node item left right ;
@ -27,8 +29,8 @@ CONSTANT: min-depth 4

 : stretch-tree ( max-depth -- )
    1 + 0 over bottom-up-tree item-check
-    [ "stretch tree of depth " write pprint ]
-    [ "\t check: " write . ] bi* ; inline
+    [ "stretch tree of depth " write number>string write ]
+    [ "\t check: " write number>string print ] bi* ; inline

 :: long-lived-tree ( max-depth -- )
    0 max-depth bottom-up-tree
@ -40,13 +42,13 @@ CONSTANT: min-depth 4
                [ depth bottom-up-tree item-check + ] bi@
            ] reduce
        ]
-        [ 2 * ] bi
-        pprint "\t trees of depth " write depth pprint
-        "\t check: " write .
+        [ 2 * number>string write ] bi
+        "\t trees of depth " write depth number>string write
+        "\t check: " write number>string print
    ] each

-    "long lived tree of depth " write max-depth pprint
-    "\t check: " write item-check . ; inline
+    "long lived tree of depth " write max-depth number>string write
+    "\t check: " write item-check number>string print ; inline

 : binary-trees ( n -- )
    min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline
--- a/extra/benchmark/binary-trees/deploy.factor
+++ b/extra/benchmark/binary-trees/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.binary-trees" }
+}
--- a/extra/benchmark/fasta/deploy.factor
+++ b/extra/benchmark/fasta/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "benchmark.fasta" }
+    { deploy-ui? f }
+    { deploy-c-types? f }
+    { deploy-console? t }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}
--- a/extra/benchmark/knucleotide/deploy.factor
+++ b/extra/benchmark/knucleotide/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.knucleotide" }
+}
--- a/extra/benchmark/knucleotide/knucleotide-input.txt
+++ b/extra/benchmark/knucleotide/knucleotide-input.txt
--- a/extra/benchmark/knucleotide/knucleotide.factor
+++ b/extra/benchmark/knucleotide/knucleotide.factor
@ -1,9 +1,13 @@
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: ascii kernel io io.files splitting strings
 io.encodings.ascii hashtables sequences assocs math
-math.statistics namespaces prettyprint math.parser combinators
-arrays sorting formatting grouping fry ;
+math.statistics namespaces math.parser combinators arrays
+sorting formatting grouping fry ;
 IN: benchmark.knucleotide

+CONSTANT: knucleotide-in "vocab:benchmark/knucleotide/knucleotide-input.txt"
+
 : discard-lines ( -- )
    readln
    [ ">THREE" head? [ discard-lines ] unless ] when* ;
@ -34,7 +38,7 @@ IN: benchmark.knucleotide
    tri ;

 : knucleotide ( -- )
-    "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
+    knucleotide-in
    ascii [ read-input ] with-file-reader
    process-input ;

--- a/extra/benchmark/nbody-simd/deploy.factor
+++ b/extra/benchmark/nbody-simd/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.nbody-simd" }
+}
--- a/extra/benchmark/nbody-simd/nbody-simd.factor
+++ b/extra/benchmark/nbody-simd/nbody-simd.factor
@ -1,9 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types fry kernel locals math
 math.constants math.functions math.vectors math.vectors.simd
-math.vectors.simd.cords prettyprint combinators.smart sequences
-hints classes.struct specialized-arrays ;
+math.vectors.simd.cords math.parser combinators.smart sequences
+hints classes.struct specialized-arrays io ;
 IN: benchmark.nbody-simd

 : solar-mass ( -- x ) 4 pi sq * ; inline
@ -94,7 +94,9 @@ SPECIALIZED-ARRAY: body
 : nbody ( n -- )
    >fixnum
    <nbody-system>
-    [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+    [ energy number>string print ]
+    [ '[ _ 0.01 advance ] times ]
+    [ energy number>string print ] tri ;

 : nbody-main ( -- ) 1000000 nbody ;

--- a/extra/benchmark/regex-dna/deploy.factor
+++ b/extra/benchmark/regex-dna/deploy.factor
@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-word-defs? f }
-    { deploy-word-props? f }
-    { deploy-math? f }
    { deploy-ui? f }
-    { deploy-c-types? f }
-    { "stop-after-last-window?" t }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 3 }
    { deploy-reflection 1 }
-    { deploy-name "benchmark.regex-dna" }
-    { deploy-io 2 }
-    { deploy-threads? f }
    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.regex-dna" }
 }
--- a/extra/benchmark/regex-dna/regex-dna.factor
+++ b/extra/benchmark/regex-dna/regex-dna.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors io io.encodings.ascii io.files kernel sequences
-assocs math.parser namespaces regexp ;
+assocs math.parser namespaces regexp benchmark.knucleotide ;
 IN: benchmark.regex-dna

 ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
@ -55,6 +55,6 @@ SYMBOL: clen
    length number>string print ;

 : regex-dna-main ( -- )
-    "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
+    knucleotide-in regex-dna ;

 MAIN: regex-dna-main
--- a/extra/benchmark/reverse-complement/deploy.factor
+++ b/extra/benchmark/reverse-complement/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.reverse-complement" }
+}
--- a/extra/benchmark/spectral-norm-simd/authors.txt
+++ b/extra/benchmark/spectral-norm-simd/authors.txt
@ -0,0 +1 @@
+Marc Fauconneau
--- a/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor
+++ b/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor
@ -0,0 +1,68 @@
+! Copyright (C) 2010 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types specialized-arrays kernel math
+math.functions math.vectors sequences sequences.private
+prettyprint words typed locals math.vectors.simd
+math.vectors.simd.cords ;
+SPECIALIZED-ARRAYS: double double-4 ;
+IN: benchmark.spectral-norm-simd
+
+:: inner-loop ( u n quot -- seq )
+    n 4 /i iota [| i |
+        n iota [| j | u i j quot call ] [ v+ ] map-reduce
+    ] double-4-array{ } map-as ; inline
+
+: eval-A ( i j -- n )
+    [ >float ] bi@
+    [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+    + 1 + ; inline
+
+: vrecip ( u -- v ) double-4{ 1.0 1.0 1.0 1.0 } swap v/ ; inline
+
+:: eval4-A ( i j -- n )
+    i 4 * 0 + j eval-A
+    i 4 * 1 + j eval-A
+    i 4 * 2 + j eval-A
+    i 4 * 3 + j eval-A
+    double-4-boa vrecip ; inline
+
+: (eval-A-times-u) ( u i j -- x )
+    [ swap nth-unsafe ] [ eval4-A ] bi-curry bi* n*v ; inline
+
+: eval-A-times-u ( n u -- seq )
+    [ (eval-A-times-u) ] inner-loop ; inline
+    
+:: eval4-A' ( i j -- n )
+    j i 4 * 0 + eval-A
+    j i 4 * 1 + eval-A
+    j i 4 * 2 + eval-A
+    j i 4 * 3 + eval-A
+    double-4-boa vrecip ; inline
+
+: (eval-At-times-u) ( u i j -- x )
+    [ swap nth-unsafe ] [ eval4-A' ] bi-curry bi* n*v ; inline
+
+: eval-At-times-u ( u n -- seq )
+    [ double-array-cast ] dip [ (eval-At-times-u) ] inner-loop ; inline
+
+: eval-AtA-times-u ( u n -- seq )
+    [ double-array-cast ] dip [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
+
+: ones ( n -- seq )
+    4 /i [ double-4{ 1.0 1.0 1.0 1.0 } ] double-4-array{ } replicate-as ; inline
+
+:: u/v ( n -- u v )
+    n ones dup
+    10 [
+        drop
+        n eval-AtA-times-u
+        [ n eval-AtA-times-u ] keep
+    ] times ; inline
+
+TYPED: spectral-norm ( n: fixnum -- norm )
+    u/v [ double-array-cast ] bi@ [ v. ] [ norm-sq ] bi /f sqrt ;
+
+: spectral-norm-main ( -- )
+    2000 spectral-norm . ;
+
+MAIN: spectral-norm-main
--- a/extra/benchmark/spectral-norm/deploy.factor
+++ b/extra/benchmark/spectral-norm/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-word-defs? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.spectral-norm" }
+}
--- a/extra/benchmark/spectral-norm/spectral-norm.factor
+++ b/extra/benchmark/spectral-norm/spectral-norm.factor
@ -1,8 +1,11 @@
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+!
 ! Factor port of
 ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: alien.c-types specialized-arrays kernel math
-math.functions math.vectors sequences sequences.private
-prettyprint words typed locals ;
+USING: alien.c-types io kernel math math.functions math.parser
+math.vectors sequences sequences.private specialized-arrays
+typed locals ;
 SPECIALIZED-ARRAY: double
 IN: benchmark.spectral-norm

@ -47,6 +50,6 @@ TYPED: spectral-norm ( n: fixnum -- norm )
    u/v [ v. ] [ norm-sq ] bi /f sqrt ;

 : spectral-norm-main ( -- )
-    2000 spectral-norm . ;
+    2000 spectral-norm number>string print ;

 MAIN: spectral-norm-main
--- a/extra/bson/bson-tests.factor
+++ b/extra/bson/bson-tests.factor
@ -1,10 +1,10 @@
-USING: bson.reader bson.writer byte-arrays io.encodings.binary
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
 io.streams.byte-array tools.test literals calendar kernel math ;

 IN: bson.tests

 : turnaround ( value -- value )
-    assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+    assoc>bv >byte-array binary [ H{ } clone stream>assoc ] with-byte-reader ;

 [ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test

@ -17,6 +17,9 @@ IN: bson.tests
 [ H{ { "a quotation" [ 1 2 + ] } } ]
 [ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test

+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
+
 [ H{ { "a date" T{ timestamp { year 2009 }
                   { month 7 }
                   { day 11 }
@ -34,10 +37,12 @@ IN: bson.tests
 ] unit-test
                   
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "ref" T{ dbref f "a" "b" "c" } }
     { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
     { "quot" [ 1 2 + ] } }
 ]     
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "ref" T{ dbref f "a" "b" "c" } }
     { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
     { "quot" [ 1 2 + ] } } turnaround ] unit-test
     
--- a/extra/bson/bson.factor
+++ b/extra/bson/bson.factor
@ -1,3 +1,5 @@
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader ;

 IN: bson
--- a/extra/bson/constants/constants.factor
+++ b/extra/bson/constants/constants.factor
@ -1,5 +1,8 @@
-USING: accessors constructors kernel strings uuid ;
-
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators
+combinators.short-circuit constructors kernel linked-assocs
+math math.bitwise random strings uuid ;
 IN: bson.constants

 : <objid> ( -- objid )
@ -7,9 +10,33 @@ IN: bson.constants

 TUPLE: oid { a initial: 0 } { b initial: 0 } ;

-TUPLE: objref ns objid ;
+: <oid> ( -- oid )
+    oid new
+    now timestamp>micros >>a
+    8 random-bits 16 shift HEX: FF0000 mask
+    16 random-bits HEX: FFFF mask
+    bitor >>b ;

-CONSTRUCTOR: objref ( ns objid -- objref ) ;
+TUPLE: dbref ref id db ;
+
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
+
+: dbref>assoc ( dbref -- assoc )
+    [ <linked-hash> ] dip over
+    {
+        [ [ ref>> "$ref" ] [ set-at ] bi* ]
+        [ [ id>> "$id" ] [ set-at ] bi* ]
+        [ over db>> [
+                [ db>> "$db" ] [ set-at ] bi*
+            ] [ 2drop ] if ]
+    } 2cleave ; inline
+
+: assoc>dbref ( assoc -- dbref )
+    [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
+    dbref boa ; inline
+
+: dbref-assoc? ( assoc -- ? )
+    { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline

 TUPLE: mdbregexp { regexp string } { options string } ;

--- a/extra/bson/reader/reader.factor
+++ b/extra/bson/reader/reader.factor
@ -1,185 +1,161 @@
-USING: accessors assocs bson.constants calendar fry io io.binary
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize locals ;
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants calendar combinators
+combinators.short-circuit io io.binary kernel math locals
+namespaces sequences serialize strings vectors byte-arrays ;

-FROM: kernel.private => declare ;
-FROM: io.encodings.private => (read-until) ;
+FROM: io.encodings.binary => binary ;
+FROM: io.streams.byte-array => with-byte-reader ;
+FROM: typed => TYPED: ;

 IN: bson.reader

 <PRIVATE

 TUPLE: element { type integer } name ;
+
 TUPLE: state
-    { size initial: -1 } exemplar
-    result scope element ;
+    { 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 ] keep
-    clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
-    V{ } clone [ T_Object "" element boa swap push ] keep >>element ; 
+    {
+        [ clone >>exemplar ]
+        [ clone >>result ]
+        [ V{ } clone [ push ] keep >>scope ]
+    } cleave
+    (prepare-elements) >>elements ;

-PREDICATE: bson-not-eoo < integer T_EOO > ;
-PREDICATE: bson-eoo     < integer T_EOO = ;
-
-PREDICATE: bson-string  < integer T_String = ;
-PREDICATE: bson-object  < integer T_Object = ;
-PREDICATE: bson-oid     < integer T_OID = ;
-PREDICATE: bson-array   < integer T_Array = ;
-PREDICATE: bson-integer < integer T_Integer = ;
-PREDICATE: bson-double  < integer T_Double = ;
-PREDICATE: bson-date    < integer T_Date = ;
-PREDICATE: bson-binary  < integer T_Binary = ;
-PREDICATE: bson-boolean < integer T_Boolean = ;
-PREDICATE: bson-regexp  < integer T_Regexp = ;
-PREDICATE: bson-null    < integer T_NULL = ;
-PREDICATE: bson-ref     < integer T_DBRef = ;
-PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
-PREDICATE: bson-binary-function < integer T_Binary_Function = ;
-PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
-PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
-
-GENERIC: element-read ( type -- cont? )
-GENERIC: element-data-read ( type -- object )
-GENERIC: element-binary-read ( length type -- object )
-
-: get-state ( -- state )
+TYPED: get-state ( -- state: state )
    state get ; inline

-: read-int32 ( -- int32 )
+TYPED: read-int32 ( -- int32: integer )
    4 read signed-le> ; inline

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

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

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

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

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

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

-: read-element-type ( -- type )
-    read-byte ; inline
+TYPED: push-element ( type: integer name: string state: state -- )
+    [ element boa ] dip elements>> push ; inline

-: push-element ( type name -- )
-    element boa get-state element>> push ; inline
+TYPED: pop-element ( state: state -- element: element )
+    elements>> pop ; inline

-: pop-element ( -- element )
-    get-state element>> pop ; inline
+TYPED: peek-scope ( state: state -- ht )
+    scope>> last ; inline

-: peek-scope ( -- ht )
-    get-state scope>> last ; inline
+: bson-object-data-read ( -- object )
+    read-int32 drop get-state 
+    [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
+
+: bson-binary-read ( -- binary )
+   read-int32 read-byte 
+   {
+        { T_Binary_Bytes [ read ] }
+        { T_Binary_Custom [ read bytes>object ] }
+        { T_Binary_Function [ read ] }
+        [ drop read >string ]
+   } case ; inline
+
+TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
+   mdbregexp new
+   read-cstring >>regexp read-cstring >>options ; inline
+
+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 )
+    {
+        { T_Array [ values ] }
+        { T_Object [ check-object ] }
+    } case ; inline
+
+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: (element-read) ( type: integer -- cont?: boolean )
+    dup T_EOO > 
+    [ bson-not-eoo-element-read ]
+    [ drop bson-eoo-element-read ] if ; inline

 : read-elements ( -- )
-    read-element-type
-    element-read 
+    read-byte (element-read)
    [ read-elements ] when ; inline recursive

-GENERIC: fix-result ( assoc type -- result )
-
-M: bson-object fix-result ( assoc type -- result )
-    drop ;
-
-M: bson-array fix-result ( assoc type -- result )
-    drop values ;
-
-GENERIC: end-element ( type -- )
-
-M: bson-object end-element ( type -- )
-    drop ;
-
-M: bson-array end-element ( type -- )
-    drop ;
-
-M: object end-element ( type -- )
-    pop-element 2drop ;
-
-M:: bson-eoo element-read ( type -- cont? )
-    pop-element :> element
-    get-state scope>>
-    [ pop element type>> fix-result ] [ empty? ] bi
-    [ [ get-state ] dip >>result drop f ]
-    [ element name>> peek-scope set-at t ] if ;
-
-M:: bson-not-eoo element-read ( type -- cont? )
-    peek-scope :> scope
-    type read-cstring [ push-element ] 2keep
-    [ [ element-data-read ] [ end-element ] bi ]
-    [ scope set-at t ] bi* ;
-
-: [scope-changer] ( state -- state quot )
-    dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
-
-: (object-data-read) ( type -- object )
-    drop
-    read-int32 drop
-    get-state
-    [scope-changer] change-scope
-    scope>> last ; inline
-    
-M: bson-object element-data-read ( type -- object )
-    (object-data-read) ;
-
-M: bson-string element-data-read ( type -- object )
-    drop
-    read-int32 read-sized-string ;
-
-M: bson-array element-data-read ( type -- object )
-    (object-data-read) ;
-    
-M: bson-integer element-data-read ( type -- object )
-    drop
-    read-int32 ;
-
-M: bson-double element-data-read ( type -- double )
-    drop
-    read-double ;
-
-M: bson-boolean element-data-read ( type -- boolean )
-   drop
-   read-byte 1 = ;
-
-M: bson-date element-data-read ( type -- timestamp )
-   drop
-   read-longlong millis>timestamp ;
-
-M: bson-binary element-data-read ( type -- binary )
-   drop
-   read-int32 read-byte element-binary-read ;
-
-M: bson-regexp element-data-read ( type -- mdbregexp )
-   drop mdbregexp new
-   read-cstring >>regexp read-cstring >>options ;
- 
-M: bson-null element-data-read ( type -- bf  )
-    drop f ;
-
-M: bson-oid element-data-read ( type -- oid )
-    drop
-    read-longlong
-    read-int32 oid boa ;
-
-M: bson-binary-bytes element-binary-read ( size type -- bytes )
-    drop read ;
-
-M: bson-binary-custom element-binary-read ( size type -- quot )
-    drop read bytes>object ;
-
 PRIVATE>

-USE: tools.continuations
-
 : stream>assoc ( exemplar -- assoc )
-    <state> dup state
-    [ read-int32 >>size read-elements ] with-variable 
-    result>> ; 
+    <state> read-int32 >>size
+    [ state [ read-elements ] with-variable ]
+    [ result>> ] bi ;
--- a/extra/bson/summary.txt
+++ b/extra/bson/summary.txt
@ -1 +1 @@
-BSON reader and writer
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
--- a/extra/bson/writer/writer.factor
+++ b/extra/bson/writer/writer.factor
@ -1,155 +1,160 @@
-! Copyright (C) 2008 Sascha Matzke.
+! Copyright (C) 2010 Sascha Matzke.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bson.constants byte-arrays byte-vectors
-calendar fry io io.binary io.encodings io.encodings.binary
-io.encodings.utf8 io.streams.byte-array kernel math math.parser
-namespaces quotations sequences sequences.private serialize strings
-words combinators.short-circuit literals ;
-
-FROM: io.encodings.utf8.private => char>utf8 ;
-FROM: kernel.private => declare ;
-
+USING: accessors arrays assocs bson.constants byte-arrays
+calendar combinators.short-circuit fry hashtables io io.binary
+kernel linked-assocs literals math math.parser namespaces byte-vectors
+quotations sequences serialize strings vectors dlists alien.accessors ;
+FROM: words => word? word ;
+FROM: typed => TYPED: ;
+FROM: combinators => cond ;
 IN: bson.writer

 <PRIVATE

-SYMBOL: shared-buffer 
+CONSTANT: INT32-SIZE { 0 1 2 3 }
+CONSTANT: INT64-SIZE { 0 1 2 3 4 5 6 7 }

-CONSTANT: CHAR-SIZE  1
-CONSTANT: INT32-SIZE 4
-CONSTANT: INT64-SIZE 8
-
-: (buffer) ( -- buffer )
-    shared-buffer get
-    [ BV{ } clone [ shared-buffer set ] keep ] unless*
-    { byte-vector } declare ; inline 
-    
 PRIVATE>

-: reset-buffer ( buffer -- )
-    0 >>length drop ; inline
+TYPED: get-output ( -- stream: byte-vector )
+    output-stream get ; inline

-: ensure-buffer ( -- )
-    (buffer) drop ; inline
-
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
-    [ (buffer) [ reset-buffer ] keep dup ] dip
-    with-output-stream* ; inline
-
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
-    [ (buffer) [ length ] keep ] dip
+TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
+    [ get-output [ length ] [ ] bi ] dip
    call length swap [ - ] keep ; inline

-: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
+: (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
    [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
-    [ call ] dip (buffer) copy ; inline
+    [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline

-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
-    [ INT32-SIZE >le ] (with-length-prefix) ; inline
+: with-length-prefix ( quot: ( .. -- .. ) -- )
+    [ ] (with-length-prefix) ; inline
    
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
-    [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
+: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
+    [ 4 - ] (with-length-prefix) ; inline
+
+: (>le) ( x n -- )
+    [ nth-byte write1 ] with each ; inline
    
 <PRIVATE

-GENERIC: bson-type? ( obj -- type ) 
-GENERIC: bson-write ( obj -- ) 
+TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline

-M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
-M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
+TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline

-M: string bson-type? ( string -- type ) drop T_String ; 
-M: integer bson-type? ( integer -- type ) drop T_Integer ; 
-M: assoc bson-type? ( assoc -- type ) drop T_Object ;
-M: real bson-type? ( real -- type ) drop T_Double ; 
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+TYPED: write-cstring ( string: string -- )
+    get-output [ length ] [  ] bi copy 0 write1 ; inline

-M: oid bson-type? ( word -- type ) drop T_OID ;
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
-M: word bson-type? ( word -- type ) drop T_Binary ;
-M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
-M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
-
-: write-int32 ( int -- ) INT32-SIZE >le write ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
-: write-longlong ( object -- ) INT64-SIZE >le write ; inline
+: write-longlong ( object -- ) INT64-SIZE (>le) ; inline

 : write-eoo ( -- ) T_EOO write1 ; inline
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline

-M: string bson-write ( obj -- )
-    '[ _ write-cstring ] with-length-prefix-excl ;
+TYPED: write-header ( name: string object type: integer -- object )
+    write1 [ write-cstring ] dip ; inline

-M: f bson-write ( f -- )
-    drop 0 write1 ; 
+DEFER: write-pair

-M: t bson-write ( t -- )
-    drop 1 write1 ;
+TYPED: write-byte-array ( binary: byte-array -- )
+    [ length write-int32 ]
+    [ T_Binary_Bytes write1 write ] bi ; inline

-M: integer bson-write ( num -- )
-    write-int32 ;
-
-M: real bson-write ( num -- )
-    >float write-double ;
-
-M: timestamp bson-write ( timestamp -- )
-    timestamp>millis write-longlong ;
-
-M: byte-array bson-write ( binary -- )
-    [ length write-int32 ] keep
-    T_Binary_Bytes write1
-    write ; 
-
-M: oid bson-write ( oid -- )
-    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-       
-M: mdbregexp bson-write ( regexp -- )
+TYPED: write-mdbregexp ( regexp: mdbregexp -- )
   [ regexp>> write-cstring ]
-   [ options>> write-cstring ] bi ; 
-    
-M: sequence bson-write ( array -- )
-    '[ _ [ [ write-type ] dip number>string
-           write-cstring bson-write ] each-index
-       write-eoo ] with-length-prefix ;
+   [ options>> write-cstring ] bi ; inline

-: write-oid ( assoc -- )
-    [ MDB_OID_FIELD ] dip at
-    [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
-
-: skip-field? ( name -- boolean )
-   { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
-
-M: assoc bson-write ( assoc -- )
-    '[
-        _  [ write-oid ] keep
-        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+TYPED: write-sequence ( array: sequence -- )
+   '[
+        _ [ number>string swap write-pair ] each-index
        write-eoo
-    ] with-length-prefix ;
+    ] with-length-prefix ; inline recursive

-: (serialize-code) ( code -- )
-    object>bytes [ length write-int32 ] keep
-    T_Binary_Custom write1
-    write ;
+TYPED: write-oid ( oid: oid -- )
+    [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline

-M: quotation bson-write ( quotation -- )
-    (serialize-code) ;
-    
-M: word bson-write ( word -- )
-    (serialize-code) ;
+: write-oid-field ( assoc -- )
+    [ MDB_OID_FIELD dup ] dip at
+    [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] 
+    [ drop ] if* ; inline
+
+: skip-field? ( name value -- name value boolean )
+    over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
+
+UNION: hashtables hashtable linked-assoc ;
+
+TYPED: write-assoc ( assoc: hashtables -- )
+    '[ _ [ write-oid-field ] [
+            [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each 
+         ] bi write-eoo
+    ] with-length-prefix ; inline recursive
+
+UNION: code word quotation ;
+
+TYPED: (serialize-code) ( code: code -- )
+  object>bytes
+  [ length write-int32 ]
+  [ T_Binary_Custom write1 write ] bi ; inline
+
+TYPED: write-string ( string: string -- )
+    '[ _ write-cstring ] with-length-prefix-excl ; inline
+
+TYPED: write-boolean ( bool: boolean -- )
+    [ 1 write1 ] [ 0 write1 ] if ; inline
+
+TYPED: write-pair ( name: string obj -- )
+    {
+        {
+            [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
+            [ T_Object write-header write-assoc ]
+        } {
+            [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
+            [ T_Array write-header write-sequence ]
+        } {
+            [ dup byte-array? ]
+            [ T_Binary write-header write-byte-array ]
+        } {
+            [ dup string? ]
+            [ T_String write-header write-string ]
+        } {
+            [ dup oid? ]
+            [ T_OID write-header write-oid ]
+        } {
+            [ dup integer? ]
+            [ T_Integer write-header write-int32 ]
+        } {
+            [ dup boolean? ] 
+            [ T_Boolean write-header write-boolean ]
+        } {
+            [ dup real? ]
+            [ T_Double write-header >float write-double ]
+        } {
+            [ dup timestamp? ]
+            [ T_Date write-header timestamp>millis write-longlong ]
+        } {
+            [ dup mdbregexp? ]
+            [ T_Regexp write-header write-mdbregexp ]
+        } {
+            [ dup quotation? ]
+            [ T_Binary write-header (serialize-code) ]
+        } {
+            [ dup word? ]
+            [ T_Binary write-header (serialize-code) ]
+        } {
+            [ dup dbref? ]
+            [ T_Object write-header dbref>assoc write-assoc ]
+        } {
+            [ dup f = ]
+            [ T_NULL write-header drop ]
+        }
+    } cond ;

 PRIVATE>

-: assoc>bv ( assoc -- byte-vector )
-    [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
+    [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline

-: assoc>stream ( assoc -- )
-    { assoc } declare bson-write ; inline
+TYPED: assoc>stream ( assoc: hashtables -- )
+    write-assoc ; inline

-: mdb-special-value? ( value -- ? )
+TYPED: mdb-special-value? ( value -- ?: boolean )
   { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
-     [ oid? ] [ byte-array? ] } 1|| ; inline
+     [ oid? ] [ byte-array? ] } 1|| ; inline
--- a/extra/cuda/contexts/contexts.factor
+++ b/extra/cuda/contexts/contexts.factor
@ -1,8 +1,12 @@
 ! (c)2010 Joe Groff bsd license
 USING: alien.c-types alien.data continuations cuda cuda.ffi
-cuda.libraries fry kernel namespaces ;
+cuda.libraries alien.destructors fry kernel namespaces ;
 IN: cuda.contexts

+: set-up-cuda-context ( -- )
+    H{ } clone cuda-modules set-global
+    H{ } clone cuda-functions set-global ; inline
+
 : create-context ( device flags -- context )
    swap
    [ CUcontext <c-object> ] 2dip
@ -16,14 +20,15 @@ IN: cuda.contexts

 : destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline

-: (set-up-cuda-context) ( device flags create-quot -- )
-    H{ } clone cuda-modules set-global
-    H{ } clone cuda-functions set
-    call ; inline
+: clean-up-context ( context -- )
+    [ sync-context ] ignore-errors destroy-context ; inline
+
+DESTRUCTOR: destroy-context
+DESTRUCTOR: clean-up-context

 : (with-cuda-context) ( context quot -- )
-    swap '[ [ sync-context ] ignore-errors _ destroy-context ] [ ] cleanup ; inline
+    swap '[ _ clean-up-context ] [ ] cleanup ; inline

 : with-cuda-context ( device flags quot -- )
-    [ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+    [ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline

--- a/extra/cuda/gl/gl.factor
+++ b/extra/cuda/gl/gl.factor
@ -1,5 +1,5 @@
 ! (c)2010 Joe Groff bsd license
-USING: accessors alien.c-types alien.data alien.destructors
+USING: accessors alien alien.c-types alien.data alien.destructors
 alien.enums continuations cuda cuda.contexts cuda.ffi
 cuda.gl.ffi destructors fry gpu.buffers kernel ;
 IN: cuda.gl
@ -10,7 +10,7 @@ IN: cuda.gl
    [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline

 : with-gl-cuda-context ( device flags quot -- )
-    [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline 
+    [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline 

 : gl-buffer>resource ( gl-buffer flags -- resource )
    enum>number
@ -39,3 +39,17 @@ DESTRUCTOR: free-resource

 : with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
    over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
+
+TUPLE: cuda-buffer
+    { buffer buffer }
+    { resource pinned-c-ptr } ;
+
+: <cuda-buffer> ( upload usage kind size initial-data flags -- buffer )
+    [ <buffer> dup ] dip buffer>resource cuda-buffer boa ; inline
+
+M: cuda-buffer dispose
+    [ [ free-resource ] when* f ] change-resource
+    buffer>> dispose ; inline
+
+: with-mapped-cuda-buffer ( ..a cuda-buffer quot: ( ..a device-ptr size -- ..b ) -- ..b )
+    [ resource>> ] dip with-mapped-resource ; inline
--- a/extra/game/input/demos/joysticks/authors.txt
+++ b/extra/game/input/demos/joysticks/authors.txt
--- a/extra/game/input/demos/joysticks/deploy.factor
+++ b/extra/game/input/demos/joysticks/deploy.factor
--- a/extra/game/input/demos/joysticks/joysticks.factor
+++ b/extra/game/input/demos/joysticks/joysticks.factor
@ -3,7 +3,7 @@ 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
 combinators math.parser assocs threads ;
-IN: joystick-demo
+IN: game.input.demos.joysticks

 CONSTANT: SIZE { 151 151 }
 CONSTANT: INDICATOR-SIZE { 4 4 }
--- a/extra/game/input/demos/joysticks/summary.txt
+++ b/extra/game/input/demos/joysticks/summary.txt
--- a/extra/game/input/demos/joysticks/tags.txt
+++ b/extra/game/input/demos/joysticks/tags.txt
--- a/extra/game/input/demos/key-caps/authors.txt
+++ b/extra/game/input/demos/key-caps/authors.txt
--- a/extra/game/input/demos/key-caps/key-caps.factor
+++ b/extra/game/input/demos/key-caps/key-caps.factor
@ -1,8 +1,8 @@
 USING: game.input game.input.scancodes
 kernel ui.gadgets ui.gadgets.buttons sequences accessors
 words arrays assocs math calendar fry alarms ui
-ui.gadgets.borders ui.gestures ;
-IN: key-caps
+ui.gadgets.borders ui.gestures literals ;
+IN: game.input.demos.key-caps

 CONSTANT: key-locations H{
    { key-escape        { {   0   0 } {  10  10 } } }
@ -132,7 +132,7 @@ CONSTANT: key-locations H{
 }

 CONSTANT: KEYBOARD-SIZE { 230 65 }
-: FREQUENCY ( -- f ) 30 recip seconds ;
+CONSTANT: FREQUENCY $[ 1/30 seconds ]

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

--- a/extra/game/input/demos/key-caps/summary.txt
+++ b/extra/game/input/demos/key-caps/summary.txt
--- a/extra/game/input/demos/key-caps/tags.txt
+++ b/extra/game/input/demos/key-caps/tags.txt
--- a/extra/gpu/buffers/buffers-docs.factor
+++ b/extra/gpu/buffers/buffers-docs.factor
@ -149,6 +149,10 @@ HELP: dynamic-upload
 HELP: gpu-data-ptr
 { $class-description "This class is a union of the " { $link c-ptr } " and " { $link buffer-ptr } " classes. It represents a value that can be supplied either from CPU or GPU memory." } ;

+HELP: grow-buffer
+{ $values { "buffer" buffer } { "target-size" integer } }
+{ $description "If the " { $link buffer-size } " of the given " { $link buffer } " is less than " { $snippet "target-size" } ", reallocates the buffer to a size large enough to accommodate " { $snippet "target-size" } " bytes. If the buffer is reallocated, the original contents are lost." } ;
+
 HELP: index-buffer
 { $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to index vertex arrays." } ;

@ -243,6 +247,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
 { $subsections
    allocate-buffer
    allocate-byte-array
+    grow-buffer
    update-buffer
    read-buffer
    copy-buffer
--- a/extra/gpu/buffers/buffers.factor
+++ b/extra/gpu/buffers/buffers.factor
@ -132,6 +132,13 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
    from-buffer-ptr offset>> to-buffer-ptr offset>>
    size glCopyBufferSubData ;

+: (grow-buffer-size) ( target-size old-size -- new-size )
+    [ 2dup > ] [ 2 * ] while nip ; inline
+
+TYPED: grow-buffer ( buffer: buffer target-size: integer -- )
+    over buffer-size 2dup >
+    [ (grow-buffer-size) f allocate-buffer ] [ 3drop ] if ; inline
+
 :: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
    buffer bind-buffer :> target
    target access gl-access glMapBuffer
--- a/extra/key-logger/authors.txt
+++ b/extra/key-logger/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/extra/key-logger/deploy.factor
+++ b/extra/key-logger/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "key-logger" }
+    { deploy-ui? f }
+    { deploy-c-types? f }
+    { deploy-console? f }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}
--- a/extra/key-logger/key-logger.factor
+++ b/extra/key-logger/key-logger.factor
@ -0,0 +1,35 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms bit-arrays calendar game.input io
+io.binary io.encodings.binary io.files kernel literals math
+namespaces system threads ;
+IN: key-logger
+
+CONSTANT: frequency $[ 1/30 seconds ]
+
+CONSTANT: path "resource:key-log.txt"
+
+: update-key-caps-state ( -- )
+    read-keyboard keys>>
+    path binary [
+        [ gmt unix-1970 time- duration>nanoseconds >integer ]
+        [ bit-array>integer ] bi*
+        [ 8 >be write ] bi@ flush
+    ] with-file-appender ;
+
+SYMBOL: key-logger
+
+: start-key-logger ( -- )
+    key-logger get-global [
+        [
+            open-game-input
+            [ update-key-caps-state ] frequency every key-logger set-global
+        ] in-thread
+    ] unless ;
+
+: stop-key-logger ( -- )
+    key-logger get-global [ stop-alarm ] when*
+    f key-logger set-global
+    close-game-input ;
+
+MAIN: start-key-logger
--- a/extra/mason/updates/updates.factor
+++ b/extra/mason/updates/updates.factor
@ -1,4 +1,4 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! 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 ;
@ -20,8 +20,7 @@ IN: mason.updates
    = not ;

 : new-image-available? ( -- ? )
-    boot-image-name need-new-image?
-    [ boot-image-arch download-image t ] [ f ] if ;
+    boot-image-name maybe-download-image ;

 : new-code-available? ( -- ? )
    updates-available?
--- a/extra/mongodb/benchmark/benchmark.factor
+++ b/extra/mongodb/benchmark/benchmark.factor
@ -247,7 +247,8 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
 : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
    '[ _ swap _
       '[ [ [ _ execute( -- quot ) ] dip
-          [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
+          [ execute( -- ) ] each _ execute( quot -- quot ) gc
+            benchmark ] with-result ] each
       print-separator ] ; 

 : run-serialization-bench ( doc-word-seq feat-seq -- )
@ -282,7 +283,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }

    
 : run-benchmarks ( -- )
-    "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+    "db" "db" get* "host" "127.0.0.1" get* "port" 27017 get* ensure-number <mdb>
    [ print-header
      ! serialization
      { small-doc-prepare medium-doc-prepare
--- a/extra/mongodb/cmd/cmd.factor
+++ b/extra/mongodb/cmd/cmd.factor
@ -0,0 +1,132 @@
+USING: accessors assocs hashtables kernel linked-assocs strings ;
+IN: mongodb.cmd
+
+<PRIVATE
+
+TUPLE: mongodb-cmd 
+    { name string }
+    { const? boolean }
+    { admin? boolean }
+    { auth? boolean }
+    { assoc assoc }
+    { norep? boolean } ;
+
+PRIVATE>
+
+CONSTANT: buildinfo-cmd 
+    T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
+
+CONSTANT: list-databases-cmd
+    T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
+
+! Options: { "async" t }
+CONSTANT: fsync-cmd
+    T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
+
+! Value: { "clone" from_host }
+CONSTANT: clone-db-cmd
+    T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
+
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
+CONSTANT: copy-db-cmd
+    T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
+
+CONSTANT: shutdown-cmd
+    T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
+
+CONSTANT: reseterror-cmd
+    T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
+
+CONSTANT: getlasterror-cmd
+    T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
+
+CONSTANT: getpreverror-cmd
+    T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
+
+CONSTANT: forceerror-cmd
+    T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
+
+CONSTANT: drop-db-cmd
+    T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
+
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
+CONSTANT: repair-db-cmd
+    T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
+
+! Options: -1 gets the current profile level; 0-2 set the profile level
+CONSTANT: profile-cmd 
+    T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
+
+CONSTANT: server-status-cmd
+    T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
+
+CONSTANT: assertinfo-cmd
+    T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
+
+CONSTANT: getoptime-cmd
+    T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
+
+CONSTANT: oplog-cmd
+    T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
+
+! Value: { "deleteIndexes" collection-name }
+! Options: { "index" index_name or "*" }
+CONSTANT: delete-index-cmd
+    T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
+
+! Value: { "create" collection-name }
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
+CONSTANT: create-cmd
+    T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
+
+! Value { "drop" collection-name }
+CONSTANT: drop-cmd
+    T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
+
+! Value { "count" collection-name }
+! Options: { "query" query-object }
+CONSTANT: count-cmd
+    T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
+
+! Value { "validate" collection-name }
+CONSTANT: validate-cmd
+    T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
+
+! Value { "collstats" collection-name }
+CONSTANT: collstats-cmd
+    T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
+
+! Value: { "distinct" collection-name }
+! Options: { "key" key-name }
+CONSTANT: distinct-cmd
+    T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
+
+! Value: { "filemd5" oid }
+! Options: { "root" bucket-name }
+CONSTANT: filemd5-cmd
+    T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
+
+CONSTANT: getnonce-cmd
+    T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
+
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
+CONSTANT: authenticate-cmd
+    T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
+
+CONSTANT: logout-cmd
+    T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
+
+! Value: { "findandmodify" collection-name }
+! Options: { { "query" selector } { "sort" sort-spec } 
+!            { "remove" t/f } { "update" modified-object } 
+!            { "new" t/f } }
+CONSTANT: findandmodify-cmd
+    T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
+
+: make-cmd ( cmd-stub -- cmd-assoc )
+    dup const?>> [  ] [  
+        clone [ clone <linked-assoc> ] change-assoc
+    ] if ; inline
+
+: set-cmd-opt ( cmd value key -- cmd )
+    pick assoc>> set-at ; inline
--- a/extra/mongodb/connection/connection.factor
+++ b/extra/mongodb/connection/connection.factor
@ -1,9 +1,9 @@
-USING: accessors assocs fry io.encodings.binary io.sockets kernel math
-math.parser mongodb.msg mongodb.operations namespaces destructors
-constructors sequences splitting checksums checksums.md5 
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
-arrays hashtables sequences.deep vectors locals ;
-
+USING: accessors arrays assocs byte-vectors checksums
+checksums.md5 constructors destructors fry hashtables
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.sockets io.streams.duplex kernel locals math math.parser
+mongodb.cmd mongodb.msg namespaces sequences
+splitting ;
 IN: mongodb.connection

 : md5-checksum ( string -- digest )
@ -15,13 +15,18 @@ TUPLE: mdb-node master? { address inet } remote ;

 CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;

-TUPLE: mdb-connection instance node handle remote local ;
+TUPLE: mdb-connection instance node handle remote local buffer ;
+
+: connection-buffer ( -- buffer )
+    mdb-connection get buffer>> 0 >>length ; inline
+
+USE: mongodb.operations

 CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;

 : check-ok ( result -- errmsg ? )
    [ [ "errmsg" ] dip at ] 
-    [ [ "ok" ] dip at >integer 1 = ] bi ; inline 
+    [ [ "ok" ] dip at ] bi ; inline 

 : <mdb-db> ( name nodes -- mdb-db )
    mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
    nodes>> f swap at ;

 : with-connection ( connection quot -- * )
-    [ mdb-connection set ] prepose with-scope ; inline
+    [ mdb-connection ] dip with-variable ; inline
    
 : mdb-instance ( -- mdb )
    mdb-connection get instance>> ; inline
@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 : namespaces-collection ( -- ns )
    mdb-instance name>> "system.namespaces" "." glue ; inline

-: cmd-collection ( -- ns )
-    mdb-instance name>> "$cmd" "." glue ; inline
+: cmd-collection ( cmd -- ns )
+    admin?>> [ "admin"  ] [ mdb-instance name>> ] if
+    "$cmd" "." glue ; inline

 : index-ns ( colname -- index-ns )
    [ mdb-instance name>> ] dip "." glue ; inline
@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
    '[ _ write-message read-message ] with-stream* ;

 : send-query-1result ( collection assoc -- result )
-    <mdb-query-msg>
-        1 >>return#
-    send-query-plain objects>>
-    [ f ] [ first ] if-empty ;
+    <mdb-query-msg> -1 >>return# send-query-plain
+    objects>> [ f ] [ first ] if-empty ;
+
+: send-cmd ( cmd -- result )
+    [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline

 <PRIVATE

 : get-nonce ( -- nonce )
-    cmd-collection H{ { "getnonce" 1 } } send-query-1result 
+    getnonce-cmd make-cmd send-cmd
    [ "nonce" swap at ] [ f ] if* ;

 : auth? ( mdb -- ? )
@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
    [ pwd-digest>> ] bi
    3array concat md5-checksum ; inline

-: build-auth-query ( -- query-assoc )
-    { "authenticate" 1 }
-    "user"  mdb-instance username>> 2array
-    "nonce" get-nonce 2array
-    3array >hashtable
-    [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
-    [ set-at ] keep ; 
+: build-auth-cmd ( cmd -- cmd )
+    mdb-instance username>> "user" set-cmd-opt
+    get-nonce [ "nonce" set-cmd-opt ] [ ] bi
+    calculate-key-digest "key" set-cmd-opt ; inline
    
 : perform-authentication ( --  )
-    cmd-collection build-auth-query send-query-1result
+    authenticate-cmd make-cmd
+    build-auth-cmd send-cmd
    check-ok [ drop ] [ throw ] if ; inline

 : authenticate-connection ( mdb-connection -- )
@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 : open-connection ( mdb-connection node -- mdb-connection )
   [ >>node ] [ address>> ] bi
   [ >>remote ] keep binary <client>
-   [ >>handle ] dip >>local ;
+   [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;

 : get-ismaster ( -- result )
    "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; 
@ -119,7 +124,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;

 : nodelist>table ( seq -- assoc )
   [ [ master?>> ] keep 2array ] map >hashtable ;
-   
+
 PRIVATE>

 :: verify-nodes ( mdb -- )
--- a/extra/mongodb/driver/driver.factor
+++ b/extra/mongodb/driver/driver.factor
@ -1,10 +1,10 @@
 USING: accessors arrays assocs bson.constants combinators
-combinators.smart constructors destructors formatting fry hashtables
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
-sequences sets splitting strings
-tools.continuations uuid memoize locals ;
-
+combinators.smart constructors destructors fry hashtables io
+io.pools io.sockets kernel linked-assocs locals math
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
+prettyprint prettyprint.custom prettyprint.sections sequences
+sets splitting strings ;
+FROM: ascii => ascii? ;
 IN: mongodb.driver

 TUPLE: mdb-pool < pool mdb ;
@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;

 TUPLE: mdb-collection
 { name string }
-{ capped boolean initial: f }
-{ size integer initial: -1 }
-{ max integer initial: -1 } ;
+{ capped boolean }
+{ size integer }
+{ max integer } ;

 CONSTRUCTOR: mdb-collection ( name -- collection ) ;

@ -61,7 +61,7 @@ M: mdb-getmore-msg update-query
    query>> update-query ; 
      
 : make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
-    over cursor>> 0 > 
+    over cursor>> 0 >
    [ [ update-query ]
      [ [ cursor>> ] dip <mdb-cursor> ] 2bi
    ] [ 2drop f ] if ;
@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
    [ make-cursor ] 2tri
    swap objects>> ;

-: make-collection-assoc ( collection assoc -- )
-    [ [ name>> "create" ] dip set-at ]
-    [ [ [ capped>> ] keep ] dip
-      '[ _ _
-         [ [ drop t "capped" ] dip set-at ]
-         [ [ size>> "size" ] dip set-at ]
-         [ [ max>> "max" ] dip set-at ] 2tri ] when
-    ] 2bi ; 

 PRIVATE>

 SYNTAX: r/ ( token -- mdbregexp )
    \ / [ >mdbregexp ] parse-literal ; 

-: with-db ( mdb quot -- * )
+: with-db ( mdb quot -- )
    '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
-  
+
+: with-mdb ( mdb quot -- )
+    [ <mdb-pool> ] dip
+    [ mdb-pool swap with-variable ] curry with-disposal ; inline
+
+: with-mdb-connection ( quot -- )
+    [ mdb-pool get ] dip 
+    '[ _ with-connection ] with-pooled-connection ; inline
+
 : >id-selector ( assoc -- selector )
    [ MDB_OID_FIELD swap at ] keep
    H{ } clone [ set-at ] keep ;
@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
 M: string create-collection
    <mdb-collection> create-collection ;

-M: mdb-collection create-collection
-    [ [ cmd-collection ] dip
-      <linked-hash> [ make-collection-assoc ] keep
-      <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
-      [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+M: mdb-collection create-collection ( collection -- )
+    create-cmd make-cmd over
+    {
+        [ name>> "create" set-cmd-opt ]
+        [ capped>> [ "capped" set-cmd-opt ] when* ]
+        [ max>> [ "max" set-cmd-opt ] when* ]
+        [ size>> [ "size" set-cmd-opt ] when* ]
+    } cleave send-cmd check-ok
+    [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
+    [ throw ] if ;
  
 : load-collection-list ( -- collection-list )
    namespaces-collection
@ -128,8 +133,12 @@ M: mdb-collection create-collection
 <PRIVATE

 : ensure-valid-collection-name ( collection -- )
-    [ ";$." intersect length 0 > ] keep
-    '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+    [
+        [ ";$." intersect length 0 > ] keep
+        '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
+    ] [
+        [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
+    ] bi ; inline

 : build-collection-map ( -- assoc )
    H{ } clone load-collection-list      
@ -215,21 +224,21 @@ M: mdb-cursor find
    dup empty? [ drop f ] [ first ] if ;

 : count ( mdb-query-msg -- result )
-    [ collection>> "count" H{ } clone [ set-at ] keep ] keep
-    query>> [ over [ "query" ] dip set-at ] when*
-    [ cmd-collection ] dip <mdb-query-msg> find-one 
+    [ count-cmd make-cmd ] dip
+    [ collection>> "count" set-cmd-opt ]
+    [ query>> "query" set-cmd-opt ] bi send-cmd 
    [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;

 : lasterror ( -- error )
-    cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
-    find-one [ "err" ] dip at ;
+    getlasterror-cmd make-cmd send-cmd
+    [ "err" ] dip at ;

 GENERIC: validate. ( collection -- )

 M: string validate.
-    [ cmd-collection ] dip
-    "validate" H{ } clone [ set-at ] keep
-    <mdb-query-msg> find-one [ check-ok nip ] keep
+    [ validate-cmd make-cmd ] dip
+    "validate" set-cmd-opt send-cmd
+    [ check-ok nip ] keep
    '[ "result" _ at print ] [  ] if ;

 M: mdb-collection validate.
@ -251,7 +260,7 @@ PRIVATE>
    <mdb-insert-msg> send-message ;

 : ensure-index ( index-spec -- )
-    <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+    <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
    [ { [ [ name>> "name" ] dip set-at ]
        [ [ ns>> index-ns "ns" ] dip set-at ]
        [ [ key>> "key" ] dip set-at ]
@ -261,11 +270,9 @@ PRIVATE>
    [ index-collection ] dip save ;

 : drop-index ( collection name -- )
-    H{ } clone
-    [ [ "index" ] dip set-at ] keep
-    [ [ "deleteIndexes" ] dip set-at ] keep
-    [ cmd-collection ] dip <mdb-query-msg>
-    find-one drop ;
+    [ delete-index-cmd make-cmd ] 2dip
+    [ "deleteIndexes" set-cmd-opt ]
+    [ "index" set-cmd-opt ] bi* send-cmd drop ;

 : <update> ( collection selector object -- mdb-update-msg )
    [ check-collection ] 2dip <mdb-update-msg> ;
@ -278,7 +285,16 @@ PRIVATE>

 : update-unsafe ( mdb-update-msg -- )
    send-message ;
- 
+
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
+    [ findandmodify-cmd make-cmd ] 3dip
+    [ "findandmodify" set-cmd-opt ]
+    [ "query" set-cmd-opt ]
+    [ "update" set-cmd-opt ] tri* ; inline
+
+: run-cmd ( cmd -- result )
+    send-cmd ; inline
+
 : delete ( collection selector -- )
    [ check-collection ] dip
    <mdb-delete-msg> send-message-check-error ;
@ -298,8 +314,7 @@ PRIVATE>
    check-collection drop ;

 : drop-collection ( name -- )
-    [ cmd-collection ] dip
-    "drop" H{ } clone [ set-at ] keep
-    <mdb-query-msg> find-one drop ;
+    [ drop-cmd make-cmd ] dip
+    "drop" set-cmd-opt send-cmd drop ;


--- a/extra/mongodb/gridfs/gridfs.factor
+++ b/extra/mongodb/gridfs/gridfs.factor
@ -0,0 +1,285 @@
+USING: accessors arrays assocs base64 bson.constants
+byte-arrays byte-vectors calendar combinators
+combinators.short-circuit destructors formatting fry hashtables
+io kernel linked-assocs locals math math.parser mongodb.cmd
+mongodb.connection mongodb.driver mongodb.msg namespaces
+sequences splitting strings ;
+FROM: mongodb.driver => update ;
+IN: mongodb.gridfs
+
+CONSTANT: default-chunk-size 262144
+
+TUPLE: gridfs 
+    { bucket string } 
+    { files string }
+    { chunks string } ;
+
+
+<PRIVATE
+
+: gridfs> ( -- gridfs )
+    gridfs get ; inline
+
+: files-collection ( -- str ) gridfs> files>> ; inline
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
+
+
+: init-gridfs ( gridfs -- )
+    chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } } 
+    <index-spec> ensure-index ; inline
+
+PRIVATE>
+
+: <gridfs> ( bucket -- gridfs )
+    [  ] 
+    [ "files" "%s.%s" sprintf  ] 
+    [ "chunks" "%s.%s" sprintf ] tri
+    gridfs boa [ init-gridfs ] keep ;
+
+: with-gridfs ( gridfs quot -- * )
+    [ gridfs ] dip with-variable ; inline
+
+TUPLE: entry 
+    { id oid }
+    { filename string }
+    { content-type string }
+    { length integer }
+    { chunk-size integer }
+    { created timestamp }
+    { aliases array }
+    { metadata hashtable }
+    { md5 string } ;
+
+<PRIVATE
+
+: id>base64 ( id -- str )
+    [ a>> >hex ] [ b>> >hex ] bi 
+    2array "#" join >base64 >string ; inline
+
+: base64>id ( str -- objid )
+    base64> >string "#" split 
+    [ first ] [ second ] bi 
+    [ hex> ] bi@ oid boa ; inline
+    
+PRIVATE>
+
+: <entry> ( name content-type -- entry )
+    entry new 
+    swap >>content-type swap >>filename 
+    <oid> >>id 0 >>length default-chunk-size >>chunk-size 
+    now >>created ; inline
+
+<PRIVATE 
+
+TUPLE: chunk 
+    { id oid }
+    { fileid oid }
+    { n integer }
+    { data byte-array } ;
+
+: at> ( assoc key -- value/f )
+    swap at ; inline
+
+:: >set-at ( assoc value key -- )
+    value key assoc set-at ; inline
+
+: (update-file) ( entry assoc -- entry )
+    { 
+        [ "_id" at> >>id ]
+        [ "filename" at> >>filename ]
+        [ "contentType" at> >>content-type ]
+        [ "length" at> >>length ]
+        [ "chunkSize" at> >>chunk-size ]
+        [ "uploadDate" at> >>created ]
+        [ "aliases" at> >>aliases ]
+        [ "metadata" at> >>metadata ]
+        [ "md5" at> >>md5 ]
+    } cleave ; inline
+
+: assoc>chunk ( assoc -- chunk )
+    [ chunk new ] dip
+    {  
+        [ "_id" at> >>id ]
+        [ "files_id" at> >>fileid ]
+        [ "n" at> >>n ]
+        [ "data" at> >>data ]
+    } cleave ;
+
+: assoc>entry ( assoc -- entry )
+    [ entry new ] dip (update-file) ;
+    
+: entry>assoc ( entry -- assoc )
+    [ H{  } clone ] dip
+    {
+        [ id>> "_id" >set-at ]
+        [ filename>> "filename" >set-at ]
+        [ content-type>> "contentType" >set-at ]
+        [ length>> "length" >set-at ]
+        [ chunk-size>> "chunkSize" >set-at ]
+        [ created>> "uploadDate" >set-at ]
+        [ aliases>> "aliases" >set-at ]
+        [ metadata>> "metadata" >set-at ]
+        [ md5>> "md5" >set-at ]
+        [ drop ]
+    } 2cleave ; inline
+
+: create-entry ( entry -- entry )
+    [ [ files-collection ] dip entry>assoc save ] [ ] bi ;
+
+TUPLE: state bytes count ;
+
+: <state> ( -- state )
+    0 0 state boa ; inline
+
+: get-state ( -- n )
+    state get ; inline
+
+: with-state ( quot -- state )
+    [ <state> state ] dip 
+    [ get-state ] compose 
+    with-variable ; inline
+
+: update-state ( bytes -- )
+    [ get-state ] dip
+    '[ _ + ] change-bytes 
+    [ 1 + ] change-count drop ; inline
+
+:: store-chunk ( chunk entry n -- ) 
+    entry id>> :> id
+    H{ { "files_id" id }
+       { "n" n } { "data" chunk } }
+    [ chunks-collection ] dip save ; inline
+
+:: write-chunks ( stream entry -- length )
+    entry chunk-size>> :> chunk-size
+    [
+        [ 
+            chunk-size stream stream-read dup [
+                [ entry get-state count>> store-chunk ]
+                [ length update-state ] bi 
+            ] when*
+        ] loop
+    ] with-state bytes>> ;
+
+: (entry-selector) ( entry -- selector )
+    id>> "_id" associate ; inline
+
+:: file-md5 ( id -- md5-str )
+    filemd5-cmd make-cmd
+    id "filemd5" set-cmd-opt
+    gridfs> bucket>> "root" set-cmd-opt
+    send-cmd "md5" at> ; inline
+
+: update-entry ( bytes entry -- entry )
+    [ swap >>length dup id>> file-md5 >>md5  ]
+    [ nip [ (entry-selector) ] [  ] bi
+        [ length>> "length" associate "$set" associate 
+          [ files-collection ] 2dip <update> update ]
+        [ md5>> "md5" associate "$set" associate 
+          [ files-collection ] 2dip <update> update ] 2bi 
+    ] 2bi ;
+
+TUPLE: gridfs-input-stream entry chunk n offset cpos ;
+
+: <gridfs-input-stream> ( entry -- stream )
+    [ gridfs-input-stream new ] dip
+    >>entry 0 >>offset 0 >>cpos -1 >>n ;
+
+PRIVATE>
+
+: write-entry ( input-stream entry -- entry )
+    create-entry [ write-chunks ] keep update-entry  ;
+
+: get-entry ( id -- entry )
+    [ files-collection ] dip
+    "_id" associate <query> find-one assoc>entry ;
+
+: open-entry ( entry -- input-stream )
+    <gridfs-input-stream> ;
+
+: entry-contents ( entry -- bytearray )
+    <gridfs-input-stream> stream-contents ;
+
+<PRIVATE
+
+: load-chunk ( stream -- chunk/f )
+    [ entry>> id>> "files_id" associate ]
+    [ n>> "n" associate ] bi assoc-union
+    [ chunks-collection ] dip 
+    <query> find-one dup [ assoc>chunk ] when ;
+
+: exhausted? ( stream -- boolean )
+    [ offset>> ] [ entry>> length>> ] bi = ; inline
+
+: fresh? ( stream -- boolean )
+    [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
+
+: data-available ( stream -- int/f )
+    [ cpos>> ] [ chunk>> data>> length ] bi 
+    2dup < [ swap - ] [ 2drop f ] if ; inline
+
+: next-chunk ( stream -- available chunk/f )
+    0 >>cpos [ 1 + ] change-n
+    [  ] [ load-chunk ] bi >>chunk
+    [ data-available ] [ chunk>> ] bi ; inline
+
+: ?chunk ( stream -- available chunk/f )
+    dup fresh? [ next-chunk ] [ 
+        dup exhausted? [ drop 0 f ] [  
+            dup data-available [ swap chunk>> ] [ next-chunk ] if*
+        ] if
+    ] if ; inline
+
+: set-stream ( n stream -- )
+    swap { 
+        [ >>offset drop ]
+        [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
+        [ drop dup load-chunk >>chunk drop ]
+    } 2cleave ; inline
+
+:: advance-stream ( n stream -- )
+    stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
+
+: read-part ( n stream chunk -- seq/f )
+    [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
+    [ drop advance-stream ] 3bi ; inline
+
+:: (stream-read-partial) ( n stream -- seq/f )
+    stream ?chunk :> chunk :> available
+    chunk [
+        n available < 
+        [ n ] [ available ] if 
+        stream chunk read-part 
+    ] [ f ] if ; inline
+
+:: (stream-read) ( n stream acc -- )
+    n stream (stream-read-partial)
+    {
+        { [ dup not ] [ drop ] }
+        { [ dup length n = ] [ acc push-all ] }
+        { [ dup length n < ] [
+            [ acc push-all ] [ length ] bi
+            n swap - stream acc (stream-read) ]
+        }
+    } cond ; inline recursive 
+
+PRIVATE>
+
+M: gridfs-input-stream stream-element-type drop +byte+ ;
+
+M: gridfs-input-stream stream-read ( n stream -- seq/f )
+    over <byte-vector> [ (stream-read) ] [ ] bi
+    dup empty? [ drop f ] [ >byte-array ] if ;
+
+M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
+    (stream-read-partial) ;
+
+M: gridfs-input-stream stream-tell ( stream -- n ) 
+    offset>> ;
+
+M: gridfs-input-stream stream-seek ( n seek-type stream -- )
+    swap seek-absolute = 
+    [ set-stream ] 
+    [ "seek-type not supported" throw ] if ;
+
+M: gridfs-input-stream dispose drop ;
--- a/extra/mongodb/mongodb-docs.factor
+++ b/extra/mongodb/mongodb-docs.factor
@ -9,7 +9,7 @@ ARTICLE: "mongodb" "MongoDB factor integration"
  "USING: mongodb.driver ;"
  "\"db\" \"127.0.0.1\" 27017 <mdb>"
  "[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
-  "                 [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+  "                 [ \"ageIdx\" [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
  "                 [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
  "" }
 { $heading "Highlevel tuple integration" }
--- a/extra/mongodb/msg/msg.factor
+++ b/extra/mongodb/msg/msg.factor
@ -17,52 +17,52 @@ CONSTANT: ResultFlag_ErrSet  2 ! /* { $err : ... } is being returned */
 CONSTANT: ResultFlag_ShardConfigStale 4 !  /* have to update config from the server,  usually $err is also set */
            
 TUPLE: mdb-msg
-{ opcode integer } 
-{ req-id integer initial: 0 }
-{ resp-id integer initial: 0 }
-{ length integer initial: 0 }     
-{ flags integer initial: 0 } ;
+    { opcode integer } 
+    { req-id integer initial: 0 }
+    { resp-id integer initial: 0 }
+    { length integer initial: 0 }     
+    { flags integer initial: 0 } ;

 TUPLE: mdb-query-msg < mdb-msg
-{ collection string }
-{ skip# integer initial: 0 }
-{ return# integer initial: 0 }
-{ query assoc }
-{ returnfields assoc }
-{ orderby assoc }
-explain hint ;
+    { collection string }
+    { skip# integer initial: 0 }
+    { return# integer initial: 0 }
+    { query assoc }
+    { returnfields assoc }
+    { orderby assoc }
+    explain hint ;

 TUPLE: mdb-insert-msg < mdb-msg
-{ collection string }
-{ objects sequence } ;
+    { collection string }
+    { objects sequence } ;

 TUPLE: mdb-update-msg < mdb-msg
-{ collection string }
-{ upsert? integer initial: 0 }
-{ selector assoc }
-{ object assoc } ;
+    { collection string }
+    { upsert? integer initial: 0 }
+    { selector assoc }
+    { object assoc } ;

 TUPLE: mdb-delete-msg < mdb-msg
-{ collection string }
-{ selector assoc } ;
+    { collection string }
+    { selector assoc } ;

 TUPLE: mdb-getmore-msg < mdb-msg
-{ collection string }
-{ return# integer initial: 0 }
-{ cursor integer initial: 0 }
-{ query mdb-query-msg } ;
+    { collection string }
+    { return# integer initial: 0 }
+    { cursor integer initial: 0 }
+    { query mdb-query-msg } ;

 TUPLE: mdb-killcursors-msg < mdb-msg
-{ cursors# integer initial: 0 }
-{ cursors sequence } ;
+    { cursors# integer initial: 0 }
+    { cursors sequence } ;

 TUPLE: mdb-reply-msg < mdb-msg
-{ collection string }
-{ cursor integer initial: 0 }
-{ start# integer initial: 0 }
-{ requested# integer initial: 0 }
-{ returned# integer initial: 0 }
-{ objects sequence } ;
+    { collection string }
+    { cursor integer initial: 0 }
+    { start# integer initial: 0 }
+    { requested# integer initial: 0 }
+    { returned# integer initial: 0 }
+    { objects sequence } ;


 CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
--- a/extra/mongodb/operations/operations.factor
+++ b/extra/mongodb/operations/operations.factor
@ -1,11 +1,15 @@
 USING: accessors assocs bson.reader bson.writer byte-arrays
-byte-vectors combinators formatting fry io io.binary
-io.encodings.private io.encodings.binary io.encodings.string
-io.encodings.utf8 io.encodings.utf8.private io.files kernel
-locals math mongodb.msg namespaces sequences uuid
-bson.writer.private ;
+byte-vectors combinators formatting fry io io.binary io.encodings.private
+io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
+kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
+
+FROM: mongodb.connection => connection-buffer ;
+FROM: alien => byte-length ;
+
 IN: mongodb.operations

+M: byte-vector byte-length length ;
+
 <PRIVATE

 PREDICATE: mdb-reply-op < integer OP_Reply = ;
@ -16,12 +20,6 @@ PREDICATE: mdb-delete-op < integer OP_Delete = ;
 PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
 PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;

-PRIVATE>
-
-GENERIC: write-message ( message -- )
-
-<PRIVATE
-
 CONSTANT: MSG-HEADER-SIZE 16

 SYMBOL: msg-bytes-read 
@ -40,34 +38,26 @@ SYMBOL: msg-bytes-read
 : read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
 : read-byte ( -- byte ) read-byte-raw first ; inline

-: (read-cstring) ( acc -- )
-    [ read-byte ] dip ! b acc
-    2dup push             ! b acc
-    [ 0 = ] dip      ! bool acc
-    '[ _ (read-cstring) ] unless ; inline recursive
-
-: read-cstring ( -- string )
-    BV{ } clone
-    [ (read-cstring) ] keep
-    [ zero? ] trim-tail
-    >byte-array utf8 decode ; inline
-
-GENERIC: (read-message) ( message opcode -- message )
-
 : copy-header ( message msg-stub -- message )
-    [ length>> ] keep [ >>length ] dip
-    [ req-id>> ] keep [ >>req-id ] dip
-    [ resp-id>> ] keep [ >>resp-id ] dip
-    [ opcode>> ] keep [ >>opcode ] dip
-    flags>> >>flags ;
+    {
+        [ length>> >>length ]
+        [ req-id>> >>req-id ]
+        [ resp-id>> >>resp-id ]
+        [ opcode>> >>opcode ]
+        [ flags>> >>flags ]
+    } cleave ; inline

-M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
-    drop
+: reply-read-message ( msg-stub -- message )
    [ <mdb-reply-msg> ] dip copy-header
    read-longlong >>cursor
    read-int32 >>start#
    read-int32 [ >>returned# ] keep
-    [ H{ } stream>assoc ] collector [ times ] dip >>objects ;    
+    [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;    
+
+: (read-message) ( message opcode -- message )
+    OP_Reply = 
+    [ reply-read-message ]
+    [ "unknown message type" throw ] if ; inline

 : read-header ( message -- message )
    read-int32 >>length
@ -77,94 +67,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
    read-int32 >>flags ; inline

 : write-header ( message -- )
-    [ req-id>> write-int32 ] keep
-    [ resp-id>> write-int32 ] keep 
-    opcode>> write-int32 ; inline
+    [ req-id>> write-int32 ]
+    [ resp-id>> write-int32 ]
+    [ opcode>> write-int32 ] tri ; inline

 PRIVATE>

 : read-message ( -- message )
-    mdb-msg new
-    0 >bytes-read
-    read-header
-    [ ] [ opcode>> ] bi (read-message) ;
+    [
+        mdb-msg new 0 >bytes-read read-header
+        [ ] [ opcode>> ] bi (read-message)
+    ] with-scope ;

 <PRIVATE

-USE: tools.walker
-
-: dump-to-file ( array -- )
-    [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
-    '[ _ write ] with-file-writer ;
-
-: (write-message) ( message quot -- )    
-    '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
-    ! [ dump-to-file ] keep
-    write flush ; inline
+: (write-message) ( message quot -- )
+    [ connection-buffer dup ] 2dip
+    '[
+        [ _ [ write-header ] [ @ ] bi ] with-length-prefix
+    ] with-output-stream* write flush ; inline

 :: build-query-object ( query -- selector )
    H{ } clone :> selector
-    query { [ orderby>> [ "$orderby" selector set-at ] when* ]
-      [ explain>> [ "$explain" selector set-at ] when* ]
-      [ hint>> [ "$hint" selector set-at ] when* ] 
-      [ query>> "query" selector set-at ]
-    } cleave
-    selector ;
+    query {
+        [ orderby>> [ "$orderby" selector set-at ] when* ]
+        [ explain>> [ "$explain" selector set-at ] when* ]
+        [ hint>> [ "$hint" selector set-at ] when* ]
+        [ query>> "query" selector set-at ]
+    } cleave selector ; inline
+
+: write-query-message ( message -- )
+    [
+        {
+            [ flags>> write-int32 ]
+            [ collection>> write-cstring ]
+            [ skip#>> write-int32 ]
+            [ return#>> write-int32 ]
+            [ build-query-object assoc>stream ]
+            [ returnfields>> [ assoc>stream ] when* ]
+        } cleave
+    ] (write-message) ; inline
+
+: write-insert-message ( message -- )
+    [ 
+       [ flags>> write-int32 ]
+       [ collection>> write-cstring ]
+       [ objects>> [ assoc>stream ] each ] tri
+    ] (write-message) ; inline
+
+: write-update-message ( message -- )
+    [
+        { 
+            [ flags>> write-int32 ]
+            [ collection>> write-cstring ]
+            [ upsert?>> write-int32 ]
+            [ selector>> assoc>stream ]
+            [ object>> assoc>stream ]
+        } cleave
+    ] (write-message) ; inline
+
+: write-delete-message ( message -- )
+    [
+       [ flags>> write-int32 ]
+       [ collection>> write-cstring ]
+       [ 0 write-int32 selector>> assoc>stream ] tri
+    ] (write-message) ; inline
+
+: write-getmore-message ( message -- )
+    [
+        {
+           [ flags>> write-int32 ]
+           [ collection>> write-cstring ]
+           [ return#>> write-int32 ]
+           [ cursor>> write-longlong ]
+        } cleave
+    ] (write-message) ; inline
+
+: write-killcursors-message ( message -- )
+    [
+       [ flags>> write-int32 ]
+       [ cursors#>> write-int32 ]
+       [ cursors>> [ write-longlong ] each ] tri
+    ] (write-message) ; inline

 PRIVATE>

-M: mdb-query-msg write-message ( message -- )
-     dup
-     '[ _ 
-        [ flags>> write-int32 ] keep 
-        [ collection>> write-cstring ] keep
-        [ skip#>> write-int32 ] keep
-        [ return#>> write-int32 ] keep
-        [ build-query-object assoc>stream ] keep
-        returnfields>> [ assoc>stream ] when* 
-     ] (write-message) ;
- 
-M: mdb-insert-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       objects>> [ assoc>stream ] each
-    ] (write-message) ;
-
-M: mdb-update-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       [ upsert?>> write-int32 ] keep
-       [ selector>> assoc>stream ] keep
-       object>> assoc>stream
-    ] (write-message) ;
-
-M: mdb-delete-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       0 write-int32
-       selector>> assoc>stream
-    ] (write-message) ;
-
-M: mdb-getmore-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       [ return#>> write-int32 ] keep
-       cursor>> write-longlong
-    ] (write-message) ;
-
-M: mdb-killcursors-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ cursors#>> write-int32 ] keep
-       cursors>> [ write-longlong ] each
-    ] (write-message) ;
-
+: write-message ( message -- )
+    {  
+        { [ dup mdb-query-msg? ] [ write-query-message ] }
+        { [ dup mdb-insert-msg? ] [ write-insert-message ] }
+        { [ dup mdb-update-msg? ] [ write-update-message ] }
+        { [ dup mdb-delete-msg? ] [ write-delete-message ] }
+        { [ dup mdb-getmore-msg? ] [ write-getmore-message ] }
+        { [ dup mdb-killcursors-msg? ] [ write-killcursors-message ] }
+    } cond ;
--- a/extra/mongodb/tuple/persistent/persistent.factor
+++ b/extra/mongodb/tuple/persistent/persistent.factor
@ -42,7 +42,7 @@ DEFER: assoc>tuple
   swap set-at ; inline

 : write-field? ( tuple key value -- ? )
-   pick mdb-persistent? [ 
+   pick mdb-persistent? [
      { [ [ 2drop ] dip not ]
        [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline

@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
   over [ call( tuple -- assoc ) ] dip 
   [ [ tuple-collection name>> ] [ >toid ] bi ] keep
   [ add-storable ] dip
-   [ tuple-collection name>> ] [ id>> ] bi <objref> ;
+   [ tuple-collection name>> ] [ id>> ] bi <dbref> ;

 : write-field ( value quot -- value' )
   <cond-value> {
@ -78,9 +78,6 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
   H{ } clone swap [ <mirror> ] keep pick ; inline

-: ensure-mdb-info ( tuple -- tuple )    
-   dup id>> [ <objid> >>id ] unless ; inline
-
 : with-object-map ( quot: ( -- ) -- store-assoc )
   [ H{ } clone dup object-map ] dip with-variable ; inline

@ -92,11 +89,14 @@ PRIVATE>

 GENERIC: tuple>storable ( tuple -- storable )

+: ensure-oid ( tuple -- tuple )
+   dup id>> [ <oid> >>id ] unless ; inline
+
 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
   '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline

 M: mdb-persistent tuple>assoc ( tuple -- assoc )
-   ensure-mdb-info (tuple>assoc) ;
+   ensure-oid (tuple>assoc) ;

 M: tuple tuple>assoc ( tuple -- assoc )
   (tuple>assoc) ;
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@ -61,9 +61,9 @@ PRIVATE>
 
 : update-tuple ( tuple -- )
    [ tuple-collection name>> ]
-    [ id-selector ]
+    [ ensure-oid id-selector ]
    [ tuple>assoc ] tri
-    <update> update ;
+    <update> >upsert update ;

 : save-tuple ( tuple -- )
    update-tuple ;
--- a/extra/nehe/2/2.factor
+++ b/extra/nehe/2/2.factor
@ -1,5 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render literals accessors ;
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
+literals accessors ;
 IN: nehe.2

 TUPLE: nehe2-gadget < gadget ;
@ -8,36 +9,45 @@ CONSTANT: width 256
 CONSTANT: height 256

 : <nehe2-gadget> (  -- gadget )
-  nehe2-gadget new ;
+    nehe2-gadget new ;

 M: nehe2-gadget draw-gadget* ( gadget -- )
-  drop
-  GL_PROJECTION glMatrixMode
-  glLoadIdentity
-  45.0 width height / >float 0.1 100.0 gluPerspective
-  GL_MODELVIEW glMatrixMode
-  glLoadIdentity
-  GL_SMOOTH glShadeModel
-  0.0 0.0 0.0 0.0 glClearColor
-  1.0 glClearDepth
-  GL_DEPTH_TEST glEnable
-  GL_LEQUAL glDepthFunc
-  GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
-  GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
-  glLoadIdentity
-  -1.5 0.0 -6.0 glTranslatef
-  GL_TRIANGLES [
-    0.0 1.0 0.0 glVertex3f
-    -1.0 -1.0 0.0 glVertex3f
-    1.0 -1.0 0.0 glVertex3f
-  ] do-state
-  3.0 0.0 0.0 glTranslatef
-  GL_QUADS [
-    -1.0 1.0 0.0 glVertex3f
-    1.0 1.0 0.0 glVertex3f
-    1.0 -1.0 0.0 glVertex3f
-    -1.0 -1.0 0.0 glVertex3f
-  ] do-state ;
+    drop
+    GL_PROJECTION glMatrixMode
+    glLoadIdentity
+    45.0 width height / >float 0.1 100.0 gluPerspective
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    GL_SMOOTH glShadeModel
+    0.0 0.0 0.0 0.0 glClearColor
+    1.0 glClearDepth
+    GL_DEPTH_TEST glEnable
+    GL_LEQUAL glDepthFunc
+    GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    glLoadIdentity
+    -1.5 0.0 -6.0 glTranslatef
+    GL_TRIANGLES [
+        0.0 1.0 0.0 glVertex3f
+        -1.0 -1.0 0.0 glVertex3f
+        1.0 -1.0 0.0 glVertex3f
+    ] do-state
+    3.0 0.0 0.0 glTranslatef
+    GL_QUADS [
+        -1.0 1.0 0.0 glVertex3f
+        1.0 1.0 0.0 glVertex3f
+        1.0 -1.0 0.0 glVertex3f
+        -1.0 -1.0 0.0 glVertex3f
+    ] do-state ;

-MAIN-WINDOW: run2 { { title "NeHe Tutorial 2" } { pref-dim { $ width $ height } } }
-  <nehe2-gadget> >>gadgets ;
+MAIN-WINDOW: run2
+    {
+        { title "NeHe Tutorial 2" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
+    <nehe2-gadget> >>gadgets ;
--- a/extra/nehe/4/4.factor
+++ b/extra/nehe/4/4.factor
@ -1,6 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render threads accessors
-calendar literals ;
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
+threads accessors calendar literals ;
 IN: nehe.4

 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@ -10,63 +10,72 @@ CONSTANT: height 256
 : redraw-interval ( -- dt ) 10 milliseconds ;

 : <nehe4-gadget> (  -- gadget )
-  nehe4-gadget new
+    nehe4-gadget new
    0.0 >>rtri
    0.0 >>rquad ;

 M: nehe4-gadget draw-gadget* ( gadget -- )
-  GL_PROJECTION glMatrixMode
-  glLoadIdentity
-  45.0 width height / >float 0.1 100.0 gluPerspective
-  GL_MODELVIEW glMatrixMode
-  glLoadIdentity
-  GL_SMOOTH glShadeModel
-  0.0 0.0 0.0 0.0 glClearColor
-  1.0 glClearDepth
-  GL_DEPTH_TEST glEnable
-  GL_LEQUAL glDepthFunc
-  GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
-  GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
-  glLoadIdentity
-  -1.5 0.0 -6.0 glTranslatef
-  dup rtri>> 0.0 1.0 0.0 glRotatef
+    GL_PROJECTION glMatrixMode
+    glLoadIdentity
+    45.0 width height / >float 0.1 100.0 gluPerspective
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    GL_SMOOTH glShadeModel
+    0.0 0.0 0.0 0.0 glClearColor
+    1.0 glClearDepth
+    GL_DEPTH_TEST glEnable
+    GL_LEQUAL glDepthFunc
+    GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    glLoadIdentity
+    -1.5 0.0 -6.0 glTranslatef
+    dup rtri>> 0.0 1.0 0.0 glRotatef

-  GL_TRIANGLES [
-    1.0 0.0 0.0 glColor3f
-    0.0 1.0 0.0 glVertex3f
-    0.0 1.0 0.0 glColor3f
-    -1.0 -1.0 0.0 glVertex3f
-    0.0 0.0 1.0 glColor3f
-    1.0 -1.0 0.0 glVertex3f
-  ] do-state
+    GL_TRIANGLES [
+        1.0 0.0 0.0 glColor3f
+        0.0 1.0 0.0 glVertex3f
+        0.0 1.0 0.0 glColor3f
+        -1.0 -1.0 0.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        1.0 -1.0 0.0 glVertex3f
+    ] do-state

-  glLoadIdentity
+    glLoadIdentity

-  1.5 0.0 -6.0 glTranslatef
-  dup rquad>> 1.0 0.0 0.0 glRotatef
-  0.5 0.5 1.0 glColor3f
-  GL_QUADS [
-    -1.0 1.0 0.0 glVertex3f
-    1.0 1.0 0.0 glVertex3f
-    1.0 -1.0 0.0 glVertex3f
-    -1.0 -1.0 0.0 glVertex3f
-  ] do-state
-  [ 0.2 + ] change-rtri
-  [ 0.15 - ] change-rquad drop ;
+    1.5 0.0 -6.0 glTranslatef
+    dup rquad>> 1.0 0.0 0.0 glRotatef
+    0.5 0.5 1.0 glColor3f
+    GL_QUADS [
+        -1.0 1.0 0.0 glVertex3f
+        1.0 1.0 0.0 glVertex3f
+        1.0 -1.0 0.0 glVertex3f
+        -1.0 -1.0 0.0 glVertex3f
+    ] do-state
+    [ 0.2 + ] change-rtri
+    [ 0.15 - ] change-rquad drop ;

 : nehe4-update-thread ( gadget -- )
-  dup quit?>> [ drop ] [
-    redraw-interval sleep
-    dup relayout-1
-    nehe4-update-thread
-  ] if ;
+    dup quit?>> [ drop ] [
+        redraw-interval sleep
+        dup relayout-1
+        nehe4-update-thread
+    ] if ;

 M: nehe4-gadget graft* ( gadget -- )
-  f >>quit?
-  [ nehe4-update-thread ] curry in-thread ;
+    f >>quit?
+    [ nehe4-update-thread ] curry in-thread ;

 M: nehe4-gadget ungraft* ( gadget -- )
-  t >>quit? drop ;
+    t >>quit? drop ;

-MAIN-WINDOW: run4 { { title "NeHe Tutorial 4" } { pref-dim { $ width $ height } } }
-  <nehe4-gadget> >>gadgets ;
+MAIN-WINDOW: run4
+    {
+        { title "NeHe Tutorial 4" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
+    <nehe4-gadget> >>gadgets ;
--- a/extra/nehe/5/5.factor
+++ b/extra/nehe/5/5.factor
@ -1,6 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render threads accessors
-calendar literals ;
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
+threads accessors calendar literals ;
 IN: nehe.5

 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@ -9,116 +9,125 @@ CONSTANT: height 256
 : redraw-interval ( -- dt ) 10 milliseconds ;

 : <nehe5-gadget> (  -- gadget )
-  nehe5-gadget new
+    nehe5-gadget new
    0.0 >>rtri
    0.0 >>rquad ;

 M: nehe5-gadget draw-gadget* ( gadget -- )
-  GL_PROJECTION glMatrixMode
-  glLoadIdentity
-  45.0 width height / >float 0.1 100.0 gluPerspective
-  GL_MODELVIEW glMatrixMode
-  glLoadIdentity
-  GL_SMOOTH glShadeModel
-  0.0 0.0 0.0 0.0 glClearColor
-  1.0 glClearDepth
-  GL_DEPTH_TEST glEnable
-  GL_LEQUAL glDepthFunc
-  GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
-  GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
-  glLoadIdentity
-  -1.5 0.0 -6.0 glTranslatef
-  dup rtri>> 0.0 1.0 0.0 glRotatef
+    GL_PROJECTION glMatrixMode
+    glLoadIdentity
+    45.0 width height / >float 0.1 100.0 gluPerspective
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    GL_SMOOTH glShadeModel
+    0.0 0.0 0.0 0.0 glClearColor
+    1.0 glClearDepth
+    GL_DEPTH_TEST glEnable
+    GL_LEQUAL glDepthFunc
+    GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    glLoadIdentity
+    -1.5 0.0 -6.0 glTranslatef
+    dup rtri>> 0.0 1.0 0.0 glRotatef

-  GL_TRIANGLES [
-    1.0 0.0 0.0 glColor3f
-    0.0 1.0 0.0 glVertex3f
-    0.0 1.0 0.0 glColor3f
-    -1.0 -1.0 1.0 glVertex3f
-    0.0 0.0 1.0 glColor3f
-    1.0 -1.0 1.0 glVertex3f
+    GL_TRIANGLES [
+        1.0 0.0 0.0 glColor3f
+        0.0 1.0 0.0 glVertex3f
+        0.0 1.0 0.0 glColor3f
+        -1.0 -1.0 1.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        1.0 -1.0 1.0 glVertex3f

-    1.0 0.0 0.0 glColor3f
-    0.0 1.0 0.0 glVertex3f
-    0.0 0.0 1.0 glColor3f
-    1.0 -1.0 1.0 glVertex3f
-    0.0 1.0 0.0 glColor3f
-    1.0 -1.0 -1.0 glVertex3f
+        1.0 0.0 0.0 glColor3f
+        0.0 1.0 0.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        1.0 -1.0 1.0 glVertex3f
+        0.0 1.0 0.0 glColor3f
+        1.0 -1.0 -1.0 glVertex3f

-    1.0 0.0 0.0 glColor3f
-    0.0 1.0 0.0 glVertex3f
-    0.0 1.0 0.0 glColor3f
-    1.0 -1.0 -1.0 glVertex3f
-    0.0 0.0 1.0 glColor3f
-    -1.0 -1.0 -1.0 glVertex3f
+        1.0 0.0 0.0 glColor3f
+        0.0 1.0 0.0 glVertex3f
+        0.0 1.0 0.0 glColor3f
+        1.0 -1.0 -1.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        -1.0 -1.0 -1.0 glVertex3f

-    1.0 0.0 0.0 glColor3f
-    0.0 1.0 0.0 glVertex3f
-    0.0 0.0 1.0 glColor3f
-    -1.0 -1.0 -1.0 glVertex3f
-    0.0 1.0 0.0 glColor3f
-    -1.0 -1.0 1.0 glVertex3f
-  ] do-state
+        1.0 0.0 0.0 glColor3f
+        0.0 1.0 0.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        -1.0 -1.0 -1.0 glVertex3f
+        0.0 1.0 0.0 glColor3f
+        -1.0 -1.0 1.0 glVertex3f
+    ] do-state

-  glLoadIdentity
+    glLoadIdentity

-  1.5 0.0 -7.0 glTranslatef
-  dup rquad>> 1.0 0.0 0.0 glRotatef
-  GL_QUADS [
-    0.0 1.0 0.0 glColor3f
-    1.0 1.0 -1.0 glVertex3f
-    -1.0 1.0 -1.0 glVertex3f
-    -1.0 1.0 1.0 glVertex3f
-    1.0 1.0 1.0 glVertex3f
+    1.5 0.0 -7.0 glTranslatef
+    dup rquad>> 1.0 0.0 0.0 glRotatef
+    GL_QUADS [
+        0.0 1.0 0.0 glColor3f
+        1.0 1.0 -1.0 glVertex3f
+        -1.0 1.0 -1.0 glVertex3f
+        -1.0 1.0 1.0 glVertex3f
+        1.0 1.0 1.0 glVertex3f

-    1.0 0.5 0.0 glColor3f
-    1.0 -1.0 1.0 glVertex3f
-    -1.0 -1.0 1.0 glVertex3f
-    -1.0 -1.0 -1.0 glVertex3f
-    1.0 -1.0 -1.0 glVertex3f
+        1.0 0.5 0.0 glColor3f
+        1.0 -1.0 1.0 glVertex3f
+        -1.0 -1.0 1.0 glVertex3f
+        -1.0 -1.0 -1.0 glVertex3f
+        1.0 -1.0 -1.0 glVertex3f

-    1.0 0.0 0.0 glColor3f
-    1.0 1.0 1.0 glVertex3f
-    -1.0 1.0 1.0 glVertex3f
-    -1.0 -1.0 1.0 glVertex3f
-    1.0 -1.0 1.0 glVertex3f
+        1.0 0.0 0.0 glColor3f
+        1.0 1.0 1.0 glVertex3f
+        -1.0 1.0 1.0 glVertex3f
+        -1.0 -1.0 1.0 glVertex3f
+        1.0 -1.0 1.0 glVertex3f

-    1.0 1.0 0.0 glColor3f
-    1.0 -1.0 -1.0 glVertex3f
-    -1.0 -1.0 -1.0 glVertex3f
-    -1.0 1.0 -1.0 glVertex3f
-    1.0 1.0 -1.0 glVertex3f
+        1.0 1.0 0.0 glColor3f
+        1.0 -1.0 -1.0 glVertex3f
+        -1.0 -1.0 -1.0 glVertex3f
+        -1.0 1.0 -1.0 glVertex3f
+        1.0 1.0 -1.0 glVertex3f

-    0.0 0.0 1.0 glColor3f
-    -1.0 1.0 1.0 glVertex3f
-    -1.0 1.0 -1.0 glVertex3f
-    -1.0 -1.0 -1.0 glVertex3f
-    -1.0 -1.0 1.0 glVertex3f
+        0.0 0.0 1.0 glColor3f
+        -1.0 1.0 1.0 glVertex3f
+        -1.0 1.0 -1.0 glVertex3f
+        -1.0 -1.0 -1.0 glVertex3f
+        -1.0 -1.0 1.0 glVertex3f

-    1.0 0.0 1.0 glColor3f
-    1.0 1.0 -1.0 glVertex3f
-    1.0 1.0 1.0 glVertex3f
-    1.0 -1.0 1.0 glVertex3f
-    1.0 -1.0 -1.0 glVertex3f
-  ] do-state 
-  [ 0.2 + ] change-rtri
-  [ 0.15 - ] change-rquad drop ;
+        1.0 0.0 1.0 glColor3f
+        1.0 1.0 -1.0 glVertex3f
+        1.0 1.0 1.0 glVertex3f
+        1.0 -1.0 1.0 glVertex3f
+        1.0 -1.0 -1.0 glVertex3f
+    ] do-state
+    [ 0.2 + ] change-rtri
+    [ 0.15 - ] change-rquad drop ;

-: nehe5-update-thread ( gadget -- )  
-  dup quit?>> [
-    drop
-  ] [
-    redraw-interval sleep 
-    dup relayout-1  
-    nehe5-update-thread 
-  ] if ;
+: nehe5-update-thread ( gadget -- )
+    dup quit?>> [
+        drop
+    ] [
+        redraw-interval sleep
+        dup relayout-1
+        nehe5-update-thread
+    ] if ;

 M: nehe5-gadget graft* ( gadget -- )
-  f >>quit?
-  [ nehe5-update-thread ] curry in-thread ;
+    f >>quit?
+    [ nehe5-update-thread ] curry in-thread ;

 M: nehe5-gadget ungraft* ( gadget -- )
-  t >>quit? drop ;
+    t >>quit? drop ;

-MAIN-WINDOW: run5 { { title "NeHe Tutorial 5" } { pref-dim { $ width $ height } } }
-  <nehe5-gadget> >>gadgets ;
+MAIN-WINDOW: run5
+    {
+        { title "NeHe Tutorial 5" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
+    <nehe5-gadget> >>gadgets ;