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

basis/alien/arrays/arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings alien.c-types alien.accessors alien.structs
 arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 io.encodings.utf16n ;
+io.encodings.utf8 ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -95,5 +95,4 @@ M: string-type c-type-setter
 
 { "char*" utf8 } "char*" typedef
 "char*" "uchar*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
 

basis/bootstrap/image/image.factor

@@ -448,7 +448,6 @@ M: quotation '
         array>> '
         quotation [
             emit ! array
-            f ' emit ! compiled
             f ' emit ! cached-effect
             f ' emit ! cache-counter
             0 emit ! xt

basis/bootstrap/stage2.factor

@@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
 
 SYMBOL: bootstrap-time
 
+: strip-encodings ( -- )
+    os unix? [
+        [
+            P" resource:core/io/encodings/utf16/utf16.factor" 
+            P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
+            "io.encodings.utf16" 
+            "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
+        ] with-compilation-unit
+    ] when ;
+
 : default-image-name ( -- string )
     vm file-name os windows? [ "." split1-last drop ] when
     ".image" append resource-path ;
@@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
     "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
+    strip-encodings
+
     (command-line) parse-command-line
 
     ! Set dll paths

basis/compiler/constants/constants.factor

@@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
 : word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
 : word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
 : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline

basis/io/backend/unix/unix.factor

@@ -173,10 +173,11 @@ M: stdin refill
         size-read-fd <fd> init-fd <input-port> >>size
         data-read-fd <fd> >>data ;
 
-M: unix (init-stdio)
+M: unix init-stdio
     <stdin> <input-port>
     1 <fd> <output-port>
-    2 <fd> <output-port> t ;
+    2 <fd> <output-port>
+    set-stdio ;
 
 ! mx io-task for embedding an fd-based mx inside another mx
 TUPLE: mx-port < port mx ;

basis/io/backend/windows/nt/nt.factor

@@ -1,9 +1,9 @@
-USING: alien alien.c-types arrays assocs combinators
+USING: alien alien.c-types arrays assocs combinators continuations
-continuations destructors io io.backend io.ports io.timeouts
+destructors io io.backend io.ports io.timeouts io.backend.windows
-io.backend.windows io.files.windows io.files.windows.nt io.files
+io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
-io.pathnames io.buffers io.streams.c libc kernel math namespaces
+io.streams.c io.streams.null libc kernel math namespaces sequences
-sequences threads windows windows.errors windows.kernel32
+threads windows windows.errors windows.kernel32 strings splitting
-strings splitting ascii system accessors locals ;
+ascii system accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.backend.windows.nt
 
@@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
 
 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 
-M: winnt (init-stdio)
+M: winnt init-stdio
-    console-app? [ init-c-stdio t ] [ f f f f ] if ;
+    console-app?
+    [ init-c-stdio ]
+    [ null-reader null-writer null-writer set-stdio ] if ;
 
 winnt set-io-backend

basis/io/directories/unix/linux/linux.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.directories.unix kernel system unix ;
+IN: io.directories.unix.linux
+
+M: unix find-next-file ( DIR* -- byte-array )
+    "dirent" <c-object>
+    f <void*>
+    [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+    *void* [ drop f ] unless ;

basis/io/directories/unix/linux/tags.txt

@@ -0,0 +1 @@
+unportable

basis/io/directories/unix/unix.factor

@@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
 continuations destructors fry io io.backend io.backend.unix
 io.directories io.encodings.binary io.encodings.utf8 io.files
 io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat ;
+unix unix.stat vocabs.loader ;
 IN: io.directories.unix
 
 : touch-mode ( -- n )
@@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
     [ opendir dup [ (io-error) ] unless ] dip
     dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
 
-: find-next-file ( DIR* -- byte-array )
+HOOK: find-next-file os ( DIR* -- byte-array )
+
+M: unix find-next-file ( DIR* -- byte-array )
     "dirent" <c-object>
     f <void*>
     [ readdir_r 0 = [ (io-error) ] unless ] 2keep
@@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
     } case ;
 
 M: unix >directory-entry ( byte-array -- directory-entry )
+    {
         [ dirent-d_name utf8 alien>string ]
-    [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
+        [ dirent-d_type dirent-type>file-type ]
+    } cleave directory-entry boa ;
 
 M: unix (directory-entries) ( path -- seq )
     [
@@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
         [ >directory-entry ]
         produce nip
     ] with-unix-directory ;
+
+os linux? [ "io.directories.unix.linux" require ] when

basis/io/files/info/info.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types ;
+vocabs.loader io.files.types math ;
 IN: io.files.info
 
 ! File info
@@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
 
 : directory? ( file-info -- ? ) type>> +directory+ = ;
 
+: sparse-file? ( file-info -- ? )
+    [ size-on-disk>> ] [ size>> ] bi < ;
+
 ! File systems
 HOOK: file-systems os ( -- array )
 

basis/io/launcher/launcher.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel namespaces strings hashtables sequences 
+USING: system kernel namespaces strings hashtables sequences assocs
-assocs combinators vocabs.loader init threads continuations
+combinators vocabs.loader init threads continuations math accessors
-math accessors concurrency.flags destructors environment
+concurrency.flags destructors environment io io.encodings.ascii
-io io.encodings.ascii io.backend io.timeouts io.pipes
+io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.pipes.private io.encodings io.streams.duplex io.ports
+io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
-debugger prettyprint summary calendar ;
+summary calendar ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -254,6 +254,21 @@ M: object run-pipeline-element
     swap [ with-stream ] dip
     wait-for-success ; inline
 
+ERROR: output-process-error { output string } { process process } ;
+
+M: output-process-error error.
+    [ "Process:" print process>> . nl ]
+    [ "Output:" print output>> print ]
+    bi ;
+
+: try-output-process ( command -- )
+    >process
+    +stdout+ >>stderr
+    +closed+ >>stdin
+    utf8 <process-reader*>
+    [ stream-contents ] [ dup wait-for-process ] bi*
+    0 = [ 2drop ] [ output-process-error ] if ;
+
 : notify-exit ( process status -- )
     >>status
     [ processes get delete-at* drop [ resume ] each ] keep

basis/struct-arrays/struct-arrays.factor

@@ -35,6 +35,6 @@ ERROR: bad-byte-array-length byte-array ;
     heap-size struct-array boa ; inline
 
 : malloc-struct-array ( length c-type -- struct-array )
-    [ heap-size calloc ] 2keep <direct-struct-array> ;
+    [ heap-size calloc ] 2keep <direct-struct-array> ; inline
 
 INSTANCE: struct-array sequence

basis/tools/deploy/deploy-tests.factor

@@ -98,3 +98,7 @@ M: quit-responder call-responder*
         run-temp-image
     ] curry unit-test
 ] each
