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

2009-05-01 13:01:04 -05:00 · 2009-05-01 13:01:04 -05:00 · c8739f5430
parent b45ea14d39 06bc18342c
commit c8739f5430
125 changed files with 3076 additions and 172 deletions
--- a/1
+++ b/1
@ -10,7 +10,6 @@ VERSION = 0.92
 BUNDLE = Factor.app
 LIBPATH = -L/usr/X11R6/lib
 CFLAGS = -Wall -Werror
-FFI_TEST_CFLAGS = -fPIC

 ifdef DEBUG
 	CFLAGS += -g -DFACTOR_DEBUG
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
    ] when* ;

 : init-alarms ( -- )
-    alarms global [ cancel-alarms <min-heap> ] change-at
+    alarms [ cancel-alarms <min-heap> ] change-global
    [ alarm-thread-loop t ] "Alarms" spawn-server
    alarm-thread set-global ;

--- a/basis/alien/libraries/libraries-docs.factor
+++ b/basis/alien/libraries/libraries-docs.factor
@ -15,7 +15,7 @@ HELP: libraries
 { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;

 HELP: library
-{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $values { "name" "a string" } { "library" assoc } }
 { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
    { $list
        { { $snippet "name" } " - the full path of the C library binary" }
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@ -23,7 +23,7 @@ IN: bootstrap.compiler

 "cpu." cpu name>> append require

-enable-compiler
+enable-optimizer

 ! Push all tuple layouts to tenured space to improve method caching
 gc
--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@ -7,7 +7,7 @@ compiler.units lexer init ;
 IN: cocoa

 : (remember-send) ( selector variable -- )
-    global [ dupd ?set-at ] change-at ;
+    [ dupd ?set-at ] change-global ;

 SYMBOL: sent-messages

--- a/basis/compiler/compiler-docs.factor
+++ b/basis/compiler/compiler-docs.factor
@ -4,16 +4,16 @@ compiler.units help.markup help.syntax io parser quotations
 sequences words ;
 IN: compiler

-HELP: enable-compiler
+HELP: enable-optimizer
 { $description "Enables the optimizing compiler." } ;

-HELP: disable-compiler
+HELP: disable-optimizer
 { $description "Disable the optimizing compiler." } ;

 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"
-{ $subsection disable-compiler }
-{ $subsection enable-compiler }
+{ $subsection disable-optimizer }
+{ $subsection enable-optimizer }
 "Removing a word's optimized definition:"
 { $subsection decompile }
 "Compiling a single quotation:"
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@ -192,10 +192,13 @@ M: optimizing-compiler recompile ( words -- alist )
        compiled get >alist
    ] with-scope ;

-: enable-compiler ( -- )
+: with-optimizer ( quot -- )
+    [ optimizing-compiler compiler-impl ] dip with-variable ; inline
+
+: enable-optimizer ( -- )
    optimizing-compiler compiler-impl set-global ;

-: disable-compiler ( -- )
+: disable-optimizer ( -- )
    f compiler-impl set-global ;

 : recompile-all ( -- )
--- a/basis/compiler/tests/call-effect.factor
+++ b/basis/compiler/tests/call-effect.factor
@ -4,4 +4,11 @@ USING: tools.test combinators generic.single sequences kernel ;
 : execute-ic-test ( a b -- c ) execute( a -- c ) ;

 ! VM type check error
-[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+
+: call-test ( q -- ) call( -- ) ;
+
+[ ] [ [ ] call-test ] unit-test
+[ ] [ f [ drop ] curry call-test ] unit-test
+[ ] [ [ ] [ ] compose call-test ] unit-test
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
--- a/basis/compiler/tests/generic.factor
+++ b/basis/compiler/tests/generic.factor
@ -0,0 +1,11 @@
+IN: compiler.tests.generic
+USING: tools.test math kernel compiler.units definitions ;
+
+GENERIC: bad ( -- )
+M: integer bad ;
+M: object bad ;
+
+[ 0 bad ] must-fail
+[ "" bad ] must-fail
+
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
--- a/basis/compiler/tests/redefine14.factor
+++ b/basis/compiler/tests/redefine14.factor
@ -1,8 +1,8 @@
 USING: compiler.units definitions tools.test sequences ;
 IN: compiler.tests.redefine14

-! TUPLE: bad ;
-! 
-! M: bad length 1 2 3 ;
-! 
-! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
+TUPLE: bad ;
+
+M: bad length 1 2 3 ;
+
+[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
--- a/basis/compiler/tests/redefine17.factor
+++ b/basis/compiler/tests/redefine17.factor
@ -0,0 +1,49 @@
+IN: compiler.tests.redefine17
+USING: tools.test classes.mixin compiler.units arrays kernel.private
+strings sequences vocabs definitions kernel ;
+
+<< "compiler.tests.redefine17" words forget-all >>
+
+GENERIC: bong ( a -- b )
+
+M: array bong ;
+
+M: string bong length ;
+
+MIXIN: mixin
+
+INSTANCE: array mixin
+
+: blah ( a -- b ) { mixin } declare bong ;
+
+[ { } ] [ { } blah ] unit-test
+
+[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 0 ] [ "" blah ] unit-test
+
+MIXIN: mixin1
+
+INSTANCE: string mixin1
+
+MIXIN: mixin2
+
+GENERIC: billy ( a -- b )
+
+M: mixin2 billy ;
+
+M: array billy drop "BILLY" ;
+
+INSTANCE: string mixin2
+
+: bully ( a -- b ) { mixin1 } declare billy ;
+
+[ "" ] [ "" bully ] unit-test
+
+[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "BILLY" ] [ { } bully ] unit-test
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }

 : <value-info> ( -- info ) \ value-info new ;

-: read-only-slots ( values class -- slots )
-    all-slots
-    [ read-only>> [ drop f ] unless ] 2map
-    f prefix ;
-
 DEFER: <literal-info>

+: tuple-slot-infos ( tuple -- slots )
+    [ tuple-slots ] [ class all-slots ] bi
+    [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+    f prefix ;
+
 : init-literal-info ( info -- info )
    dup literal>> class >>class
    dup literal>> dup real? [ [a,a] >>interval ] [
        [ [-inf,inf] >>interval ] dip
-        dup tuple? [
-            [ tuple-slots [ <literal-info> ] map ] [ class ] bi
-            read-only-slots >>slots
-        ] [ drop ] if
+        dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
    ] if ; inline

 : init-value-info ( info -- info )
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
 IN: compiler.tree.propagation.tests

 [ V{ } ] [ [ ] final-classes ] unit-test
@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test

 [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ;
    [ [ literal>> ] map ] dip prefix >tuple
    <literal-info> ;

+: read-only-slots ( values class -- slots )
+    all-slots
+    [ read-only>> [ value-info ] [ drop f ] if ] 2map
+    f prefix ;
+
 : (propagate-tuple-constructor) ( values class -- info )
-    [ [ value-info ] map ] dip [ read-only-slots ] keep
+    [ read-only-slots ] keep
    over rest-slice [ dup [ literal?>> ] when ] all? [
        [ rest-slice ] dip fold-<tuple-boa>
    ] [
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
    \ event-stream-counter counter ;

 [
-    event-stream-callbacks global
-    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
+    event-stream-callbacks
+    [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
 ] "core-foundation" add-init-hook

 : add-event-source-callback ( quot -- id )
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
    check_sse2 ;

 "-no-sse2" (command-line) member? [
-    optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
+    [ { check_sse2 } compile ] with-optimizer

    "Checking if your CPU supports SSE2..." print flush
    sse2? [
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@ -1,6 +1,6 @@
 USING: delegate kernel arrays tools.test words math definitions
 compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline generic.standard delegate.protocols
+accessors eval multiline generic.single delegate.protocols
 delegate.private assocs see ;
 IN: delegate.tests

--- a/basis/documents/elements/elements.factor
+++ b/basis/documents/elements/elements.factor
@ -79,6 +79,13 @@ M: one-word-elt next-elt
    drop
    [ f next-word ] modify-col ;

+SINGLETON: word-start-elt
+
+M: word-start-elt prev-elt
+    drop one-word-elt prev-elt ;
+
+M: word-start-elt next-elt 2drop ;
+
 SINGLETON: word-elt

 M: word-elt prev-elt
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@ -1,6 +1,7 @@
 USING: http help.markup help.syntax io.pathnames io.streams.string
 io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences destructors ;
+urls.encoding byte-arrays strings assocs sequences destructors
+http.client.post-data.private ;
 IN: http.client

 HELP: download-failed
@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 { $subsection with-http-get }
 { $subsection with-http-request } ;

-ARTICLE: "http.client.post-data" "HTTP client submission data"
+ARTICLE: "http.client.post-data" "HTTP client post data"
 "HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
 { $list
    { "a " { $link byte-array } ": the data is sent the server without further encoding" }
@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
 { $code
  "\"my-large-post-request.txt\" ascii <file-reader>"
  "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
-} ;
+}
+"An internal word used to convert objects to " { $link post-data } " instances:"
+{ $subsection >post-data } ;

 ARTICLE: "http.client.post" "POST requests with the HTTP client"
 "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
--- a/basis/http/client/post-data/post-data-docs.factor
+++ b/basis/http/client/post-data/post-data-docs.factor
@ -0,0 +1,6 @@
+IN: http.client.post-data
+USING: http http.client.post-data.private help.markup help.syntax kernel ;
+
+HELP: >post-data
+{ $values { "object" object } { "post-data" { $maybe post-data } } }
+{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;
--- a/basis/io/styles/styles-docs.factor
+++ b/basis/io/styles/styles-docs.factor
@ -1,17 +1,17 @@
 USING: help.markup help.syntax io.streams.plain io strings
-hashtables kernel quotations colors ;
+hashtables kernel quotations colors assocs ;
 IN: io.styles

 HELP: stream-format
-{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
 { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
 $nl
-"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
 { $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
 $io-error ;

 HELP: make-block-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
 { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
 $nl
 "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
@ -21,7 +21,7 @@ $nl
 $io-error ;

 HELP: stream-write-table
-{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
 { $contract "Prints a table of cells produced by " { $link with-cell } "."
 $nl
 "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -29,13 +29,13 @@ $nl
 $io-error ;

 HELP: make-cell-stream
-{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
 { $contract "Creates an output stream which writes to a table cell object." }
 { $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
 $io-error ;

 HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
 { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
 $nl
 "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
@ -43,19 +43,19 @@ $nl
 $io-error ;

 HELP: format
-{ $values { "str" string } { "style" "a hashtable" } }
+{ $values { "str" string } { "style" assoc } }
 { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
 { $notes "Details are in the documentation for " { $link stream-format } "." }
 $io-error ;

 HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
 { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
 { $notes "Details are in the documentation for " { $link make-block-stream } "." }
 $io-error ;

 HELP: tabular-output
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
 { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
 $nl
 "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -85,7 +85,7 @@ HELP: write-cell
 $io-error ;

 HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
 { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
 { $notes "Details are in the documentation for " { $link make-span-stream } "." }
 $io-error ;
--- a/basis/macros/macros-docs.factor
+++ b/basis/macros/macros-docs.factor
@ -49,6 +49,7 @@ $nl
 { $subsection POSTPONE: MACRO: }
 "A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
 { $subsection define-transform }
-"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
+"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
+{ $see-also "generalizations" "fry" } ;

 ABOUT: "macros"
--- a/basis/peg/peg-tests.factor
+++ b/basis/peg/peg-tests.factor
@ -199,10 +199,10 @@ IN: peg.tests

 USE: compiler

-[ ] [ disable-compiler ] unit-test
+[ ] [ disable-optimizer ] unit-test

 [ ] [ "" epsilon parse drop ] unit-test

-[ ] [ enable-compiler ] unit-test
+[ ] [ enable-optimizer ] unit-test

 [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
--- a/basis/refs/refs-docs.factor
+++ b/basis/refs/refs-docs.factor
@ -1,14 +1,18 @@
 ! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: boxes help.markup help.syntax kernel math namespaces ;
+USING: boxes help.markup help.syntax kernel math namespaces assocs ;
 IN: refs

 ARTICLE: "refs" "References"
-"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
-{ $subsection get-ref }
-{ $subsection set-ref }
-{ $subsection set-ref* }
-{ $subsection delete-ref }
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol."
+{ $subsection "refs-protocol" }
+{ $subsection "refs-impls" }
+{ $subsection "refs-utils" }
+"References are used by the " { $link "ui-inspector" } "." ;
+
+ABOUT: "refs"
+
+ARTICLE: "refs-impls" "Reference implementations"
 "References to objects:"
 { $subsection obj-ref }
 { $subsection <obj-ref> }
@ -27,20 +31,24 @@ ARTICLE: "refs" "References"
 { $subsection slot-ref }
 { $subsection <slot-ref> }
 "Using boxes as references:"
-{ $subsection "box-refs" }
-"References are used by the UI inspector." ;
+{ $subsection "box-refs" } ;

-ABOUT: "refs"
+ARTICLE: "refs-utils" "Reference utilities"
+{ $subsection ref-on }
+{ $subsection ref-off }
+{ $subsection ref-inc }
+{ $subsection ref-dec }
+{ $subsection set-ref* } ;

-ARTICLE: "refs-protocol" "Reference Protocol"
+ARTICLE: "refs-protocol" "Reference protocol"
 "To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
 { $subsection get-ref }
 { $subsection set-ref }
 "References may also implement:"
 { $subsection delete-ref } ;

-ARTICLE: "box-refs" "Using Boxes as References"
-"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+ARTICLE: "box-refs" "Boxes as references"
+{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;

 HELP: ref
 { $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
@ -89,14 +97,14 @@ HELP: key-ref
 { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;

 HELP: <key-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } }
+{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } }
 { $description "Creates a reference to a key stored in an assoc." } ;

 HELP: value-ref
 { $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;

 HELP: <value-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
+{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } }
 { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;

 { get-ref set-ref delete-ref set-ref* } related-words
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/stack-checker/call-effect/call-effect.factor
@ -19,7 +19,7 @@ IN: stack-checker.call-effect
 TUPLE: inline-cache value ;

 : cache-hit? ( word/quot ic -- ? )
-    [ value>> ] [ value>> eq? ] bi and ; inline
+    [ value>> eq? ] [ value>> ] bi and ; inline

 SINGLETON: +unknown+

--- a/basis/stack-checker/errors/errors-docs.factor
+++ b/basis/stack-checker/errors/errors-docs.factor
@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error
 } ;

 ARTICLE: "inference-errors" "Stack checker errors"
-"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
-$nl
+"These " { $link "inference" } " failure conditions are reported in one of two ways:"
+{ $list
+    { { $link "tools.inference" } " throws them as errors" }
+    { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
+}
 "Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
 { $subsection literal-expected }
 "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@ -19,7 +19,6 @@ IN: stack-checker.transforms
    rstate recursive-state
    [ word stack quot call-transformer ] with-variable
    [
-        word inlined-dependency depends-on
        values [ length meta-d shorten-by ] [ #drop, ] bi
        rstate infer-quot
    ] [ word infer-word ] if* ;
--- a/basis/tools/deploy/test/test.factor
+++ b/basis/tools/deploy/test/test.factor
@ -16,4 +16,5 @@ IN: tools.deploy.test
 : run-temp-image ( -- )
    vm
    "-i=" "test.image" temp-file append
-    2array try-process ;
+    2array
+    <process> swap >>command +closed+ >>stdin try-process ;
--- a/basis/tools/disassembler/disassembler-tests.factor
+++ b/basis/tools/disassembler/disassembler-tests.factor
@ -1,6 +1,4 @@
 IN: tools.disassembler.tests
-USING: math classes.tuple prettyprint.custom 
-tools.disassembler tools.test strings ;
+USING: kernel fry vocabs tools.disassembler tools.test sequences ;

-[ ] [ \ + disassemble ] unit-test
-[ ] [ M\ string pprint* disassemble ] unit-test
+"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each
--- a/basis/tools/disassembler/udis/udis.factor
+++ b/basis/tools/disassembler/udis/udis.factor
@ -3,7 +3,7 @@
 USING: tools.disassembler namespaces combinators
 alien alien.syntax alien.c-types lexer parser kernel
 sequences layouts math math.order alien.libraries
-math.parser system make fry arrays ;
+math.parser system make fry arrays libc destructors ;
 IN: tools.disassembler.udis

 <<
@ -47,11 +47,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ;
 FUNCTION: char* ud_lookup_mnemonic ( int c ) ;

 : <ud> ( -- ud )
-    "ud" <c-object>
+    "ud" malloc-object &free
    dup ud_init
    dup cell-bits ud_set_mode
    dup UD_SYN_INTEL ud_set_syntax ;

+: with-ud ( quot: ( ud -- ) -- )
+    [ [ <ud> ] dip call ] with-destructors ; inline
+
 SINGLETON: udis-disassembler

 : buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
@ -82,10 +85,12 @@ SINGLETON: udis-disassembler
    ] { } make ;

 M: udis-disassembler disassemble* ( from to -- buffer )
-    [ <ud> ] 2dip {
+    '[
+        _ _
        [ drop ud_set_pc ]
        [ buf/len ud_set_input_buffer ]
        [ 2drop (disassemble) format-disassembly ]
-    } 3cleave ;
+        3tri
+    ] with-ud ;

 udis-disassembler disassembler-backend set-global
--- a/basis/tools/vocabs/vocabs.factor
+++ b/basis/tools/vocabs/vocabs.factor
@ -74,8 +74,6 @@ SYMBOL: failures

 SYMBOL: changed-vocabs

-[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
-
 : changed-vocab ( vocab -- )
    dup vocab changed-vocabs get and
    [ dup changed-vocabs get set-at ] [ drop ] if ;
@ -287,3 +285,12 @@ MEMO: all-authors ( -- seq )
    \ all-vocabs-seq reset-memoized
    \ all-authors reset-memoized
    \ all-tags reset-memoized ;
+
+SINGLETON: cache-observer
+
+M: cache-observer vocabs-changed drop reset-cache ;
+
+[
+    f changed-vocabs set-global
+    cache-observer add-vocab-observer
+] "tools.vocabs" add-init-hook
--- a/basis/tuple-arrays/summary.txt
+++ b/basis/tuple-arrays/summary.txt
@ -0,0 +1 @@
+Efficient arrays of tuples with value semantics for elements
--- a/basis/tuple-arrays/tags.txt
+++ b/basis/tuple-arrays/tags.txt
@ -0,0 +1 @@
+collections
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/basis/ui/gadgets/sliders/sliders.factor
@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30
    [ slider-max* 1 max ]
    bi / ;

-: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ;
-: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ;
+: slider>screen ( m slider -- n ) slider-scale * ;
+: screen>slider ( m slider -- n ) slider-scale / ;

 M: slider model-changed nip elevator>> relayout-1 ;

@ -133,7 +133,7 @@ elevator H{
        swap >>orientation ;

 : thumb-loc ( slider -- loc )
-    [ slider-value ] keep slider>screen ;
+    [ slider-value ] keep slider>screen elevator-padding + ;

 : layout-thumb-loc ( thumb slider -- )
    [ thumb-loc ] [ orientation>> ] bi n*v
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@ -46,14 +46,16 @@ mouse-index
 { takes-focus? initial: t }
 focused? ;

-: <table> ( rows renderer -- table )
-    table new-line-gadget
+: new-table ( rows renderer class -- table )
+    new-line-gadget
        swap >>renderer
        swap >>model
        f <model> >>selected-value
        sans-serif-font >>font
        focus-border-color >>focus-border-color
-        transparent >>column-line-color ;
+        transparent >>column-line-color ; inline
+
+: <table> ( rows renderer -- table ) table new-table ;

 <PRIVATE

--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string )

 M: macosx keysym>string >upper ;

-M: object keysym>string ;
+M: object keysym>string dup length 1 = [ >lower ] when ;

 M: key-down gesture>string
    [ mods>> ] [ sym>> ] bi
    {
        { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
        { [ dup " " = ] [ drop "SPACE" ] }
-        [ keysym>string ]
+        [ ]
    } cond
-    [ modifiers>string ] dip append ;
+    [ modifiers>string ] [ keysym>string ] bi* append ;

 M: button-up gesture>string
    [
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@ -25,7 +25,10 @@ M: browser-gadget set-history-value

 : show-help ( link browser-gadget -- )
    [ >link ] dip
-    [ [ add-recent ] [ history>> add-history ] bi* ]
+    [
+        2dup model>> value>> =
+        [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
+    ]
    [ model>> set-model ]
    2bi ;

--- a/basis/ui/tools/common/common.factor
+++ b/basis/ui/tools/common/common.factor
@ -7,7 +7,7 @@ IN: ui.tools.common

 SYMBOL: tool-dims

-tool-dims global [ H{ } clone or ] change-at
+tool-dims [ H{ } clone ] initialize

 TUPLE: tool < track ;

--- a/basis/ui/tools/listener/completion/completion.factor
+++ b/basis/ui/tools/listener/completion/completion.factor
@ -39,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ;

 GENERIC: completion-element ( completion-mode -- element )

-M: object completion-element drop one-word-elt ;
+M: object completion-element drop word-start-elt ;
 M: history-completion completion-element drop one-line-elt ;

 GENERIC: completion-banner ( completion-mode -- string )
@ -72,13 +72,13 @@ M: vocab-completion row-color
    drop vocab? COLOR: black COLOR: dark-gray ? ;

 : complete-IN:/USE:? ( tokens -- ? )
-    2 short tail* { "IN:" "USE:" } intersects? ;
+    1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;

 : chop-; ( seq -- seq' )
    { ";" } split1-last [ ] [ ] ?if ;

 : complete-USING:? ( tokens -- ? )
-    chop-; { "USING:" } intersects? ;
+    chop-; 1 short head* { "USING:" } intersects? ;

 : complete-CHAR:? ( tokens -- ? )
    2 short tail* "CHAR:" swap member? ;
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@ -28,7 +28,7 @@ SYMBOL: windows
    [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;

 : unregister-window ( handle -- )
-    windows global [ [ first = not ] with filter ] change-at ;
+    windows [ [ first = not ] with filter ] change-global ;

 : raised-window ( world -- )
    windows get-global
--- a/basis/windows/dinput/constants/constants.factor
+++ b/basis/windows/dinput/constants/constants.factor
@ -842,7 +842,7 @@ SYMBOLS:
 [ define-constants ] "windows.dinput.constants" add-init-hook

 : uninitialize ( variable quot -- )
-    [ global ] dip '[ _ when* f ] change-at ; inline
+    '[ _ when* f ] change-global ; inline

 : free-dinput-constants ( -- )
    {
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@ -205,7 +205,7 @@ find_architecture() {

 write_test_program() {
    echo "#include <stdio.h>" > $C_WORD.c
-    echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+    echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
 }

 c_find_word_size() {
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@ -290,7 +290,6 @@ $nl
 "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
 { $subsection call-effect }
 { $subsection execute-effect }
-{ $subsection "call-unsafe" }
 "The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
 { $subsection "call-unsafe" }
 { $see-also "effects" "inference" } ;
@ -306,6 +305,7 @@ ARTICLE: "combinators" "Combinators"
 { $subsection "combinators.smart" }
 "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
 { $subsection "combinators-quot" }
+{ $subsection "generalizations" }
 { $see-also "quotations" } ;

 ABOUT: "combinators"
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
--- a/core/compiler/units/units-tests.factor
+++ b/core/compiler/units/units-tests.factor
@ -19,7 +19,7 @@ IN: compiler.units.tests
 ] unit-test

 [ "A" "B" ] [
-    disable-compiler
+    disable-optimizer

    gensym "a" set
    gensym "b" set
@ -33,7 +33,7 @@ IN: compiler.units.tests
    ] with-compilation-unit
    "b" get execute

-    enable-compiler
+    enable-optimizer
 ] unit-test

 ! Check that we notify observers
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist )
 ! Non-optimizing compiler
 M: f recompile [ dup def>> ] { } map>assoc ;

+: without-optimizer ( quot -- )
+    [ f compiler-impl ] dip with-variable ; inline
+
 ! Trivial compiler. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
 SINGLETON: dummy-compiler
@ -58,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- )
 [ V{ } clone definition-observers set-global ]
 "compiler.units" add-init-hook

+! This goes here because vocabs cannot depend on init
+[ V{ } clone vocab-observers set-global ]
+"vocabs" add-init-hook
+
 : add-definition-observer ( obj -- )
    definition-observers get push ;

--- a/core/hashtables/hashtables-docs.factor
+++ b/core/hashtables/hashtables-docs.factor
@ -116,7 +116,7 @@ HELP: ?set-at
 { $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;

 HELP: >hashtable
-{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
+{ $values { "assoc" assoc } { "hashtable" hashtable } }
 { $description "Constructs a hashtable from any assoc." } ;

 HELP: rehash
--- a/core/init/init.factor
+++ b/core/init/init.factor
@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations continuations.private kernel
-kernel.private sequences assocs namespaces namespaces.private ;
+kernel.private sequences assocs namespaces namespaces.private
+continuations continuations.private ;
 IN: init

 SYMBOL: init-hooks
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@ -1,7 +1,7 @@
 USING: arrays debugger.threads destructors io io.directories
 io.encodings.8-bit io.encodings.ascii io.encodings.binary
 io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test generic.standard ;
+make math sequences system threads tools.test generic.single ;
 IN: io.files.tests

 [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private
 sequences words namespaces.private quotations vectors
-math.parser math words.symbol ;
+math.parser math words.symbol assocs ;
 IN: namespaces

 ARTICLE: "namespaces-combinators" "Namespace combinators"
@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values"
 { $subsection off }
 { $subsection inc }
 { $subsection dec }
-{ $subsection change } ;
+{ $subsection change }
+{ $subsection change-global } ;

 ARTICLE: "namespaces-global" "Global variables"
 { $subsection namespace }
@ -73,6 +74,11 @@ HELP: change
 { $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
 { $side-effects "variable" } ;

+HELP: change-global
+{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." }
+{ $side-effects "variable" } ;
+
 HELP: +@
 { $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } }
 { $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
@ -113,19 +119,19 @@ HELP: with-variable
 } ;

 HELP: make-assoc
-{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } }
+{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
 { $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;

 HELP: bind
-{ $values { "ns" "a hashtable" } { "quot" quotation } }
+{ $values { "ns" assoc } { "quot" quotation } }
 { $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;

 HELP: namespace
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
 { $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ;

 HELP: global
-{ $values { "g" "an assoc" } }
+{ $values { "g" assoc } }
 { $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ;

 HELP: get-global
@ -150,7 +156,7 @@ HELP: set-namestack
 { $description "Replaces the name stack with a copy of the given vector." } ;

 HELP: >n
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
 { $description "Pushes a namespace on the name stack." } ;

 HELP: ndrop
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@ -24,12 +24,13 @@ PRIVATE>
 : get-global ( variable -- value ) global at ;
 : set-global ( value variable -- ) global set-at ;
 : change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
+: change-global ( variable quot -- ) [ global ] dip change-at ; inline
 : +@ ( n variable -- ) [ 0 or + ] change ;
 : inc ( variable -- ) 1 swap +@ ; inline
 : dec ( variable -- ) -1 swap +@ ; inline
 : bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
+: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
 : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
 : with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
 : with-variable ( value key quot -- ) [ associate ] dip bind ; inline
-: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
+: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@ -1,4 +1,4 @@
-USING: kernel help.markup help.syntax sequences quotations ;
+USING: kernel help.markup help.syntax sequences quotations assocs ;
 IN: sets

 ARTICLE: "sets" "Set-theoretic operations on sequences"
@ -42,7 +42,7 @@ HELP: adjoin
 { $side-effects "seq" } ;

 HELP: conjoin
-{ $values { "elt" object } { "assoc" "an assoc" } }
+{ $values { "elt" object } { "assoc" assoc } }
 { $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
 { $examples
    { $example
@ -54,7 +54,7 @@ HELP: conjoin
 { $side-effects "assoc" } ;

 HELP: unique
-{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $values { "seq" "a sequence" } { "assoc" assoc } }
 { $description "Outputs a new assoc where the keys and values are equal." }
 { $examples
    { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
--- a/core/slots/slots-tests.factor
+++ b/core/slots/slots-tests.factor
@ -1,5 +1,5 @@
 IN: slots.tests
-USING: math accessors slots strings generic.standard kernel
+USING: math accessors slots strings generic.single kernel
 tools.test generic words parser eval math.functions ;

 TUPLE: r/w-test foo ;
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@ -58,7 +58,7 @@ unit-test
 [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test

 ! Random tester found this
-[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
+[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with

 ! Make sure 24-bit strings work
 "hello world" "s" set
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ;

 M: f vocab-main ;

+SYMBOL: vocab-observers
+
+GENERIC: vocabs-changed ( obj -- )
+
+: add-vocab-observer ( obj -- )
+    vocab-observers get push ;
+
+: remove-vocab-observer ( obj -- )
+    vocab-observers get delq ;
+
+: notify-vocab-observers ( -- )
+    vocab-observers get [ vocabs-changed ] each ;
+
 : create-vocab ( name -- vocab )
-    dictionary get [ <vocab> ] cache ;
+    dictionary get [ <vocab> ] cache
+    notify-vocab-observers ;

 ERROR: no-vocab name ;

@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;

 : forget-vocab ( vocab -- )
    dup words forget-all
-    vocab-name dictionary get delete-at ;
+    vocab-name dictionary get delete-at
+    notify-vocab-observers ;

 M: vocab-spec forget* forget-vocab ;

--- a/extra/bson/bson.factor
+++ b/extra/bson/bson.factor
@ -0,0 +1,6 @@
+USING: vocabs.loader ;
+
+IN: bson
+
+"bson.reader" require
+"bson.writer" require
--- a/extra/bson/constants/constants.factor
+++ b/extra/bson/constants/constants.factor
@ -0,0 +1,49 @@
+USING: accessors constructors kernel strings uuid ;
+
+IN: bson.constants
+
+: <objid> ( -- objid )
+   uuid1 ; inline
+
+TUPLE: oid { a initial: 0 } { b initial: 0 } ;
+
+TUPLE: objref ns objid ;
+
+CONSTRUCTOR: objref ( ns objid -- objref ) ;
+
+TUPLE: mdbregexp { regexp string } { options string } ;
+
+: <mdbregexp> ( string -- mdbregexp )
+   [ mdbregexp new ] dip >>regexp ;
+
+
+CONSTANT: MDB_OID_FIELD "_id"
+CONSTANT: MDB_META_FIELD "_mfd"
+
+CONSTANT: T_EOO  0  
+CONSTANT: T_Double  1  
+CONSTANT: T_Integer  16  
+CONSTANT: T_Boolean  8  
+CONSTANT: T_String  2  
+CONSTANT: T_Object  3  
+CONSTANT: T_Array  4  
+CONSTANT: T_Binary  5  
+CONSTANT: T_Undefined  6  
+CONSTANT: T_OID  7  
+CONSTANT: T_Date  9  
+CONSTANT: T_NULL  10  
+CONSTANT: T_Regexp  11  
+CONSTANT: T_DBRef  12  
+CONSTANT: T_Code  13  
+CONSTANT: T_ScopedCode  17  
+CONSTANT: T_Symbol  14  
+CONSTANT: T_JSTypeMax  16  
+CONSTANT: T_MaxKey  127  
+
+CONSTANT: T_Binary_Function 1   
+CONSTANT: T_Binary_Bytes 2
+CONSTANT: T_Binary_UUID 3
+CONSTANT: T_Binary_MD5 5
+CONSTANT: T_Binary_Custom 128
+
+
--- a/extra/bson/reader/reader.factor
+++ b/extra/bson/reader/reader.factor
@ -0,0 +1,200 @@
+USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
+io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
+sequences serialize arrays calendar io.encodings ;
+
+IN: bson.reader
+
+<PRIVATE
+
+TUPLE: element { type integer } name ;
+TUPLE: state
+    { size initial: -1 } { read initial: 0 } exemplar
+    result scope element ;
+
+: <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 ; 
+
+PREDICATE: bson-eoo     < integer T_EOO = ;
+PREDICATE: bson-not-eoo < integer T_EOO > ;
+
+PREDICATE: bson-double  < integer T_Double = ;
+PREDICATE: bson-integer < integer T_Integer = ;
+PREDICATE: bson-string  < integer T_String = ;
+PREDICATE: bson-object  < integer T_Object = ;
+PREDICATE: bson-array   < integer T_Array = ;
+PREDICATE: bson-binary  < integer T_Binary = ;
+PREDICATE: bson-regexp  < integer T_Regexp = ;
+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 = ;
+PREDICATE: bson-oid     < integer T_OID = ;
+PREDICATE: bson-boolean < integer T_Boolean = ;
+PREDICATE: bson-date    < integer T_Date = ;
+PREDICATE: bson-null    < integer T_NULL = ;
+PREDICATE: bson-ref     < integer T_DBRef = ;
+
+GENERIC: element-read ( type -- cont? )
+GENERIC: element-data-read ( type -- object )
+GENERIC: element-binary-read ( length type -- object )
+
+: byte-array>number ( seq -- number )
+    byte-array>bignum >integer ; inline
+
+: get-state ( -- state )
+    state get ; inline
+
+: count-bytes ( count -- )
+    [ get-state ] dip '[ _ + ] change-read drop ; inline
+
+: read-int32 ( -- int32 )
+    4 [ read byte-array>number ] [ count-bytes ] bi  ; inline
+
+: read-longlong ( -- longlong )
+    8 [ read byte-array>number ] [ count-bytes ] bi ; inline
+
+: read-double ( -- double )
+    8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
+
+: read-byte-raw ( -- byte-raw )
+    1 [ read ] [ count-bytes ] bi ; inline
+
+: read-byte ( -- byte )
+    read-byte-raw first ; inline
+
+: read-cstring ( -- string )
+    input-stream get utf8 <decoder>
+    "\0" swap stream-read-until drop ; inline
+
+: read-sized-string ( length -- string )
+    drop read-cstring ; inline
+
+: read-element-type ( -- type )
+    read-byte ; inline
+
+: push-element ( type name -- element )
+    element boa
+    [ get-state element>> push ] keep ; inline
+
+: pop-element ( -- element )
+    get-state element>> pop ; inline
+
+: peek-scope ( -- ht )
+    get-state scope>> peek ; inline
+
+: read-elements ( -- )
+    read-element-type
+    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 -- )
+    drop
+    pop-element drop ;
+
+M: bson-eoo element-read ( type -- cont? )
+    drop
+    get-state scope>> [ pop ] keep swap ! vec assoc
+    pop-element [ type>> ] keep       ! vec assoc element
+    [ fix-result ] dip
+    rot length 0 >                      ! assoc element 
+    [ name>> peek-scope set-at t ]
+    [ drop [ get-state ] dip >>result drop f ] if ;
+
+M: bson-not-eoo element-read ( type -- cont? )
+    [ peek-scope ] dip                                 ! scope type 
+    '[ _ read-cstring push-element [ name>> ] [ type>> ] bi 
+       [ element-data-read ] keep
+       end-element
+       swap
+    ] dip set-at t ;
+
+: [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>> peek ; inline
+    
+M: bson-object element-data-read ( type -- object )
+    (object-data-read) ;
+
+M: bson-array element-data-read ( type -- object )
+    (object-data-read) ;
+    
+M: bson-string element-data-read ( type -- object )
+    drop
+    read-int32 read-sized-string ;
+
+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-custom element-binary-read ( size type -- dbref )
+    2drop
+    read-cstring
+    read-cstring objref boa ;
+
+M: bson-binary-bytes element-binary-read ( size type -- bytes )
+    drop read ;
+
+M: bson-binary-function element-binary-read ( size type -- quot )
+    drop read bytes>object ;
+
+PRIVATE>
+
+: stream>assoc ( exemplar -- assoc bytes-read )
+    <state> dup state
+    [ read-int32 >>size read-elements ] with-variable 
+    [ result>> ] [ read>> ] bi ; 
--- a/extra/bson/writer/writer.factor
+++ b/extra/bson/writer/writer.factor
@ -0,0 +1,164 @@
+! Copyright (C) 2008 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 ;
+
+IN: bson.writer
+
+<PRIVATE
+
+SYMBOL: shared-buffer 
+
+CONSTANT: INT32-SIZE 4
+CONSTANT: CHAR-SIZE 1
+CONSTANT: INT64-SIZE 8
+
+: (buffer) ( -- buffer )
+    shared-buffer get
+    [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
+
+: >le-stream ( x n -- )
+    swap
+    '[ _ swap nth-byte 0 B{ 0 }
+       [ set-nth-unsafe ] keep write ] each ; inline
+
+PRIVATE>
+
+: reset-buffer ( buffer -- )
+    0 >>length drop ; inline
+
+: ensure-buffer ( -- )
+    (buffer) drop ; inline
+
+: with-buffer ( quot -- byte-vector )
+    [ (buffer) [ reset-buffer ] keep dup ] dip
+    with-output-stream* dup encoder? [ stream>> ] when ; inline
+
+: with-length ( quot: ( -- ) -- bytes-written start-index )
+    [ (buffer) [ length ] keep ] dip call
+    length swap [ - ] keep ; inline
+
+: with-length-prefix ( quot: ( -- ) -- )
+    [ B{ 0 0 0 0 } write ] prepose with-length
+    [ INT32-SIZE >le ] dip (buffer)
+    '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+    [ INT32-SIZE ] dip each-integer ; inline
+
+: with-length-prefix-excl ( quot: ( -- ) -- )
+    [ B{ 0 0 0 0 } write ] prepose with-length
+    [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
+    '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+    [ INT32-SIZE ] dip each-integer ; inline
+    
+<PRIVATE
+
+GENERIC: bson-type? ( obj -- type ) foldable flushable
+GENERIC: bson-write ( obj -- )
+
+M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
+M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
+
+M: real bson-type? ( real -- type ) drop T_Double ; 
+M: word bson-type? ( word -- type ) drop T_String ; 
+M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
+M: sequence bson-type? ( seq -- type ) drop T_Array ;
+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: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
+M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+
+M: oid bson-type? ( word -- type ) drop T_OID ;
+M: objref bson-type? ( objref -- 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-utf8-string ( string -- )
+    output-stream get utf8 <encoder> stream-write ; inline
+
+: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
+: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
+: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
+: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
+: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline
+
+: write-eoo ( -- ) T_EOO write-byte ; inline
+: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
+
+M: f bson-write ( f -- )
+    drop 0 write-byte ; 
+
+M: t bson-write ( t -- )
+    drop 1 write-byte ;
+
+M: string bson-write ( obj -- )
+    '[ _ write-cstring ] with-length-prefix-excl ;
+
+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 write-byte
+    write ; 
+
+M: quotation bson-write ( quotation -- )
+    object>bytes [ length write-int32 ] keep
+    T_Binary_Function write-byte
+    write ; 
+
+M: oid bson-write ( oid -- )
+    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
+
+M: objref bson-write ( objref -- )
+    [ binary ] dip
+    '[ _
+       [ ns>> write-cstring ]
+       [ objid>> write-cstring ] bi ] with-byte-writer
+    [ length write-int32 ] keep
+    T_Binary_Custom write-byte write ;
+       
+M: mdbregexp bson-write ( regexp -- )
+   [ 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 ;
+
+: 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
+       write-eoo ] with-length-prefix ; 
+
+M: word bson-write name>> bson-write ;
+
+PRIVATE>
+
+: assoc>bv ( assoc -- byte-vector )
+    [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+
+: assoc>stream ( assoc -- )
+    bson-write ; inline
+
+: mdb-special-value? ( value -- ? )
+   { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
+     [ oid? ] [ byte-array? ] } 1|| ;
--- a/extra/crypto/hmac/hmac-tests.factor
+++ b/extra/crypto/hmac/hmac-tests.factor
@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math
 parser crypto.hmac tools.test ;
 IN: crypto.hmac.tests

-[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
-[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
-[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
+[
+    "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
+] [
+    16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test

-[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
+[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
+
+[
+    "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
+]
+[
+    16 HEX: aa <string>
+    50 HEX: dd <repetition> sequence>md5-hmac >string
+] unit-test
+
+[
+    "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
+] [
+    16 11 <string> "Hi There" sequence>sha1-hmac >string
+] unit-test
+
+[
+    "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
+] [
+    "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string
+] unit-test
+
+[
+    "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
+] [
+    16 HEX: aa <string>
+    50 HEX: dd <repetition> sequence>sha1-hmac >string
+] unit-test
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences
 io.encodings.binary ;
 IN: crypto.hmac

+<PRIVATE
+
 : sha1-hmac ( Ko Ki -- hmac )
    initialize-sha1 process-sha1-block
    stream>sha1 get-sha1
@ -24,6 +26,7 @@ IN: crypto.hmac
    [ bitxor ] 2map ;

 MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+
 MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;

 : init-hmac ( K -- o i )
@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
    [ opad seq-bitxor ] keep
    ipad seq-bitxor ;

+PRIVATE>
+
 : stream>sha1-hmac ( K stream -- hmac )
    [ init-hmac sha1-hmac ] with-input-stream ;

 : file>sha1-hmac ( K path -- hmac )
    binary <file-reader> stream>sha1-hmac ;

-: byte-array>sha1-hmac ( K string -- hmac )
+: sequence>sha1-hmac ( K sequence -- hmac )
    binary <byte-reader> stream>sha1-hmac ;

 : stream>md5-hmac ( K stream -- hmac )
@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
 : file>md5-hmac ( K path -- hmac )
    binary <file-reader> stream>md5-hmac ;

-: byte-array>md5-hmac ( K string -- hmac )
+: sequence>md5-hmac ( K sequence -- hmac )
    binary <byte-reader> stream>md5-hmac ;
--- a/extra/drills/deployed/deploy.factor
+++ b/extra/drills/deployed/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-unicode? f }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-name "drills" }
+    { deploy-ui? t }
+    { deploy-compiler? t }
+    { "stop-after-last-window?" t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-io 2 }
+    { deploy-word-defs? f }
+    { deploy-reflection 1 }
+}
--- a/extra/drills/deployed/deployed.factor
+++ b/extra/drills/deployed/deployed.factor
@ -0,0 +1,36 @@
+USING: accessors arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings system ;
+
+IN: drills.deployed
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+   { [ [ first ] card ]
+     [ [ second ] card ]
+     [ '[ |<< it get _ model-changed ] "No" op ]
+          [ '[ |<< [ it get [
+        _ value>> swap remove
+        [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+     ] change-model ] with-return ] "Yes" op ]
+   } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+   open-panel [
+         [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+            [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+         "Got it?" open-window
+   ] [ 0 exit ] if*
+] with-ui ;
+
+MAIN: drill
--- a/extra/drills/deployed/tags.txt
+++ b/extra/drills/deployed/tags.txt
@ -0,0 +1 @@
+unportable
--- a/extra/drills/drills.factor
+++ b/extra/drills/drills.factor
@ -3,40 +3,34 @@ fry grouping io.encodings.utf8 io.files io.styles kernel math
 math.parser models models.arrow models.history namespaces random
 sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
 ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks ui.gestures
-ui.gadgets.corners ;
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings ;

 IN: drills
 SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) { "sans-serif" plain 30 } >>font ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
 : card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
 : op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;

 : show ( model -- gadget ) dup it set-global [ random ] <arrow>
   { [ [ first ] card ]
-   [ [ [ second ] [ drop [ "malformed input" throw ] "Malformed Input" alert ] recover ] card ]
-   [ '[ |<< [ it get [
-      _ value>> swap remove
-      [ [ it get go-back ] "Drill Complete" alert return ] when-empty
-   ] change-model ] with-return ] "Yes" op ]
-   [ '[ |<< it get _ model-changed ] "No" op ] } cleave
+     [ [ second ] card ]
+     [ '[ |<< it get _ model-changed ] "No" op ]
+          [ '[ |<< [ it get [
+        _ value>> swap remove
+        [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+     ] change-model ] with-return ] "Yes" op ]
+   } cleave
 2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 450 175 } >>pref-dim swap @center grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> @bottom grid-add ;
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;

-: drill ( -- ) [ 
+: drill ( -- ) [
   open-panel [
-      [ utf8 file-lines [ "\t" split
-         [ " " split 4 group [ " " join ] map ] map ] map ] map concat dup [ [ first ] [ second ] bi swap 2array ] map append
-         [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
-      "Got it?" open-window
+         [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+            [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+         "Got it?" open-window
   ] when*
 ] with-ui ;

-
-MAIN: drill
-
-    
-! FIXME: command-line opening
-! TODO: Menu bar
-! TODO: Pious hot-buttons
+MAIN: drill
--- a/extra/game-input/dinput/dinput.factor
+++ b/extra/game-input/dinput/dinput.factor
@ -22,7 +22,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
    +dinput+ set-global ;

 : delete-dinput ( -- )
-    +dinput+ global [ com-release f ] change-at ;
+    +dinput+ [ com-release f ] change-global ;

 : device-for-guid ( guid -- device )
    +dinput+ get swap f <void*>
@ -172,10 +172,8 @@ TUPLE: window-rect < rect window-loc ;
    [ +device-change-window+ set-global ] bi ;

 : close-device-change-window ( -- )
-    +device-change-handle+ global
-    [ UnregisterDeviceNotification drop f ] change-at
-    +device-change-window+ global
-    [ DestroyWindow win32-error=0/f f ] change-at ;
+    +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
+    +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;

 : add-wm-devicechange ( -- )
    [ 4dup handle-wm-devicechange DefWindowProc ]
@ -185,14 +183,11 @@ TUPLE: window-rect < rect window-loc ;
    WM_DEVICECHANGE wm-handlers get-global delete-at ;

 : release-controllers ( -- )
-    +controller-devices+ global [
-        [ drop com-release ] assoc-each f
-    ] change-at
+    +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
    f +controller-guids+ set-global ;

 : release-keyboard ( -- )
-    +keyboard-device+ global
-    [ com-release f ] change-at
+    +keyboard-device+ [ com-release f ] change-global
    f +keyboard-state+ set-global ;

 M: dinput-game-input-backend (open-game-input)
--- a/extra/game-input/iokit/iokit.factor
+++ b/extra/game-input/iokit/iokit.factor
@ -239,7 +239,7 @@ M: iokit-game-input-backend (reset-game-input)

 M: iokit-game-input-backend (close-game-input)
    +hid-manager+ get-global [
-        +hid-manager+ global [ 
+        +hid-manager+ [ 
            [
                CFRunLoopGetMain CFRunLoopDefaultMode
                IOHIDManagerUnscheduleFromRunLoop
@ -247,7 +247,7 @@ M: iokit-game-input-backend (close-game-input)
            [ 0 IOHIDManagerClose drop ]
            [ CFRelease ] tri
            f
-        ] change-at
+        ] change-global
        f +keyboard-state+ set-global
        f +controller-states+ set-global
    ] when ;
--- a/extra/merger/deploy.factor
+++ b/extra/merger/deploy.factor
@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-unicode? t }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-ui? t }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-name "Merger" }
+    { deploy-word-props? f }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}
--- a/extra/merger/merger.factor
+++ b/extra/merger/merger.factor
@ -0,0 +1,30 @@
+USING: accessors arrays fry io.directories kernel models sequences sets ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
+ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
+math.rectangles cocoa.dialogs ;
+IN: merger
+: main ( -- ) [
+   vertical <track>
+    { "From:" "To:" } f <model> f <model> 2array
+    [
+      [
+         "…" [
+            open-panel [ first
+            [ <label> 1array >>children drop ]
+            [ swap set-control-value ] 2bi ] [ drop ] if*
+         ] <border-button> swap >>model swap <labeled-gadget>
+         1 track-add
+      ] 2each
+    ] keep
+    dup first2
+    '[ _ [ value>> ] all? [ parent>> "processing..." <label> [
+         <zero-rect> show-glass
+         _ value>> [
+            "." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
+         ] with-directory
+      ] keep hide-glass
+    ] [ drop ] if ]
+    "merge" swap <border-button> 0.4 track-add { 300 220 } >>pref-dim "Merging" open-window
+] with-ui ;
+
+MAIN: main
--- a/extra/merger/tags.txt
+++ b/extra/merger/tags.txt
@ -0,0 +1,2 @@
+unportable
+
--- a/extra/modules/remote-loading/authors.txt
+++ b/extra/modules/remote-loading/authors.txt
@ -0,0 +1 @@
+Sam Anklesaria
--- a/extra/modules/remote-loading/remote-loading.factor
+++ b/extra/modules/remote-loading/remote-loading.factor
@ -0,0 +1,4 @@
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
--- a/extra/modules/remote-loading/summary.txt
+++ b/extra/modules/remote-loading/summary.txt
@ -0,0 +1 @@
+required for listeners allowing remote loading of modules
--- a/extra/modules/rpc-server/authors.txt
+++ b/extra/modules/rpc-server/authors.txt
@ -0,0 +1 @@
+Sam Anklesaria
--- a/extra/modules/rpc-server/rpc-server.factor
+++ b/extra/modules/rpc-server/rpc-server.factor
@ -0,0 +1,37 @@
+USING: accessors assocs continuations effects io
+io.encodings.binary io.servers.connection kernel
+memoize namespaces parser sets sequences serialize
+threads vocabs vocabs.parser words ;
+
+IN: modules.rpc-server
+
+SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
+
+: do-rpc ( args word -- bytes )
+   [ execute ] curry with-datastack object>bytes ; inline
+
+MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
+
+: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+   swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- ) deserialize dup serving-vocabs get-global index
+   [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- ) [
+   <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+   start-server ] in-thread ;
+
+: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+   current-vocab serving-vocabs get-global adjoin
+   "get-words" create-in
+   in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+   (( -- words )) define-inline ;
+
+SYNTAX: service \ do-rpc  "executer" set (service) ;
+SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
+
+load-vocab-hook [
+   [ dup words>> values
+   \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
+append ] change-global
--- a/extra/modules/rpc-server/summary.txt
+++ b/extra/modules/rpc-server/summary.txt
@ -0,0 +1 @@
+remote procedure call server
--- a/extra/modules/rpc/authors.txt
+++ b/extra/modules/rpc/authors.txt
@ -0,0 +1 @@
+Sam Anklesaria
--- a/extra/modules/rpc/rpc-docs.factor
+++ b/extra/modules/rpc/rpc-docs.factor
@ -0,0 +1,9 @@
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+   "Send vocab as string"
+   "Send arglist"
+   "Send word as string"
+   "Receive result list"
+} ;
--- a/extra/modules/rpc/rpc.factor
+++ b/extra/modules/rpc/rpc.factor
@ -0,0 +1,26 @@
+USING: accessors compiler.units combinators fry generalizations io
+io.encodings.binary io.sockets kernel namespaces
+parser sequences serialize vocabs vocabs.parser words ;
+IN: modules.rpc
+
+DEFER: get-words
+
+: remote-quot ( addrspec vocabspec effect str -- quot )
+   '[ _ 5000 <inet> binary
+      [
+         _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
+      ] with-client
+    ] ;
+
+: define-remote ( addrspec vocabspec effect str -- ) [
+      [ remote-quot ] 2keep create-in -rot define-declared word make-inline
+   ] with-compilation-unit ;
+
+: with-in ( vocab quot -- vocab ) over
+   [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
+
+: remote-vocab ( addrspec vocabspec -- vocab )
+   dup "-remote" append [ 
+      [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
+      [ rot first2 swap define-remote ] 2curry each
+   ] with-in ;
--- a/extra/modules/rpc/summary.txt
+++ b/extra/modules/rpc/summary.txt
@ -0,0 +1 @@
+remote procedure call client
--- a/extra/modules/uploads/authors.txt
+++ b/extra/modules/uploads/authors.txt
@ -0,0 +1 @@
+Sam Anklesaria
--- a/extra/modules/uploads/summary.txt
+++ b/extra/modules/uploads/summary.txt
@ -0,0 +1 @@
+module pushing in remote-loading listeners
--- a/extra/modules/uploads/uploads.factor
+++ b/extra/modules/uploads/uploads.factor
@ -0,0 +1,5 @@
+USING: assocs modules.rpc-server vocabs
+modules.remote-loading words ;
+IN: modules.uploads service
+
+: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
--- a/extra/modules/using/authors.txt
+++ b/extra/modules/using/authors.txt
@ -0,0 +1 @@
+Sam Anklesaria
--- a/extra/modules/using/summary.txt
+++ b/extra/modules/using/summary.txt
@ -0,0 +1 @@
+improved module import syntax
--- a/extra/modules/using/tests/tags.txt
+++ b/extra/modules/using/tests/tags.txt
@ -0,0 +1 @@
+unportable
--- a/extra/modules/using/tests/test-server.factor
+++ b/extra/modules/using/tests/test-server.factor
@ -0,0 +1,3 @@
+USING: modules.rpc-server io.servers.connection ;
+IN: modules.test-server service
+: rpc-hello ( -- str ) "hello world" stop-this-server ;
--- a/extra/modules/using/tests/tests.factor
+++ b/extra/modules/using/tests/tests.factor
@ -0,0 +1,4 @@
+USING: modules.using ;
+IN: modules.using.tests
+USING: tools.test localhost::modules.test-server ;
+[ "hello world" ] [ rpc-hello ] unit-test
--- a/extra/modules/using/using-docs.factor
+++ b/extra/modules/using/using-docs.factor
@ -0,0 +1,14 @@
+USING: modules.using modules.rpc-server help.syntax help.markup strings ;
+IN: modules
+
+HELP: service
+{ $syntax "IN: module service" }
+{ $description "Starts a server for requests for remote procedure calls." } ;
+
+ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
+"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
+
+HELP: USING:
+{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
+{ $description "Adds vocabularies to the front of the search path.  Vocabularies can be fetched remotely, if preceded by a valid hostname.  Name pairs facilitate imports like in the "
+{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
--- a/extra/modules/using/using.factor
+++ b/extra/modules/using/using.factor
@ -0,0 +1,36 @@
+USING: assocs kernel modules.remote-loading modules.rpc
+namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
+strings ;
+IN: modules.using
+
+: >qualified ( vocab prefix -- assoc )
+    [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
+
+: >partial-vocab ( words assoc -- assoc )
+    [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
+
+: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+plain = tokenpart => [[ load-vocab ]]
+module = rpc | remote | plain
+;EBNF
+
+ON-BNF: USING:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>").
+modspec = sym => [[ modulize ]]
+qualified = modspec sym => [[ first2 >qualified ]]
+unqualified = modspec => [[ vocab-words ]]
+words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
+long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
+short = modspec => [[ use+ ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
--- a/extra/mongodb/benchmark/benchmark.factor
+++ b/extra/mongodb/benchmark/benchmark.factor
@ -0,0 +1,312 @@
+USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
+sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
+accessors words mongodb.driver strings math.parser tools.walker bson.writer
+tools.continuations ;
+
+IN: mongodb.benchmark
+
+SYMBOL: collection
+
+: get* ( symbol default -- value )
+    [ get ] dip or ; inline
+
+: ensure-number ( v -- n )
+    dup string? [ string>number ] when ; inline
+
+: trial-size ( -- size )
+    "per-trial" 5000 get* ensure-number ; inline flushable
+
+: batch-size ( -- size )
+    "batch-size" 100 get* ensure-number ; inline flushable
+
+TUPLE: result doc collection index batch lasterror ;
+
+: <result> ( -- ) result new result set ; inline
+
+
+CONSTANT: CHECK-KEY f 
+
+CONSTANT: DOC-SMALL H{ }
+
+CONSTANT: DOC-MEDIUM H{ { "integer" 5 }
+                        { "number" 5.05 }
+                        { "boolean" f }
+                        { "array"
+                          { "test" "benchmark" } } }
+
+CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
+                       { "total_word_count" 6743 }
+                       { "access_time" f } 
+                       { "meta_tags" H{ { "description" "i am a long description string" }
+                                        { "author" "Holly Man" }
+                                        { "dynamically_created_meta_tag" "who know\n what" } } }
+                       { "page_structure" H{ { "counted_tags" 3450 }
+                                             { "no_of_js_attached" 10 }
+                                             { "no_of_images" 6 } } }
+                       { "harvested_words" { "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo"
+                                             "10gen" "web" "open" "source" "application" "paas" 
+                                             "platform-as-a-service" "technology" "helps" 
+                                             "developers" "focus" "building" "mongodb" "mongo" } } }
+
+: set-doc ( name -- )
+    [ result ] dip '[ _ >>doc ] change ; inline
+
+: small-doc ( -- quot )
+    "small" set-doc [ ] ; inline
+
+: medium-doc ( -- quot )
+    "medium" set-doc [ ] ; inline
+
+: large-doc ( -- quot )
+    "large" set-doc [ ] ; inline
+
+: small-doc-prepare ( -- quot: ( i -- doc ) )
+    small-doc drop
+    '[ "x" DOC-SMALL clone [ set-at ] keep ] ; 
+
+: medium-doc-prepare ( -- quot: ( i -- doc ) )
+    medium-doc drop
+    '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; 
+
+: large-doc-prepare ( -- quot: ( i -- doc ) )
+    large-doc drop
+    [ "x" DOC-LARGE clone [ set-at ] keep 
+       [ now "access-time" ] dip
+       [ set-at ] keep ] ;
+
+: (insert) ( quot: ( i -- doc ) collection -- )
+    [ trial-size ] 2dip
+    '[ _ call( i -- doc ) [ _ ] dip
+       result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; 
+
+: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
+    [ [ * ] keep 1 range boa ] dip
+    '[ _ call( i -- doc ) ] map ; 
+
+: (insert-batch) ( quot: ( i -- doc ) collection -- )
+    [ trial-size batch-size [ / ] keep ] 2dip
+    '[ _ _ (prepare-batch) [ _ ] dip
+       result get lasterror>> [ save ] [ save-unsafe ] if
+    ] each-integer ; 
+
+: bchar ( boolean -- char )
+    [ "t" ] [ "f" ] if ; inline 
+
+: collection-name ( -- collection )
+    collection "benchmark" get*
+    result get doc>>
+    result get index>> bchar
+    "%s-%s-%s" sprintf
+    [ [ result get ] dip >>collection drop ] keep ; 
+    
+: prepare-collection ( -- collection )
+    collection-name
+    [ "_x_idx" drop-index ] keep
+    [ drop-collection ] keep
+    [ create-collection ] keep ; 
+
+: prepare-index ( collection -- )
+    "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ; 
+
+: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+    prepare-collection
+    result get index>> [ [ prepare-index ] keep ] when
+    result get batch>>
+    [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
+
+: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+    '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; 
+
+: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+    [ 0 ] dip call( i -- doc ) assoc>bv
+    '[ trial-size [  _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; 
+
+: check-for-key ( assoc key -- )
+    CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; 
+
+: (check-find-result) ( result -- )
+    "x" check-for-key ; inline
+  
+: (find) ( cursor -- )
+    [ find [ (check-find-result) ] each (find) ] when* ; inline recursive
+
+: find-one ( quot -- quot: ( -- ) )
+    drop
+    [ trial-size
+      collection-name
+      trial-size 2 / "x" H{ } clone [ set-at ] keep
+      '[ _ _ <query> 1 limit (find) ] times ] ;
+  
+: find-all ( quot -- quot: ( -- ) )
+    drop
+    collection-name
+    H{ } clone
+    '[ _ _ <query> (find) ] ;
+  
+: find-range ( quot -- quot: ( -- ) )
+    drop
+    [ trial-size batch-size /i
+       collection-name
+       trial-size 2 / "$gt" H{ } clone [ set-at ] keep
+       [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
+       "x" H{ } clone [ set-at ] keep
+       '[ _ _ <query> (find) ] times ] ;
+
+: batch ( -- )
+    result [ t >>batch ] change ; inline
+   
+: index ( -- )
+    result [ t >>index ] change ; inline
+
+: errcheck ( -- )
+    result [ t >>lasterror ] change ; inline
+
+: print-result ( time -- )
+    [ result get [ collection>> ] keep
+      [ batch>> bchar ] keep
+      [ index>> bchar ] keep
+      lasterror>> bchar
+      trial-size ] dip
+    1000000 / /i
+    "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+    sprintf print flush ; 
+
+: print-separator ( -- )
+    "----------------------------------------------------------------" print flush ; inline
+
+: print-separator-bold ( -- )
+    "================================================================" print flush ; inline
+
+: print-header ( -- )
+    trial-size
+    batch-size
+    "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
+    sprintf print flush
+    print-separator-bold ;
+
+: with-result ( options quot -- )
+    '[ <result> _ call( options -- time ) print-result ] with-scope ; 
+
+: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
+    '[ _ swap _
+       '[ [ [ _ execute( -- quot ) ] dip
+          [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
+       print-separator ] ; 
+
+: run-serialization-bench ( doc-word-seq feat-seq -- )
+    "Serialization Tests" print
+    print-separator-bold
+    \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+
+: run-deserialization-bench ( doc-word-seq feat-seq -- )
+    "Deserialization Tests" print
+    print-separator-bold
+    \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+    
+: run-insert-bench ( doc-word-seq feat-seq -- )
+    "Insert Tests" print
+    print-separator-bold 
+    \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+
+: run-find-one-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-One" print
+    print-separator-bold
+    \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+
+: run-find-all-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-All" print
+    print-separator-bold
+    \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+
+: run-find-range-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-Range" print
+    print-separator-bold
+    \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ; 
+
+    
+: run-benchmarks ( -- )
+    "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+    [ print-header
+      ! serialization
+      { small-doc-prepare medium-doc-prepare
+        large-doc-prepare }
+      { { } } run-serialization-bench
+      ! deserialization
+      { small-doc-prepare medium-doc-prepare
+        large-doc-prepare }
+      { { } } run-deserialization-bench
+      ! insert
+      { small-doc-prepare medium-doc-prepare
+        large-doc-prepare }
+      { { } { index } { errcheck } { index errcheck }
+        { batch } { batch errcheck } { batch index errcheck }
+      } run-insert-bench
+      ! find-one
+      { small-doc medium-doc large-doc }
+      { { } { index } } run-find-one-bench
+      ! find-all
+      { small-doc medium-doc large-doc }
+      { { } { index } } run-find-all-bench
+      ! find-range
+      { small-doc medium-doc large-doc }
+      { { } { index } } run-find-range-bench        
+    ] with-db ;
+        
+MAIN: run-benchmarks
+
--- a/extra/mongodb/connection/connection.factor
+++ b/extra/mongodb/connection/connection.factor
@ -0,0 +1,146 @@
+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 formatting
+io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
+arrays hashtables sequences.deep vectors locals ;
+
+IN: mongodb.connection
+
+: md5-checksum ( string -- digest )
+    utf8 encode md5 checksum-bytes hex-string ; inline
+
+TUPLE: mdb-db name username pwd-digest nodes collections ;
+
+TUPLE: mdb-node master? { address inet } remote ;
+
+CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
+
+TUPLE: mdb-connection instance node handle remote local ;
+
+CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
+
+: check-ok ( result -- errmsg ? )
+    [ [ "errmsg" ] dip at ] 
+    [ [ "ok" ] dip at >integer 1 = ] bi ; inline 
+
+: <mdb-db> ( name nodes -- mdb-db )
+    mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
+
+: master-node ( mdb -- node )
+    nodes>> t swap at ;
+
+: slave-node ( mdb -- node )
+    nodes>> f swap at ;
+
+: with-connection ( connection quot -- * )
+    [ mdb-connection set ] prepose with-scope ; inline
+    
+: mdb-instance ( -- mdb )
+    mdb-connection get instance>> ; inline
+
+: index-collection ( -- ns )
+    mdb-instance name>> "%s.system.indexes" sprintf ; inline
+
+: namespaces-collection ( -- ns )
+    mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+
+: cmd-collection ( -- ns )
+    mdb-instance name>> "%s.$cmd" sprintf ; inline
+
+: index-ns ( colname -- index-ns )
+    [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+
+: send-message ( message -- )
+    [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
+
+: send-query-plain ( query-message -- result )
+    [ mdb-connection get handle>> ] dip
+    '[ _ 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 ;
+
+<PRIVATE
+
+: get-nonce ( -- nonce )
+    cmd-collection H{ { "getnonce" 1 } } send-query-1result 
+    [ "nonce" swap at ] [ f ] if* ;
+
+: auth? ( mdb -- ? )
+    [ username>> ] [ pwd-digest>> ] bi and ; 
+
+: calculate-key-digest ( nonce -- digest )
+    mdb-instance
+    [ username>> ]
+    [ 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 ; 
+    
+: perform-authentication ( --  )
+    cmd-collection build-auth-query send-query-1result
+    check-ok [ drop ] [ throw ] if ; inline
+
+: authenticate-connection ( mdb-connection -- )
+   [ mdb-connection get instance>> auth?
+     [ perform-authentication ] when
+   ] with-connection ; inline
+
+: open-connection ( mdb-connection node -- mdb-connection )
+   [ >>node ] [ address>> ] bi
+   [ >>remote ] keep binary <client>
+   [ >>handle ] dip >>local ;
+
+: get-ismaster ( -- result )
+    "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; 
+
+: split-host-str ( hoststr -- host port )
+   ":" split [ first ] [ second string>number ] bi ; inline
+
+: eval-ismaster-result ( node result -- )
+   [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
+   [ [ "remote" ] dip at
+     [ split-host-str <inet> f <mdb-node> >>remote ] when*
+     drop ] 2bi ;
+
+: check-node ( mdb node --  )
+   [ <mdb-connection> &dispose ] dip
+   [ open-connection ] keep swap
+   [ get-ismaster eval-ismaster-result ] with-connection ;
+
+: nodelist>table ( seq -- assoc )
+   [ [ master?>> ] keep 2array ] map >hashtable ;
+   
+PRIVATE>
+
+:: verify-nodes ( mdb -- )
+    [ [let* | acc [ V{ } clone ]
+              node1 [ mdb dup master-node [ check-node ] keep ]
+              node2 [ mdb node1 remote>>
+                      [ [ check-node ] keep ]
+                      [ drop f ] if*  ]
+              | node1 [ acc push ] when*
+                node2 [ acc push ] when*
+                mdb acc nodelist>table >>nodes drop 
+              ]
+    ] with-destructors ; 
+              
+: mdb-open ( mdb -- mdb-connection )
+    clone [ <mdb-connection> ] keep
+    master-node open-connection
+    [ authenticate-connection ] keep ; 
+
+: mdb-close ( mdb-connection -- )
+     [ dispose f ] change-handle drop ;
+
+M: mdb-connection dispose
+     mdb-close ;
--- a/extra/mongodb/driver/authors.txt
+++ b/extra/mongodb/driver/authors.txt
@ -0,0 +1 @@
+Sascha Matzke
--- a/extra/mongodb/driver/driver-docs.factor
+++ b/extra/mongodb/driver/driver-docs.factor
@ -0,0 +1,288 @@
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel quotations ;
+IN: mongodb.driver
+
+HELP: <mdb-collection>
+{ $values
+  { "name" "name of the collection" }
+  { "collection" "mdb-collection instance" }
+}
+{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" "" } }
+{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ;
+
+HELP: <mdb>
+{ $values
+  { "db" "name of the database to use" }
+  { "host" "host name or IP address" }
+  { "port" "port number" }
+  { "mdb" "mdb-db instance" }
+}
+{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 <mdb>" "" } } ;
+
+HELP: <query>
+{ $values
+  { "collection" "collection to query" }
+  { "assoc" "query assoc" }
+  { "mdb-query-msg" "mdb-query-msg instance" }
+}
+{ $description "Creates a new mdb-query-msg instance. "
+  "This word must be called from within a with-db scope."
+  "For more see: "
+  { $link with-db } }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" H{ } <query>" "" } } ;
+
+HELP: <update>
+{ $values
+  { "collection" "collection to update" }
+  { "selector" "selector assoc (selects which object(s) to update" }
+  { "object" "updated object or update instruction" }
+  { "mdb-update-msg" "mdb-update-msg instance" }
+}
+{ $description "Creates an update message for the object(s) identified by the given selector."
+  "MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push"
+  "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ;
+
+HELP: >upsert
+{ $values
+  { "mdb-update-msg" "a mdb-update-msg" }
+  { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
+}
+{ $description "Marks a mdb-update-msg as upsert operation"
+  "(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
+
+HELP: PARTIAL?
+{ $values  
+  { "value" "partial?" }
+}
+{ $description "key which refers to a partially loaded object" } ;
+
+HELP: asc
+{ $values
+  { "key" "sort key" }
+  { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
+
+HELP: count
+{ $values
+  { "mdb-query-msg" "query" }
+  { "result" "number of objects in the collection that match the query" }
+}
+{ $description "count objects in a collection" } ;
+
+HELP: create-collection
+{ $values
+  { "name" "collection name" }
+}
+{ $description "Creates a new collection with the given name." } ;
+
+HELP: delete
+{ $values
+  { "collection" "a collection" }
+  { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (with lasterror check)" } ;
+
+HELP: delete-unsafe
+{ $values
+  { "collection" "a collection" }
+  { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (without error check)" } ;
+
+HELP: desc
+{ $values
+  { "key" "sort key" }
+  { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
+
+HELP: drop-collection
+{ $values
+  { "name" "a collection" }
+}
+{ $description "removes the collection and all objects in it from the database" } ;
+
+HELP: drop-index
+{ $values
+  { "collection" "a collection" }
+  { "name" "an index name" }
+}
+{ $description "drops the specified index from the collection" } ;
+
+HELP: ensure-collection
+{ $values
+  { "name" "a collection; e.g. mycollection " }
+}
+{ $description "ensures that the collection exists in the database" } ;
+
+HELP: ensure-index
+{ $values
+  { "index-spec" "an index specification" }
+}
+{ $description "Ensures the existence of the given index. "
+  "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;"
+    "\"db\" \"127.0.0.1\" 27017 <mdb>"
+    "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
+  { $unchecked-example  "USING: mongodb.driver ;"
+    "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+
+HELP: explain.
+{ $values
+  { "mdb-query-msg" "a query message" }
+}
+{ $description "Prints the execution plan for the given query" } ;
+
+HELP: find
+{ $values
+  { "selector" "a mdb-query or mdb-cursor" }
+  { "mdb-cursor/f" "a cursor (if there are more results) or f" }
+  { "seq" "a sequences of objects" }
+}
+{ $description "executes the given query" }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;"
+    "\"db\" \"127.0.0.1\" 27017 <mdb>"
+    "[ \"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find ] with-db" "" } } ;
+
+HELP: find-one
+{ $values
+  { "mdb-query-msg" "a query" }
+  { "result/f" "a single object or f" }
+}
+{ $description "Executes the query and returns one object at most" } ;
+
+HELP: hint
+{ $values
+  { "mdb-query-msg" "a query" }
+  { "index-hint" "a hint to an index" }
+  { "mdb-query-msg" "modified query object" }
+}
+{ $description "Annotates the query with a hint to an index. "
+  "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;"
+    "\"db\" \"127.0.0.1\" 27017 <mdb>"
+    "[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find ] with-db" "" } } ;
+
+HELP: lasterror
+{ $values
+  
+  { "error" "error message or f" }
+}
+{ $description "Checks if the last operation resulted in an error on the MongoDB side"
+  "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ;
+
+HELP: limit
+{ $values
+  { "mdb-query-msg" "a query" }
+  { "limit#" "number of objects that should be returned at most" }
+  { "mdb-query-msg" "modified query object" }
+}
+{ $description "Limits the number of returned objects to limit#" }
+{ $examples
+  { $unchecked-example "USING: mongodb.driver ;"
+    "\"db\" \"127.0.0.1\" 27017 <mdb>"
+    "[ \"mycollection\" H{ } <query> 10 limit find ] with-db" "" } } ;
+
+HELP: load-collection-list
+{ $values
+  
+  { "collection-list" "list of collections in the current database" }
+}
+{ $description "Returns a list of all collections that exist in the current database" } ;
+
+HELP: load-index-list
+{ $values
+  
+  { "index-list" "list of indexes" }
+}
+{ $description "Returns a list of all indexes that exist in the current database" } ;
+
+HELP: mdb-collection
+{ $var-description "MongoDB collection" } ;
+
+HELP: mdb-cursor
+{ $var-description "MongoDB cursor" } ;
+
+HELP: mdb-error
+{ $values
+  { "msg" "error message" }
+}
+{ $description "error class" } ;
+
+HELP: r/
+{ $values
+  { "token" "a regexp string" }
+  { "mdbregexp" "a mdbregexp tuple instance" }
+}
+{ $description "creates a new mdbregexp instance" } ;
+
+HELP: save
+{ $values
+  { "collection" "a collection" }
+  { "assoc" "object" }
+}
+{ $description "Saves the object to the given collection."
+  " If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ;
+
+HELP: save-unsafe
+{ $values
+  { "collection" "a collection" }
+  { "assoc" "object" }
+}
+{ $description "Save the object to the given collection without automatic error check" } ;
+
+HELP: skip
+{ $values
+  { "mdb-query-msg" "a query message" }
+  { "skip#" "number of objects to skip" }
+  { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
+
+HELP: sort
+{ $values
+  { "mdb-query-msg" "a query message" }
+  { "sort-quot" "a quotation with sort specifiers" }
+  { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates the query message for sort specifiers" } ;
+
+HELP: update
+{ $values
+  { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update" } ;
+
+HELP: update-unsafe
+{ $values
+  { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update without automatic error check" } ;
+
+HELP: validate.
+{ $values
+  { "collection" "collection to validate" }
+}
+{ $description "validates the collection" } ;
+
+HELP: with-db
+{ $values
+  { "mdb" "mdb instance" }
+  { "quot" "quotation to execute with the given mdb instance as context" }
+}
+{ $description "executes a quotation with the given mdb instance in its context" } ;
+
+ARTICLE: "mongodb.driver" "MongoDB factor driver"
+{ $vocab-link "mongodb.driver" }
+;
+
+ABOUT: "mongodb.driver"
+
--- a/extra/mongodb/driver/driver.factor
+++ b/extra/mongodb/driver/driver.factor
@ -0,0 +1,305 @@
+USING: accessors assocs bson.constants bson.writer combinators combinators.smart
+constructors continuations destructors formatting fry io io.pools
+io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
+namespaces parser prettyprint sequences sets splitting strings uuid arrays
+math math.parser memoize mongodb.connection mongodb.msg mongodb.operations  ;
+
+IN: mongodb.driver
+
+TUPLE: mdb-pool < pool mdb ;
+
+TUPLE: mdb-cursor id query ;
+
+TUPLE: mdb-collection
+{ name string }
+{ capped boolean initial: f }
+{ size integer initial: -1 }
+{ max integer initial: -1 } ;
+
+CONSTRUCTOR: mdb-collection ( name -- collection ) ;
+
+TUPLE: index-spec
+{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ;
+
+CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
+
+: unique-index ( index-spec -- index-spec )
+    t >>unique? ;
+
+M: mdb-pool make-connection
+    mdb>> mdb-open ;
+
+: <mdb-pool> ( mdb -- pool ) [ mdb-pool <pool> ] dip >>mdb ; inline
+
+CONSTANT: PARTIAL? "partial?"
+
+ERROR: mdb-error msg ;
+
+: >pwd-digest ( user password -- digest )
+    "mongo" swap 3array ":" join md5-checksum ; 
+
+<PRIVATE
+
+GENERIC: <mdb-cursor> ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor )
+
+M: mdb-query-msg <mdb-cursor>
+    mdb-cursor boa ;
+
+M: mdb-getmore-msg <mdb-cursor>
+    query>> mdb-cursor boa ;
+
+: >mdbregexp ( value -- regexp )
+   first <mdbregexp> ; inline
+
+GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
+
+M: mdb-query-msg update-query 
+    swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
+
+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 > 
+    [ [ update-query ]
+      [ [ cursor>> ] dip <mdb-cursor> ] 2bi
+    ] [ 2drop f ] if ;
+
+DEFER: send-query
+
+GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg ) 
+
+M: mdb-query-msg verify-query-result ;
+
+M: mdb-getmore-msg verify-query-result
+    over flags>> ResultFlag_CursorNotFound =
+    [ nip query>> [ send-query-plain ] keep ] when ;
+    
+: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
+    [ send-query-plain ] keep
+    verify-query-result 
+    [ collection>> >>collection drop ]
+    [ return#>> >>requested# ] 
+    [ make-cursor ] 2tri
+    swap objects>> ;
+
+PRIVATE>
+
+SYNTAX: r/ ( token -- mdbregexp )
+    \ / [ >mdbregexp ] parse-literal ; 
+
+: with-db ( mdb quot -- * )
+    '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
+  
+: >id-selector ( assoc -- selector )
+    [ MDB_OID_FIELD swap at ] keep
+    H{ } clone [ set-at ] keep ;
+
+: <mdb> ( db host port -- mdb )
+   <inet> t [ <mdb-node> ] keep
+   H{ } clone [ set-at ] keep <mdb-db>
+   [ verify-nodes ] keep ;
+
+GENERIC: create-collection ( name -- )
+
+M: string create-collection
+    <mdb-collection> create-collection ;
+
+M: mdb-collection create-collection
+    [ cmd-collection ] dip
+    <linked-hash> [
+        [ [ 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
+    ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
+
+: load-collection-list ( -- collection-list )
+    namespaces-collection
+    H{ } clone <mdb-query-msg> send-query-plain objects>> ;
+
+<PRIVATE
+
+: ensure-valid-collection-name ( collection -- )
+    [ ";$." intersect length 0 > ] keep
+    '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
+
+: (ensure-collection) ( collection --  )
+    mdb-instance collections>> dup keys length 0 = 
+    [ load-collection-list      
+      [ [ "options" ] dip key? ] filter
+      [ [ "name" ] dip at "." split second <mdb-collection> ] map
+      over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
+    [ dup ] dip key? [ drop ]
+    [ [ ensure-valid-collection-name ] keep create-collection ] if ; 
+
+: reserved-namespace? ( name -- ? )
+    [ "$cmd" = ] [ "system" head? ] bi or ;
+
+: check-collection ( collection -- fq-collection )
+    dup mdb-collection? [ name>> ] when
+    "." split1 over mdb-instance name>> =
+    [ nip ] [ drop ] if
+    [ ] [ reserved-namespace? ] bi
+    [ [ (ensure-collection) ] keep ] unless
+    [ mdb-instance name>> ] dip "%s.%s" sprintf ; 
+
+: fix-query-collection ( mdb-query -- mdb-query )
+    [ check-collection ] change-collection ; inline
+
+GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
+
+M: mdb-cursor get-more 
+    [ [ query>> dup [ collection>> ] [ return#>> ] bi ]
+      [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ] 
+    [ f f ] if* ;
+
+PRIVATE>
+
+: <query> ( collection assoc -- mdb-query-msg )
+    <mdb-query-msg> ; inline
+
+GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
+
+M: mdb-query-msg limit 
+    >>return# ; inline
+
+GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
+
+M: mdb-query-msg skip 
+    >>skip# ; inline
+
+: asc ( key -- spec ) 1 2array ; inline
+: desc ( key -- spec ) -1 2array ; inline
+
+GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
+
+M: mdb-query-msg sort
+    output>array >>orderby ; inline
+
+: key-spec ( spec-quot -- spec-assoc )
+    output>array >hashtable ; inline
+
+GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
+
+M: mdb-query-msg hint 
+    >>hint ;
+
+GENERIC: find ( selector -- mdb-cursor/f seq )
+
+M: mdb-query-msg find
+    fix-query-collection send-query ;
+
+M: mdb-cursor find
+    get-more ;
+
+GENERIC: explain. ( mdb-query-msg -- )
+
+M: mdb-query-msg explain.
+    t >>explain find nip . ;
+
+GENERIC: find-one ( mdb-query-msg -- result/f )
+
+M: mdb-query-msg find-one
+    fix-query-collection 
+    1 >>return# send-query-plain objects>>
+    dup empty? [ drop f ] [ first ] if ;
+
+GENERIC: count ( mdb-query-msg -- result )
+
+M: mdb-query-msg count    
+    [ collection>> "count" H{ } clone [ set-at ] keep ] keep
+    query>> [ over [ "query" ] dip set-at ] when*
+    [ cmd-collection ] dip <mdb-query-msg> find-one 
+    [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
+
+: lasterror ( -- error )
+    cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
+    find-one [ "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
+    '[ "result" _ at print ] [  ] if ;
+
+M: mdb-collection validate.
+    name>> validate. ;
+
+<PRIVATE
+
+: send-message-check-error ( message -- )
+    send-message lasterror [ mdb-error ] when* ;
+
+PRIVATE>
+
+GENERIC: save ( collection assoc -- )
+M: assoc save
+    [ check-collection ] dip
+    <mdb-insert-msg> send-message-check-error ;
+
+GENERIC: save-unsafe ( collection assoc -- )
+M: assoc save-unsafe
+    [ check-collection ] dip
+    <mdb-insert-msg> send-message ;
+
+GENERIC: ensure-index ( index-spec -- )
+M: index-spec ensure-index
+    <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+    [ { [ [ name>> "name" ] dip set-at ]
+        [ [ ns>> index-ns "ns" ] dip set-at ]
+        [ [ key>> "key" ] dip set-at ]
+        [ swap unique?>>
+          [ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave
+    ] keep
+    [ 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 ;
+
+: <update> ( collection selector object -- mdb-update-msg )
+    [ check-collection ] 2dip <mdb-update-msg> ;
+
+: >upsert ( mdb-update-msg -- mdb-update-msg )
+    1 >>upsert? ; 
+
+GENERIC: update ( mdb-update-msg -- )
+M: mdb-update-msg update
+    send-message-check-error ;
+
+GENERIC: update-unsafe ( mdb-update-msg -- )
+M: mdb-update-msg update-unsafe
+    send-message ;
+ 
+GENERIC: delete ( collection selector -- )
+M: assoc delete
+    [ check-collection ] dip
+    <mdb-delete-msg> send-message-check-error ;
+
+GENERIC: delete-unsafe ( collection selector -- )
+M: assoc delete-unsafe
+    [ check-collection ] dip
+    <mdb-delete-msg> send-message ;
+
+: load-index-list ( -- index-list )
+    index-collection
+    H{ } clone <mdb-query-msg> find nip ;
+
+: ensure-collection ( name -- )
+    check-collection drop ;
+
+: drop-collection ( name -- )
+    [ cmd-collection ] dip
+    "drop" H{ } clone [ set-at ] keep
+    <mdb-query-msg> find-one drop ;
+
+
--- a/extra/mongodb/driver/summary.txt
+++ b/extra/mongodb/driver/summary.txt
@ -0,0 +1 @@
+A driver for the MongoDB document-oriented database (http://www.mongodb.org)
--- a/extra/mongodb/driver/tags.txt
+++ b/extra/mongodb/driver/tags.txt
@ -0,0 +1 @@
+database
--- a/extra/mongodb/mmm/mmm.factor
+++ b/extra/mongodb/mmm/mmm.factor
@ -0,0 +1,102 @@
+USING: accessors fry io io.encodings.binary io.servers.connection
+io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
+namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
+json.writer mongodb.operations.private mongodb.operations ;
+
+IN: mongodb.mmm
+
+SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ; 
+
+GENERIC: dump-message ( message -- )
+
+: check-options ( -- )
+    mmm-port get [ 27040 mmm-port set ] unless
+    mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
+    mmm-server-port get [ 27017 mmm-server-port set ] unless
+    mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
+
+: read-msg-binary ( -- )
+    read-int32
+    [ write-int32 ] keep
+    4 - read write ;
+    
+: read-request-header ( -- msg-stub )
+    mdb-msg new
+    read-int32 MSG-HEADER-SIZE - >>length
+    read-int32 >>req-id
+    read-int32 >>resp-id
+    read-int32 >>opcode ;
+    
+: read-request ( -- msg-stub binary )
+    binary [ read-msg-binary ] with-byte-writer    
+    [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
+
+: dump-request ( msg-stub binary -- )
+    [ mmm-dump-output get ] 2dip
+    '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: read-reply ( -- binary )
+    binary [ read-msg-binary ] with-byte-writer ;
+
+: forward-request-read-reply ( msg-stub binary -- binary )
+    [ mmm-server get binary ] 2dip
+    '[ _ opcode>> _ write flush
+       OP_Query =
+       [ read-reply ]
+       [ f ] if ] with-client ; 
+
+: dump-reply ( binary -- )
+    [ mmm-dump-output get ] dip
+    '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: message-prefix ( message -- prefix message )
+    [ now timestamp>http-string ] dip
+    [ class name>> ] keep
+    [ "%s: %s" sprintf ] dip ; inline
+
+M: mdb-query-msg dump-message ( message -- )
+    message-prefix
+    [ collection>> ] keep
+    query>> >json
+    "%s -> %s: %s \n" printf ;
+
+M: mdb-insert-msg dump-message ( message -- )
+    message-prefix
+    [ collection>> ] keep
+    objects>> >json
+    "%s -> %s : %s \n" printf ;
+
+M: mdb-reply-msg dump-message ( message -- )
+    message-prefix
+    [ cursor>> ] keep
+    [ start#>> ] keep
+    [ returned#>> ] keep
+    objects>> >json
+    "%s -> cursor: %d, start: %d, returned#: %d,  -> %s \n" printf ; 
+
+M: mdb-msg dump-message ( message -- )
+    message-prefix drop "%s \n" printf ;
+
+: forward-reply ( binary -- )
+    write flush ;
+
+: handle-mmm-connection ( -- )
+    read-request
+    [ dump-request ] 2keep
+    forward-request-read-reply
+    [ dump-reply ] keep 
+    forward-reply ; 
+
+: start-mmm-server ( -- )
+    output-stream get mmm-dump-output set
+    <threaded-server> [ mmm-t-srv set ] keep 
+    "127.0.0.1" mmm-port get <inet4> >>insecure
+    binary >>encoding
+    [ handle-mmm-connection ] >>handler
+    start-server* ;
+
+: run-mmm ( -- )
+    check-options
+    start-mmm-server ;
+    
+MAIN: run-mmm
--- a/extra/mongodb/msg/msg.factor
+++ b/extra/mongodb/msg/msg.factor
@ -0,0 +1,105 @@
+USING: accessors assocs hashtables constructors kernel linked-assocs math
+sequences strings ;
+
+IN: mongodb.msg
+
+CONSTANT: OP_Reply   1 
+CONSTANT: OP_Message 1000 
+CONSTANT: OP_Update  2001 
+CONSTANT: OP_Insert  2002 
+CONSTANT: OP_Query   2004 
+CONSTANT: OP_GetMore 2005 
+CONSTANT: OP_Delete  2006 
+CONSTANT: OP_KillCursors 2007
+
+CONSTANT: ResultFlag_CursorNotFound  1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
+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 } ;
+
+TUPLE: mdb-query-msg < mdb-msg
+{ collection string }
+{ skip# integer initial: 0 }
+{ return# integer initial: 0 }
+{ query assoc }
+{ returnfields assoc }
+{ orderby sequence }
+explain hint ;
+
+TUPLE: mdb-insert-msg < mdb-msg
+{ collection string }
+{ objects sequence } ;
+
+TUPLE: mdb-update-msg < mdb-msg
+{ collection string }
+{ upsert? integer initial: 0 }
+{ selector assoc }
+{ object assoc } ;
+
+TUPLE: mdb-delete-msg < mdb-msg
+{ collection string }
+{ selector assoc } ;
+
+TUPLE: mdb-getmore-msg < mdb-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 } ;
+
+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 } ;
+
+
+CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
+    OP_GetMore >>opcode ; inline
+
+CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg )
+    OP_Delete >>opcode ; inline
+
+CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg )
+    OP_Query >>opcode ; inline
+
+GENERIC: <mdb-killcursors-msg> ( object -- mdb-killcursors-msg )
+
+M: sequence <mdb-killcursors-msg> ( sequences -- mdb-killcursors-msg )
+    [ mdb-killcursors-msg new ] dip
+    [ length >>cursors# ] keep
+    >>cursors OP_KillCursors >>opcode ; inline
+
+M: integer <mdb-killcursors-msg> ( integer -- mdb-killcursors-msg )
+    V{ } clone [ push ] keep <mdb-killcursors-msg> ;
+
+GENERIC: <mdb-insert-msg> ( collection objects -- mdb-insert-msg )
+
+M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
+    [ mdb-insert-msg new ] 2dip
+    [ >>collection ] dip
+    >>objects OP_Insert >>opcode ;
+
+M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
+    [ mdb-insert-msg new ] 2dip
+    [ >>collection ] dip
+    V{ } clone tuck push
+    >>objects OP_Insert >>opcode ;
+
+
+CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg )
+    OP_Update >>opcode ; inline
+    
+CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline
+
--- a/extra/mongodb/operations/operations.factor
+++ b/extra/mongodb/operations/operations.factor
@ -0,0 +1,222 @@
+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 ;
+
+IN: alien.c-types
+
+M: byte-vector byte-length length ;
+
+IN: mongodb.operations
+
+<PRIVATE
+
+PREDICATE: mdb-reply-op < integer OP_Reply = ;
+PREDICATE: mdb-query-op < integer OP_Query = ;
+PREDICATE: mdb-insert-op < integer OP_Insert = ;
+PREDICATE: mdb-update-op < integer OP_Update = ;
+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 
+
+: bytes-read> ( -- integer )
+    msg-bytes-read get ; inline
+
+: >bytes-read ( integer -- )
+    msg-bytes-read set ; inline
+
+: change-bytes-read ( integer -- )
+    bytes-read> [ 0 ] unless* + >bytes-read ; inline
+
+: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline
+: 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 ;
+
+M: mdb-query-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-query-msg new ] dip copy-header
+    read-cstring >>collection
+    read-int32 >>skip#
+    read-int32 >>return#
+    H{ } stream>assoc change-bytes-read >>query 
+    dup length>> bytes-read> >
+    [ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
+
+M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-insert-msg new ] dip copy-header
+    read-cstring >>collection
+    V{ } clone >>objects
+    [ '[ _ length>> bytes-read> > ] ] keep tuck
+    '[ H{ } stream>assoc change-bytes-read _ objects>> push ]
+    while ;
+
+M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-delete-msg new ] dip copy-header
+    read-cstring >>collection
+    H{ } stream>assoc change-bytes-read >>selector ;
+
+M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-getmore-msg new ] dip copy-header
+    read-cstring >>collection
+    read-int32 >>return#
+    read-longlong >>cursor ;
+
+M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-killcursors-msg new ] dip copy-header
+    read-int32 >>cursors#
+    V{ } clone >>cursors
+    [ [ cursors#>> ] keep 
+      '[ read-longlong _ cursors>> push ] times ] keep ;
+
+M: mdb-update-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ mdb-update-msg new ] dip copy-header
+    read-cstring >>collection
+    read-int32 >>upsert?
+    H{ } stream>assoc change-bytes-read >>selector
+    H{ } stream>assoc change-bytes-read >>object ;
+
+M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
+    drop
+    [ <mdb-reply-msg> ] dip copy-header
+    read-longlong >>cursor
+    read-int32 >>start#
+    read-int32 [ >>returned# ] keep
+    [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;    
+
+: read-header ( message -- message )
+    read-int32 >>length
+    read-int32 >>req-id
+    read-int32 >>resp-id
+    read-int32 >>opcode
+    read-int32 >>flags ; inline
+
+: write-header ( message -- )
+    [ req-id>> write-int32 ] keep
+    [ resp-id>> write-int32 ] keep 
+    opcode>> write-int32 ; inline
+
+PRIVATE>
+
+: read-message ( -- message )
+    mdb-msg new
+    0 >bytes-read
+    read-header
+    [ ] [ opcode>> ] bi (read-message) ;
+
+<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
+
+: build-query-object ( query -- selector )
+    [let | selector [ H{ } clone ] |
+        { [ 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
+    ] ;     
+
+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) ;
+
--- a/Show More
+++ b/Show More
				`@ -0,0 +1 @@`
				`Efficient arrays of tuples with value semantics for elements`
				`@ -0,0 +1 @@`
				`required for listeners allowing remote loading of modules`
				`@ -0,0 +1 @@`
				`A driver for the MongoDB document-oriented database (http://www.mongodb.org)`