+
+os windows? os macosx? or [
+    [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when

basis/tools/deploy/shaker/shaker.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors io.backend io.streams.c init fry namespaces
-make assocs kernel parser lexer strings.parser vocabs sequences words
+math make assocs kernel parser lexer strings.parser vocabs sequences
-memory kernel.private continuations io vocabs.loader system strings
+sequences.private words memory kernel.private continuations io
-sets vectors quotations byte-arrays sorting compiler.units definitions
+vocabs.loader system strings sets vectors quotations byte-arrays
-generic generic.standard tools.deploy.config combinators classes ;
+sorting compiler.units definitions generic generic.standard
+generic.single tools.deploy.config combinators classes
+slots.private ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: command-line
 QUALIFIED: compiler.errors
@@ -38,10 +40,11 @@ IN: tools.deploy.shaker
     strip-io? [
         "io.files" init-hooks get delete-at
         "io.backend" init-hooks get delete-at
+        "io.thread" init-hooks get delete-at
     ] when
     strip-dictionary? [
         {
-            "compiler.units"
+            ! "compiler.units"
             "vocabs"
             "vocabs.cache"
             "source-files.errors"
@@ -193,7 +196,8 @@ IN: tools.deploy.shaker
 
 : strip-compiler-classes ( -- )
     "Stripping compiler classes" show
-    "compiler" child-vocabs [ words ] map concat [ class? ] filter
+    { "compiler" "stack-checker" }
+    [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
     [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
 
 : strip-default-methods ( -- )
@@ -271,7 +275,7 @@ IN: tools.deploy.shaker
                 compiled-generic-crossref
                 compiler-impl
                 compiler.errors:compiler-errors
-                definition-observers
+                ! definition-observers
                 interactive-vocabs
                 lexer-factory
                 print-use-hook
@@ -301,16 +305,16 @@ IN: tools.deploy.shaker
                 compiler.errors:compiler-errors
                 continuations:thread-error-hook
             } %
+            
+            deploy-ui? get [
+                "ui-error-hook" "ui.gadgets.worlds" lookup ,
+            ] when
         ] when
 
         deploy-c-types? get [
             "c-types" "alien.c-types" lookup ,
         ] unless
 
-        deploy-ui? get [
-            "ui-error-hook" "ui.gadgets.worlds" lookup ,
-        ] when
-
         "windows-messages" "windows.messages" lookup [ , ] when*
     ] { } make ;
 
@@ -325,12 +329,17 @@ IN: tools.deploy.shaker
     ] [ drop ] if ;
 
 : strip-c-io ( -- )
-    deploy-io get 2 = os windows? or [
+    strip-io?
+    deploy-io get 3 = os windows? not and
+    or [
         [
             c-io-backend forget
             "io.streams.c" forget-vocab
+            "io-thread-running?" "io.thread" lookup [
+                global delete-at
+            ] when*
         ] with-compilation-unit
-    ] unless ;
+    ] when ;
 
 : compress ( pred post-process string -- )
     "Compressing " prepend show
@@ -353,7 +362,7 @@ IN: tools.deploy.shaker
     #! Quotations which were formerly compiled must remain
     #! compiled.
     2dup [
-        2dup [ compiled>> ] [ compiled>> not ] bi* and
+        2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
         [ nip jit-compile ] [ 2drop ] if
     ] 2each ;
 
@@ -406,6 +415,23 @@ SYMBOL: deploy-vocab
     ] each
     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 
+: (clear-megamorphic-cache) ( i array -- )
+    2dup 1 slot < [
+        2dup [ f ] 2dip set-array-nth
+        [ 1 + ] dip (clear-megamorphic-cache)
+    ] [ 2drop ] if ;
+
+: clear-megamorphic-cache ( array -- )
+    [ 0 ] dip (clear-megamorphic-cache) ;
+
+: find-megamorphic-caches ( -- seq )
+    "Finding megamorphic caches" show
+    [ standard-generic? ] instances [ def>> third ] map ;
+
+: clear-megamorphic-caches ( cache -- )
+    "Clearing megamorphic caches" show
+    [ clear-megamorphic-cache ] each ;
+
 : strip ( -- )
     init-stripper
     strip-libc
@@ -419,11 +445,13 @@ SYMBOL: deploy-vocab
     strip-default-methods
     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main deploy-boot-quot
+    find-megamorphic-caches
     stripped-word-props
     stripped-globals strip-globals
     compress-objects
     compress-quotations
-    strip-words ;
+    strip-words
+    clear-megamorphic-caches ;
 
 : deploy-error-handler ( quot -- )
     [
@@ -443,6 +471,9 @@ SYMBOL: deploy-vocab
             strip-debugger? [
                 "debugger" require
                 "inspector" require
+                deploy-ui? get [
+                    "ui.debugger" require
+                ] when
             ] unless
             deploy-vocab set
             deploy-vocab get require

basis/tools/deploy/test/8/8.factor

@@ -0,0 +1,21 @@
+USING: calendar game-input threads ui ui.gadgets.worlds kernel
+method-chains system ;
+IN: tools.deploy.test.8
+
+TUPLE: my-world < world ;
+
+BEFORE: my-world begin-world drop open-game-input ;
+
+AFTER: my-world end-world drop close-game-input ;
+
+: test-game-input ( -- )
+    [
+        f T{ world-attributes
+             { world-class my-world }
+             { title "Test" }
+        } open-window
+        1 seconds sleep
+        0 exit
+    ] with-ui ;
+
+MAIN: test-game-input

basis/tools/deploy/test/8/deploy.factor

@@ -0,0 +1,14 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-c-types? f }
+    { deploy-unicode? f }
+    { deploy-word-defs? f }
+    { deploy-name "tools.deploy.test.8" }
+    { "stop-after-last-window?" t }
+    { deploy-reflection 1 }
+    { deploy-ui? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-word-props? f }
+    { deploy-threads? t }
+}

basis/tools/deploy/test/test.factor

@@ -1,5 +1,5 @@
 USING: accessors arrays continuations io.directories io.files.info
-io.files.temp io.launcher kernel layouts math sequences system
+io.files.temp io.launcher io.backend kernel layouts math sequences system
 tools.deploy.backend tools.deploy.config.editor ;
 IN: tools.deploy.test
 
@@ -14,7 +14,6 @@ IN: tools.deploy.test
     [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
 
 : run-temp-image ( -- )
-    vm
+    os macosx?
-    "-i=" "test.image" temp-file append
+    "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
-    2array
+    "-i=" "test.image" temp-file append 2array try-output-process ;
-    <process> swap >>command +closed+ >>stdin try-process ;

basis/ui/backend/windows/windows.factor

@@ -616,10 +616,8 @@ M: windows-ui-backend do-events
     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr [
+    class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global
-        [ [ f UnregisterClass drop ] [ free ] bi ] when* f
+    msg-obj [ [ free ] when* f ] change-global ;
-    ] change-global
-    msg-obj change-global [ [ free ] when* f ] ;
 
 : get-dc ( world -- )
     handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;

basis/ui/debugger/debugger.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors debugger io kernel namespaces prettyprint
+ui.gadgets.panes ui.gadgets.worlds ui ;
+IN: ui.debugger
+
+: <error-pane> ( error -- pane )
+    <pane> [ [ print-error ] with-pane ] keep ; inline
+
+: error-window ( error -- )
+    <error-pane> "Error" open-window ;
+
+[ error-window ] ui-error-hook set-global
+
+M: world-error error.
+    "An error occurred while drawing the world " write
+    dup world>> pprint-short "." print
+    "This world has been deactivated to prevent cascading errors." print
+    error>> error. ;

basis/ui/gadgets/presentations/presentations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors definitions hashtables io kernel sequences
-strings words help math models namespaces quotations ui.gadgets
+strings words math models namespaces quotations ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private
 ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
 ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -13,6 +13,17 @@ HELP: origin
 HELP: hand-world
 { $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
 
+HELP: grab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." }
+{ $notes "Normal mouse gestures may not be available while input is grabbed." } ;
+
+HELP: ungrab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ;
+
+{ grab-input ungrab-input } related-words
+
 HELP: set-title
 { $values { "string" string } { "world" world } }
 { $description "Sets the title bar of the native window containing the world." }
@@ -42,6 +53,7 @@ HELP: world
         { { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
         { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
         { { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." }
+        { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
         { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
         { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
     }

basis/ui/gadgets/worlds/worlds.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals strings ;
 IN: ui.gadgets.worlds
 
 CONSTANT: default-world-pixel-format-attributes
@@ -21,7 +21,7 @@ TUPLE: world < track
 TUPLE: world-attributes
     { world-class initial: world }
     grab-input?
-    title
+    { title string initial: "Factor Window" }
     status
     gadgets
     { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
@@ -31,6 +31,20 @@ TUPLE: world-attributes
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
+: grab-input ( gadget -- )
+    find-world dup grab-input?>>
+    [ drop ] [
+        t >>grab-input?
+        dup focused?>> [ handle>> (grab-input) ] [ drop ] if
+    ] if ;
+
+: ungrab-input ( gadget -- )
+    find-world dup grab-input?>>
+    [
+        f >>grab-input?
+        dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
+    ] [ drop ] if ;
+    
 : show-status ( string/f gadget -- )
     dup find-world dup [
         dup status>> [
@@ -63,7 +77,7 @@ M: world request-focus-on ( child gadget -- )
 : new-world ( class -- world )
     vertical swap new-track
         t >>root?
-        t >>active?
+        f >>active?
         { 0 0 } >>window-loc
         f >>grab-input? ;
 
@@ -87,7 +101,7 @@ M: world layout*
     [ call-next-method ]
     [ dup layers>> [ as-big-as-possible ] with each ] bi ;
 
-M: world focusable-child* gadget-child ;
+M: world focusable-child* children>> [ t ] [ first ] if-empty ;
 
 M: world children-on nip children>> ;
 

basis/ui/operations/operations.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions kernel ui.commands
 ui.gestures sequences strings math words generic namespaces
-hashtables help.markup quotations assocs fry linked-assocs ;
+hashtables quotations assocs fry linked-assocs ;
 IN: ui.operations
 
 SYMBOL: +keyboard+

basis/ui/tools/debugger/debugger.factor

@@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
 ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
 ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ui.tools.browser ;
+ui.tools.inspector ui.tools.browser ui.debugger ;
 IN: ui.tools.debugger
 
 TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
@@ -27,9 +27,6 @@ M: restart-renderer row-columns
         t >>selection-required?
         t >>single-click? ; inline
 
-: <error-pane> ( error -- pane )
-    <pane> [ [ print-error ] with-pane ] keep ; inline
-
 : <error-display> ( debugger -- gadget )
     [ <filled-pile> ] dip
     [ error>> <error-pane> add-gadget ]
@@ -72,12 +69,6 @@ M: object error-in-debugger? drop f ;
     [ rethrow ] [ error-continuation get debugger-window ] if 
 ] ui-error-hook set-global
 
-M: world-error error.
-    "An error occurred while drawing the world " write
-    dup world>> pprint-short "." print
-    "This world has been deactivated to prevent cascading errors." print
-    error>> error. ;
-
 debugger "gestures" f {
     { T{ button-down } request-focus }
 } define-command-map

basis/ui/ui-docs.factor

@@ -40,12 +40,12 @@ HELP: find-window
 { $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
 
 HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $values { "world" world } { "handle" "a backend-specific handle" } }
 { $description "Adds a window to the global " { $link windows } " variable." }
 { $notes "This word should only be called by the UI backend.  User code can open new windows with " { $link open-window } "." } ;
 
 HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
+{ $values { "handle" "a backend-specific handle" } }
 { $description "Removes a window from the global " { $link windows } " variable." }
 { $notes "This word should only be called only by the UI backend, and not user code." } ;
 

basis/ui/ui.factor

@@ -59,22 +59,28 @@ SYMBOL: windows
     [ ?ungrab-input ]
     [ focus-path f swap focus-gestures ] bi ;
 
-: try-to-open-window ( world -- )
+: set-up-window ( world -- )
     {
-        [ (open-window) ]
         [ handle>> select-gl-context ]
-        [
+        [ [ title>> ] keep set-title ]
         [ begin-world ]
-            [ [ handle>> (close-window) ] [ ui-error ] bi* ]
-            recover
-        ]
         [ resize-world ]
+        [ t >>active? drop ]
+        [ request-focus ]
     } cleave ;
 
+: clean-up-broken-window ( world -- )
+    [
+        dup { [ focused?>> ] [ grab-input?>> ] } 1&&
+        [ handle>> (ungrab-input) ] [ drop ] if
+    ] [ handle>> (close-window) ] bi ;
+
 M: world graft*
-    [ try-to-open-window ]
+    [ (open-window) ]
-    [ [ title>> ] keep set-title ]
+    [
-    [ request-focus ] tri ;
+        [ set-up-window ]
+        [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
+    ] bi ;
 
 : reset-world ( world -- )
     #! This is used when a window is being closed, but also

basis/unix/linux/linux.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax alien system ;
 IN: unix
 
 ! Linux.
@@ -93,13 +93,20 @@ C-STRUCT: passwd
     { "char*"  "pw_dir" }
     { "char*"  "pw_shell" } ;
 
+! dirent64
 C-STRUCT: dirent
-    { "__ino_t" "d_ino" }
+    { "ulonglong" "d_ino" }
-    { "__off_t" "d_off" }
+    { "longlong" "d_off" }
     { "ushort" "d_reclen" }
     { "uchar" "d_type" }
     { { "char" 256 } "d_name" } ;
 
+FUNCTION: int open64 ( char* path, int flags, int prot ) ;
+FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
+FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
+
+M: linux open-file [ open64 ] unix-system-call ;
+
 CONSTANT: EPERM 1
 CONSTANT: ENOENT 2
 CONSTANT: ESRCH 3

basis/unix/stat/linux/32/32.factor

@@ -1,29 +1,28 @@
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math sequences unix
+alien.c-types arrays accessors combinators ;
 IN: unix.stat
 
-! Ubuntu 8.04 32-bit
+! stat64
-
 C-STRUCT: stat
     { "dev_t"      "st_dev" }
     { "ushort"     "__pad1" }
-    { "ino_t"     "st_ino" }
+    { "__ino_t"     "__st_ino" }
     { "mode_t"     "st_mode" }
     { "nlink_t"    "st_nlink" }
     { "uid_t"      "st_uid" }
     { "gid_t"      "st_gid" }
     { "dev_t"      "st_rdev" }
-    { "ushort"    "__pad2" }
+    { { "ushort" 2 } "__pad2" }
-    { "off_t"     "st_size" }
+    { "off64_t"    "st_size" }
     { "blksize_t"  "st_blksize" }
-    { "blkcnt_t"  "st_blocks" }
+    { "blkcnt64_t" "st_blocks" }
     { "timespec"   "st_atimespec" }
     { "timespec"   "st_mtimespec" }
     { "timespec"   "st_ctimespec" }
-    { "ulong"     "unused4" }
+    { "ulonglong"  "st_ino" } ;
-    { "ulong"     "unused5" } ;
 
-FUNCTION: int __xstat  ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __xstat64  ( int ver, char* pathname, stat* buf ) ;
-FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
 
-:  stat ( pathname buf -- int ) [ 3 ] 2dip __xstat ;
+:  stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ;
-: lstat ( pathname buf -- int ) [ 3 ] 2dip __lxstat ;
+: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ;

basis/unix/stat/linux/64/64.factor

@@ -2,29 +2,27 @@ USING: kernel alien.syntax math sequences unix
 alien.c-types arrays accessors combinators ;
 IN: unix.stat
 
-! Ubuntu 7.10 64-bit
+! stat64
-
 C-STRUCT: stat
     { "dev_t"      "st_dev" }
-    { "ino_t"     "st_ino" }
+    { "ushort"     "__pad1" }
-    { "nlink_t"   "st_nlink" }
+    { "__ino_t"     "__st_ino" }
     { "mode_t"     "st_mode" }
+    { "nlink_t"    "st_nlink" }
     { "uid_t"      "st_uid" }
     { "gid_t"      "st_gid" }
-    { "int"       "pad0" }
     { "dev_t"      "st_rdev" }
-    { "off_t"     "st_size" }
+    { { "ushort" 2 } "__pad2" }
+    { "off64_t"    "st_size" }
     { "blksize_t"  "st_blksize" }
-    { "blkcnt_t"  "st_blocks" }
+    { "blkcnt64_t" "st_blocks" }
     { "timespec"   "st_atimespec" }
     { "timespec"   "st_mtimespec" }
     { "timespec"   "st_ctimespec" }
-    { "long"      "__unused0" }
+    { "ulonglong"  "st_ino" } ;
-    { "long"      "__unused1" }
-    { "long"      "__unused2" } ;
 
-FUNCTION: int __xstat  ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __xstat64  ( int ver, char* pathname, stat* buf ) ;
-FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
 
-:  stat ( pathname buf -- int ) [ 1 ] 2dip __xstat ;
+:  stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ;
-: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat ;
+: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ;

basis/unix/types/linux/linux.factor

@@ -23,7 +23,11 @@ TYPEDEF: __slongword_type blkcnt_t
 TYPEDEF: __sword_type     ssize_t
 TYPEDEF: __s32_type       pid_t
 TYPEDEF: __slongword_type time_t
+TYPEDEF: __slongword_type __time_t
 
 TYPEDEF: ssize_t __SWORD_TYPE
+TYPEDEF: ulonglong blkcnt64_t
 TYPEDEF: ulonglong __fsblkcnt64_t
 TYPEDEF: ulonglong __fsfilcnt64_t
+TYPEDEF: ulonglong ino64_t
+TYPEDEF: ulonglong off64_t

basis/unix/unix.factor

@@ -140,9 +140,11 @@ FUNCTION: int shutdown ( int fd, int how ) ;
 
 FUNCTION: int open ( char* path, int flags, int prot ) ;
 
-FUNCTION: DIR* opendir ( char* path ) ;
+HOOK: open-file os ( path flags mode -- fd )
 
-: open-file ( path flags mode -- fd ) [ open ] unix-system-call ;
+M: unix open-file [ open ] unix-system-call ;
+
+FUNCTION: DIR* opendir ( char* path ) ;
 
 C-STRUCT: utimbuf
     { "time_t" "actime"  }
@@ -165,7 +167,6 @@ FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
 
 FUNCTION: dirent* readdir ( DIR* dirp ) ;
 FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
-
 FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
 
 CONSTANT: PATH_MAX 1024

basis/windows/dinput/constants/constants.factor

@@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com
 windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
 combinators sequences fry math accessors macros words quotations
 libc continuations generalizations splitting locals assocs init
-struct-arrays ;
+struct-arrays memoize ;
 IN: windows.dinput.constants
 
 ! Some global variables aren't provided by the DirectInput DLL (they're in the
@@ -18,12 +18,15 @@ SYMBOLS:
 
 <PRIVATE
 
+MEMO: c-type* ( name -- c-type ) c-type ;
+MEMO: heap-size* ( c-type -- n ) heap-size ;
+
 : (field-spec-of) ( field struct -- field-spec )
-    c-type fields>> [ name>> = ] with find nip ;
+    c-type* fields>> [ name>> = ] with find nip ;
 : (offsetof) ( field struct -- offset )
     [ (field-spec-of) offset>> ] [ drop 0 ] if* ;
 : (sizeof) ( field struct -- size )
-    [ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
+    [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ;
 
 : (flag) ( thing -- integer )
     {
@@ -79,6 +82,9 @@ SYMBOLS:
     [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
     "DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
 
+: initialize ( symbol quot -- )
+    call swap set-global ; inline
+
 : (malloc-guid-symbol) ( symbol guid -- )
     '[
         _ execute( -- value )

basis/windows/types/types.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax namespaces kernel words
-sequences math math.bitwise math.vectors colors ;
+sequences math math.bitwise math.vectors colors
+io.encodings.utf16n ;
 IN: windows.types
 
 TYPEDEF: char                CHAR
@@ -68,6 +69,8 @@ TYPEDEF: ulonglong   ULARGE_INTEGER
 TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
 TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
 
+<< { "char*" utf16n } "wchar_t*" typedef >>
+
 TYPEDEF: wchar_t*  LPCSTR
 TYPEDEF: wchar_t*  LPWSTR
 TYPEDEF: WCHAR       TCHAR

core/bootstrap/primitives.factor

@@ -211,7 +211,6 @@ bi
 
 "quotation" "quotations" create {
     { "array" { "array" "arrays" } read-only }
-    { "compiled" read-only }
     "cached-effect"
     "cache-counter"
 } define-builtin
@@ -514,6 +513,7 @@ tuple
     { "reset-inline-cache-stats" "generic.single" (( -- )) }
     { "inline-cache-stats" "generic.single" (( -- stats )) }
     { "optimized?" "words" (( word -- ? )) }
+    { "quot-compiled?" "quotations" (( quot -- ? )) }
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number

core/io/backend/backend.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting alien io.streams.null ;
+io.encodings.utf8 init assocs splitting alien ;
 IN: io.backend
 
 SYMBOL: io-backend
@@ -12,22 +12,12 @@ io-backend [ c-io-backend ] initialize
 
 HOOK: init-io io-backend ( -- )
 
-HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? )
+HOOK: init-stdio io-backend ( -- )
 
-: set-stdio ( input-handle output-handle error-handle -- )
+: set-stdio ( input output error -- )
-    [ input-stream set-global ]
+    [ utf8 <decoder> input-stream set-global ]
-    [ output-stream set-global ]
+    [ utf8 <encoder> output-stream set-global ]
-    [ error-stream set-global ] tri* ;
+    [ utf8 <encoder> error-stream set-global ] tri* ;
-
-: init-stdio ( -- )
-    (init-stdio) [
-        [ utf8 <decoder> ]
-        [ utf8 <encoder> ]
-        [ utf8 <encoder> ] tri*
-    ] [
-        3drop
-        null-reader null-writer null-writer
-    ] if set-stdio ;
 
 HOOK: io-multiplex io-backend ( us -- )
 

core/io/streams/c/c.factor

@@ -60,12 +60,13 @@ M: c-io-backend init-io ;
 : stdout-handle ( -- alien ) 12 getenv ;
 : stderr-handle ( -- alien ) 61 getenv ;
 
-: init-c-stdio ( -- stdin stdout stderr )
+: init-c-stdio ( -- )
     stdin-handle <c-reader>
     stdout-handle <c-writer>
-    stderr-handle <c-writer> ;
+    stderr-handle <c-writer>
+    set-stdio ;
 
-M: c-io-backend (init-stdio) init-c-stdio t ;
+M: c-io-backend init-stdio init-c-stdio ;
 
 M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
 

extra/bloom-filters/authors.txt

@@ -0,0 +1 @@
+Alec Berryman

extra/bloom-filters/bloom-filters-docs.factor

@@ -0,0 +1,38 @@
+USING: help.markup help.syntax kernel math ;
+IN: bloom-filters
+
+HELP: <bloom-filter>
+{ $values { "error-rate" "The desired false positive rate.  A " { $link float } " between 0 and 1." }
+          { "number-objects" "The expected number of object in the set.  A positive " { $link integer } "." }
+          { "bloom-filter" bloom-filter } }
+{ $description "Creates an empty Bloom filter." }
+{ $errors "Throws a " { $link capacity-error } " when unable to produce a filter meeting the given constraints.  Throws a " { $link invalid-error-rate } " or a " { $link invalid-n-objects } " when input is invalid." } ;
+
+
+HELP: bloom-filter-insert
+{ $values { "object" object }
+          { "bloom-filter" bloom-filter } }
+{ $description "Records the item as a member of the filter." }
+{ $side-effects "bloom-filter" } ;
+
+HELP: bloom-filter-member?
+{ $values { "object" object }
+          { "bloom-filter" bloom-filter }
+          { "?" boolean } }
+{ $description "Returns " { $link t } " if the object may be a member of Bloom filter, " { $link f } " otherwise.  The false positive rate is configurable; there are no false negatives." } ;
+
+HELP: bloom-filter
+{ $class-description "This is the class for Bloom filters. These provide constant-time insertion and probabilistic membership-testing operations, but do not actually store any elements." } ;
+
+ARTICLE: "bloom-filters" "Bloom filters"
+"This is a library for Bloom filters, sets that provide a constant-time insertion operation and probabilistic membership tests, but do not actually store any elements."
+$nl
+"The accuracy of the membership test is configurable; a Bloom filter will never incorrectly report an item is not a member of the set, but may incorrectly report than an item is a member of the set."
+$nl
+"Bloom filters cannot be resized and do not support removal."
+$nl
+{ $subsection <bloom-filter> }
+{ $subsection bloom-filter-insert }
+{ $subsection bloom-filter-member? } ;
+
+ABOUT: "bloom-filters"

extra/bloom-filters/bloom-filters-tests.factor

@@ -0,0 +1,81 @@
+USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts
+math random sequences tools.test ;
+IN: bloom-filters.tests
+
+
+[ { 200 5 } ] [ { 100 7 } { 200 5 } smaller-second ] unit-test
+[ { 200 5 } ] [ { 200 5 } { 100 7 } smaller-second ] unit-test
+
+! The sizing information was generated using the subroutine
+! calculate_shortest_filter_length from
+! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html.
+
+! Test bloom-filter creation
+[ 47965 ] [ 7 0.01 5000 bits-to-satisfy-error-rate ] unit-test
+[ 7 47965 ] [ 0.01 5000 size-bloom-filter ] unit-test
+[ 7 ] [ 0.01 5000 <bloom-filter> n-hashes>> ] unit-test
+[ 47965 ] [ 0.01 5000 <bloom-filter> bits>> length ] unit-test
+[ 5000 ] [ 0.01 5000 <bloom-filter> maximum-n-objects>> ] unit-test
+[ 0 ] [ 0.01 5000 <bloom-filter> current-n-objects>> ] unit-test
+
+! Should return the fewest hashes to satisfy the bits requested, not the most.
+[ 32 ] [ 4 0.05 5 bits-to-satisfy-error-rate ] unit-test
+[ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test
+[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test
+
+! This is a lot of bits.
+: oversized-filter-params ( -- error-rate n-objects )
+    0.00000001 400000000000000 ;
+! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ]  must-fail-with
+! [ oversized-filter-params <bloom-filter> ] [ capacity-error? ] must-fail-with
+
+! Other error conditions.
+[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 20 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ -2 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.5 0 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
+[ 0.5 -5 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
+
+! Should not generate bignum hash codes.  Enhanced double hashing may generate a
+! lot of hash codes, and it's better to do this earlier than later.
+[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ ] all? ] unit-test
+
+[ ?{ t f t f t f } ] [ { 0 2 4 } 6 <bit-array> [ set-indices ] keep ] unit-test
+
+: empty-bloom-filter ( -- bloom-filter )
+    0.01 2000 <bloom-filter> ;
+
+[ 1 ] [ empty-bloom-filter dup increment-n-objects current-n-objects>> ] unit-test
+
+: basic-insert-test-setup ( -- bloom-filter )
+    1 empty-bloom-filter [ bloom-filter-insert ] keep ;
+
+! Basic tests that insert does something
+[ t ] [ basic-insert-test-setup bits>> [ ] any? ] unit-test
+[ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test
+
+: non-empty-bloom-filter ( -- bloom-filter )
+    1000 iota
+    empty-bloom-filter
+    [ [ bloom-filter-insert ] curry each ] keep ;
+
+: full-bloom-filter ( -- bloom-filter )
+    2000 iota
+    empty-bloom-filter
+    [ [ bloom-filter-insert ] curry each ] keep ;
+
+! Should find what we put in there.
+[ t ] [ 2000 iota
+        full-bloom-filter
+        [ bloom-filter-member? ] curry map
+        [ ] all? ] unit-test
+
+! We shouldn't have more than 0.01 false-positive rate.
+[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
+        full-bloom-filter
+        [ bloom-filter-member? ] curry map
+        [ ] filter
+        ! TODO: This should be 10, but the false positive rate is currently very
+        ! high.  It shouldn't be much more than this.
+        length 150 <= ] unit-test

extra/bloom-filters/bloom-filters.factor

@@ -0,0 +1,158 @@
+! Copyright (C) 2009 Alec Berryman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays bit-arrays fry infix kernel layouts locals math
+math.functions multiline sequences ;
+IN: bloom-filters
+
+FROM: math.ranges => [1,b] [0,b) ;
+FROM: math.intervals => (a,b) interval-contains? ;
+
+/*
+
+TODO:
+
+- The false positive rate is 10x what it should be, based on informal testing.
+  Better object hashes or a better method of generating extra hash codes would
+  help.  Another way is to increase the number of bits used.
+
+  - Try something smarter than the bitwise complement for a second hash code.
+
+  - http://spyced.blogspot.com/2009/01/all-you-ever-wanted-to-know-about.html
+    makes a case for http://murmurhash.googlepages.com/ instead of enhanced
+    double-hashing.
+
+  - Be sure to adjust the test that asserts the number of false positives isn't
+    unreasonable.
+
+- Could round bits up to next power of two and use wrap instead of mod.  This
+  would cost a lot of bits on 32-bit platforms, though, and limit the bit-array
+  to 8MB.
+
+- Should allow user to specify the hash codes, either as inputs to enhanced
+  double hashing or for direct use.
+
+- Support for serialization.
+
+- Wrappers for combining filters.
+
+- Should we signal an error when inserting past the number of objects the filter
+  is sized for?  The filter will continue to work, just not very well.
+
+*/
+
+TUPLE: bloom-filter
+{ n-hashes fixnum read-only }
+{ bits bit-array read-only }
+{ maximum-n-objects fixnum read-only }
+{ current-n-objects fixnum } ;
+
+ERROR: capacity-error ;
+ERROR: invalid-error-rate ;
+ERROR: invalid-n-objects ;
+
+<PRIVATE
+
+! infix doesn't like ^
+: pow ( x y -- z )
+    ^ ; inline
+
+:: bits-to-satisfy-error-rate ( hashes error objects -- size )
+    [infix -(objects * hashes) / log(1 - pow(error, (1/hashes))) infix]
+    ceiling >integer ;
+
+! 100 hashes ought to be enough for anybody.
+: n-hashes-range ( -- range )
+    100 [1,b] ;
+
+! { n-hashes n-bits }
+: identity-configuration ( -- 2seq )
+    0 max-array-capacity 2array ;
+
+: smaller-second ( 2seq 2seq -- 2seq )
+    [ [ second ] bi@ <= ] most ;
+
+! If the number of hashes isn't positive, we haven't found anything smaller than the
+! identity configuration.
+: validate-sizes ( 2seq -- )
+    first 0 <= [ capacity-error ] when ;
+
+! The consensus on the tradeoff between increasing the number of bits and
+! increasing the number of hash functions seems to be "go for the smallest
+! number of bits", probably because most implementations just generate one hash
+! value and cheaply mangle it into the number of hashes they need.  I have not
+! seen any usage studies from the implementations that made this tradeoff to
+! support it, and I haven't done my own, but we'll go with it anyway.
+!
+: size-bloom-filter ( error-rate number-objects -- number-hashes number-bits )
+    [ n-hashes-range identity-configuration ] 2dip
+    '[ dup [ _ _ bits-to-satisfy-error-rate ]
+       call 2array smaller-second ]
+    reduce
+    dup validate-sizes
+    first2 ;
+
+: validate-n-objects ( n-objects -- )
+    0 <= [ invalid-n-objects ] when ;
+
+: valid-error-rate-interval ( -- interval )
+    0 1 (a,b) ;
+
+: validate-error-rate ( error-rate -- )
+    valid-error-rate-interval interval-contains?
+    [ invalid-error-rate ] unless ;
+
+: validate-constraints ( error-rate n-objects -- )
+    validate-n-objects validate-error-rate ;
+
+PRIVATE>
+
+: <bloom-filter> ( error-rate number-objects -- bloom-filter )
+    [ validate-constraints ] 2keep
+    [ size-bloom-filter <bit-array> ] keep
+    0 ! initially empty
+    bloom-filter boa ;
+
+<PRIVATE
+
+! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and
+! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing":
+! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html
+:: enhanced-double-hash ( index hash0 hash1 -- hash )
+    [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
+
+: enhanced-double-hashes ( hash0 hash1 n -- seq )
+    [0,b)
+    [ '[ _ _ enhanced-double-hash ] ] dip
+    swap map ;
+
+! Make sure it's a fixnum here to speed up double-hashing.
+: hashcodes-from-hashcode ( n -- n n )
+    dup most-positive-fixnum >fixnum bitxor ;
+
+: hashcodes-from-object ( obj -- n n )
+    hashcode abs hashcodes-from-hashcode ;
+
+: set-indices ( indices bit-array -- )
+    [ [ drop t ] change-nth ] curry each ;
+
+: increment-n-objects ( bloom-filter -- )
+    [ 1 + ] change-current-n-objects drop ;
+
+: n-hashes-and-length ( bloom-filter -- n-hashes length )
+    [ n-hashes>> ] [ bits>> length ] bi ;
+
+: relevant-indices ( value bloom-filter -- indices )
+    [ hashcodes-from-object ] [ n-hashes-and-length ] bi*
+    [ enhanced-double-hashes ] dip '[ _ mod ] map ;
+
+PRIVATE>
+
+: bloom-filter-insert ( object bloom-filter -- )
+    [ increment-n-objects ]
+    [ relevant-indices ]
+    [ bits>> set-indices ]
+    tri ;
+
+: bloom-filter-member? ( object bloom-filter -- ? )
+    [ relevant-indices ] keep
+    bits>> nths [ ] all? ;

extra/bson/reader/reader.factor

@@ -181,19 +181,16 @@ M: bson-oid element-data-read ( type -- oid )
     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 )
+M: bson-binary-custom element-binary-read ( size type -- quot )
     drop read bytes>object ;
 
 PRIVATE>
 
+USE: tools.continuations
+
 : stream>assoc ( exemplar -- assoc bytes-read )
     <state> dup state
     [ read-int32 >>size read-elements ] with-variable 

extra/bson/writer/writer.factor

@@ -62,7 +62,6 @@ 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 ; 
@@ -73,6 +72,7 @@ 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: word bson-type? ( word -- type ) drop T_Binary ;
 M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
 M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
 
@@ -112,22 +112,9 @@ M: byte-array bson-write ( binary -- )
     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 ; 
@@ -149,7 +136,16 @@ M: assoc bson-write ( assoc -- )
        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
        write-eoo ] with-length-prefix ; 
 
-M: word bson-write name>> bson-write ;
+: (serialize-code) ( code -- )
+    object>bytes [ length write-int32 ] keep
+    T_Binary_Custom write-byte
+    write ;
+
+M: quotation bson-write ( quotation -- )
+    (serialize-code) ;
+    
+M: word bson-write ( word -- )
+    (serialize-code) ;
 
 PRIVATE>
 

extra/game-input/game-input-tests.factor

@@ -1,11 +1,7 @@
 IN: game-input.tests
-USING: ui game-input tools.test kernel system threads
+USING: ui game-input tools.test kernel system threads calendar ;
-combinators.short-circuit calendar ;
 
-{
+os windows? os macosx? or [
-    [ os windows? ui-running? and ]
-    [ os macosx? ]
-} 0|| [
     [ ] [ open-game-input ] unit-test
     [ ] [ 1 seconds sleep ] unit-test
     [ ] [ close-game-input ] unit-test

extra/game-worlds/game-worlds.factor

@@ -21,5 +21,3 @@ M: game-world end-world
     [ [ stop-loop ] when* f ] change-game-loop
     drop ;
 
-M: game-world focusable-child* drop t ;
-

extra/hello-ui/deploy.factor

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

extra/mason/common/common.factor

@@ -10,18 +10,6 @@ IN: mason.common
 
 SYMBOL: current-git-id
 
-ERROR: output-process-error { output string } { process process } ;
-
-M: output-process-error error.
-    [ "Process:" print process>> . nl ]
-    [ "Output:" print output>> print ]
-    bi ;
-
-: try-output-process ( command -- )
-    >process +stdout+ >>stderr utf8 <process-reader*>
-    [ stream-contents ] [ dup wait-for-process ] bi*
-    0 = [ 2drop ] [ output-process-error ] if ;
-
 HOOK: really-delete-tree os ( path -- )
 
 M: windows really-delete-tree

extra/mason/notify/notify.factor

@@ -16,8 +16,8 @@ IN: mason.notify
         ] { } make prepend
         [ 5 ] 2dip '[
             <process>
-                _ >>command
                 _ [ +closed+ ] unless* >>stdin
+                _ >>command
             try-output-process
         ] retry
     ] [ 2drop ] if ;

extra/mongodb/tuple/collection/collection.factor

@@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence )
       [ ] [ name>> ] bi  H{ } clone [ set-at ] keep
     ] [ 2drop H{ } clone ] if ;
 
+
+
 PRIVATE>
 
 : MDB_ADDON_SLOTS ( -- slots )
@@ -116,7 +118,7 @@ PRIVATE>
     [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
 
 : set-index-map ( class index-list -- )
-    [ [ dup user-defined-key-index ] dip index-list>map  ] output>sequence
+    [ dup user-defined-key-index ] dip index-list>map 2array
     assoc-combine MDB_INDEX_MAP set-word-prop ; inline
 
 M: tuple-class tuple-collection ( tuple -- mdb-collection )

extra/mongodb/tuple/tuple.factor

@@ -54,19 +54,30 @@ M: mdb-persistent id-selector
            <update> >upsert update ] assoc-each ; inline
 PRIVATE>
  
-: save-tuple ( tuple -- )
+: save-tuple-deep ( tuple -- )
     tuple>storable [ (save-tuples) ] assoc-each ; 
  
 : update-tuple ( tuple -- )
-   save-tuple ;
+    [ tuple-collection name>> ]
+    [ id-selector ]
+    [ tuple>assoc ] tri
+    <update> update ;
+
+: save-tuple ( tuple -- )
+    update-tuple ;
 
 : insert-tuple ( tuple -- )
-   save-tuple ;
+   [ tuple-collection name>> ]
+   [ tuple>assoc ] bi
+   save ;
 
 : delete-tuple ( tuple -- )
    [ tuple-collection name>> ] keep
    id-selector delete ;
 
+: delete-tuples ( seq -- )
+    [ delete-tuple ] each ;
+
 : tuple>query ( tuple -- query )
    [ tuple-collection name>> ] keep
    tuple>selector <query> ;

extra/opengl/demo-support/demo-support.factor

@@ -36,9 +36,6 @@ M: demo-world distance-step ( gadget -- dz )
 : zoom-demo-world ( distance gadget -- )
     [ + ] with change-distance relayout-1 ;
 
-M: demo-world focusable-child* ( world -- gadget )
-    drop t ;
-
 M: demo-world pref-dim* ( gadget -- dim )
     drop { 640 480 } ;
 

extra/spheres/deploy.factor

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

extra/terrain/shaders/shaders.factor

@@ -8,11 +8,14 @@ varying vec3 direction;
 
 void main()
 {
-    vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0);
+    vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0);
     gl_Position = v;
+
+    vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1);
+    
     float s = sin(sky_theta), c = cos(sky_theta);
     direction = mat3(1, 0, 0,  0, c, s,  0, -s, c)
-        * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz;
+        * (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz;
 }
 
 ;

vm/code_block.cpp

@@ -68,10 +68,10 @@ static void *xt_pic(word *w, cell tagged_quot)
 	else
 	{
 		quotation *quot = untag<quotation>(tagged_quot);
-		if(quot->compiledp == F)
+		if(quot->code)
-			return w->xt;
-		else
 			return quot->xt;
+		else
+			return w->xt;
 	}
 }
 
@@ -409,7 +409,7 @@ void mark_object_code_block(object *object)
 	case QUOTATION_TYPE:
 		{
 			quotation *q = (quotation *)object;
-			if(q->compiledp != F)
+			if(q->code)
 				mark_code_block(q->code);
 			break;
 		}

vm/code_heap.cpp

@@ -158,7 +158,7 @@ void forward_object_xts()
 			{
 				quotation *quot = untag<quotation>(obj);
 
-				if(quot->compiledp != F)
+				if(quot->code)
 					quot->code = forward_xt(quot->code);
 			}
 			break;
@@ -194,7 +194,7 @@ void fixup_object_xts()
 		case QUOTATION_TYPE:
 			{
 				quotation *quot = untag<quotation>(obj);
-				if(quot->compiledp != F)
+				if(quot->code)
 					set_quot_xt(quot,quot->code);
 				break;
 			}

vm/cpu-ppc.S

@@ -45,7 +45,7 @@ multiply_overflow:
 	
 /* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
-	lwz r11,16(r3)	   /* load quotation-xt slot */ XX \
+	lwz r11,12(r3)	   /* load quotation-xt slot */ XX \
 
 #define CALL_QUOT \
 	CALL_OR_JUMP_QUOT XX \

vm/cpu-x86.32.S

@@ -25,7 +25,7 @@
 	pop %ebp ; \
 	pop %ebx
 
-#define QUOT_XT_OFFSET 16
+#define QUOT_XT_OFFSET 12
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative

vm/cpu-x86.64.S

@@ -61,7 +61,7 @@
 
 #endif
 
-#define QUOT_XT_OFFSET 36
+#define QUOT_XT_OFFSET 28
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative

vm/image.cpp

@@ -187,13 +187,13 @@ static void fixup_word(word *word)
 
 static void fixup_quotation(quotation *quot)
 {
-	if(quot->compiledp == F)
+	if(quot->code)
-		quot->xt = (void *)lazy_jit_compile;
-	else
 	{
 		code_fixup(&quot->xt);
 		code_fixup(&quot->code);
 	}
+	else
+		quot->xt = (void *)lazy_jit_compile;
 }
 
 static void fixup_alien(alien *d)

vm/layouts.hpp

@@ -269,8 +269,6 @@ struct quotation : public object {
 	/* tagged */
 	cell array;
 	/* tagged */
-	cell compiledp;
-	/* tagged */
 	cell cached_effect;
 	/* tagged */
 	cell cache_counter;

vm/primitives.cpp

@@ -155,6 +155,7 @@ const primitive_type primitives[] = {
 	primitive_reset_inline_cache_stats,
 	primitive_inline_cache_stats,
 	primitive_optimized_p,
+	primitive_quot_compiled_p,
 };
 
 }

vm/quotations.cpp

@@ -272,14 +272,13 @@ void set_quot_xt(quotation *quot, code_block *code)
 
 	quot->code = code;
 	quot->xt = code->xt();
-	quot->compiledp = T;
 }
 
 /* Allocates memory */
 void jit_compile(cell quot_, bool relocating)
 {
 	gc_root<quotation> quot(quot_);
-	if(quot->compiledp != F) return;
+	if(quot->code) return;
 
 	quotation_jit compiler(quot.value(),true,relocating);
 	compiler.iterate_quotation();
@@ -300,10 +299,10 @@ PRIMITIVE(array_to_quotation)
 {
 	quotation *quot = allot<quotation>(sizeof(quotation));
 	quot->array = dpeek();
-	quot->xt = (void *)lazy_jit_compile;
-	quot->compiledp = F;
 	quot->cached_effect = F;
 	quot->cache_counter = F;
+	quot->xt = (void *)lazy_jit_compile;
+	quot->code = NULL;
 	drepl(tag<quotation>(quot));
 }
 
@@ -354,4 +353,11 @@ VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack)
 	return quot.value();
 }
 
+PRIMITIVE(quot_compiled_p)
+{
+	tagged<quotation> quot(dpop());
+	quot.untag_check();
+	dpush(tag_boolean(quot->code != NULL));
+}
+
 }

vm/quotations.hpp

@@ -35,4 +35,6 @@ PRIMITIVE(quotation_xt);
 
 VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
 
+PRIMITIVE(quot_compiled_p);
+
 }